module Crypto.JOSE.Types.Internal
(
objectPairs
, encodeB64
, parseB64
, encodeB64Url
, parseB64Url
, pad
, unpad
, bsToInteger
, integerToBS
, sizedIntegerToBS
, base64url
) where
import Data.Bifunctor (first)
import Data.Char (ord)
import Data.Monoid ((<>))
import Data.Tuple (swap)
import Data.Word (Word8)
import Control.Lens
import Control.Lens.Cons.Extras
import Data.Aeson.Types
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Base64.URL as B64U
import qualified Data.HashMap.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
objectPairs :: Value -> [Pair]
objectPairs (Object o) = M.toList o
objectPairs _ = []
parseB64 :: (B.ByteString -> Parser a) -> T.Text -> Parser a
parseB64 f = either fail f . decodeB64
where
decodeB64 = B64.decode . E.encodeUtf8
encodeB64 :: B.ByteString -> Value
encodeB64 = String . E.decodeUtf8 . B64.encode
class IsChar a where
fromChar :: Char -> a
instance IsChar Char where
fromChar = id
instance IsChar Word8 where
fromChar = fromIntegral . ord
pad :: (Snoc s s a a, IsChar a) => s -> s
pad = rpad 4 (fromChar '=')
rpad :: (Snoc s s a a) => Int -> a -> s -> s
rpad w a s =
let n = ((w snocLength s `mod` w) `mod` w)
in foldr (.) id (replicate n (`snoc` a)) s
snocLength :: (Snoc s s a a) => s -> Int
snocLength s = case unsnoc s of
Nothing -> 0
Just (s', _) -> 1 + snocLength s'
padB :: B.ByteString -> B.ByteString
padB s = s <> B.replicate ((4 B.length s `mod` 4) `mod` 4) 61
padL :: L.ByteString -> L.ByteString
padL s = s <> L.replicate ((4 L.length s `mod` 4) `mod` 4) 61
unpad :: (Snoc s s a a, IsChar a, Eq a) => s -> s
unpad = rstrip (== fromChar '=')
rstrip :: (Snoc s s a a) => (a -> Bool) -> s -> s
rstrip p s = case unsnoc s of
Nothing -> s
Just (s', a) -> if p a then rstrip p s' else s
unpadB :: B.ByteString -> B.ByteString
unpadB = B.reverse . B.dropWhile (== 61) . B.reverse
unpadL :: L.ByteString -> L.ByteString
unpadL = L.reverse . L.dropWhile (== 61) . L.reverse
base64url ::
( AsEmpty s1, AsEmpty s2
, Cons s1 s1 Word8 Word8
, Cons s2 s2 Word8 Word8
) => Prism' s1 s2
base64url = reconsIso . padder . b64u . reconsIso
where
padder = iso pad unpad
b64u = prism B64U.encode (\s -> first (const s) (B64U.decode s))
reconsIso = iso (view recons) (view recons)
parseB64Url :: (B.ByteString -> Parser a) -> T.Text -> Parser a
parseB64Url f = maybe (fail "Not valid base64url") f . preview base64url . E.encodeUtf8
encodeB64Url :: B.ByteString -> Value
encodeB64Url = String . E.decodeUtf8 . review base64url
bsToInteger :: B.ByteString -> Integer
bsToInteger = B.foldl (\acc x -> acc * 256 + toInteger x) 0
integerToBS :: Integer -> B.ByteString
integerToBS = B.reverse . B.unfoldr (fmap swap . f)
where
f x = if x == 0 then Nothing else Just (toWord8 $ quotRem x 256)
toWord8 (seed, x) = (seed, fromIntegral x)
sizedIntegerToBS :: Int -> Integer -> B.ByteString
sizedIntegerToBS w = zeroPad . integerToBS
where zeroPad xs = B.replicate (w B.length xs) 0 `B.append` xs