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