{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DoAndIfThenElse #-}
-- |
-- Module      : Data.ByteString.Base64.Internal
-- Copyright   : (c) 2010 Bryan O'Sullivan
--
-- License     : BSD-style
-- Maintainer  : bos@serpentine.com
-- Stability   : experimental
-- Portability : GHC
--
-- Fast and efficient encoding and decoding of base64-encoded strings.

module Data.ByteString.Base64.Internal
  ( encodeWith
  , decodeWithTable
  , decodeLenientWithTable
  , mkEncodeTable
  , done
  , peek8, poke8, peek8_32
  , reChunkIn
  , Padding(..)
  , withBS
  , mkBS
  ) where

import Data.Bits ((.|.), (.&.), shiftL, shiftR)
import qualified Data.ByteString as B
import Data.ByteString.Internal (ByteString(..), mallocByteString)
import Data.Word (Word8, Word16, Word32)
import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, castForeignPtr)
import Foreign.Ptr (Ptr, castPtr, minusPtr, plusPtr)
import Foreign.Storable (peek, peekElemOff, poke)
import System.IO.Unsafe (unsafePerformIO)

peek8 :: Ptr Word8 -> IO Word8
peek8 :: Ptr Word8 -> IO Word8
peek8 = Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek

poke8 :: Ptr Word8 -> Word8 -> IO ()
poke8 :: Ptr Word8 -> Word8 -> IO ()
poke8 = Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke

peek8_32 :: Ptr Word8 -> IO Word32
peek8_32 :: Ptr Word8 -> IO Word32
peek8_32 = (Word8 -> Word32) -> IO Word8 -> IO Word32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO Word8 -> IO Word32)
-> (Ptr Word8 -> IO Word8) -> Ptr Word8 -> IO Word32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ptr Word8 -> IO Word8
peek8


data Padding = Padded | Don'tCare | Unpadded deriving Padding -> Padding -> Bool
(Padding -> Padding -> Bool)
-> (Padding -> Padding -> Bool) -> Eq Padding
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Padding -> Padding -> Bool
$c/= :: Padding -> Padding -> Bool
== :: Padding -> Padding -> Bool
$c== :: Padding -> Padding -> Bool
Eq

-- | Encode a string into base64 form.  The result will always be a multiple
-- of 4 bytes in length.
encodeWith :: Padding -> EncodeTable -> ByteString -> ByteString
encodeWith :: Padding -> EncodeTable -> ByteString -> ByteString
encodeWith !Padding
padding (ET ForeignPtr Word8
alfaFP ForeignPtr Word16
encodeTable) !ByteString
bs = ByteString -> (Ptr Word8 -> Int -> IO ByteString) -> ByteString
forall a. ByteString -> (Ptr Word8 -> Int -> IO a) -> a
withBS ByteString
bs Ptr Word8 -> Int -> IO ByteString
go
  where
    go :: Ptr Word8 -> Int -> IO ByteString
go !Ptr Word8
sptr !Int
slen
      | Int
slen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
forall a. Bounded a => a
maxBound Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4 =
        [Char] -> IO ByteString
forall a. HasCallStack => [Char] -> a
error [Char]
"Data.ByteString.Base64.encode: input too long"
      | Bool
otherwise = do
        let dlen :: Int
dlen = (Int
slen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4
        ForeignPtr Word8
dfp <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocByteString Int
dlen
        ForeignPtr Word8 -> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
alfaFP ((Ptr Word8 -> IO ByteString) -> IO ByteString)
-> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
aptr ->
          ForeignPtr Word16 -> (Ptr Word16 -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word16
encodeTable ((Ptr Word16 -> IO ByteString) -> IO ByteString)
-> (Ptr Word16 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word16
ep -> do
            let aidx :: Int -> IO Word8
aidx Int
n = Ptr Word8 -> IO Word8
peek8 (Ptr Word8
aptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
n)
                sEnd :: Ptr b
sEnd = Ptr Word8
sptr Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
slen
                finish :: Int -> m ByteString
finish !Int
n = ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> ByteString
mkBS ForeignPtr Word8
dfp Int
n
                fill :: Ptr Word16 -> Ptr Word8 -> Int -> IO ByteString
fill !Ptr Word16
dp !Ptr Word8
sp !Int
n
                  | Ptr Word8
sp Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2 Ptr Any -> Ptr Any -> Bool
forall a. Ord a => a -> a -> Bool
>= Ptr Any
forall b. Ptr b
sEnd = Ptr Word8 -> Ptr Word8 -> Int -> IO ByteString
forall b. Ptr Word8 -> Ptr b -> Int -> IO ByteString
complete (Ptr Word16 -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr Word16
dp) Ptr Word8
sp Int
n
                  | Bool
otherwise = {-# SCC "encode/fill" #-} do
                  Word32
i <- Ptr Word8 -> IO Word32
peek8_32 Ptr Word8
sp
                  Word32
j <- Ptr Word8 -> IO Word32
peek8_32 (Ptr Word8
sp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1)
                  Word32
k <- Ptr Word8 -> IO Word32
peek8_32 (Ptr Word8
sp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2)
                  let w :: Word32
w = Word32
i Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
16 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
j Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
8 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
k
                      enc :: Word32 -> IO Word16
enc = Ptr Word16 -> Int -> IO Word16
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word16
ep (Int -> IO Word16) -> (Word32 -> Int) -> Word32 -> IO Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral
                  Ptr Word16 -> Word16 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr Word16
dp (Word16 -> IO ()) -> IO Word16 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Word32 -> IO Word16
enc (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
12)
                  Ptr Word16 -> Word16 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word16
dp Ptr Word16 -> Int -> Ptr Word16
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2) (Word16 -> IO ()) -> IO Word16 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Word32 -> IO Word16
enc (Word32
w Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.&. Word32
0xfff)
                  Ptr Word16 -> Ptr Word8 -> Int -> IO ByteString
fill (Ptr Word16
dp Ptr Word16 -> Int -> Ptr Word16
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
4) (Ptr Word8
sp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
3) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
                complete :: Ptr Word8 -> Ptr b -> Int -> IO ByteString
complete Ptr Word8
dp Ptr b
sp Int
n
                    | Ptr b
sp Ptr b -> Ptr b -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr b
forall b. Ptr b
sEnd = Int -> IO ByteString
forall (m :: * -> *). Monad m => Int -> m ByteString
finish Int
n
                    | Bool
otherwise  = {-# SCC "encode/complete" #-} do
                  let peekSP :: Int -> (b -> b) -> IO b
peekSP Int
m b -> b
f = (b -> b
f (b -> b) -> (Word8 -> b) -> Word8 -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (Word8 -> b) -> IO Word8 -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Ptr Word8 -> IO Word8
peek8 (Ptr b
sp Ptr b -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
m)
                      twoMore :: Bool
twoMore    = Ptr b
sp Ptr b -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2 Ptr Any -> Ptr Any -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Any
forall b. Ptr b
sEnd
                      equals :: Word8
equals     = Word8
0x3d :: Word8
                      doPad :: Bool
doPad = Padding
padding Padding -> Padding -> Bool
forall a. Eq a => a -> a -> Bool
== Padding
Padded
                      {-# INLINE equals #-}
                  !Int
a <- Int -> (Int -> Int) -> IO Int
forall b b. Num b => Int -> (b -> b) -> IO b
peekSP Int
0 ((Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
2) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xfc))
                  !Int
b <- Int -> (Int -> Int) -> IO Int
forall b b. Num b => Int -> (b -> b) -> IO b
peekSP Int
0 ((Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
4) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x03))

                  Ptr Word8 -> Word8 -> IO ()
poke8 Ptr Word8
dp (Word8 -> IO ()) -> IO Word8 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO Word8
aidx Int
a

                  if Bool
twoMore
                    then do
                      !Int
b' <- Int -> (Int -> Int) -> IO Int
forall b b. Num b => Int -> (b -> b) -> IO b
peekSP Int
1 ((Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|. Int
b) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
4) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0xf0))
                      !Word8
c <- Int -> IO Word8
aidx (Int -> IO Word8) -> IO Int -> IO Word8
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> (Int -> Int) -> IO Int
forall b b. Num b => Int -> (b -> b) -> IO b
peekSP Int
1 ((Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
2) (Int -> Int) -> (Int -> Int) -> Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
0x0f))
                      Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8
dp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1) (Word8 -> IO ()) -> IO Word8 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO Word8
aidx Int
b'
                      Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8
dp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2) Word8
c

                      if Bool
doPad
                        then Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8
dp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
3) Word8
equals IO () -> IO ByteString -> IO ByteString
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ByteString
forall (m :: * -> *). Monad m => Int -> m ByteString
finish (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
                        else Int -> IO ByteString
forall (m :: * -> *). Monad m => Int -> m ByteString
finish (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
                    else do
                      Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8
dp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1) (Word8 -> IO ()) -> IO Word8 -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Int -> IO Word8
aidx Int
b

                      if Bool
doPad
                        then do
                          Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8
dp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2) Word8
equals
                          Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8
dp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
3) Word8
equals
                          Int -> IO ByteString
forall (m :: * -> *). Monad m => Int -> m ByteString
finish (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
4)
                        else Int -> IO ByteString
forall (m :: * -> *). Monad m => Int -> m ByteString
finish (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)


            ForeignPtr Word8 -> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
dfp (\Ptr Word8
dptr -> Ptr Word16 -> Ptr Word8 -> Int -> IO ByteString
fill (Ptr Word8 -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
dptr) Ptr Word8
sptr Int
0)

data EncodeTable = ET !(ForeignPtr Word8) !(ForeignPtr Word16)

-- The encoding table is constructed such that the expansion of a 12-bit
-- block to a 16-bit block can be done by a single Word16 copy from the
-- correspoding table entry to the target address. The 16-bit blocks are
-- stored in big-endian order, as the indices into the table are built in
-- big-endian order.
mkEncodeTable :: ByteString -> EncodeTable
#if MIN_VERSION_bytestring(0,11,0)
mkEncodeTable alphabet@(BS afp _) =
    case table of BS fp _ -> ET afp (castForeignPtr fp)
#else
mkEncodeTable :: ByteString -> EncodeTable
mkEncodeTable alphabet :: ByteString
alphabet@(PS ForeignPtr Word8
afp Int
_ Int
_) =
    case ByteString
table of PS ForeignPtr Word8
fp Int
_ Int
_ -> ForeignPtr Word8 -> ForeignPtr Word16 -> EncodeTable
ET ForeignPtr Word8
afp (ForeignPtr Word8 -> ForeignPtr Word16
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr Word8
fp)
#endif
  where
    ix :: Int -> Word8
ix    = Word8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word8) -> (Int -> Word8) -> Int -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Int -> Word8
B.index ByteString
alphabet
    table :: ByteString
table = [Word8] -> ByteString
B.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ [[Word8]] -> [Word8]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Word8]] -> [Word8]) -> [[Word8]] -> [Word8]
forall a b. (a -> b) -> a -> b
$ [ [Int -> Word8
ix Int
j, Int -> Word8
ix Int
k] | Int
j <- [Int
0..Int
63], Int
k <- [Int
0..Int
63] ]

-- | Decode a base64-encoded string.  This function strictly follows
-- the specification in <http://tools.ietf.org/rfc/rfc4648 RFC 4648>.
--
-- This function takes the decoding table (for @base64@ or @base64url@) as
-- the first parameter.
--
-- For validation of padding properties, see note: $Validation
--
decodeWithTable :: Padding -> ForeignPtr Word8 -> ByteString -> Either String ByteString
decodeWithTable :: Padding
-> ForeignPtr Word8 -> ByteString -> Either [Char] ByteString
decodeWithTable Padding
padding !ForeignPtr Word8
decodeFP ByteString
bs
  | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right ByteString
B.empty
  | Bool
otherwise = case Padding
padding of
    Padding
Padded
      | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> ByteString
-> (Ptr Word8 -> Int -> IO (Either [Char] ByteString))
-> Either [Char] ByteString
forall a. ByteString -> (Ptr Word8 -> Int -> IO a) -> a
withBS ByteString
bs Ptr Word8 -> Int -> IO (Either [Char] ByteString)
go
      | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left [Char]
"Base64-encoded bytestring has invalid size"
      | Bool
otherwise -> [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left [Char]
"Base64-encoded bytestring is unpadded or has invalid padding"
    Padding
Don'tCare
      | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> ByteString
-> (Ptr Word8 -> Int -> IO (Either [Char] ByteString))
-> Either [Char] ByteString
forall a. ByteString -> (Ptr Word8 -> Int -> IO a) -> a
withBS ByteString
bs Ptr Word8 -> Int -> IO (Either [Char] ByteString)
go
      | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 -> ByteString
-> (Ptr Word8 -> Int -> IO (Either [Char] ByteString))
-> Either [Char] ByteString
forall a. ByteString -> (Ptr Word8 -> Int -> IO a) -> a
withBS (ByteString -> ByteString -> ByteString
B.append ByteString
bs (Int -> Word8 -> ByteString
B.replicate Int
2 Word8
0x3d)) Ptr Word8 -> Int -> IO (Either [Char] ByteString)
go
      | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 -> ByteString
-> [Char] -> Either [Char] ByteString -> Either [Char] ByteString
validateLastPad ByteString
bs [Char]
invalidPad (Either [Char] ByteString -> Either [Char] ByteString)
-> Either [Char] ByteString -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
-> (Ptr Word8 -> Int -> IO (Either [Char] ByteString))
-> Either [Char] ByteString
forall a. ByteString -> (Ptr Word8 -> Int -> IO a) -> a
withBS (ByteString -> ByteString -> ByteString
B.append ByteString
bs (Int -> Word8 -> ByteString
B.replicate Int
1 Word8
0x3d)) Ptr Word8 -> Int -> IO (Either [Char] ByteString)
go
      | Bool
otherwise -> [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left [Char]
"Base64-encoded bytestring has invalid size"
    Padding
Unpadded
      | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> ByteString
-> [Char] -> Either [Char] ByteString -> Either [Char] ByteString
validateLastPad ByteString
bs [Char]
noPad (Either [Char] ByteString -> Either [Char] ByteString)
-> Either [Char] ByteString -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
-> (Ptr Word8 -> Int -> IO (Either [Char] ByteString))
-> Either [Char] ByteString
forall a. ByteString -> (Ptr Word8 -> Int -> IO a) -> a
withBS ByteString
bs Ptr Word8 -> Int -> IO (Either [Char] ByteString)
go
      | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 -> ByteString
-> [Char] -> Either [Char] ByteString -> Either [Char] ByteString
validateLastPad ByteString
bs [Char]
noPad (Either [Char] ByteString -> Either [Char] ByteString)
-> Either [Char] ByteString -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
-> (Ptr Word8 -> Int -> IO (Either [Char] ByteString))
-> Either [Char] ByteString
forall a. ByteString -> (Ptr Word8 -> Int -> IO a) -> a
withBS (ByteString -> ByteString -> ByteString
B.append ByteString
bs (Int -> Word8 -> ByteString
B.replicate Int
2 Word8
0x3d)) Ptr Word8 -> Int -> IO (Either [Char] ByteString)
go
      | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
3 -> ByteString
-> [Char] -> Either [Char] ByteString -> Either [Char] ByteString
validateLastPad ByteString
bs [Char]
noPad (Either [Char] ByteString -> Either [Char] ByteString)
-> Either [Char] ByteString -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
-> (Ptr Word8 -> Int -> IO (Either [Char] ByteString))
-> Either [Char] ByteString
forall a. ByteString -> (Ptr Word8 -> Int -> IO a) -> a
withBS (ByteString -> ByteString -> ByteString
B.append ByteString
bs (Int -> Word8 -> ByteString
B.replicate Int
1 Word8
0x3d)) Ptr Word8 -> Int -> IO (Either [Char] ByteString)
go
      | Bool
otherwise -> [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left [Char]
"Base64-encoded bytestring has invalid size"
  where
    !r :: Int
r = ByteString -> Int
B.length ByteString
bs Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
4

    noPad :: [Char]
noPad = [Char]
"Base64-encoded bytestring required to be unpadded"
    invalidPad :: [Char]
invalidPad = [Char]
"Base64-encoded bytestring has invalid padding"

    go :: Ptr Word8 -> Int -> IO (Either [Char] ByteString)
go !Ptr Word8
sptr !Int
slen = do
      ForeignPtr Word8
dfp <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocByteString (Int
slen Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3)
      ForeignPtr Word8
-> (Ptr Word8 -> IO (Either [Char] ByteString))
-> IO (Either [Char] ByteString)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
decodeFP (\ !Ptr Word8
decptr ->
        ForeignPtr Word8
-> (Ptr Word8 -> IO (Either [Char] ByteString))
-> IO (Either [Char] ByteString)
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
dfp (\Ptr Word8
dptr ->
          Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> ForeignPtr Word8
-> IO (Either [Char] ByteString)
decodeLoop Ptr Word8
decptr Ptr Word8
sptr Ptr Word8
dptr (Ptr Word8
sptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
slen) ForeignPtr Word8
dfp))

decodeLoop
    :: Ptr Word8
      -- ^ decoding table pointer
    -> Ptr Word8
      -- ^ source pointer
    -> Ptr Word8
      -- ^ destination pointer
    -> Ptr Word8
      -- ^ source end pointer
    -> ForeignPtr Word8
      -- ^ destination foreign pointer (used for finalizing string)
    -> IO (Either String ByteString)
decodeLoop :: Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> ForeignPtr Word8
-> IO (Either [Char] ByteString)
decodeLoop !Ptr Word8
dtable !Ptr Word8
sptr !Ptr Word8
dptr !Ptr Word8
end !ForeignPtr Word8
dfp = Ptr Word8 -> Ptr Word8 -> IO (Either [Char] ByteString)
go Ptr Word8
dptr Ptr Word8
sptr
  where
    err :: Ptr a -> m (Either [Char] b)
err Ptr a
p = Either [Char] b -> m (Either [Char] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] b -> m (Either [Char] b))
-> ([Char] -> Either [Char] b) -> [Char] -> m (Either [Char] b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] b
forall a b. a -> Either a b
Left
      ([Char] -> m (Either [Char] b)) -> [Char] -> m (Either [Char] b)
forall a b. (a -> b) -> a -> b
$ [Char]
"invalid character at offset: "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Ptr a
p Ptr a -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
sptr)

    padErr :: Ptr a -> m (Either [Char] b)
padErr Ptr a
p = Either [Char] b -> m (Either [Char] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] b -> m (Either [Char] b))
-> ([Char] -> Either [Char] b) -> [Char] -> m (Either [Char] b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] b
forall a b. a -> Either a b
Left
      ([Char] -> m (Either [Char] b)) -> [Char] -> m (Either [Char] b)
forall a b. (a -> b) -> a -> b
$ [Char]
"invalid padding at offset: "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Ptr a
p Ptr a -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
sptr)

    canonErr :: Ptr a -> m (Either [Char] b)
canonErr Ptr a
p = Either [Char] b -> m (Either [Char] b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] b -> m (Either [Char] b))
-> ([Char] -> Either [Char] b) -> [Char] -> m (Either [Char] b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Either [Char] b
forall a b. a -> Either a b
Left
      ([Char] -> m (Either [Char] b)) -> [Char] -> m (Either [Char] b)
forall a b. (a -> b) -> a -> b
$ [Char]
"non-canonical encoding detected at offset: "
      [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show (Ptr a
p Ptr a -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
sptr)

    look :: Ptr Word8 -> IO Word32
    look :: Ptr Word8 -> IO Word32
look !Ptr Word8
p = do
      !Word8
i <- Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek Ptr Word8
p
      !Word8
v <- Ptr Word8 -> Int -> IO Word8
forall a. Storable a => Ptr a -> Int -> IO a
peekElemOff Ptr Word8
dtable (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
i)
      Word32 -> IO Word32
forall (m :: * -> *) a. Monad m => a -> m a
return (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
v)

    go :: Ptr Word8 -> Ptr Word8 -> IO (Either [Char] ByteString)
go !Ptr Word8
dst !Ptr Word8
src
      | Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
4 Ptr Word8 -> Ptr Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Ptr Word8
end = do
        !Word32
a <- Ptr Word8 -> IO Word32
look Ptr Word8
src
        !Word32
b <- Ptr Word8 -> IO Word32
look (Ptr Word8
src Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1)
        !Word32
c <- Ptr Word8 -> IO Word32
look (Ptr Word8
src Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2)
        !Word32
d <- Ptr Word8 -> IO Word32
look (Ptr Word8
src Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
3)
        Ptr Word8
-> Ptr Word8
-> Word32
-> Word32
-> Word32
-> Word32
-> IO (Either [Char] ByteString)
forall a.
Ptr Word8
-> Ptr a
-> Word32
-> Word32
-> Word32
-> Word32
-> IO (Either [Char] ByteString)
finalChunk Ptr Word8
dst Ptr Word8
src Word32
a Word32
b Word32
c Word32
d

      | Bool
otherwise = do
        !Word32
a <- Ptr Word8 -> IO Word32
look Ptr Word8
src
        !Word32
b <- Ptr Word8 -> IO Word32
look (Ptr Word8
src Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1)
        !Word32
c <- Ptr Word8 -> IO Word32
look (Ptr Word8
src Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2)
        !Word32
d <- Ptr Word8 -> IO Word32
look (Ptr Word8
src Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
3)
        Ptr Word8
-> Ptr Word8
-> Word32
-> Word32
-> Word32
-> Word32
-> IO (Either [Char] ByteString)
decodeChunk Ptr Word8
dst Ptr Word8
src Word32
a Word32
b Word32
c Word32
d

    -- | Decodes chunks of 4 bytes at a time, recombining into
    -- 3 bytes. Note that in the inner loop stage, no padding
    -- characters are admissible.
    --
    decodeChunk :: Ptr Word8
-> Ptr Word8
-> Word32
-> Word32
-> Word32
-> Word32
-> IO (Either [Char] ByteString)
decodeChunk !Ptr Word8
dst !Ptr Word8
src !Word32
a !Word32
b !Word32
c !Word32
d
     | Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x63 = Ptr Word8 -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
padErr Ptr Word8
src
     | Word32
b Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x63 = Ptr Any -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
padErr (Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
1)
     | Word32
c Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x63 = Ptr Any -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
padErr (Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
2)
     | Word32
d Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x63 = Ptr Any -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
padErr (Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
3)
     | Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0xff = Ptr Word8 -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
err Ptr Word8
src
     | Word32
b Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0xff = Ptr Any -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
err (Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
1)
     | Word32
c Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0xff = Ptr Any -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
err (Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
2)
     | Word32
d Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0xff = Ptr Any -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
err (Ptr Word8 -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
3)
     | Bool
otherwise = do
       let !w :: Word32
w = (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
a Int
18
             Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
b Int
12
             Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
c Int
6
             Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
d) :: Word32

       Ptr Word8 -> Word8 -> IO ()
poke8 Ptr Word8
dst (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR Word32
w Int
16))
       Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dst Int
1) (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR Word32
w Int
8))
       Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dst Int
2) (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w)
       Ptr Word8 -> Ptr Word8 -> IO (Either [Char] ByteString)
go (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dst Int
3) (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src Int
4)

    -- | Decode the final 4 bytes in the string, recombining into
    -- 3 bytes. Note that in this stage, we can have padding chars
    -- but only in the final 2 positions.
    --
    finalChunk :: Ptr Word8
-> Ptr a
-> Word32
-> Word32
-> Word32
-> Word32
-> IO (Either [Char] ByteString)
finalChunk !Ptr Word8
dst !Ptr a
src Word32
a Word32
b Word32
c Word32
d
      | Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x63 = Ptr a -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
padErr Ptr a
src
      | Word32
b Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x63 = Ptr Any -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
padErr (Ptr a -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr a
src Int
1)
      | Word32
c Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x63 Bool -> Bool -> Bool
&& Word32
d Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word32
0x63 = Ptr Any -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
err (Ptr a -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr a
src Int
3) -- make sure padding is coherent.
      | Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0xff = Ptr a -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
err Ptr a
src
      | Word32
b Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0xff = Ptr Any -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
err (Ptr a -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr a
src Int
1)
      | Word32
c Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0xff = Ptr Any -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
err (Ptr a -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr a
src Int
2)
      | Word32
d Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0xff = Ptr Any -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
err (Ptr a -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr a
src Int
3)
      | Bool
otherwise = do
        let !w :: Word32
w = (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
a Int
18
              Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
b Int
12
              Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
c Int
6
              Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
d) :: Word32

        Ptr Word8 -> Word8 -> IO ()
poke8 Ptr Word8
dst (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR Word32
w Int
16))

        if Word32
c Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x63 Bool -> Bool -> Bool
&& Word32
d Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x63
        then
          if Word32 -> Word8 -> Bool
sanityCheckPos Word32
b Word8
mask_4bits
          then Either [Char] ByteString -> IO (Either [Char] ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] ByteString -> IO (Either [Char] ByteString))
-> Either [Char] ByteString -> IO (Either [Char] ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right (ByteString -> Either [Char] ByteString)
-> ByteString -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> ByteString
mkBS ForeignPtr Word8
dfp (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Ptr Word8
dst Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
dptr))
          else Ptr Any -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
canonErr (Ptr a -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr a
src Int
1)
        else if Word32
d Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
0x63
          then
            if Word32 -> Word8 -> Bool
sanityCheckPos Word32
c Word8
mask_2bits
            then do
              Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dst Int
1) (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR Word32
w Int
8))
              Either [Char] ByteString -> IO (Either [Char] ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] ByteString -> IO (Either [Char] ByteString))
-> Either [Char] ByteString -> IO (Either [Char] ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right (ByteString -> Either [Char] ByteString)
-> ByteString -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> ByteString
mkBS ForeignPtr Word8
dfp (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Ptr Word8
dst Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
dptr))
            else Ptr Any -> IO (Either [Char] ByteString)
forall (m :: * -> *) a b. Monad m => Ptr a -> m (Either [Char] b)
canonErr (Ptr a -> Int -> Ptr Any
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr a
src Int
2)
          else do
            Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dst Int
1) (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftR Word32
w Int
8))
            Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dst Int
2) (Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w)
            Either [Char] ByteString -> IO (Either [Char] ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [Char] ByteString -> IO (Either [Char] ByteString))
-> Either [Char] ByteString -> IO (Either [Char] ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right (ByteString -> Either [Char] ByteString)
-> ByteString -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> ByteString
mkBS ForeignPtr Word8
dfp (Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Ptr Word8
dst Ptr Word8 -> Ptr Word8 -> Int
forall a b. Ptr a -> Ptr b -> Int
`minusPtr` Ptr Word8
dptr))


-- | Decode a base64-encoded string.  This function is lenient in
-- following the specification from
-- <http://tools.ietf.org/rfc/rfc4648 RFC 4648>, and will not
-- generate parse errors no matter how poor its input.  This function
-- takes the decoding table (for @base64@ or @base64url@) as the first
-- paramert.
decodeLenientWithTable :: ForeignPtr Word8 -> ByteString -> ByteString
decodeLenientWithTable :: ForeignPtr Word8 -> ByteString -> ByteString
decodeLenientWithTable !ForeignPtr Word8
decodeFP !ByteString
bs = ByteString -> (Ptr Word8 -> Int -> IO ByteString) -> ByteString
forall a. ByteString -> (Ptr Word8 -> Int -> IO a) -> a
withBS ByteString
bs Ptr Word8 -> Int -> IO ByteString
go
  where
    go :: Ptr Word8 -> Int -> IO ByteString
go !Ptr Word8
sptr !Int
slen
      | Int
dlen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = ByteString -> IO ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
      | Bool
otherwise = do
        ForeignPtr Word8
dfp <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocByteString Int
dlen
        ForeignPtr Word8 -> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
decodeFP ((Ptr Word8 -> IO ByteString) -> IO ByteString)
-> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ !Ptr Word8
decptr -> do
          let finish :: Int -> m ByteString
finish Int
dbytes
                  | Int
dbytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString -> m ByteString) -> ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ ForeignPtr Word8 -> Int -> ByteString
mkBS ForeignPtr Word8
dfp Int
dbytes
                  | Bool
otherwise = ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
B.empty
              sEnd :: Ptr b
sEnd = Ptr Word8
sptr Ptr Word8 -> Int -> Ptr b
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
slen
              fill :: Ptr Word8 -> Ptr Word8 -> Int -> IO ByteString
fill !Ptr Word8
dp !Ptr Word8
sp !Int
n
                | Ptr Word8
sp Ptr Word8 -> Ptr Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Ptr Word8
forall b. Ptr b
sEnd = Int -> IO ByteString
forall (m :: * -> *). Monad m => Int -> m ByteString
finish Int
n
                | Bool
otherwise = {-# SCC "decodeLenientWithTable/fill" #-}
                let look :: Bool -> Ptr Word8
                         -> (Ptr Word8 -> Word32 -> IO ByteString)
                         -> IO ByteString
                    {-# INLINE look #-}
                    look :: Bool
-> Ptr Word8
-> (Ptr Word8 -> Word32 -> IO ByteString)
-> IO ByteString
look Bool
skipPad Ptr Word8
p0 Ptr Word8 -> Word32 -> IO ByteString
f = Ptr Word8 -> IO ByteString
go' Ptr Word8
p0
                      where
                        go' :: Ptr Word8 -> IO ByteString
go' Ptr Word8
p | Ptr Word8
p Ptr Word8 -> Ptr Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Ptr Word8
forall b. Ptr b
sEnd = Ptr Word8 -> Word32 -> IO ByteString
f (Ptr Any
forall b. Ptr b
sEnd Ptr Any -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (-Int
1)) Word32
forall a. Integral a => a
done
                             | Bool
otherwise = {-# SCC "decodeLenient/look" #-} do
                          Int
ix <- Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Int) -> IO Word8 -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Ptr Word8 -> IO Word8
peek8 Ptr Word8
p
                          Word8
v <- Ptr Word8 -> IO Word8
peek8 (Ptr Word8
decptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
ix)
                          if Word8
v Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
forall a. Integral a => a
x Bool -> Bool -> Bool
|| Word8
v Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
forall a. Integral a => a
done Bool -> Bool -> Bool
&& Bool
skipPad
                            then Ptr Word8 -> IO ByteString
go' (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1)
                            else Ptr Word8 -> Word32 -> IO ByteString
f (Ptr Word8
p Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1) (Word8 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
v)
                in Bool
-> Ptr Word8
-> (Ptr Word8 -> Word32 -> IO ByteString)
-> IO ByteString
look Bool
True Ptr Word8
sp ((Ptr Word8 -> Word32 -> IO ByteString) -> IO ByteString)
-> (Ptr Word8 -> Word32 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ !Ptr Word8
aNext !Word32
aValue ->
                   Bool
-> Ptr Word8
-> (Ptr Word8 -> Word32 -> IO ByteString)
-> IO ByteString
look Bool
True Ptr Word8
aNext ((Ptr Word8 -> Word32 -> IO ByteString) -> IO ByteString)
-> (Ptr Word8 -> Word32 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ !Ptr Word8
bNext !Word32
bValue ->
                     if Word32
aValue Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
forall a. Integral a => a
done Bool -> Bool -> Bool
|| Word32
bValue Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
forall a. Integral a => a
done
                     then Int -> IO ByteString
forall (m :: * -> *). Monad m => Int -> m ByteString
finish Int
n
                     else
                        Bool
-> Ptr Word8
-> (Ptr Word8 -> Word32 -> IO ByteString)
-> IO ByteString
look Bool
False Ptr Word8
bNext ((Ptr Word8 -> Word32 -> IO ByteString) -> IO ByteString)
-> (Ptr Word8 -> Word32 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ !Ptr Word8
cNext !Word32
cValue ->
                        Bool
-> Ptr Word8
-> (Ptr Word8 -> Word32 -> IO ByteString)
-> IO ByteString
look Bool
False Ptr Word8
cNext ((Ptr Word8 -> Word32 -> IO ByteString) -> IO ByteString)
-> (Ptr Word8 -> Word32 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ !Ptr Word8
dNext !Word32
dValue -> do
                          let w :: Word32
w = Word32
aValue Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
18 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
bValue Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
12 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
                                  Word32
cValue Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` Int
6 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
dValue
                          Ptr Word8 -> Word8 -> IO ()
poke8 Ptr Word8
dp (Word8 -> IO ()) -> Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
16)
                          if Word32
cValue Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
forall a. Integral a => a
done
                            then Int -> IO ByteString
forall (m :: * -> *). Monad m => Int -> m ByteString
finish (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                            else do
                              Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8
dp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
1) (Word8 -> IO ()) -> Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
8)
                              if Word32
dValue Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
forall a. Integral a => a
done
                                then Int -> IO ByteString
forall (m :: * -> *). Monad m => Int -> m ByteString
finish (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
                                else do
                                  Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8
dp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
2) (Word8 -> IO ()) -> Word8 -> IO ()
forall a b. (a -> b) -> a -> b
$ Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w
                                  Ptr Word8 -> Ptr Word8 -> Int -> IO ByteString
fill (Ptr Word8
dp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
3) Ptr Word8
dNext (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
3)
          ForeignPtr Word8 -> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
dfp ((Ptr Word8 -> IO ByteString) -> IO ByteString)
-> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
dptr -> Ptr Word8 -> Ptr Word8 -> Int -> IO ByteString
fill Ptr Word8
dptr Ptr Word8
sptr Int
0
      where
        !dlen :: Int
dlen = (Int
slen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3

x :: Integral a => a
x :: a
x = a
255
{-# INLINE x #-}

done :: Integral a => a
done :: a
done = a
99
{-# INLINE done #-}

-- This takes a list of ByteStrings, and returns a list in which each
-- (apart from possibly the last) has length that is a multiple of n
reChunkIn :: Int -> [ByteString] -> [ByteString]
reChunkIn :: Int -> [ByteString] -> [ByteString]
reChunkIn !Int
n = [ByteString] -> [ByteString]
go
  where
    go :: [ByteString] -> [ByteString]
go [] = []
    go (ByteString
y : [ByteString]
ys) = case ByteString -> Int
B.length ByteString
y Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` Int
n of
                    (Int
_, Int
0) -> ByteString
y ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString] -> [ByteString]
go [ByteString]
ys
                    (Int
d, Int
_) -> case Int -> ByteString -> (ByteString, ByteString)
B.splitAt (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n) ByteString
y of
                                (ByteString
prefix, ByteString
suffix) -> ByteString
prefix ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString -> [ByteString] -> [ByteString]
fixup ByteString
suffix [ByteString]
ys
    fixup :: ByteString -> [ByteString] -> [ByteString]
fixup ByteString
acc [] = [ByteString
acc]
    fixup ByteString
acc (ByteString
z : [ByteString]
zs) = case Int -> ByteString -> (ByteString, ByteString)
B.splitAt (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
B.length ByteString
acc) ByteString
z of
                           (ByteString
prefix, ByteString
suffix) ->
                             let acc' :: ByteString
acc' = ByteString
acc ByteString -> ByteString -> ByteString
`B.append` ByteString
prefix
                             in if ByteString -> Int
B.length ByteString
acc' Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n
                                then let zs' :: [ByteString]
zs' = if ByteString -> Bool
B.null ByteString
suffix
                                               then          [ByteString]
zs
                                               else ByteString
suffix ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString]
zs
                                     in ByteString
acc' ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString] -> [ByteString]
go [ByteString]
zs'
                                else -- suffix must be null
                                    ByteString -> [ByteString] -> [ByteString]
fixup ByteString
acc' [ByteString]
zs

-- $Validation
--
-- This function checks that the last char of a bytestring is '='
-- and, if true, fails with a message or completes some io action.
--
-- This is necessary to check when decoding permissively (i.e. filling in padding chars).
-- Consider the following 4 cases of a string of length l:
--
-- l = 0 mod 4: No pad chars are added, since the input is assumed to be good.
-- l = 1 mod 4: Never an admissible length in base64
-- l = 2 mod 4: 2 padding chars are added. If padding chars are present in the last 4 chars of the string,
-- they will fail to decode as final quanta.
-- l = 3 mod 4: 1 padding char is added. In this case  a string is of the form <body> + <padchar>. If adding the
-- pad char "completes" the string so that it is `l = 0 mod 4`, then this may possibly form corrupted data.
-- This case is degenerate and should be disallowed.
--
-- Hence, permissive decodes should only fill in padding chars when it makes sense to add them. That is,
-- if an input is degenerate, it should never succeed when we add padding chars. We need the following invariant to hold:
--
-- @
--   B64U.decodeUnpadded <|> B64U.decodePadded ~ B64U.decodePadded
-- @
--
-- This means the only char we need to check is the last one, and only to disallow `l = 3 mod 4`.
--
validateLastPad
    :: ByteString
      -- ^ input to validate
    -> String
      -- ^ error msg
    -> Either String ByteString
    -> Either String ByteString
validateLastPad :: ByteString
-> [Char] -> Either [Char] ByteString -> Either [Char] ByteString
validateLastPad !ByteString
bs [Char]
err !Either [Char] ByteString
io
    | ByteString -> Word8
B.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x3d = [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left [Char]
err
    | Bool
otherwise = Either [Char] ByteString
io
{-# INLINE validateLastPad #-}

-- | Sanity check an index against a bitmask to make sure
-- it's coherent. If pos & mask == 0, we're good. If not, we should fail.
--
sanityCheckPos :: Word32 -> Word8 -> Bool
sanityCheckPos :: Word32 -> Word8 -> Bool
sanityCheckPos Word32
pos Word8
mask = Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
pos Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
mask Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0
{-# INLINE sanityCheckPos #-}

-- | Mask 2 bits
--
mask_2bits :: Word8
mask_2bits :: Word8
mask_2bits = Word8
3  -- (1 << 2) - 1
{-# NOINLINE mask_2bits #-}

-- | Mask 4 bits
--
mask_4bits :: Word8
mask_4bits :: Word8
mask_4bits = Word8
15 -- (1 << 4) - 1
{-# NOINLINE mask_4bits #-}

-- | Back-compat shim for bytestring >=0.11. Constructs a
-- bytestring from a foreign ptr and a length. Offset is 0.
--
mkBS :: ForeignPtr Word8 -> Int -> ByteString
#if MIN_VERSION_bytestring(0,11,0)
mkBS dfp n = BS dfp n
#else
mkBS :: ForeignPtr Word8 -> Int -> ByteString
mkBS ForeignPtr Word8
dfp Int
n = ForeignPtr Word8 -> Int -> Int -> ByteString
PS ForeignPtr Word8
dfp Int
0 Int
n
#endif
{-# INLINE mkBS #-}

-- | Back-compat shim for bytestring >=0.11. Unwraps the foreign ptr of
-- a bytestring, executing an IO action as a function of the underlying
-- pointer and some starting length.
--
-- Note: in `unsafePerformIO`.
--
withBS :: ByteString -> (Ptr Word8 -> Int -> IO a) -> a
#if MIN_VERSION_bytestring(0,11,0)
withBS (BS !sfp !slen) f = unsafePerformIO $
  withForeignPtr sfp $ \p -> f p slen
#else
withBS :: ByteString -> (Ptr Word8 -> Int -> IO a) -> a
withBS (PS !ForeignPtr Word8
sfp !Int
soff !Int
slen) Ptr Word8 -> Int -> IO a
f = IO a -> a
forall a. IO a -> a
unsafePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$
  ForeignPtr Word8 -> (Ptr Word8 -> IO a) -> IO a
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
sfp ((Ptr Word8 -> IO a) -> IO a) -> (Ptr Word8 -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
p -> Ptr Word8 -> Int -> IO a
f (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
p Int
soff) Int
slen
#endif
{-# INLINE withBS #-}