{-# LANGUAGE ForeignFunctionInterface #-}
module Codec.Binary.Yenc
( yEncode
, yDecode
, encode
, decode
) where
import qualified Data.ByteString as BS
import Foreign
import Foreign.C.Types
import System.IO.Unsafe as U
import qualified Data.ByteString.Unsafe as BSU
import Data.List
castEnum :: (Enum a, Enum b) => a -> b
castEnum :: forall a b. (Enum a, Enum b) => a -> b
castEnum = Int -> b
forall a. Enum a => Int -> a
toEnum (Int -> b) -> (a -> Int) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int
forall a. Enum a => a -> Int
fromEnum
foreign import ccall "static yenc.h y_enc"
c_y_enc :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CSize -> IO ()
foreign import ccall "static yenc.h y_dec"
c_y_dec :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CSize -> IO CInt
yEncode :: BS.ByteString -> (BS.ByteString, BS.ByteString)
yEncode :: ByteString -> (ByteString, ByteString)
yEncode ByteString
bs = IO (ByteString, ByteString) -> (ByteString, ByteString)
forall a. IO a -> a
U.unsafePerformIO (IO (ByteString, ByteString) -> (ByteString, ByteString))
-> IO (ByteString, ByteString) -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString
-> (CStringLen -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BSU.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString))
-> (CStringLen -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ \ (Ptr CChar
inBuf, Int
inLen) -> do
let maxOutLen :: Int
maxOutLen = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
512 (Rational -> Int
forall b. Integral b => Rational -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Rational -> Int) -> Rational -> Int
forall a b. (a -> b) -> a -> b
$ (Int -> Rational
forall a. Real a => a -> Rational
toRational Int
inLen) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational
1.2)
outBuf <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
maxOutLen
alloca $ \ Ptr CSize
pOutLen ->
(Ptr (Ptr Word8) -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr Word8) -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString))
-> (Ptr (Ptr Word8) -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ \ Ptr (Ptr Word8)
pRemBuf ->
(Ptr CSize -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString)
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString))
-> (Ptr CSize -> IO (ByteString, ByteString))
-> IO (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ \ Ptr CSize
pRemLen -> do
Ptr CSize -> CSize -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CSize
pOutLen (Int -> CSize
forall a b. (Enum a, Enum b) => a -> b
castEnum Int
maxOutLen)
Ptr Word8
-> CSize
-> Ptr Word8
-> Ptr CSize
-> Ptr (Ptr Word8)
-> Ptr CSize
-> IO ()
c_y_enc (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
inBuf) (Int -> CSize
forall a b. (Enum a, Enum b) => a -> b
castEnum Int
inLen) Ptr Word8
outBuf Ptr CSize
pOutLen Ptr (Ptr Word8)
pRemBuf Ptr CSize
pRemLen
outLen <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
pOutLen
newOutBuf <- reallocBytes outBuf (castEnum outLen)
remBuf <- peek pRemBuf
remLen <- peek pRemLen
remBs <- BS.packCStringLen (castPtr remBuf, castEnum remLen)
outBs <- BSU.unsafePackCStringFinalizer newOutBuf (castEnum outLen) (free newOutBuf)
return (outBs, remBs)
yDecode :: BS.ByteString -> Either (BS.ByteString, BS.ByteString) (BS.ByteString, BS.ByteString)
yDecode :: ByteString
-> Either (ByteString, ByteString) (ByteString, ByteString)
yDecode ByteString
bs = IO (Either (ByteString, ByteString) (ByteString, ByteString))
-> Either (ByteString, ByteString) (ByteString, ByteString)
forall a. IO a -> a
U.unsafePerformIO (IO (Either (ByteString, ByteString) (ByteString, ByteString))
-> Either (ByteString, ByteString) (ByteString, ByteString))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
-> Either (ByteString, ByteString) (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString
-> (CStringLen
-> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BSU.unsafeUseAsCStringLen ByteString
bs ((CStringLen
-> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> (CStringLen
-> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ \ (Ptr CChar
inBuf, Int
inLen) -> do
outBuf <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
inLen
alloca $ \ Ptr CSize
pOutLen ->
(Ptr (Ptr Word8)
-> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr Word8)
-> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> (Ptr (Ptr Word8)
-> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ \ Ptr (Ptr Word8)
pRemBuf ->
(Ptr CSize
-> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize
-> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> (Ptr CSize
-> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ \ Ptr CSize
pRemLen -> do
Ptr CSize -> CSize -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CSize
pOutLen (Int -> CSize
forall a b. (Enum a, Enum b) => a -> b
castEnum Int
inLen)
r <- Ptr Word8
-> CSize
-> Ptr Word8
-> Ptr CSize
-> Ptr (Ptr Word8)
-> Ptr CSize
-> IO CInt
c_y_dec (Ptr CChar -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr CChar
inBuf) (Int -> CSize
forall a b. (Enum a, Enum b) => a -> b
castEnum Int
inLen) Ptr Word8
outBuf Ptr CSize
pOutLen Ptr (Ptr Word8)
pRemBuf Ptr CSize
pRemLen
outLen <- peek pOutLen
newOutBuf <- reallocBytes outBuf (castEnum outLen)
remBuf <- peek pRemBuf
remLen <- peek pRemLen
remBs <- BS.packCStringLen (castPtr remBuf, castEnum remLen)
outBs <- BSU.unsafePackCStringFinalizer newOutBuf (castEnum outLen) (free newOutBuf)
if r == 0
then return $ Right (outBs, remBs)
else return $ Left (outBs, remBs)
encode :: BS.ByteString -> BS.ByteString
encode :: ByteString -> ByteString
encode = [ByteString] -> ByteString
BS.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
BS.null) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Maybe (ByteString, ByteString))
-> ByteString -> [ByteString]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr ((ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just ((ByteString, ByteString) -> Maybe (ByteString, ByteString))
-> (ByteString -> (ByteString, ByteString))
-> ByteString
-> Maybe (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> (ByteString, ByteString)
yEncode)
decode :: BS.ByteString -> Either (BS.ByteString, BS.ByteString) BS.ByteString
decode :: ByteString -> Either (ByteString, ByteString) ByteString
decode ByteString
bs = case ByteString
-> Either (ByteString, ByteString) (ByteString, ByteString)
yDecode ByteString
bs of
Right a :: (ByteString, ByteString)
a@(ByteString
d, ByteString
r) -> if ByteString -> Bool
BS.null ByteString
r
then ByteString -> Either (ByteString, ByteString) ByteString
forall a b. b -> Either a b
Right ByteString
d
else (ByteString, ByteString)
-> Either (ByteString, ByteString) ByteString
forall a b. a -> Either a b
Left (ByteString, ByteString)
a
Left (ByteString, ByteString)
a -> (ByteString, ByteString)
-> Either (ByteString, ByteString) ByteString
forall a b. a -> Either a b
Left (ByteString, ByteString)
a