{-# LANGUAGE ForeignFunctionInterface #-}

-- |
-- Module: Codec.Binary.Base16
-- Copyright: (c) 2012 Magnus Therning
-- License: BSD3
--
-- Implemention of base 16 encoding (hex encoding) as specified in RFC 4648
-- (<http://tools.ietf.org/html/rfc4648>).
module Codec.Binary.Base16
    ( b16Enc
    , b16Dec
    , encode
    , decode
    ) where

import Foreign
import Foreign.C.Types
import System.IO.Unsafe as U
import qualified Data.ByteString as BS
import qualified Data.ByteString.Unsafe as BSU

castEnum :: (Enum a, Enum b) => a -> b
castEnum :: 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 b16.h b16_enc"
    c_b16_enc :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CSize -> IO ()

foreign import ccall "static b16.h b16_dec"
    c_b16_dec :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CSize -> IO CInt

-- | Encoding function.
--
-- This function, unlike some other encoding functions in the library, simply
-- cannot fail.  Double the length of the input string is allocated for the
-- encoded data, which is guaranteed to hold the result.
--
-- >>> b16Enc $ Data.ByteString.pack [0x00]
-- "00"
--
-- >>> b16Enc $ Data.ByteString.Char8.pack "foobar"
-- "666F6F626172"
b16Enc :: BS.ByteString
    -> BS.ByteString -- ^ The encoded string
b16Enc :: ByteString -> ByteString
b16Enc ByteString
bs = IO ByteString -> ByteString
forall a. IO a -> a
U.unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> (CStringLen -> IO ByteString) -> IO ByteString
forall a. ByteString -> (CStringLen -> IO a) -> IO a
BSU.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO ByteString) -> IO ByteString)
-> (CStringLen -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ (Ptr CChar
inBuf, Int
inLen) -> do
    let maxOutLen :: Int
maxOutLen = Int
inLen Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
    Ptr Word8
outBuf <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
maxOutLen
    (Ptr CSize -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize -> IO ByteString) -> IO ByteString)
-> (Ptr CSize -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ Ptr CSize
pOutLen ->
        (Ptr (Ptr Word8) -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr (Ptr Word8) -> IO ByteString) -> IO ByteString)
-> (Ptr (Ptr Word8) -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ Ptr (Ptr Word8)
pRemBuf ->
            (Ptr CSize -> IO ByteString) -> IO ByteString
forall a b. Storable a => (Ptr a -> IO b) -> IO b
alloca ((Ptr CSize -> IO ByteString) -> IO ByteString)
-> (Ptr CSize -> IO ByteString) -> IO 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_b16_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
                CSize
outLen <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
pOutLen
                Ptr Word8 -> Int -> IO () -> IO ByteString
BSU.unsafePackCStringFinalizer Ptr Word8
outBuf (CSize -> Int
forall a b. (Enum a, Enum b) => a -> b
castEnum CSize
outLen) (Ptr Word8 -> IO ()
forall a. Ptr a -> IO ()
free Ptr Word8
outBuf)

-- | Decoding function.
--
-- The returned value on success is @Right (\<decoded part>, \<undecoded
-- part>)@ (the undecoded part is either a empty or a single byte), and on
-- failure it's @Left (\<decoded part\>, \<undecodable part>)@.  Space equal to
-- the length of the input string is allocated, which is more than enough to
-- hold the decoded data.
--
-- >>> b16Dec $ Data.ByteString.Char8.pack "00"
-- Right ("\NUL","")
--
-- >>> b16Dec $ Data.ByteString.Char8.pack "666F6F626172"
-- Right ("foobar","")
--
-- >>> b16Dec $ Data.ByteString.Char8.pack "666F6F62617"
-- Right ("fooba","7")
-- >>> b16Dec $ Data.ByteString.Char8.pack "666F6F62617g"
-- Left ("fooba","g")
b16Dec :: BS.ByteString -> Either (BS.ByteString, BS.ByteString) (BS.ByteString, BS.ByteString)
b16Dec :: ByteString
-> Either (ByteString, ByteString) (ByteString, ByteString)
b16Dec 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
    Ptr Word8
outBuf <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
inLen
    (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
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)
                CInt
r <- Ptr Word8
-> CSize
-> Ptr Word8
-> Ptr CSize
-> Ptr (Ptr Word8)
-> Ptr CSize
-> IO CInt
c_b16_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
                CSize
outLen <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
pOutLen
                Ptr Word8
newOutBuf <- Ptr Word8 -> Int -> IO (Ptr Word8)
forall a. Ptr a -> Int -> IO (Ptr a)
reallocBytes Ptr Word8
outBuf (CSize -> Int
forall a b. (Enum a, Enum b) => a -> b
castEnum CSize
outLen)
                Ptr Word8
remBuf <- Ptr (Ptr Word8) -> IO (Ptr Word8)
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr Word8)
pRemBuf
                CSize
remLen <- Ptr CSize -> IO CSize
forall a. Storable a => Ptr a -> IO a
peek Ptr CSize
pRemLen
                ByteString
remBs <- CStringLen -> IO ByteString
BS.packCStringLen (Ptr Word8 -> Ptr CChar
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
remBuf, CSize -> Int
forall a b. (Enum a, Enum b) => a -> b
castEnum CSize
remLen)
                ByteString
outBs <- Ptr Word8 -> Int -> IO () -> IO ByteString
BSU.unsafePackCStringFinalizer Ptr Word8
newOutBuf (CSize -> Int
forall a b. (Enum a, Enum b) => a -> b
castEnum CSize
outLen) (Ptr Word8 -> IO ()
forall a. Ptr a -> IO ()
free Ptr Word8
newOutBuf)
                if CInt
r CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0
                    then Either (ByteString, ByteString) (ByteString, ByteString)
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ByteString, ByteString) (ByteString, ByteString)
 -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> Either (ByteString, ByteString) (ByteString, ByteString)
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString)
-> Either (ByteString, ByteString) (ByteString, ByteString)
forall a b. b -> Either a b
Right (ByteString
outBs, ByteString
remBs)
                    else Either (ByteString, ByteString) (ByteString, ByteString)
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall (m :: * -> *) a. Monad m => a -> m a
return (Either (ByteString, ByteString) (ByteString, ByteString)
 -> IO (Either (ByteString, ByteString) (ByteString, ByteString)))
-> Either (ByteString, ByteString) (ByteString, ByteString)
-> IO (Either (ByteString, ByteString) (ByteString, ByteString))
forall a b. (a -> b) -> a -> b
$ (ByteString, ByteString)
-> Either (ByteString, ByteString) (ByteString, ByteString)
forall a b. a -> Either a b
Left (ByteString
outBs, ByteString
remBs)

-- | A synonym for 'b16_enc'.
encode :: BS.ByteString -> BS.ByteString
encode :: ByteString -> ByteString
encode = ByteString -> ByteString
b16Enc

-- | A synonum for 'b16_dec'.
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)
b16Dec 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