{-# language BangPatterns #-}
{-# language BinaryLiterals #-}
{-# language BlockArguments #-}
{-# language DataKinds #-}
{-# language ExplicitNamespaces #-}
{-# language MagicHash #-}
{-# language NoStarIsType #-}
{-# language PatternSynonyms #-}
{-# language ScopedTypeVariables #-}
{-# language TypeApplications #-}
{-# language TypeOperators #-}
{-# language UnboxedTuples #-}
module Data.Bytes.Base64
( encode
, builder
, recodeBoundedBuilder
, decode64
) where
import GHC.TypeNats (type (+),type (*),Div)
import Control.Monad.ST.Run (runByteArrayST)
import Data.Char (ord)
import Data.Bits (unsafeShiftR,unsafeShiftL,(.|.),(.&.))
import Data.Bytes.Types (Bytes(Bytes))
import Data.Primitive (ByteArray(..),MutableByteArray(..))
import Data.Primitive (newByteArray,unsafeFreezeByteArray,readByteArray)
import Data.Primitive.Ptr (indexOffPtr)
import Data.Word (Word8,Word64)
import GHC.Exts (Ptr(Ptr),Int(I#),State#,(+#),(-#))
import GHC.ST (ST(ST))
import GHC.Word (Word(W#),Word32)
import GHC.Word.Compat (pattern W32#)
import qualified Arithmetic.Nat as Nat
import qualified Arithmetic.Types as Arithmetic
import qualified Data.Bytes as Bytes
import qualified Data.Bytes.Builder.Unsafe as BU
import qualified Data.Bytes.Builder.Bounded.Unsafe as BBU
import qualified Data.Primitive.ByteArray.BigEndian as BE
import qualified Data.Primitive.ByteArray.LittleEndian as LE
import qualified Data.Primitive.Ptr as PM
import qualified GHC.Exts as Exts
encode :: Bytes -> ByteArray
encode :: Bytes -> ByteArray
encode (Bytes ByteArray
src Int
soff Int
slen) = (forall s. ST s ByteArray) -> ByteArray
runByteArrayST do
let dlen :: Int
dlen = Int -> Int
calculatePaddedLength Int
slen
MutableByteArray s
dst <- forall (m :: Type -> Type).
PrimMonad m =>
Int -> m (MutableByteArray (PrimState m))
newByteArray Int
dlen
forall s.
MutableByteArray s -> Int -> ByteArray -> Int -> Int -> ST s ()
performEncodeImmutable MutableByteArray s
dst Int
0 ByteArray
src Int
soff Int
slen
forall (m :: Type -> Type).
PrimMonad m =>
MutableByteArray (PrimState m) -> m ByteArray
unsafeFreezeByteArray MutableByteArray s
dst
builder :: Bytes -> BU.Builder
builder :: Bytes -> Builder
builder (Bytes ByteArray
src Int
soff Int
slen) = Int -> (forall s. MutableByteArray s -> Int -> ST s Int) -> Builder
BU.fromEffect Int
dlen \MutableByteArray s
dst Int
doff -> do
forall s.
MutableByteArray s -> Int -> ByteArray -> Int -> Int -> ST s ()
performEncodeImmutable MutableByteArray s
dst Int
doff ByteArray
src Int
soff Int
slen
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Int
doff forall a. Num a => a -> a -> a
+ Int
dlen)
where
dlen :: Int
dlen = Int -> Int
calculatePaddedLength Int
slen
recodeBoundedBuilder ::
Arithmetic.Nat n
-> BBU.Builder n
-> BBU.Builder (4 * (Div (n + 2) 3))
recodeBoundedBuilder :: forall (n :: Nat).
Nat n -> Builder n -> Builder (4 * Div (n + 2) 3)
recodeBoundedBuilder !Nat n
n (BBU.Builder forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
f) = forall (a :: Nat).
(forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #))
-> Builder a
BBU.Builder
(\MutableByteArray# s
arr Int#
off0 State# s
s0 -> let !off1 :: Int#
off1 = (Int#
off0 Int# -> Int# -> Int#
+# Int#
maxEncLen) Int# -> Int# -> Int#
-# Int#
maxRawLen in
case forall s.
MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)
f MutableByteArray# s
arr Int#
off1 State# s
s0 of
(# State# s
s1, Int#
off2 #) ->
let !actualLen :: Int#
actualLen = Int#
off2 Int# -> Int# -> Int#
-# Int#
off1 in
case forall s a. ST s a -> State# s -> (# State# s, a #)
unST (forall s.
MutableByteArray s
-> Int -> MutableByteArray s -> Int -> Word -> ST s ()
performEncode (forall s. MutableByteArray# s -> MutableByteArray s
MutableByteArray MutableByteArray# s
arr) (Int# -> Int
I# Int#
off0) (forall s. MutableByteArray# s -> MutableByteArray s
MutableByteArray MutableByteArray# s
arr) (Int# -> Int
I# Int#
off1) (Word# -> Word
W# (Int# -> Word#
Exts.int2Word# Int#
actualLen))) State# s
s1 of
(# State# s
s2, (()
_ :: ()) #) ->
let !(I# Int#
actualEncLen) = Int -> Int
calculatePaddedLength (Int# -> Int
I# Int#
actualLen) in
(# State# s
s2, Int#
actualEncLen #)
)
where
!(I# Int#
maxRawLen) = forall (n :: Nat). Nat n -> Int
Nat.demote Nat n
n
!(I# Int#
maxEncLen) = Int -> Int
calculatePaddedLength (Int# -> Int
I# Int#
maxRawLen)
performEncodeImmutable ::
MutableByteArray s
-> Int
-> ByteArray
-> Int
-> Int
-> ST s ()
performEncodeImmutable :: forall s.
MutableByteArray s -> Int -> ByteArray -> Int -> Int -> ST s ()
performEncodeImmutable MutableByteArray s
dst Int
doff (ByteArray ByteArray#
src) Int
soff Int
slen =
forall s.
MutableByteArray s
-> Int -> MutableByteArray s -> Int -> Word -> ST s ()
performEncode MutableByteArray s
dst Int
doff (forall s. MutableByteArray# s -> MutableByteArray s
MutableByteArray (unsafeCoerce# :: forall a b. a -> b
Exts.unsafeCoerce# ByteArray#
src)) Int
soff (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Int @Word Int
slen)
performEncode ::
MutableByteArray s
-> Int
-> MutableByteArray s
-> Int
-> Word
-> ST s ()
performEncode :: forall s.
MutableByteArray s
-> Int -> MutableByteArray s -> Int -> Word -> ST s ()
performEncode !MutableByteArray s
dst !Int
doff !MutableByteArray s
src !Int
soff !Word
slen = case Word
slen of
Word
3 -> do
Word8
x1 <- forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray MutableByteArray s
src Int
soff
Word8
x2 <- forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray MutableByteArray s
src (Int
soff forall a. Num a => a -> a -> a
+ Int
1)
Word8
x3 <- forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray MutableByteArray s
src (Int
soff forall a. Num a => a -> a -> a
+ Int
2)
let (Word
w1,Word
w2,Word
w3,Word
w4) = Word32 -> (Word, Word, Word, Word)
disassembleBE (Word8 -> Word8 -> Word8 -> Word8 -> Word32
assembleBE Word8
x1 Word8
x2 Word8
x3 Word8
0)
c1 :: Word8
c1 = forall a. Prim a => Ptr a -> Int -> a
indexOffPtr Ptr Word8
table (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int Word
w1)
c2 :: Word8
c2 = forall a. Prim a => Ptr a -> Int -> a
indexOffPtr Ptr Word8
table (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int Word
w2)
c3 :: Word8
c3 = forall a. Prim a => Ptr a -> Int -> a
indexOffPtr Ptr Word8
table (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int Word
w3)
c4 :: Word8
c4 = forall a. Prim a => Ptr a -> Int -> a
indexOffPtr Ptr Word8
table (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int Word
w4)
forall (m :: Type -> Type) a.
(PrimMonad m, PrimUnaligned a, Bytes a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
LE.writeUnalignedByteArray MutableByteArray s
dst Int
doff (Word8 -> Word8 -> Word8 -> Word8 -> Word32
assembleLE Word8
c1 Word8
c2 Word8
c3 Word8
c4)
Word
2 -> do
Word8
x1 <- forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray MutableByteArray s
src Int
soff
Word8
x2 <- forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray MutableByteArray s
src (Int
soff forall a. Num a => a -> a -> a
+ Int
1)
let (Word
w1,Word
w2,Word
w3,Word
_) = Word32 -> (Word, Word, Word, Word)
disassembleBE (Word8 -> Word8 -> Word8 -> Word8 -> Word32
assembleBE Word8
x1 Word8
x2 Word8
0 Word8
0)
c1 :: Word8
c1 = forall a. Prim a => Ptr a -> Int -> a
indexOffPtr Ptr Word8
table (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int Word
w1)
c2 :: Word8
c2 = forall a. Prim a => Ptr a -> Int -> a
indexOffPtr Ptr Word8
table (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int Word
w2)
c3 :: Word8
c3 = forall a. Prim a => Ptr a -> Int -> a
indexOffPtr Ptr Word8
table (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int Word
w3)
c4 :: Word8
c4 = Char -> Word8
c2w Char
'='
forall (m :: Type -> Type) a.
(PrimMonad m, PrimUnaligned a, Bytes a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
LE.writeUnalignedByteArray MutableByteArray s
dst Int
doff (Word8 -> Word8 -> Word8 -> Word8 -> Word32
assembleLE Word8
c1 Word8
c2 Word8
c3 Word8
c4)
Word
1 -> do
Word8
x1 <- forall a (m :: Type -> Type).
(Prim a, PrimMonad m) =>
MutableByteArray (PrimState m) -> Int -> m a
readByteArray MutableByteArray s
src Int
soff
let (Word
w1,Word
w2,Word
_,Word
_) = Word32 -> (Word, Word, Word, Word)
disassembleBE (Word8 -> Word8 -> Word8 -> Word8 -> Word32
assembleBE Word8
x1 Word8
0 Word8
0 Word8
0)
c1 :: Word8
c1 = forall a. Prim a => Ptr a -> Int -> a
indexOffPtr Ptr Word8
table (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int Word
w1)
c2 :: Word8
c2 = forall a. Prim a => Ptr a -> Int -> a
indexOffPtr Ptr Word8
table (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int Word
w2)
c3 :: Word8
c3 = Char -> Word8
c2w Char
'='
c4 :: Word8
c4 = Char -> Word8
c2w Char
'='
forall (m :: Type -> Type) a.
(PrimMonad m, PrimUnaligned a, Bytes a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
LE.writeUnalignedByteArray MutableByteArray s
dst Int
doff (Word8 -> Word8 -> Word8 -> Word8 -> Word32
assembleLE Word8
c1 Word8
c2 Word8
c3 Word8
c4)
Word
0 -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
Word
_ -> do
Word32
w :: Word32 <- forall (m :: Type -> Type) a.
(PrimMonad m, PrimUnaligned a, Bytes a) =>
MutableByteArray (PrimState m) -> Int -> m a
BE.readUnalignedByteArray MutableByteArray s
src Int
soff
let (Word
w1,Word
w2,Word
w3,Word
w4) = Word32 -> (Word, Word, Word, Word)
disassembleBE Word32
w
c1 :: Word8
c1 = forall a. Prim a => Ptr a -> Int -> a
indexOffPtr Ptr Word8
table (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int Word
w1)
c2 :: Word8
c2 = forall a. Prim a => Ptr a -> Int -> a
indexOffPtr Ptr Word8
table (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int Word
w2)
c3 :: Word8
c3 = forall a. Prim a => Ptr a -> Int -> a
indexOffPtr Ptr Word8
table (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int Word
w3)
c4 :: Word8
c4 = forall a. Prim a => Ptr a -> Int -> a
indexOffPtr Ptr Word8
table (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word @Int Word
w4)
forall (m :: Type -> Type) a.
(PrimMonad m, PrimUnaligned a, Bytes a) =>
MutableByteArray (PrimState m) -> Int -> a -> m ()
LE.writeUnalignedByteArray MutableByteArray s
dst Int
doff (Word8 -> Word8 -> Word8 -> Word8 -> Word32
assembleLE Word8
c1 Word8
c2 Word8
c3 Word8
c4)
forall s.
MutableByteArray s
-> Int -> MutableByteArray s -> Int -> Word -> ST s ()
performEncode MutableByteArray s
dst (Int
doff forall a. Num a => a -> a -> a
+ Int
4) MutableByteArray s
src (Int
soff forall a. Num a => a -> a -> a
+ Int
3) (Word
slen forall a. Num a => a -> a -> a
- Word
3)
assembleLE :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
assembleLE :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
assembleLE Word8
a Word8
b Word8
c Word8
d = Word -> Word32
unsafeW32
(forall a. Bits a => a -> Int -> a
unsafeShiftL (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word Word8
d) Int
24 forall a. Bits a => a -> a -> a
.|.
forall a. Bits a => a -> Int -> a
unsafeShiftL (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word Word8
c) Int
16 forall a. Bits a => a -> a -> a
.|.
forall a. Bits a => a -> Int -> a
unsafeShiftL (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word Word8
b) Int
8 forall a. Bits a => a -> a -> a
.|.
(forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word Word8
a)
)
assembleBE :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
assembleBE :: Word8 -> Word8 -> Word8 -> Word8 -> Word32
assembleBE Word8
a Word8
b Word8
c Word8
d = Word -> Word32
unsafeW32
(forall a. Bits a => a -> Int -> a
unsafeShiftL (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word Word8
a) Int
24 forall a. Bits a => a -> a -> a
.|.
forall a. Bits a => a -> Int -> a
unsafeShiftL (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word Word8
b) Int
16 forall a. Bits a => a -> a -> a
.|.
forall a. Bits a => a -> Int -> a
unsafeShiftL (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word Word8
c) Int
8 forall a. Bits a => a -> a -> a
.|.
(forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word Word8
d)
)
unsafeW32 :: Word -> Word32
unsafeW32 :: Word -> Word32
unsafeW32 (W# Word#
w) = Word# -> Word32
W32# Word#
w
disassembleBE :: Word32 -> (Word,Word,Word,Word)
disassembleBE :: Word32 -> (Word, Word, Word, Word)
disassembleBE !Word32
w =
( forall a. Bits a => a -> Int -> a
unsafeShiftR (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 @Word Word32
w) Int
26
, forall a. Bits a => a -> Int -> a
unsafeShiftR (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 @Word Word32
w) Int
20 forall a. Bits a => a -> a -> a
.&. Word
0b00111111
, forall a. Bits a => a -> Int -> a
unsafeShiftR (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 @Word Word32
w) Int
14 forall a. Bits a => a -> a -> a
.&. Word
0b00111111
, forall a. Bits a => a -> Int -> a
unsafeShiftR (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word32 @Word Word32
w) Int
8 forall a. Bits a => a -> a -> a
.&. Word
0b00111111
)
table :: Ptr Word8
table :: Ptr Word8
table = forall a. Addr# -> Ptr a
Ptr Addr#
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"#
calculatePaddedLength :: Int -> Int
calculatePaddedLength :: Int -> Int
calculatePaddedLength Int
n = Int
4 forall a. Num a => a -> a -> a
* (Int -> Int -> Int
divRoundUp Int
n Int
3)
divRoundUp :: Int -> Int -> Int
divRoundUp :: Int -> Int -> Int
divRoundUp Int
x Int
y = forall a. Integral a => a -> a -> a
div (Int
x forall a. Num a => a -> a -> a
+ Int
y forall a. Num a => a -> a -> a
- Int
1) Int
y
c2w :: Char -> Word8
c2w :: Char -> Word8
c2w = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
unST :: ST s a -> State# s -> (# State# s, a #)
unST :: forall s a. ST s a -> State# s -> (# State# s, a #)
unST (ST STRep s a
f) State# s
s = STRep s a
f State# s
s
decode64 :: Bytes -> Maybe Word64
decode64 :: Bytes -> Maybe Word64
decode64 Bytes
bs
| Bytes -> Int
Bytes.length Bytes
bs forall a. Ord a => a -> a -> Bool
> Int
10 = forall a. Maybe a
Nothing
| Bool
otherwise = forall (m :: Type -> Type) a.
Monad m =>
(a -> Word8 -> m a) -> a -> Bytes -> m a
Bytes.foldlM
(\ !(Word64
acc :: Word64) Word8
b -> case forall a. Prim a => Ptr a -> Int -> a
PM.indexOffPtr Ptr Word8
decodeTable (forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Int Word8
b) of
Word8
0xFF -> forall a. Maybe a
Nothing
Word8
w -> forall (f :: Type -> Type) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$! (forall a. Bits a => a -> Int -> a
unsafeShiftL Word64
acc Int
6 forall a. Bits a => a -> a -> a
.|. forall a b. (Integral a, Num b) => a -> b
fromIntegral @Word8 @Word64 Word8
w)
) Word64
0 Bytes
bs
decodeTable :: Ptr Word8
decodeTable :: Ptr Word8
decodeTable = forall a. Addr# -> Ptr a
Ptr
Addr#
"\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
\\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
\\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\xff\xff\xff\x3f\
\\x34\x35\x36\x37\x38\x39\x3a\x3b\x3c\x3d\xff\xff\xff\x63\xff\xff\
\\xff\x00\x01\x02\x03\x04\x05\x06\x07\x08\x09\x0a\x0b\x0c\x0d\x0e\
\\x0f\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19\xff\xff\xff\xff\xff\
\\xff\x1a\x1b\x1c\x1d\x1e\x1f\x20\x21\x22\x23\x24\x25\x26\x27\x28\
\\x29\x2a\x2b\x2c\x2d\x2e\x2f\x30\x31\x32\x33\xff\xff\xff\xff\xff\
\\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
\\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
\\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
\\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
\\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
\\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
\\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\
\\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#