{-|
Module      : Z.Data.Vector.Base64
Description : Base64 codec for bytes.
Copyright   : (c) Dong Han, 2017-2018
License     : BSD
Maintainer  : winterland1989@gmail.com
Stability   : experimental
Portability : non-portable

This module provides base64 encoding & decoding tools, as well as 'Base64Bytes' newtype with base64 textual instances.

-}

module Z.Data.Vector.Base64
  ( -- * The Base64Bytes type
    Base64Bytes(..)
  -- * Encoding & Decoding functions
  , base64Encode
  , base64EncodeLength
  , base64EncodeText
  , base64EncodeBuilder
  , base64Decode
  , base64Decode'
  , base64DecodeLength
  , Base64DecodeException(..)
  -- * Internal C FFIs
  ,  hs_base64_encode, hs_base64_decode
  ) where

import           Control.Exception
import           Data.Word
import           Data.Bits                      (unsafeShiftL, unsafeShiftR, (.&.))
import           Data.Hashable                  (Hashable(..))
import           GHC.Stack
import           System.IO.Unsafe
import qualified Z.Data.Vector.Base         as V
import qualified Z.Data.Builder.Base        as B
import qualified Z.Data.Text.Base           as T
import qualified Z.Data.Text.Print          as T
import qualified Z.Data.JSON                as JSON
import           Z.Foreign

-- | New type wrapper for 'V.Bytes' with base64 encoding Show\/JSON instances.
newtype Base64Bytes = Base64Bytes { Base64Bytes -> Bytes
unBase64Bytes :: V.Bytes }
    deriving (Base64Bytes -> Base64Bytes -> Bool
(Base64Bytes -> Base64Bytes -> Bool)
-> (Base64Bytes -> Base64Bytes -> Bool) -> Eq Base64Bytes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Base64Bytes -> Base64Bytes -> Bool
$c/= :: Base64Bytes -> Base64Bytes -> Bool
== :: Base64Bytes -> Base64Bytes -> Bool
$c== :: Base64Bytes -> Base64Bytes -> Bool
Eq, Eq Base64Bytes
Eq Base64Bytes
-> (Base64Bytes -> Base64Bytes -> Ordering)
-> (Base64Bytes -> Base64Bytes -> Bool)
-> (Base64Bytes -> Base64Bytes -> Bool)
-> (Base64Bytes -> Base64Bytes -> Bool)
-> (Base64Bytes -> Base64Bytes -> Bool)
-> (Base64Bytes -> Base64Bytes -> Base64Bytes)
-> (Base64Bytes -> Base64Bytes -> Base64Bytes)
-> Ord Base64Bytes
Base64Bytes -> Base64Bytes -> Bool
Base64Bytes -> Base64Bytes -> Ordering
Base64Bytes -> Base64Bytes -> Base64Bytes
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Base64Bytes -> Base64Bytes -> Base64Bytes
$cmin :: Base64Bytes -> Base64Bytes -> Base64Bytes
max :: Base64Bytes -> Base64Bytes -> Base64Bytes
$cmax :: Base64Bytes -> Base64Bytes -> Base64Bytes
>= :: Base64Bytes -> Base64Bytes -> Bool
$c>= :: Base64Bytes -> Base64Bytes -> Bool
> :: Base64Bytes -> Base64Bytes -> Bool
$c> :: Base64Bytes -> Base64Bytes -> Bool
<= :: Base64Bytes -> Base64Bytes -> Bool
$c<= :: Base64Bytes -> Base64Bytes -> Bool
< :: Base64Bytes -> Base64Bytes -> Bool
$c< :: Base64Bytes -> Base64Bytes -> Bool
compare :: Base64Bytes -> Base64Bytes -> Ordering
$ccompare :: Base64Bytes -> Base64Bytes -> Ordering
$cp1Ord :: Eq Base64Bytes
Ord)
    deriving newtype (Semigroup Base64Bytes
Base64Bytes
Semigroup Base64Bytes
-> Base64Bytes
-> (Base64Bytes -> Base64Bytes -> Base64Bytes)
-> ([Base64Bytes] -> Base64Bytes)
-> Monoid Base64Bytes
[Base64Bytes] -> Base64Bytes
Base64Bytes -> Base64Bytes -> Base64Bytes
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Base64Bytes] -> Base64Bytes
$cmconcat :: [Base64Bytes] -> Base64Bytes
mappend :: Base64Bytes -> Base64Bytes -> Base64Bytes
$cmappend :: Base64Bytes -> Base64Bytes -> Base64Bytes
mempty :: Base64Bytes
$cmempty :: Base64Bytes
$cp1Monoid :: Semigroup Base64Bytes
Monoid, b -> Base64Bytes -> Base64Bytes
NonEmpty Base64Bytes -> Base64Bytes
Base64Bytes -> Base64Bytes -> Base64Bytes
(Base64Bytes -> Base64Bytes -> Base64Bytes)
-> (NonEmpty Base64Bytes -> Base64Bytes)
-> (forall b. Integral b => b -> Base64Bytes -> Base64Bytes)
-> Semigroup Base64Bytes
forall b. Integral b => b -> Base64Bytes -> Base64Bytes
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Base64Bytes -> Base64Bytes
$cstimes :: forall b. Integral b => b -> Base64Bytes -> Base64Bytes
sconcat :: NonEmpty Base64Bytes -> Base64Bytes
$csconcat :: NonEmpty Base64Bytes -> Base64Bytes
<> :: Base64Bytes -> Base64Bytes -> Base64Bytes
$c<> :: Base64Bytes -> Base64Bytes -> Base64Bytes
Semigroup, Int -> Base64Bytes -> Int
Base64Bytes -> Int
(Int -> Base64Bytes -> Int)
-> (Base64Bytes -> Int) -> Hashable Base64Bytes
forall a. (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Base64Bytes -> Int
$chash :: Base64Bytes -> Int
hashWithSalt :: Int -> Base64Bytes -> Int
$chashWithSalt :: Int -> Base64Bytes -> Int
Hashable)

instance Show Base64Bytes where
    show :: Base64Bytes -> String
show (Base64Bytes Bytes
bs) = Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Bytes -> Text
base64EncodeText Bytes
bs

instance T.Print Base64Bytes where
    {-# INLINABLE toUTF8BuilderP #-}
    toUTF8BuilderP :: Int -> Base64Bytes -> Builder ()
toUTF8BuilderP Int
_ (Base64Bytes Bytes
bs) = Builder () -> Builder ()
B.quotes (Bytes -> Builder ()
base64EncodeBuilder Bytes
bs)

instance JSON.JSON Base64Bytes where
    {-# INLINE fromValue #-}
    fromValue :: Value -> Converter Base64Bytes
fromValue = Text
-> (Text -> Converter Base64Bytes)
-> Value
-> Converter Base64Bytes
forall a. Text -> (Text -> Converter a) -> Value -> Converter a
JSON.withText Text
"Z.Data.Text.Base64Bytes" ((Text -> Converter Base64Bytes) -> Value -> Converter Base64Bytes)
-> (Text -> Converter Base64Bytes)
-> Value
-> Converter Base64Bytes
forall a b. (a -> b) -> a -> b
$ \ Text
t ->
        case Bytes -> Maybe Bytes
base64Decode (Text -> Bytes
T.getUTF8Bytes Text
t) of
            Just Bytes
bs -> Base64Bytes -> Converter Base64Bytes
forall (m :: * -> *) a. Monad m => a -> m a
return (Bytes -> Base64Bytes
Base64Bytes Bytes
bs)
            Maybe Bytes
Nothing -> Text -> Converter Base64Bytes
forall a. Text -> Converter a
JSON.fail' Text
"illegal base64 encoding bytes"
    {-# INLINE toValue #-}
    toValue :: Base64Bytes -> Value
toValue (Base64Bytes Bytes
bs) = Text -> Value
JSON.String (Bytes -> Text
base64EncodeText Bytes
bs)
    {-# INLINE encodeJSON #-}
    encodeJSON :: Base64Bytes -> Builder ()
encodeJSON (Base64Bytes Bytes
bs) = Bytes -> Builder ()
base64EncodeBuilder Bytes
bs

-- | Encode 'V.Bytes' using base64 encoding.
base64Encode :: V.Bytes -> V.Bytes
{-# INLINABLE base64Encode #-}
base64Encode :: Bytes -> Bytes
base64Encode (V.PrimVector PrimArray Word8
arr Int
s Int
l) = (Bytes, ()) -> Bytes
forall a b. (a, b) -> a
fst ((Bytes, ()) -> Bytes)
-> (IO (Bytes, ()) -> (Bytes, ())) -> IO (Bytes, ()) -> Bytes
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Bytes, ()) -> (Bytes, ())
forall a. IO a -> a
unsafeDupablePerformIO (IO (Bytes, ()) -> Bytes) -> IO (Bytes, ()) -> Bytes
forall a b. (a -> b) -> a -> b
$ do
    Int -> (MBA# Word8 -> IO ()) -> IO (Bytes, ())
forall a b.
Prim a =>
Int -> (MBA# Word8 -> IO b) -> IO (PrimVector a, b)
allocPrimVectorUnsafe (Int -> Int
base64EncodeLength Int
l) ((MBA# Word8 -> IO ()) -> IO (Bytes, ()))
-> (MBA# Word8 -> IO ()) -> IO (Bytes, ())
forall a b. (a -> b) -> a -> b
$ \ MBA# Word8
buf# ->
        PrimArray Word8 -> (BA# Word8 -> Int -> IO ()) -> IO ()
forall a b.
Prim a =>
PrimArray a -> (BA# Word8 -> Int -> IO b) -> IO b
withPrimArrayUnsafe PrimArray Word8
arr ((BA# Word8 -> Int -> IO ()) -> IO ())
-> (BA# Word8 -> Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
parr Int
_ ->
            MBA# Word8 -> Int -> BA# Word8 -> Int -> Int -> IO ()
hs_base64_encode MBA# Word8
buf# Int
0 BA# Word8
parr Int
s Int
l

-- | Return the encoded length of a given input length, always a multipler of 4.
base64EncodeLength :: Int -> Int
{-# INLINABLE base64EncodeLength #-}
base64EncodeLength :: Int -> Int
base64EncodeLength Int
n = ((Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`quot` Int
3) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
2

-- | 'B.Builder' version of 'base64Encode'.
base64EncodeBuilder :: V.Bytes -> B.Builder ()
{-# INLINABLE base64EncodeBuilder #-}
base64EncodeBuilder :: Bytes -> Builder ()
base64EncodeBuilder (V.PrimVector PrimArray Word8
arr Int
s Int
l) =
    Int
-> (MutablePrimArray RealWorld Word8 -> Int -> IO ()) -> Builder ()
B.writeN (Int -> Int
base64EncodeLength Int
l) (\ (MutablePrimArray MBA# Word8
mba#) Int
i -> do
        PrimArray Word8 -> (BA# Word8 -> Int -> IO ()) -> IO ()
forall a b.
Prim a =>
PrimArray a -> (BA# Word8 -> Int -> IO b) -> IO b
withPrimArrayUnsafe PrimArray Word8
arr ((BA# Word8 -> Int -> IO ()) -> IO ())
-> (BA# Word8 -> Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
parr Int
_ ->
            MBA# Word8 -> Int -> BA# Word8 -> Int -> Int -> IO ()
hs_base64_encode MBA# Word8
mba# Int
i BA# Word8
parr Int
s Int
l)

-- | Text version of 'base64Encode'.
base64EncodeText :: V.Bytes -> T.Text
{-# INLINABLE base64EncodeText #-}
base64EncodeText :: Bytes -> Text
base64EncodeText = Bytes -> Text
T.Text (Bytes -> Text) -> (Bytes -> Bytes) -> Bytes -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bytes -> Bytes
base64Encode

-- | Decode a base64 encoding string, return Nothing on illegal bytes or incomplete input.
base64Decode :: V.Bytes -> Maybe V.Bytes
{-# INLINABLE base64Decode #-}
base64Decode :: Bytes -> Maybe Bytes
base64Decode Bytes
ba
    | Int
inputLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just Bytes
forall (v :: * -> *) a. Vec v a => v a
V.empty
    | Int
decodeLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 = Maybe Bytes
forall a. Maybe a
Nothing
    | Bool
otherwise = IO (Maybe Bytes) -> Maybe Bytes
forall a. IO a -> a
unsafeDupablePerformIO (IO (Maybe Bytes) -> Maybe Bytes)
-> IO (Maybe Bytes) -> Maybe Bytes
forall a b. (a -> b) -> a -> b
$ do
        ((V.PrimVector PrimArray Word8
arr Int
s' Int
_), Int
r) <- Bytes
-> (BA# Word8 -> Int -> Int -> IO (Bytes, Int)) -> IO (Bytes, Int)
forall a b.
Prim a =>
PrimVector a -> (BA# Word8 -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
ba ((BA# Word8 -> Int -> Int -> IO (Bytes, Int)) -> IO (Bytes, Int))
-> (BA# Word8 -> Int -> Int -> IO (Bytes, Int)) -> IO (Bytes, Int)
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
ba# Int
s Int
l ->
            Int -> (MBA# Word8 -> IO Int) -> IO (Bytes, Int)
forall a b.
Prim a =>
Int -> (MBA# Word8 -> IO b) -> IO (PrimVector a, b)
allocPrimVectorUnsafe Int
decodeLen ((MBA# Word8 -> IO Int) -> IO (Bytes, Int))
-> (MBA# Word8 -> IO Int) -> IO (Bytes, Int)
forall a b. (a -> b) -> a -> b
$ \ MBA# Word8
buf# ->
                MBA# Word8 -> BA# Word8 -> Int -> Int -> IO Int
hs_base64_decode MBA# Word8
buf# BA# Word8
ba# Int
s Int
l
        if Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then Maybe Bytes -> IO (Maybe Bytes)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bytes
forall a. Maybe a
Nothing
        else Maybe Bytes -> IO (Maybe Bytes)
forall (m :: * -> *) a. Monad m => a -> m a
return (Bytes -> Maybe Bytes
forall a. a -> Maybe a
Just (PrimArray Word8 -> Int -> Int -> Bytes
forall a. PrimArray a -> Int -> Int -> PrimVector a
V.PrimVector PrimArray Word8
arr Int
s' Int
r))
  where
    inputLen :: Int
inputLen = Bytes -> Int
forall (v :: * -> *) a. Vec v a => v a -> Int
V.length Bytes
ba
    decodeLen :: Int
decodeLen = Int -> Int
base64DecodeLength Int
inputLen

-- | Exception during base64 decoding.
data Base64DecodeException = IllegalBase64Bytes V.Bytes CallStack
                           | IncompleteBase64Bytes V.Bytes CallStack
                        deriving Int -> Base64DecodeException -> ShowS
[Base64DecodeException] -> ShowS
Base64DecodeException -> String
(Int -> Base64DecodeException -> ShowS)
-> (Base64DecodeException -> String)
-> ([Base64DecodeException] -> ShowS)
-> Show Base64DecodeException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Base64DecodeException] -> ShowS
$cshowList :: [Base64DecodeException] -> ShowS
show :: Base64DecodeException -> String
$cshow :: Base64DecodeException -> String
showsPrec :: Int -> Base64DecodeException -> ShowS
$cshowsPrec :: Int -> Base64DecodeException -> ShowS
Show
instance Exception Base64DecodeException

-- | Decode a base64 encoding string, throw 'Base64DecodeException' on error.
base64Decode' :: HasCallStack => V.Bytes -> V.Bytes
{-# INLINABLE base64Decode' #-}
base64Decode' :: Bytes -> Bytes
base64Decode' Bytes
ba
    | Int
inputLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Bytes
forall (v :: * -> *) a. Vec v a => v a
V.empty
    | Int
decodeLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== -Int
1 = Base64DecodeException -> Bytes
forall a e. Exception e => e -> a
throw (Bytes -> CallStack -> Base64DecodeException
IncompleteBase64Bytes Bytes
ba CallStack
HasCallStack => CallStack
callStack)
    | Bool
otherwise = IO Bytes -> Bytes
forall a. IO a -> a
unsafeDupablePerformIO (IO Bytes -> Bytes) -> IO Bytes -> Bytes
forall a b. (a -> b) -> a -> b
$ do
        ((V.PrimVector PrimArray Word8
arr Int
s' Int
_), Int
r) <- Bytes
-> (BA# Word8 -> Int -> Int -> IO (Bytes, Int)) -> IO (Bytes, Int)
forall a b.
Prim a =>
PrimVector a -> (BA# Word8 -> Int -> Int -> IO b) -> IO b
withPrimVectorUnsafe Bytes
ba ((BA# Word8 -> Int -> Int -> IO (Bytes, Int)) -> IO (Bytes, Int))
-> (BA# Word8 -> Int -> Int -> IO (Bytes, Int)) -> IO (Bytes, Int)
forall a b. (a -> b) -> a -> b
$ \ BA# Word8
ba# Int
s Int
l ->
            Int -> (MBA# Word8 -> IO Int) -> IO (Bytes, Int)
forall a b.
Prim a =>
Int -> (MBA# Word8 -> IO b) -> IO (PrimVector a, b)
allocPrimVectorUnsafe Int
decodeLen ((MBA# Word8 -> IO Int) -> IO (Bytes, Int))
-> (MBA# Word8 -> IO Int) -> IO (Bytes, Int)
forall a b. (a -> b) -> a -> b
$ \ MBA# Word8
buf# ->
                MBA# Word8 -> BA# Word8 -> Int -> Int -> IO Int
hs_base64_decode MBA# Word8
buf# BA# Word8
ba# Int
s Int
l
        if Int
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
        then Base64DecodeException -> IO Bytes
forall e a. Exception e => e -> IO a
throwIO (Bytes -> CallStack -> Base64DecodeException
IllegalBase64Bytes Bytes
ba CallStack
HasCallStack => CallStack
callStack)
        else Bytes -> IO Bytes
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimArray Word8 -> Int -> Int -> Bytes
forall a. PrimArray a -> Int -> Int -> PrimVector a
V.PrimVector PrimArray Word8
arr Int
s' Int
r)
  where
    inputLen :: Int
inputLen = Bytes -> Int
forall (v :: * -> *) a. Vec v a => v a -> Int
V.length Bytes
ba
    decodeLen :: Int
decodeLen = Int -> Int
base64DecodeLength Int
inputLen

-- | Return the upper bound of decoded length of a given input length
-- , return -1 if illegal(not a multipler of 4).
base64DecodeLength :: Int -> Int
{-# INLINABLE base64DecodeLength #-}
base64DecodeLength :: Int -> Int
base64DecodeLength Int
n | Int
n Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Int
3 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = -Int
1
                     | Bool
otherwise = (Int
n Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
2) Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
3

--------------------------------------------------------------------------------

foreign import ccall unsafe hs_base64_encode :: MBA# Word8 -> Int -> BA# Word8 -> Int -> Int -> IO ()
foreign import ccall unsafe hs_base64_decode :: MBA# Word8 -> BA# Word8 -> Int -> Int -> IO Int