{-# LANGUAGE ForeignFunctionInterface #-}

-- |
-- Module    : Codec.Binary.Base32Hex
-- Copyright : (c) 2012 Magnus Therning
-- License   : BSD3
--
-- Implemented as specified in RFC 4648 (<http://tools.ietf.org/html/rfc4648>).
--
-- This encoding is closely related to base 32 and so is its implementation, so
-- please refer to "Codec.Binary.Base32" for further details.
module Codec.Binary.Base32Hex
   ( b32hEncodePart
   , b32hEncodeFinal
   , b32hDecodePart
   , b32hDecodeFinal
   , encode
   , decode
   ) where

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

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 b32.h b32h_enc_part"
    c_b32h_enc_part :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CSize -> IO ()

foreign import ccall "static b32.h b32h_enc_final"
    c_b32h_enc_final :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> IO CInt

foreign import ccall "static b32.h b32h_dec_part"
    c_b32h_dec_part :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> Ptr (Ptr Word8) -> Ptr CSize -> IO CInt

foreign import ccall "static b32.h b32h_dec_final"
    c_b32h_dec_final :: Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> IO CInt

-- | Encoding function.
--
-- See 'Codec.Binary.Base32.b32_encode_part'.
--
-- >>> b32hEncodePart $ Data.ByteString.Char8.pack "fooba"
-- ("CPNMUOJ1","")
-- >>> b32hEncodePart $ Data.ByteString.Char8.pack "foobar"
-- ("CPNMUOJ1","r")
b32hEncodePart :: BS.ByteString -> (BS.ByteString, BS.ByteString)
b32hEncodePart :: ByteString -> (ByteString, ByteString)
b32hEncodePart 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
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
inLen Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8
    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_b32h_enc_part (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
                remBuf <- peek pRemBuf
                remLen <- peek pRemLen
                remBs <- BS.packCStringLen (castPtr remBuf, castEnum remLen)
                outBs <- unsafePackCStringFinalizer outBuf (castEnum outLen) (free outBuf)
                return (outBs, remBs)

-- | Encoding function for the final block.
--
-- See 'Codec.Binary.Base32.b32_encode_final'.
--
-- >>> b32hEncodeFinal $ Data.ByteString.Char8.pack "r"
-- Just "E8======"
-- >>> b32hEncodeFinal $ Data.ByteString.Char8.pack "fooba"
-- Nothing
b32hEncodeFinal :: BS.ByteString -> Maybe BS.ByteString
b32hEncodeFinal :: ByteString -> Maybe ByteString
b32hEncodeFinal ByteString
bs = IO (Maybe ByteString) -> Maybe ByteString
forall a. IO a -> a
U.unsafePerformIO (IO (Maybe ByteString) -> Maybe ByteString)
-> IO (Maybe ByteString) -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
-> (CStringLen -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (CStringLen -> IO (Maybe ByteString)) -> IO (Maybe 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
8
    alloca $ \ Ptr CSize
pOutLen -> do
        r <- Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> IO CInt
c_b32h_enc_final (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
        if r == 0
            then do
                outLen <- peek pOutLen
                newOutBuf <- reallocBytes outBuf (castEnum outLen)
                outBs <- unsafePackCStringFinalizer newOutBuf (castEnum outLen) (free newOutBuf)
                return $ Just outBs
            else free outBuf >> return Nothing

-- | Decoding function.
--
-- See 'Codec.Binary.Base32.b32_decode_part'.
--
-- >>> b32hDecodePart $ Data.ByteString.Char8.pack "CPNMUOJ1"
-- Right ("fooba","")
-- >>> b32hDecodePart $ Data.ByteString.Char8.pack "CPNMUOJ1E8======"
-- Right ("fooba","E8======")
-- >>> b32hDecodePart $ Data.ByteString.Char8.pack "C=NMUOJ1"
-- Left ("","C=NMUOJ1")
b32hDecodePart :: BS.ByteString -> Either (BS.ByteString, BS.ByteString) (BS.ByteString, BS.ByteString)
b32hDecodePart :: ByteString
-> Either (ByteString, ByteString) (ByteString, ByteString)
b32hDecodePart 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
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
    let maxOutLen :: Int
maxOutLen = Int
inLen Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
5
    outBuf <- Int -> IO (Ptr Word8)
forall a. Int -> IO (Ptr a)
mallocBytes Int
maxOutLen
    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
maxOutLen)
                r <- Ptr Word8
-> CSize
-> Ptr Word8
-> Ptr CSize
-> Ptr (Ptr Word8)
-> Ptr CSize
-> IO CInt
c_b32h_dec_part (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 <- unsafePackCStringFinalizer newOutBuf (castEnum outLen) (free newOutBuf)
                if r == 0
                    then return $ Right (outBs, remBs)
                    else return $ Left (outBs, remBs)

-- | Decoding function for the final block.
--
-- See 'Codec.Binary.Base32.b32_decode_final'.
--
-- >>> b32hDecodeFinal $ Data.ByteString.Char8.pack "CPNMUOG="
-- Just "foob"
-- >>> b32hDecodeFinal $ Data.ByteString.Char8.pack ""
-- Just ""
-- >>> b32hDecodeFinal $ Data.ByteString.Char8.pack "CPNMUO="
-- Nothing
-- >>> b32hDecodeFinal $ encode $ Data.ByteString.Char8.pack "fooba"
-- Nothing
b32hDecodeFinal :: BS.ByteString -> Maybe BS.ByteString
b32hDecodeFinal :: ByteString -> Maybe ByteString
b32hDecodeFinal ByteString
bs = IO (Maybe ByteString) -> Maybe ByteString
forall a. IO a -> a
U.unsafePerformIO (IO (Maybe ByteString) -> Maybe ByteString)
-> IO (Maybe ByteString) -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
-> (CStringLen -> IO (Maybe ByteString)) -> IO (Maybe ByteString)
forall a. ByteString -> (CStringLen -> IO a) -> IO a
unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO (Maybe ByteString)) -> IO (Maybe ByteString))
-> (CStringLen -> IO (Maybe ByteString)) -> IO (Maybe 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
5
    alloca $ \ Ptr CSize
pOutLen -> do
        r <- Ptr Word8 -> CSize -> Ptr Word8 -> Ptr CSize -> IO CInt
c_b32h_dec_final (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
        if r == 0
            then do
                outLen <- peek pOutLen
                newOutBuf <- reallocBytes outBuf (castEnum outLen)
                outBs <- unsafePackCStringFinalizer newOutBuf (castEnum outLen) (free newOutBuf)
                return $ Just outBs
            else free outBuf >> return Nothing

-- | Convenience function that combines 'b32h_encode_part' and
-- 'b32h_encode_final' to encode a complete string.
--
-- >>> encode $ Data.ByteString.Char8.pack "fooba"
-- "CPNMUOJ1"
-- >>> encode $ Data.ByteString.Char8.pack "foobar"
-- "CPNMUOJ1E8======"
encode :: BS.ByteString -> BS.ByteString
encode :: ByteString -> ByteString
encode ByteString
bs = ByteString
first ByteString -> ByteString -> ByteString
`BS.append` ByteString
final
    where
        (ByteString
first, ByteString
rest) = ByteString -> (ByteString, ByteString)
b32hEncodePart ByteString
bs
        Just ByteString
final = ByteString -> Maybe ByteString
b32hEncodeFinal ByteString
rest

-- | Convenience function that combines 'b32h_decode_part' and
-- 'b32h_decode_final' to decode a complete string.
--
-- >>> decode $ Data.ByteString.Char8.pack "CPNMUOJ1"
-- Right "fooba"
-- >>> decode $ Data.ByteString.Char8.pack "CPNMUOJ1E8======"
-- Right "foobar"
--
-- Failures when decoding returns the decoded part and the remainder:
--
-- >>> decode $ Data.ByteString.Char8.pack "CPNMUOJ1=8======"
-- Left ("fooba","=8======")
decode :: BS.ByteString -> Either (BS.ByteString, BS.ByteString) BS.ByteString
decode :: ByteString -> Either (ByteString, ByteString) ByteString
decode ByteString
bs = ((ByteString, ByteString)
 -> Either (ByteString, ByteString) ByteString)
-> ((ByteString, ByteString)
    -> Either (ByteString, ByteString) ByteString)
-> Either (ByteString, ByteString) (ByteString, ByteString)
-> Either (ByteString, ByteString) ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (ByteString, ByteString)
-> Either (ByteString, ByteString) ByteString
forall a b. a -> Either a b
Left
    (\ (ByteString
first, ByteString
rest) ->
        Either (ByteString, ByteString) ByteString
-> (ByteString -> Either (ByteString, ByteString) ByteString)
-> Maybe ByteString
-> Either (ByteString, ByteString) ByteString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            ((ByteString, ByteString)
-> Either (ByteString, ByteString) ByteString
forall a b. a -> Either a b
Left (ByteString
first, ByteString
rest))
            (\ ByteString
fin -> ByteString -> Either (ByteString, ByteString) ByteString
forall a b. b -> Either a b
Right (ByteString
first ByteString -> ByteString -> ByteString
`BS.append` ByteString
fin))
            (ByteString -> Maybe ByteString
b32hDecodeFinal ByteString
rest))
    (ByteString
-> Either (ByteString, ByteString) (ByteString, ByteString)
b32hDecodePart ByteString
bs)