Base16.hs

{-# 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 = toEnum . 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 bs = U.unsafePerformIO $ BSU.unsafeUseAsCStringLen bs $ \ (inBuf, inLen) -> do
    let maxOutLen = inLen * 2
    outBuf <- mallocBytes maxOutLen
    alloca $ \ pOutLen ->
        alloca $ \ pRemBuf ->
            alloca $ \ pRemLen -> do
                poke pOutLen (castEnum maxOutLen)
                c_b16_enc (castPtr inBuf) (castEnum inLen) outBuf pOutLen pRemBuf pRemLen
                outLen <- peek pOutLen
                BSU.unsafePackCStringFinalizer outBuf (castEnum outLen) (free 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 bs = U.unsafePerformIO $ BSU.unsafeUseAsCStringLen bs $ \ (inBuf, inLen) -> do
    outBuf <- mallocBytes inLen
    alloca $ \ pOutLen ->
        alloca $ \ pRemBuf ->
            alloca $ \ pRemLen -> do
                poke pOutLen (castEnum inLen)
                r <- c_b16_dec (castPtr inBuf) (castEnum inLen) outBuf pOutLen pRemBuf 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)

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

-- | A synonum for 'b16_dec'.
decode :: BS.ByteString -> Either (BS.ByteString, BS.ByteString) BS.ByteString
decode bs = case b16Dec bs of
    Right a@(d, r) -> if BS.null r
            then Right d
            else Left a
    Left a -> Left a