1{-# LANGUAGE ForeignFunctionInterface #-}
2
3-- |
4-- Module: Codec.Binary.Xx
5-- Copyright: (c) 2012 Magnus Therning
6-- License: BSD3
7--
8-- Xxencoding is obsolete but still included for completeness.  Further
9-- information on the encoding can be found at
10-- <http://en.wikipedia.org/wiki/Xxencode>.  It should be noted that this
11-- implementation performs no padding.
12--
13-- This encoding is very similar to uuencoding, therefore further information
14-- regarding the functions can be found in the documentation of
15-- "Codec.Binary.Uu".
16module Codec.Binary.Xx
17    ( xxEncodePart
18    , xxEncodeFinal
19    , xxDecodePart
20    , xxDecodeFinal
21    , encode
22    , decode
23    ) where
24
25import Data.ByteString.Unsafe
26import Foreign
27import Foreign.C.Types
28import System.IO.Unsafe as U
29import qualified Data.ByteString as BS
30
31castEnum :: (Enum a, Enum b) => a -> b
32castEnum = toEnum . fromEnum
33
34foreign import ccall "static uu.h xx_enc_part"
35    c_xx_enc_part :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CSize -> IO ()
36
37foreign import ccall "static uu.h xx_enc_final"
38    c_xx_enc_final :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> IO CInt
39
40foreign import ccall "static uu.h xx_dec_part"
41    c_xx_dec_part :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CSize -> IO CInt
42
43foreign import ccall "static uu.h xx_dec_final"
44    c_xx_dec_final :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> IO CInt
45
46-- | Encoding function.
47--
48-- >>> xxEncodePart $ Data.ByteString.Char8.pack "foo"
49-- ("Naxj","")
50-- >>> xxEncodePart $ Data.ByteString.Char8.pack "foob"
51-- ("Naxj","b")
52xxEncodePart :: BS.ByteString -> (BS.ByteString, BS.ByteString)
53xxEncodePart bs = U.unsafePerformIO $ unsafeUseAsCStringLen bs $ \ (inBuf, inLen) -> do
54    let maxOutLen = inLen `div` 3 * 4
55    outBuf <- mallocBytes maxOutLen
56    alloca $ \ pOutLen ->
57        alloca $ \ pRemBuf ->
58            alloca $ \ pRemLen -> do
59                poke pOutLen (castEnum maxOutLen)
60                c_xx_enc_part (castPtr inBuf) (castEnum inLen) outBuf pOutLen pRemBuf pRemLen
61                outLen <- peek pOutLen
62                remBuf <- peek pRemBuf
63                remLen <- peek pRemLen
64                remBs <- BS.packCStringLen (castPtr remBuf, castEnum remLen)
65                outBs <- unsafePackCStringFinalizer outBuf (castEnum outLen) (free outBuf)
66                return (outBs, remBs)
67
68-- | Encoding function for the final block.
69--
70-- >>> xxEncodeFinal $ Data.ByteString.Char8.pack "r"
71-- Just "QU"
72-- >>> xxEncodeFinal $ Data.ByteString.Char8.pack "foo"
73-- Nothing
74xxEncodeFinal :: BS.ByteString -> Maybe BS.ByteString
75xxEncodeFinal bs = U.unsafePerformIO $ unsafeUseAsCStringLen bs $ \ (inBuf, inLen) -> do
76    outBuf <- mallocBytes 4
77    alloca $ \ pOutLen -> do
78        r <- c_xx_enc_final (castPtr inBuf) (castEnum inLen) outBuf pOutLen
79        if r == 0
80            then do
81                outLen <- peek pOutLen
82                newOutBuf <- reallocBytes outBuf (castEnum outLen)
83                outBs <- unsafePackCStringFinalizer newOutBuf (castEnum outLen) (free newOutBuf)
84                return $ Just outBs
85            else free outBuf >> return Nothing
86
87-- | Decoding function.
88--
89-- >>> xxDecodePart $ Data.ByteString.Char8.pack "Naxj"
90-- Right ("foo","")
91-- >>> xxDecodePart $ Data.ByteString.Char8.pack "NaxjMa3"
92-- Right ("foo","Ma3")
93--
94-- >>> xxDecodePart $ Data.ByteString.Char8.pack "Na j"
95-- Left ("","Na J")
96xxDecodePart :: BS.ByteString -> Either (BS.ByteString, BS.ByteString) (BS.ByteString, BS.ByteString)
97xxDecodePart bs = U.unsafePerformIO $ unsafeUseAsCStringLen bs $ \ (inBuf, inLen) -> do
98    let maxOutLen = inLen `div` 4 * 3
99    outBuf <- mallocBytes maxOutLen
100    alloca $ \ pOutLen ->
101        alloca $ \ pRemBuf ->
102            alloca $ \ pRemLen -> do
103                poke pOutLen (castEnum maxOutLen)
104                r <- c_xx_dec_part (castPtr inBuf) (castEnum inLen) outBuf pOutLen pRemBuf pRemLen
105                outLen <- peek pOutLen
106                newOutBuf <- reallocBytes outBuf (castEnum outLen)
107                remBuf <- peek pRemBuf
108                remLen <- peek pRemLen
109                remBs <- BS.packCStringLen (castPtr remBuf, castEnum remLen)
110                outBs <- unsafePackCStringFinalizer newOutBuf (castEnum outLen) (free newOutBuf)
111                if r == 0
112                    then return $ Right (outBs, remBs)
113                    else return $ Left (outBs, remBs)
114
115-- | Decoding function for the final block.
116--
117-- >>> xxDecodeFinal $ Data.ByteString.Char8.pack "Naw"
118-- Just "fo"
119-- >>> xxDecodeFinal $ Data.ByteString.Char8.pack ""
120-- Just ""
121-- >>> xxDecodeFinal $ Data.ByteString.Char8.pack "Na "
122-- Nothing
123--
124-- >>> xxDecodeFinal $ encode $ Data.ByteString.Char8.pack "foo"
125-- Nothing
126xxDecodeFinal :: BS.ByteString -> Maybe BS.ByteString
127xxDecodeFinal bs = U.unsafePerformIO $ unsafeUseAsCStringLen bs $ \ (inBuf, inLen) -> do
128    outBuf <- mallocBytes 3
129    alloca $ \ pOutLen -> do
130        r <- c_xx_dec_final (castPtr inBuf) (castEnum inLen) outBuf pOutLen
131        if r == 0
132            then do
133                outLen <- peek pOutLen
134                newOutBuf <- reallocBytes outBuf (castEnum outLen)
135                outBs <- unsafePackCStringFinalizer newOutBuf (castEnum outLen) (free newOutBuf)
136                return $ Just outBs
137            else free outBuf >> return Nothing
138
139encode :: BS.ByteString -> BS.ByteString
140encode bs = first `BS.append` final
141    where
142        (first, rest) = xxEncodePart bs
143        Just final = xxEncodeFinal rest
144
145decode :: BS.ByteString -> Either (BS.ByteString, BS.ByteString) BS.ByteString
146decode bs = either
147    Left
148    (\ (first, rest) ->
149        maybe
150            (Left (first, rest))
151            (\ fin -> Right (first `BS.append` fin))
152            (xxDecodeFinal rest))
153    (xxDecodePart bs)
154