{-# LANGUAGE BangPatterns #-}

-- simple unoptimized implementation of base32(hex)
module Codec.Base32.Impl
   ( decodeBs2Bs
   , decodeBsL2BsL
   , encodeBs2Bs
   , encodeBsL2BsL
   , Fmt(..)
   ) where

import qualified Data.ByteString         as BS
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Char8   as BS.C
import qualified Data.ByteString.Lazy    as BS.L

import           Control.Monad
import           Data.Bits
import           Data.Word

import           Internal

-- exported primitives

data Fmt = Fmt'base32 | Fmt'base32hex

{-# INLINE decodeBs2Bs #-}
decodeBs2Bs :: Fmt -> BS.ByteString -> Either String BS.ByteString
decodeBs2Bs :: Fmt -> ByteString -> Either String ByteString
decodeBs2Bs !Fmt
fmt ByteString
bs0 = case Fmt -> ByteString -> DecodeRes
runDecode Fmt
fmt ByteString
bs0 of
  DR'Final Builder
chunk         -> ByteString -> Either String ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$! ByteString -> ByteString
bsToStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BB.toLazyByteString Builder
chunk
  DR'Error Word
ofs DecodeError
err       -> String -> Either String ByteString
forall a b. a -> Either a b
Left (String -> Either String ByteString)
-> String -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Word -> DecodeError -> String
showDecErr Word
ofs DecodeError
err
  DR'Partial Builder
chunk0 ByteString -> DecodeRes
cont -> case ByteString -> DecodeRes
cont ByteString
forall a. Monoid a => a
mempty of
    DR'Final Builder
chunk1  -> ByteString -> Either String ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$! ByteString -> ByteString
bsToStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BB.toLazyByteString (Builder
chunk0Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>Builder
chunk1) -- chunk1 ought to be empty -- TODO: maybe refactor internal API
    DR'Partial Builder
_ ByteString -> DecodeRes
_   -> String -> Either String ByteString
forall a. HasCallStack => String -> a
error String
"decodeBs2Bs: the impossible just happened" -- broken invariant
    DR'Error Word
ofs DecodeError
err -> String -> Either String ByteString
forall a b. a -> Either a b
Left (String -> Either String ByteString)
-> String -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Word -> DecodeError -> String
showDecErr Word
ofs DecodeError
err

{-# INLINE decodeBsL2BsL #-}
decodeBsL2BsL :: Fmt -> BS.L.ByteString -> Either String BS.L.ByteString
decodeBsL2BsL :: Fmt -> ByteString -> Either String ByteString
decodeBsL2BsL !Fmt
fmt ByteString
bs0 = Builder
-> (ByteString -> DecodeRes)
-> [ByteString]
-> Either String ByteString
go Builder
forall a. Monoid a => a
mempty (Fmt -> ByteString -> DecodeRes
runDecode Fmt
fmt) ((ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ByteString -> Bool) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
BS.null) ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
BS.L.toChunks ByteString
bs0)
  where
    go :: Builder
-> (ByteString -> DecodeRes)
-> [ByteString]
-> Either String ByteString
go Builder
acc ByteString -> DecodeRes
runDec (ByteString
c:[ByteString]
cs) = case ByteString -> DecodeRes
runDec ByteString
c of
      DR'Final Builder
_            -> String -> Either String ByteString
forall a. HasCallStack => String -> a
error String
"impossible"
      DR'Error Word
ofs DecodeError
err      -> String -> Either String ByteString
forall a b. a -> Either a b
Left (String -> Either String ByteString)
-> String -> Either String ByteString
forall a b. (a -> b) -> a -> b
$! Word -> DecodeError -> String
showDecErr Word
ofs DecodeError
err -- TODO
      DR'Partial Builder
chunk ByteString -> DecodeRes
cont -> Builder
-> (ByteString -> DecodeRes)
-> [ByteString]
-> Either String ByteString
go (Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
chunk) ByteString -> DecodeRes
cont [ByteString]
cs

    go Builder
acc ByteString -> DecodeRes
runDec [] = case ByteString -> DecodeRes
runDec ByteString
forall a. Monoid a => a
mempty of
      DR'Final Builder
chunk   -> ByteString -> Either String ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Either String ByteString)
-> ByteString -> Either String ByteString
forall a b. (a -> b) -> a -> b
$! Builder -> ByteString
BB.toLazyByteString (Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
chunk)
      DR'Partial Builder
_ ByteString -> DecodeRes
_   -> String -> Either String ByteString
forall a. HasCallStack => String -> a
error String
"decodeBsL2BsL: the impossible just happened" -- broken invariant
      DR'Error Word
ofs DecodeError
err -> String -> Either String ByteString
forall a b. a -> Either a b
Left (String -> Either String ByteString)
-> String -> Either String ByteString
forall a b. (a -> b) -> a -> b
$ Word -> DecodeError -> String
showDecErr Word
ofs DecodeError
err

encodeBs2Bs :: Fmt -> BS.ByteString -> BS.ByteString
encodeBs2Bs :: Fmt -> ByteString -> ByteString
encodeBs2Bs !Fmt
fmt = String -> ByteString
BS.C.pack (String -> ByteString)
-> (ByteString -> String) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Fmt -> Bool -> [Word8] -> String
slowEnc Fmt
fmt Bool
True ([Word8] -> String)
-> (ByteString -> [Word8]) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.unpack

encodeBsL2BsL :: Fmt -> BS.L.ByteString -> BS.L.ByteString
encodeBsL2BsL :: Fmt -> ByteString -> ByteString
encodeBsL2BsL !Fmt
fmt = [ByteString] -> ByteString
BS.L.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString] -> [ByteString]
go ByteString
forall a. Monoid a => a
mempty ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BS.L.toChunks
  where
    go :: ByteString -> [ByteString] -> [ByteString]
go ByteString
rest [] = Fmt -> ByteString -> ByteString
encodeBs2Bs Fmt
fmt ByteString
rest ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: []
    go ByteString
rest (ByteString
c:[ByteString]
cs)
      | Int
rclen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
5 = ByteString -> [ByteString] -> [ByteString]
go ByteString
rc [ByteString]
cs -- shortcut
      | Bool
otherwise = Fmt -> ByteString -> ByteString
encodeBs2Bs Fmt
fmt ByteString
c' ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString -> [ByteString] -> [ByteString]
go ByteString
rest' [ByteString]
cs
      where
        rlen :: Int
rlen = ByteString -> Int
BS.length ByteString
rest
        clen :: Int
clen = ByteString -> Int
BS.length ByteString
c
        rc :: ByteString
rc = ByteString
rest ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
c -- TODO: avoid copying large chunks of data
        rclen :: Int
rclen = Int
rlen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
clen
        rlen' :: Int
rlen' = Int
rclen Int -> Int -> Int
forall a. Integral a => a -> a -> a
`rem` Int
5
        (ByteString
c',ByteString
rest') = Int -> ByteString -> (ByteString, ByteString)
BS.splitAt (Int
rclen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
rlen') ByteString
rc

----------------------------------------------------------------------------
-- encoding

-- | Relatively slow streaming base32 encoder
slowEnc :: Fmt -> Bool -> [Word8] -> [Char]
slowEnc :: Fmt -> Bool -> [Word8] -> String
slowEnc !Fmt
fmt Bool
doPad = [Word8] -> String
go0
  where
    go0 :: [Word8] -> String
go0 [] = []
    go0 (Word8
x:[Word8]
xs) = Word8 -> Char
sym Word8
hi Char -> String -> String
forall a. a -> [a] -> [a]
: Word8 -> [Word8] -> String
go1 Word8
lo [Word8]
xs
      where -- 5|3
        (Word8
hi,Word8
lo) = Word8
x Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word8
0x08

    go1 :: Word8 -> [Word8] -> String
go1 Word8
rest [] = Word8 -> Char
sym (Word8
rest Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
0x04) Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
forall a. [a] -> [a]
pad String
"======"
    go1 Word8
rest (Word8
x:[Word8]
xs) = Word8 -> Char
sym (Word8
rest Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
0x04 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
hi) Char -> String -> String
forall a. a -> [a] -> [a]
: Word8 -> Char
sym Word8
mid Char -> String -> String
forall a. a -> [a] -> [a]
: Word8 -> [Word8] -> String
go2 Word8
lo [Word8]
xs
      where -- 2|5|1
        (Word8
hi,Word8
tmp) = Word8
x Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word8
0x40
        (Word8
mid,Word8
lo) = Word8
tmp Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word8
0x02

    go2 :: Word8 -> [Word8] -> String
go2 Word8
rest [] = Word8 -> Char
sym (Word8
rest Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
0x10) Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
forall a. [a] -> [a]
pad String
"===="
    go2 Word8
rest (Word8
x:[Word8]
xs) = Word8 -> Char
sym (Word8
rest Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
0x10 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
hi) Char -> String -> String
forall a. a -> [a] -> [a]
: Word8 -> [Word8] -> String
go3 Word8
lo [Word8]
xs
      where -- 4|4
        (Word8
hi,Word8
lo) = Word8
x Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word8
0x10

    go3 :: Word8 -> [Word8] -> String
go3 Word8
rest [] = Word8 -> Char
sym (Word8
rest Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
0x02) Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
forall a. [a] -> [a]
pad String
"==="
    go3 Word8
rest (Word8
x:[Word8]
xs) = Word8 -> Char
sym (Word8
rest Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
0x02 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
hi) Char -> String -> String
forall a. a -> [a] -> [a]
: Word8 -> Char
sym Word8
mid Char -> String -> String
forall a. a -> [a] -> [a]
: Word8 -> [Word8] -> String
go4 Word8
lo [Word8]
xs
      where -- 1|5|2
        (Word8
hi,Word8
tmp) = Word8
x Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word8
0x80
        (Word8
mid,Word8
lo) = Word8
tmp Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word8
0x04

    go4 :: Word8 -> [Word8] -> String
go4 Word8
rest [] = Word8 -> Char
sym (Word8
rest Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
0x08) Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
forall a. [a] -> [a]
pad String
"="
    go4 Word8
rest (Word8
x:[Word8]
xs) = Word8 -> Char
sym (Word8
rest Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
* Word8
0x08 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
hi) Char -> String -> String
forall a. a -> [a] -> [a]
: Word8 -> Char
sym Word8
lo Char -> String -> String
forall a. a -> [a] -> [a]
: [Word8] -> String
go0 [Word8]
xs
      where -- 3|5
        (Word8
hi,Word8
lo) = Word8
x Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
`quotRem` Word8
0x20

    pad :: [a] -> [a]
pad [a]
x | Bool
doPad     = [a]
x
          | Bool
otherwise = []

    sym :: Word8 -> Char
sym = case Fmt
fmt of
      Fmt
Fmt'base32    -> Word8 -> Char
sym0
      Fmt
Fmt'base32hex -> Word8 -> Char
symx

    -- plain base32 alphabet
    sym0 :: Word8 -> Char
    sym0 :: Word8 -> Char
sym0 Word8
w
     | Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
26 = Int -> Char
forall a. Enum a => Int -> a
toEnum (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0x41)
     | Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
32 = Int -> Char
forall a. Enum a => Int -> a
toEnum (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
24)
     | Bool
otherwise = Char
forall a. HasCallStack => a
undefined -- sym (w `rem` 32)

    -- base32hex alphabet
    symx :: Word8 -> Char
    symx :: Word8 -> Char
symx Word8
w
     | Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
10 = Int -> Char
forall a. Enum a => Int -> a
toEnum (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
0x30)
     | Word8
w Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
32 = Int -> Char
forall a. Enum a => Int -> a
toEnum (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
w Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
55)
     | Bool
otherwise = Char
forall a. HasCallStack => a
undefined -- sym (w `rem` 32)

----------------------------------------------------------------------------
-- decoding

-- internal abstraction
data DecodeRes = DR'Final   !BB.Builder -- only emitted on empty EOF-signalling input
               | DR'Partial !BB.Builder (BS.ByteString -> DecodeRes)
               | DR'Error   !Word DecodeError

instance Show DecodeRes where
  show :: DecodeRes -> String
show (DR'Final Builder
x)       = String
"DR'Final "   String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show (Builder -> ByteString
BB.toLazyByteString Builder
x)
  show (DR'Partial Builder
x ByteString -> DecodeRes
_)   = String
"DR'Partial " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show (Builder -> ByteString
BB.toLazyByteString Builder
x) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" <cont>"
  show (DR'Error Word
ofs DecodeError
err) = String
"DR'Err "     String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
ofs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ DecodeError -> String
forall a. Show a => a -> String
show DecodeError
err

data DecodeError = Error'IncompleteInput
                 | Error'InvalidChar
                 | Error'InvalidPad
                 deriving Int -> DecodeError -> String -> String
[DecodeError] -> String -> String
DecodeError -> String
(Int -> DecodeError -> String -> String)
-> (DecodeError -> String)
-> ([DecodeError] -> String -> String)
-> Show DecodeError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DecodeError] -> String -> String
$cshowList :: [DecodeError] -> String -> String
show :: DecodeError -> String
$cshow :: DecodeError -> String
showsPrec :: Int -> DecodeError -> String -> String
$cshowsPrec :: Int -> DecodeError -> String -> String
Show

showDecErr :: Word -> DecodeError -> String
showDecErr :: Word -> DecodeError -> String
showDecErr Word
ofs DecodeError
Error'InvalidPad      = String
"Base32-encoded data has invalid padding at offset: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
ofs
showDecErr Word
ofs DecodeError
Error'IncompleteInput = String
"Base32-encoded data ended prematurely at offset: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
ofs
showDecErr Word
ofs DecodeError
Error'InvalidChar     = String
"Base32-encoded data has invalid character at offset: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
ofs

runDecode :: Fmt -> BS.ByteString -> DecodeRes
runDecode :: Fmt -> ByteString -> DecodeRes
runDecode !Fmt
fmt = Word -> ByteString -> ByteString -> DecodeRes
go Word
0 ByteString
forall a. Monoid a => a
mempty
  where
    -- invariants:
    --   len(buf0) < 8

    go :: Word -> ByteString -> ByteString -> DecodeRes
go Word
ofs0 ByteString
buf0 ByteString
buf1
      | Bool
doflush, ByteString -> Bool
BS.null ByteString
buf0 = Builder -> DecodeRes
DR'Final Builder
forall a. Monoid a => a
mempty
      | Bool
doflush = case Fmt
-> ByteString -> Either (Word, DecodeError) (Builder, ByteString)
decodePaddedChunk Fmt
fmt ByteString
buf0 of
                    Left (Word
ofs,DecodeError
err) -> Word -> DecodeError -> DecodeRes
DR'Error (Word
ofs0Word -> Word -> Word
forall a. Num a => a -> a -> a
+Word
ofs) DecodeError
err
                    Right (Builder
out,ByteString
rest)
                      | ByteString -> Bool
BS.null ByteString
rest -> Builder -> DecodeRes
DR'Final Builder
out -- actually not possible for padded input
                      | Bool
otherwise -> String -> DecodeRes
forall a. HasCallStack => String -> a
error String
"runDecode: the impossible just happened" -- because buf0 invariant
      | Int
buf01len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8 = Builder -> (ByteString -> DecodeRes) -> DecodeRes
DR'Partial Builder
forall a. Monoid a => a
mempty (Word -> ByteString -> ByteString -> DecodeRes
go Word
ofs0 ByteString
buf01)
      | Bool
otherwise = case Fmt
-> ByteString -> Either (Word, DecodeError) (Builder, ByteString)
decodeChunks Fmt
fmt ByteString
buf01 of
                      Left (Word
ofs,DecodeError
err) -> Word -> DecodeError -> DecodeRes
DR'Error (Word
ofs0Word -> Word -> Word
forall a. Num a => a -> a -> a
+Word
ofs) DecodeError
err
                      Right (Builder
chunks,ByteString
rest) -> Builder -> (ByteString -> DecodeRes) -> DecodeRes
DR'Partial Builder
chunks (Word -> ByteString -> ByteString -> DecodeRes
go (Word
ofs0 Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
buf01len Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
BS.length ByteString
rest)) ByteString
rest)
      where
        -- TODO: consider avoiding copying all of buf1 and instead copy only the prefix needed to
        -- complete buf0 into a full chunk
        buf01 :: ByteString
buf01 = ByteString
buf0 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
buf1
        buf01len :: Int
buf01len = ByteString -> Int
BS.length ByteString
buf01

        doflush :: Bool
doflush = ByteString -> Bool
BS.null ByteString
buf1

-- | Iterate over multiple chunks; calls 'decodeChunk' repeatedly
--
-- The remaining ByteString is guaranteed to be smaller than 8 octets
decodeChunks :: Fmt -> BS.ByteString -> Either (Word,DecodeError) (BB.Builder,BS.ByteString)
decodeChunks :: Fmt
-> ByteString -> Either (Word, DecodeError) (Builder, ByteString)
decodeChunks !Fmt
fmt = Word
-> Builder
-> ByteString
-> Either (Word, DecodeError) (Builder, ByteString)
go Word
0 Builder
forall a. Monoid a => a
mempty
  where
    go :: Word
-> Builder
-> ByteString
-> Either (Word, DecodeError) (Builder, ByteString)
go !Word
ofs0 Builder
bb0 ByteString
bs0
      | ByteString -> Bool
BS.null ByteString
bs0 = (Builder, ByteString)
-> Either (Word, DecodeError) (Builder, ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder
bb0,ByteString
forall a. Monoid a => a
mempty)
      | Bool
otherwise = case Fmt
-> ByteString -> Either (Word, DecodeError) (Builder, ByteString)
decodePaddedChunk Fmt
fmt ByteString
bs0 of
         Left (Word
_, DecodeError
Error'IncompleteInput) -> (Builder, ByteString)
-> Either (Word, DecodeError) (Builder, ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Builder
bb0,ByteString
bs0)
         Left (Word
ofs1,DecodeError
err)                 -> (Word, DecodeError)
-> Either (Word, DecodeError) (Builder, ByteString)
forall a b. a -> Either a b
Left (Word
ofs0Word -> Word -> Word
forall a. Num a => a -> a -> a
+Word
ofs1, DecodeError
err)
         Right (Builder
chunk, ByteString
rest)             -> Word
-> Builder
-> ByteString
-> Either (Word, DecodeError) (Builder, ByteString)
go (Word
ofs0Word -> Word -> Word
forall a. Num a => a -> a -> a
+Word
8) (Builder
bb0 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
chunk) ByteString
rest

-- | Tries do decode a single 40bit base32 chunk (encoded as eight case-insensitive ASCII chars)
--
-- NB: An empty input leads to an incomplete input error result, as this function will either decode exactly a single
-- chunk or report an error
decodePaddedChunk :: Fmt -> BS.ByteString -> Either (Word,DecodeError) (BB.Builder,BS.ByteString)
decodePaddedChunk :: Fmt
-> ByteString -> Either (Word, DecodeError) (Builder, ByteString)
decodePaddedChunk !Fmt
fmt ByteString
bs0
  | Int
bs0len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
8 = (Word, DecodeError)
-> Either (Word, DecodeError) (Builder, ByteString)
forall a b. a -> Either a b
Left (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ Int
bs0len, DecodeError
Error'IncompleteInput)
  | Bool
otherwise = do
      let (ByteString
digs,ByteString
padding) = (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
BS.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x3d) (ByteString -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
BS.take Int
8 ByteString
bs0

      let vlen :: Word
vlen = Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word) -> Int -> Word
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
digs
      [Word8]
vals <- [(Word, Char)]
-> ((Word, Char) -> Either (Word, DecodeError) Word8)
-> Either (Word, DecodeError) [Word8]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Word] -> String -> [(Word, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word
0..] (ByteString -> String
BS.C.unpack ByteString
digs)) (((Word, Char) -> Either (Word, DecodeError) Word8)
 -> Either (Word, DecodeError) [Word8])
-> ((Word, Char) -> Either (Word, DecodeError) Word8)
-> Either (Word, DecodeError) [Word8]
forall a b. (a -> b) -> a -> b
$
        \(Word
i,Char
c) -> Either (Word, DecodeError) Word8
-> (Word8 -> Either (Word, DecodeError) Word8)
-> Maybe Word8
-> Either (Word, DecodeError) Word8
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ((Word, DecodeError) -> Either (Word, DecodeError) Word8
forall a b. a -> Either a b
Left (Word
i,DecodeError
Error'InvalidChar)) Word8 -> Either (Word, DecodeError) Word8
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Word8 -> Either (Word, DecodeError) Word8)
-> Maybe Word8 -> Either (Word, DecodeError) Word8
forall a b. (a -> b) -> a -> b
$ Char -> Maybe Word8
desym Char
c

      Int
olen <- case Word
vlen of
        Word
0 -> (Word, DecodeError) -> Either (Word, DecodeError) Int
forall a b. a -> Either a b
Left (Word
0, DecodeError
Error'InvalidPad)
        Word
1 -> (Word, DecodeError) -> Either (Word, DecodeError) Int
forall a b. a -> Either a b
Left (Word
1, DecodeError
Error'InvalidPad)
        Word
2 -> Int -> Either (Word, DecodeError) Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
1
        Word
3 -> (Word, DecodeError) -> Either (Word, DecodeError) Int
forall a b. a -> Either a b
Left (Word
3, DecodeError
Error'InvalidPad)
        Word
4 -> Int -> Either (Word, DecodeError) Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
2
        Word
5 -> Int -> Either (Word, DecodeError) Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
3
        Word
6 -> (Word, DecodeError) -> Either (Word, DecodeError) Int
forall a b. a -> Either a b
Left (Word
6, DecodeError
Error'InvalidPad)
        Word
7 -> Int -> Either (Word, DecodeError) Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
4
        Word
8 -> Int -> Either (Word, DecodeError) Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
5
        Word
_ -> Either (Word, DecodeError) Int
forall a. HasCallStack => a
undefined

      -- check padding trailer has no garbage
      [(Word, Word8)]
-> ((Word, Word8) -> Either (Word, DecodeError) ())
-> Either (Word, DecodeError) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Word] -> [Word8] -> [(Word, Word8)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Word
vlen ..] (ByteString -> [Word8]
BS.unpack ByteString
padding)) (((Word, Word8) -> Either (Word, DecodeError) ())
 -> Either (Word, DecodeError) ())
-> ((Word, Word8) -> Either (Word, DecodeError) ())
-> Either (Word, DecodeError) ()
forall a b. (a -> b) -> a -> b
$
        \(Word
i,Word8
c) -> Bool
-> Either (Word, DecodeError) () -> Either (Word, DecodeError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x3d) (Either (Word, DecodeError) () -> Either (Word, DecodeError) ())
-> Either (Word, DecodeError) () -> Either (Word, DecodeError) ()
forall a b. (a -> b) -> a -> b
$ (Word, DecodeError) -> Either (Word, DecodeError) ()
forall a b. a -> Either a b
Left (Word
i, DecodeError
Error'InvalidPad)

      -- bit shuffle 8*5bit into 5*8bit
      let buf64 :: Word64
buf64 = [Word64] -> Word64
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Word64] -> Word64) -> [Word64] -> Word64
forall a b. (a -> b) -> a -> b
$ (Word64 -> Int -> Word64) -> [Word64] -> [Int] -> [Word64]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftL ((Word8 -> Word64) -> [Word8] -> [Word64]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Word8]
vals)  [Int
35, Int
30 .. Int
0]
          buf8 :: [Word8]
buf8  = (Int -> Word8) -> [Int] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8) -> (Int -> Word64) -> Int -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftR (Word64
buf64 :: Word64)) [Int
32, Int
24 .. Int
0]

      -- check last 5bit digit didn't have unused bits set
      Bool
-> Either (Word, DecodeError) () -> Either (Word, DecodeError) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Word8 -> Bool) -> [Word8] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) ([Word8] -> Bool) -> [Word8] -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
drop Int
olen [Word8]
buf8) (Either (Word, DecodeError) () -> Either (Word, DecodeError) ())
-> Either (Word, DecodeError) () -> Either (Word, DecodeError) ()
forall a b. (a -> b) -> a -> b
$ do
        (Word, DecodeError) -> Either (Word, DecodeError) ()
forall a b. a -> Either a b
Left (Word -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
vlen Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
1, DecodeError
Error'InvalidPad)

      (Builder, ByteString)
-> Either (Word, DecodeError) (Builder, ByteString)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Builder, ByteString)
 -> Either (Word, DecodeError) (Builder, ByteString))
-> (Builder, ByteString)
-> Either (Word, DecodeError) (Builder, ByteString)
forall a b. (a -> b) -> a -> b
$ (ByteString -> Builder
BB.byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ [Word8] -> ByteString
BS.pack ([Word8] -> ByteString) -> [Word8] -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> [Word8] -> [Word8]
forall a. Int -> [a] -> [a]
take Int
olen [Word8]
buf8, Int -> ByteString -> ByteString
BS.drop Int
8 ByteString
bs0)
  where
    bs0len :: Int
bs0len = ByteString -> Int
BS.length ByteString
bs0

    desym :: Char -> Maybe Word8
desym = case Fmt
fmt of
      Fmt
Fmt'base32    -> Char -> Maybe Word8
desym0
      Fmt
Fmt'base32hex -> Char -> Maybe Word8
desymx

    -- plain base32 alphabet (case-insens)
    desym0 :: Char -> Maybe Word8
    desym0 :: Char -> Maybe Word8
desym0 Char
c0 = case Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c0 of
      Int
c | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x32 -> Maybe Word8
forall a. Maybe a
Nothing
        | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x38 -> Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (Word8 -> Maybe Word8) -> Word8 -> Maybe Word8
forall a b. (a -> b) -> a -> b
$! Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
24)
        | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x41 -> Maybe Word8
forall a. Maybe a
Nothing
        | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x5b -> Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (Word8 -> Maybe Word8) -> Word8 -> Maybe Word8
forall a b. (a -> b) -> a -> b
$! Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x41)
        | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x61 -> Maybe Word8
forall a. Maybe a
Nothing
        | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x7b -> Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (Word8 -> Maybe Word8) -> Word8 -> Maybe Word8
forall a b. (a -> b) -> a -> b
$! Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x61)
        | Bool
otherwise -> Maybe Word8
forall a. Maybe a
Nothing

    -- base32hex alphabet (case-insens)
    desymx :: Char -> Maybe Word8
    desymx :: Char -> Maybe Word8
desymx Char
c0 = case Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c0 of
      Int
c | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x30 -> Maybe Word8
forall a. Maybe a
Nothing
        | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x3a -> Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (Word8 -> Maybe Word8) -> Word8 -> Maybe Word8
forall a b. (a -> b) -> a -> b
$! Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
0x30)
        | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x41 -> Maybe Word8
forall a. Maybe a
Nothing
        | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x57 -> Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (Word8 -> Maybe Word8) -> Word8 -> Maybe Word8
forall a b. (a -> b) -> a -> b
$! Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
55)
        | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x61 -> Maybe Word8
forall a. Maybe a
Nothing
        | Int
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x77 -> Word8 -> Maybe Word8
forall a. a -> Maybe a
Just (Word8 -> Maybe Word8) -> Word8 -> Maybe Word8
forall a b. (a -> b) -> a -> b
$! Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
87)
        | Bool
otherwise -> Maybe Word8
forall a. Maybe a
Nothing