-- | Percent encoding
--
-- The gRPC spec is similar, but not identical, to URI encoding.
--
-- > Percent-Encoded        → 1*(Percent-Byte-Unencoded / Percent-Byte-Encoded)
-- > Percent-Byte-Unencoded → 1*( %x20-%x24 / %x26-%x7E ) ; space and VCHAR, except %
-- > Percent-Byte-Encoded   → "%" 2HEXDIGIT ; 0-9 A-F
--
-- We work with strict bytestrings here, since these are ultimately intended
-- as header values.
--
-- Intended for qualified import.
--
-- > import Network.GRPC.Spec.PercentEncoding qualified as PercentEncoding
module Network.GRPC.Spec.PercentEncoding (
    encode
  , decode
  ) where

import Control.Exception
import Data.Bifunctor
import Data.Bits
import Data.ByteString qualified as BS.Strict
import Data.ByteString qualified as Strict (ByteString)
import Data.ByteString.Builder (Builder)
import Data.ByteString.Builder qualified as Builder
import Data.ByteString.Lazy qualified as BS.Lazy
import Data.Text (Text)
import Data.Text.Encoding qualified as Text
import Data.Text.Encoding.Error qualified as Text
import Data.Word

import Network.GRPC.Spec.Util.ByteString (ascii)

{-------------------------------------------------------------------------------
  Encoding
-------------------------------------------------------------------------------}

encode :: Text -> Strict.ByteString
encode :: Text -> ByteString
encode =
      LazyByteString -> ByteString
BS.Lazy.toStrict
    (LazyByteString -> ByteString)
-> (Text -> LazyByteString) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> LazyByteString
Builder.toLazyByteString
    (Builder -> LazyByteString)
-> (Text -> Builder) -> Text -> LazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Word8 -> Builder) -> [Word8] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Word8 -> Builder
encodeChar
    ([Word8] -> Builder) -> (Text -> [Word8]) -> Text -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.Strict.unpack
    (ByteString -> [Word8]) -> (Text -> ByteString) -> Text -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
Text.encodeUtf8

encodeChar :: Word8 -> Builder
encodeChar :: Word8 -> Builder
encodeChar Word8
c
  | Word8 -> Bool
needsEncoding Word8
c = let (Word8
hi, Word8
lo) = Word8 -> (Word8, Word8)
toBase16 Word8
c
                      in [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat [
                             Char -> Builder
Builder.char7 Char
'%'
                           , Word8 -> Builder
Builder.word8 Word8
hi
                           , Word8 -> Builder
Builder.word8 Word8
lo
                           ]
  | Bool
otherwise       = Word8 -> Builder
Builder.word8 Word8
c

-- | Does this character have to be encoded?
--
-- The gRPC spec unencoded characters as "space and VCHAR, except %":
--
-- > Percent-Byte-Unencoded → 1*( %x20-%x24 / %x26-%x7E )
needsEncoding :: Word8 -> Bool
needsEncoding :: Word8 -> Bool
needsEncoding Word8
c
  | Word8
0x20 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
c Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x24 = Bool
False
  | Word8
0x26 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
c Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
0x7E = Bool
False
  | Bool
otherwise              = Bool
True

{-------------------------------------------------------------------------------
  Decoding
-------------------------------------------------------------------------------}

data DecodeException =
    -- | Hex digit outside its range @(0..9, A..F)@
    InvalidHexDigit Word8

    -- | Percent (@%@) which was not followed by two hex digits
  | MissingHexDigits

    -- | Hex-decoding was fine, but encoded string was not valid UTF8
  | InvalidUtf8 Text.UnicodeException
  deriving stock (Int -> DecodeException -> ShowS
[DecodeException] -> ShowS
DecodeException -> String
(Int -> DecodeException -> ShowS)
-> (DecodeException -> String)
-> ([DecodeException] -> ShowS)
-> Show DecodeException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecodeException -> ShowS
showsPrec :: Int -> DecodeException -> ShowS
$cshow :: DecodeException -> String
show :: DecodeException -> String
$cshowList :: [DecodeException] -> ShowS
showList :: [DecodeException] -> ShowS
Show)

instance Exception DecodeException where
  displayException :: DecodeException -> String
displayException (InvalidHexDigit Word8
w) =
      String
"invalid hex digit '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
w String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'"
  displayException DecodeException
MissingHexDigits =
      String
"'%' not followed by two hex digits"
  displayException (InvalidUtf8 UnicodeException
err) =
      UnicodeException -> String
forall e. Exception e => e -> String
displayException UnicodeException
err

decode :: Strict.ByteString -> Either DecodeException Text
decode :: ByteString -> Either DecodeException Text
decode =
      (Either DecodeException ByteString
-> (ByteString -> Either DecodeException Text)
-> Either DecodeException Text
forall a b.
Either DecodeException a
-> (a -> Either DecodeException b) -> Either DecodeException b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (UnicodeException -> DecodeException)
-> Either UnicodeException Text -> Either DecodeException Text
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first UnicodeException -> DecodeException
InvalidUtf8 (Either UnicodeException Text -> Either DecodeException Text)
-> (ByteString -> Either UnicodeException Text)
-> ByteString
-> Either DecodeException Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
Text.decodeUtf8')
    (Either DecodeException ByteString -> Either DecodeException Text)
-> (ByteString -> Either DecodeException ByteString)
-> ByteString
-> Either DecodeException Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Word8] -> ByteString)
-> Either DecodeException [Word8]
-> Either DecodeException ByteString
forall a b.
(a -> b) -> Either DecodeException a -> Either DecodeException b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Word8] -> ByteString
BS.Strict.pack
    (Either DecodeException [Word8]
 -> Either DecodeException ByteString)
-> (ByteString -> Either DecodeException [Word8])
-> ByteString
-> Either DecodeException ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> [Word8] -> Either DecodeException [Word8]
go []
    ([Word8] -> Either DecodeException [Word8])
-> (ByteString -> [Word8])
-> ByteString
-> Either DecodeException [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Word8]
BS.Strict.unpack
  where
    go :: [Word8] -> [Word8] -> Either DecodeException [Word8]
    go :: [Word8] -> [Word8] -> Either DecodeException [Word8]
go [Word8]
acc (Word8
c:[Word8]
cs)
      | Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'%' = case [Word8]
cs of
                           Word8
hi:Word8
lo:[Word8]
cs' -> do
                             c' <- (Word8, Word8) -> Either DecodeException Word8
fromBase16 (Word8
hi, Word8
lo)
                             go (c':acc) cs'
                           [Word8]
_otherwise ->
                             DecodeException -> Either DecodeException [Word8]
forall a b. a -> Either a b
Left (DecodeException -> Either DecodeException [Word8])
-> DecodeException -> Either DecodeException [Word8]
forall a b. (a -> b) -> a -> b
$ DecodeException
MissingHexDigits
      | Bool
otherwise      = [Word8] -> [Word8] -> Either DecodeException [Word8]
go (Word8
cWord8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:[Word8]
acc) [Word8]
cs
    go [Word8]
acc []          = [Word8] -> Either DecodeException [Word8]
forall a b. b -> Either a b
Right ([Word8] -> [Word8]
forall a. [a] -> [a]
reverse [Word8]
acc)

{-------------------------------------------------------------------------------
  Utilities for working with base16

  We could depend on @base16@ or @base16-bytestring@ here, but they deal with
  entire strings at a time, which doesn't quite fit our needs here and would
  result in quite a bit of overhead.
-------------------------------------------------------------------------------}

toBase16 :: Word8 -> (Word8, Word8)
toBase16 :: Word8 -> (Word8, Word8)
toBase16 Word8
c = (Word8 -> Word8
toHexDigit Word8
hi, Word8 -> Word8
toHexDigit Word8
lo)
  where
    hi, lo :: Word8
    hi :: Word8
hi = Word8
c Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftR` Int
4
    lo :: Word8
lo = Word8
c Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.&. Word8
0x0F;

fromBase16 :: (Word8, Word8) -> Either DecodeException Word8
fromBase16 :: (Word8, Word8) -> Either DecodeException Word8
fromBase16 = \(Word8
hi, Word8
lo) -> Word8 -> Word8 -> Word8
aux (Word8 -> Word8 -> Word8)
-> Either DecodeException Word8
-> Either DecodeException (Word8 -> Word8)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Word8 -> Either DecodeException Word8
fromHexDigit Word8
hi Either DecodeException (Word8 -> Word8)
-> Either DecodeException Word8 -> Either DecodeException Word8
forall a b.
Either DecodeException (a -> b)
-> Either DecodeException a -> Either DecodeException b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Word8 -> Either DecodeException Word8
fromHexDigit Word8
lo
  where
    aux :: Word8 -> Word8 -> Word8
    aux :: Word8 -> Word8 -> Word8
aux Word8
hi Word8
lo = (Word8
hi Word8 -> Int -> Word8
forall a. Bits a => a -> Int -> a
`shiftL` Int
4) Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Word8
lo

toHexDigit :: Word8 -> Word8
toHexDigit :: Word8 -> Word8
toHexDigit Word8
c
  |  Word8
0 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
c Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<=  Word8
9 = HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'0' Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
c
  | Word8
10 Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
c Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
15 = HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'A' Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ (Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
10)
  | Bool
otherwise          = String -> Word8
forall a. HasCallStack => String -> a
error String
"toHexDigit: out of range"

-- | Value of a single hex digit
--
-- The gRPC spec does not actually allow for lowercase here, but we support it
-- in case we're dealing with non-conformant peers.
fromHexDigit :: Word8 -> Either DecodeException Word8
fromHexDigit :: Word8 -> Either DecodeException Word8
fromHexDigit Word8
c
  | HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'0' Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
c Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'9' = Word8 -> Either DecodeException Word8
forall a b. b -> Either a b
Right (Word8 -> Either DecodeException Word8)
-> Word8 -> Either DecodeException Word8
forall a b. (a -> b) -> a -> b
$      Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'0'
  | HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'A' Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
c Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'F' = Word8 -> Either DecodeException Word8
forall a b. b -> Either a b
Right (Word8 -> Either DecodeException Word8)
-> Word8 -> Either DecodeException Word8
forall a b. (a -> b) -> a -> b
$ Word8
10 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'A'
  | HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'a' Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
c Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'f' = Word8 -> Either DecodeException Word8
forall a b. b -> Either a b
Right (Word8 -> Either DecodeException Word8)
-> Word8 -> Either DecodeException Word8
forall a b. (a -> b) -> a -> b
$ Word8
10 Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
c Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- HasCallStack => Char -> Word8
Char -> Word8
ascii Char
'a'
  | Bool
otherwise                        = DecodeException -> Either DecodeException Word8
forall a b. a -> Either a b
Left (DecodeException -> Either DecodeException Word8)
-> DecodeException -> Either DecodeException Word8
forall a b. (a -> b) -> a -> b
$ Word8 -> DecodeException
InvalidHexDigit Word8
c