{-# LANGUAGE BangPatterns #-}
{-# 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(..)
  ) 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 alfaFP :: ForeignPtr Word8
alfaFP encodeTable :: ForeignPtr Word16
encodeTable) (PS sfp :: ForeignPtr Word8
sfp soff :: Int
soff slen :: 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` 4 =
        [Char] -> ByteString
forall a. HasCallStack => [Char] -> a
error "Data.ByteString.Base64.encode: input too long"
    | Bool
otherwise = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ do
  let dlen :: Int
dlen = ((Int
slen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 3) Int -> Int -> Int
forall a. Num a => a -> a -> a
* 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
$ \aptr :: 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
$ \ep :: Ptr Word16
ep ->
      ForeignPtr Word8 -> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
sfp ((Ptr Word8 -> IO ByteString) -> IO ByteString)
-> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \sptr :: Ptr Word8
sptr -> do
        let aidx :: Int -> IO Word8
aidx n :: 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
soff)
            finish :: Int -> m ByteString
finish !Int
n = ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Word8 -> Int -> Int -> ByteString
PS ForeignPtr Word8
dfp 0 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` 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` 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` 2)
              let w :: Word32
w = (Word32
i Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` 16) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
j Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` 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` 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` 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
.&. 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` 4) (Ptr Word8
sp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` 3) (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 4)
            complete :: Ptr Word8 -> Ptr b -> Int -> IO ByteString
complete dp :: Ptr Word8
dp sp :: Ptr b
sp n :: 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 m :: Int
m f :: 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` 2 Ptr Any -> Ptr Any -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr Any
forall b. Ptr b
sEnd
                  equals :: Word8
equals     = 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 0 ((Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` 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
.&. 0xfc))
              !Int
b <- Int -> (Int -> Int) -> IO Int
forall b b. Num b => Int -> (b -> b) -> IO b
peekSP 0 ((Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` 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
.&. 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 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` 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
.&. 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 1 ((Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` 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
.&. 0x0f))
                  Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8
dp Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` 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` 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` 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
+ 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
+ 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` 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` 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` 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
+ 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
+ 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 -> IO ByteString) -> IO ByteString)
-> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \dptr :: 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 Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
soff) 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
mkEncodeTable :: ByteString -> EncodeTable
mkEncodeTable alphabet :: ByteString
alphabet@(PS afp :: ForeignPtr Word8
afp _ _) =
    case ByteString
table of PS fp :: ForeignPtr Word8
fp _ _ -> ForeignPtr Word8 -> ForeignPtr Word16 -> EncodeTable
ET ForeignPtr Word8
afp (ForeignPtr Word8 -> ForeignPtr Word16
forall a b. ForeignPtr a -> ForeignPtr b
castForeignPtr ForeignPtr Word8
fp)
  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 <- [0..63], Int
k <- [0..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 _ _ (PS _ _ 0) = ByteString -> Either [Char] ByteString
forall a b. b -> Either a b
Right ByteString
B.empty
decodeWithTable padding :: Padding
padding decodeFP :: ForeignPtr Word8
decodeFP bs :: ByteString
bs =
   case Padding
padding of
     Padded
       | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 -> IO (Either [Char] ByteString) -> Either [Char] ByteString
forall a. IO a -> a
unsafePerformIO (IO (Either [Char] ByteString) -> Either [Char] ByteString)
-> IO (Either [Char] ByteString) -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Either [Char] ByteString)
go ByteString
bs
       | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 -> [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left "Base64-encoded bytestring has invalid size"
       | Bool
otherwise -> [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left "Base64-encoded bytestring is unpadded or has invalid padding"
     Don'tCare
       | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 -> IO (Either [Char] ByteString) -> Either [Char] ByteString
forall a. IO a -> a
unsafePerformIO (IO (Either [Char] ByteString) -> Either [Char] ByteString)
-> IO (Either [Char] ByteString) -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Either [Char] ByteString)
go ByteString
bs
       | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2 -> IO (Either [Char] ByteString) -> Either [Char] ByteString
forall a. IO a -> a
unsafePerformIO (IO (Either [Char] ByteString) -> Either [Char] ByteString)
-> IO (Either [Char] ByteString) -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Either [Char] ByteString)
go (ByteString -> ByteString -> ByteString
B.append ByteString
bs (Int -> Word8 -> ByteString
B.replicate 2 0x3d))
       | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3 -> ByteString
-> [Char]
-> IO (Either [Char] ByteString)
-> Either [Char] ByteString
validateLastPad ByteString
bs [Char]
invalidPad (IO (Either [Char] ByteString) -> Either [Char] ByteString)
-> IO (Either [Char] ByteString) -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Either [Char] ByteString)
go (ByteString -> ByteString -> ByteString
B.append ByteString
bs (Int -> Word8 -> ByteString
B.replicate 1 0x3d))
       | Bool
otherwise -> [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left "Base64-encoded bytestring has invalid size"
     Unpadded
       | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 -> ByteString
-> [Char]
-> IO (Either [Char] ByteString)
-> Either [Char] ByteString
validateLastPad ByteString
bs [Char]
noPad (IO (Either [Char] ByteString) -> Either [Char] ByteString)
-> IO (Either [Char] ByteString) -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Either [Char] ByteString)
go ByteString
bs
       | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 2 -> ByteString
-> [Char]
-> IO (Either [Char] ByteString)
-> Either [Char] ByteString
validateLastPad ByteString
bs [Char]
noPad (IO (Either [Char] ByteString) -> Either [Char] ByteString)
-> IO (Either [Char] ByteString) -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Either [Char] ByteString)
go (ByteString -> ByteString -> ByteString
B.append ByteString
bs (Int -> Word8 -> ByteString
B.replicate 2 0x3d))
       | Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 3 -> ByteString
-> [Char]
-> IO (Either [Char] ByteString)
-> Either [Char] ByteString
validateLastPad ByteString
bs [Char]
noPad (IO (Either [Char] ByteString) -> Either [Char] ByteString)
-> IO (Either [Char] ByteString) -> Either [Char] ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Either [Char] ByteString)
go (ByteString -> ByteString -> ByteString
B.append ByteString
bs (Int -> Word8 -> ByteString
B.replicate 1 0x3d))
       | Bool
otherwise -> [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left "Base64-encoded bytestring has invalid size"
  where
    (!Int
q, !Int
r) = (ByteString -> Int
B.length ByteString
bs) Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
`divMod` 4

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

    !dlen :: Int
dlen = Int
q Int -> Int -> Int
forall a. Num a => a -> a -> a
* 3

    go :: ByteString -> IO (Either [Char] ByteString)
go (PS !ForeignPtr Word8
sfp !Int
soff !Int
slen) = do
      ForeignPtr Word8
dfp <- Int -> IO (ForeignPtr Word8)
forall a. Int -> IO (ForeignPtr a)
mallocByteString Int
dlen
      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 -> IO (Either [Char] ByteString))
 -> IO (Either [Char] ByteString))
-> (Ptr Word8 -> IO (Either [Char] ByteString))
-> IO (Either [Char] ByteString)
forall a b. (a -> b) -> a -> b
$ \ !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
sfp ((Ptr Word8 -> IO (Either [Char] ByteString))
 -> IO (Either [Char] ByteString))
-> (Ptr Word8 -> IO (Either [Char] ByteString))
-> IO (Either [Char] ByteString)
forall a b. (a -> b) -> a -> b
$ \sptr :: Ptr Word8
sptr ->
        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 -> IO (Either [Char] ByteString))
 -> IO (Either [Char] ByteString))
-> (Ptr Word8 -> IO (Either [Char] ByteString))
-> IO (Either [Char] ByteString)
forall a b. (a -> b) -> a -> b
$ \dptr :: Ptr Word8
dptr ->
          Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> Ptr Word8
-> ForeignPtr Word8
-> IO (Either [Char] ByteString)
decodeLoop Ptr Word8
decptr (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
sptr Int
soff) Ptr Word8
dptr
            (Ptr Word8
sptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
slen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
soff)) 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 p :: 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
$ "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 p :: 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
$ "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 p :: 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
$ "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 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` 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` 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` 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` 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` 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` 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
== 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
== 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 1)
     | Word32
c Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 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 2)
     | Word32
d Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 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 3)
     | Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 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
== 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 1)
     | Word32
c Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 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 2)
     | Word32
d Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 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 3)
     | Bool
otherwise = do
       let !w :: Word32
w = ((Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
a 18)
             Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
b 12)
             Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
c 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 16))
       Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dst 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 8))
       Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dst 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 3) (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
src 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 a :: Word32
a b :: Word32
b c :: Word32
c d :: Word32
d
      | Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 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
== 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 1)
      | Word32
c Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x63 Bool -> Bool -> Bool
&& Word32
d Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
/= 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 3) -- make sure padding is coherent.
      | Word32
a Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 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
== 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 1)
      | Word32
c Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 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 2)
      | Word32
d Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 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 3)
      | Bool
otherwise = do
        let !w :: Word32
w = ((Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
a 18)
              Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
b 12)
              Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
c 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 16))

        if Word32
c Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x63 Bool -> Bool -> Bool
&& Word32
d Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 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 -> Int -> ByteString
PS ForeignPtr Word8
dfp 0 (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 1)
        else if Word32
d Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== 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 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 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 -> Int -> ByteString
PS ForeignPtr Word8
dfp 0 (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 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 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 8))
            Ptr Word8 -> Word8 -> IO ()
poke8 (Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
dst 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 -> Int -> ByteString
PS ForeignPtr Word8
dfp 0 (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 decodeFP :: ForeignPtr Word8
decodeFP (PS sfp :: ForeignPtr Word8
sfp soff :: Int
soff slen :: Int
slen)
    | Int
dlen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 = ByteString
B.empty
    | Bool
otherwise = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ 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 ->
    ForeignPtr Word8 -> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr ForeignPtr Word8
sfp ((Ptr Word8 -> IO ByteString) -> IO ByteString)
-> (Ptr Word8 -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \ !Ptr Word8
sptr -> do
      let finish :: Int -> m ByteString
finish dbytes :: Int
dbytes
              | Int
dbytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> 0 = ByteString -> m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (ForeignPtr Word8 -> Int -> Int -> ByteString
PS ForeignPtr Word8
dfp 0 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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
soff)
          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 skipPad :: Bool
skipPad p0 :: Ptr Word8
p0 f :: Ptr Word8 -> Word32 -> IO ByteString
f = Ptr Word8 -> IO ByteString
go Ptr Word8
p0
                  where
                    go :: Ptr Word8 -> IO ByteString
go p :: 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` (-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` 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` 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` 18) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. (Word32
bValue Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` 12) Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|.
                              (Word32
cValue Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftL` 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` 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
+ 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` 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` 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
+ 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` 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` 3) Ptr Word8
dNext (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+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
$ \dptr :: Ptr Word8
dptr ->
        Ptr Word8 -> Ptr Word8 -> Int -> IO ByteString
fill Ptr Word8
dptr (Ptr Word8
sptr Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
soff) 0
  where dlen :: Int
dlen = ((Int
slen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 4) Int -> Int -> Int
forall a. Num a => a -> a -> a
* 3

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

done :: Integral a => a
done :: a
done = 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 (y :: ByteString
y : ys :: [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
                    (_, 0) -> ByteString
y ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: [ByteString] -> [ByteString]
go [ByteString]
ys
                    (d :: Int
d, _) -> case Int -> ByteString -> (ByteString, ByteString)
B.splitAt (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
n) ByteString
y of
                                (prefix :: ByteString
prefix, suffix :: 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 acc :: ByteString
acc [] = [ByteString
acc]
    fixup acc :: ByteString
acc (z :: ByteString
z : zs :: [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
                           (prefix :: ByteString
prefix, suffix :: 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
    -> IO (Either String ByteString)
    -> Either String ByteString
validateLastPad :: ByteString
-> [Char]
-> IO (Either [Char] ByteString)
-> Either [Char] ByteString
validateLastPad bs :: ByteString
bs err :: [Char]
err io :: IO (Either [Char] ByteString)
io
    | ByteString -> Word8
B.last ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== 0x3d = [Char] -> Either [Char] ByteString
forall a b. a -> Either a b
Left [Char]
err
    | Bool
otherwise = IO (Either [Char] ByteString) -> Either [Char] ByteString
forall a. IO a -> a
unsafePerformIO IO (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 pos :: Word32
pos mask :: 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
== 0
{-# INLINE sanityCheckPos #-}

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

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