{-# OPTIONS_HADDOCK show-extensions #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Libjwt.Encoding
( EncodeResult
, Encode(..)
, ClaimEncoder(..)
, nullEncode
)
where
import Libjwt.Classes
import Libjwt.FFI.Jwt
import Libjwt.JsonByteString
import Libjwt.NumericDate
import Data.ByteString ( ByteString )
import Data.ByteString.Builder ( Builder
, char7
, string7
, lazyByteString
)
import Data.ByteString.Builder.Extra ( toLazyByteStringWith
, safeStrategy
)
import Data.ByteString.Lazy ( toStrict )
import Data.Coerce ( coerce )
import Data.Proxy ( Proxy(..) )
type EncodeResult = JwtIO ()
nullEncode :: b -> EncodeResult
nullEncode :: b -> EncodeResult
nullEncode = EncodeResult -> b -> EncodeResult
forall a b. a -> b -> a
const (EncodeResult -> b -> EncodeResult)
-> EncodeResult -> b -> EncodeResult
forall a b. (a -> b) -> a -> b
$ () -> EncodeResult
forall (m :: * -> *) a. Monad m => a -> m a
return ()
data EncoderType = Native | Spec | Derived
type family EncoderDef a :: EncoderType where
EncoderDef (Maybe a) = 'Spec
EncoderDef ByteString = 'Native
EncoderDef Bool = 'Native
EncoderDef Int = 'Native
EncoderDef NumericDate = 'Native
EncoderDef JsonByteString = 'Native
EncoderDef String = 'Derived
EncoderDef [a] = 'Spec
EncoderDef _ = 'Derived
class ClaimEncoder t where
encodeClaim :: String -> t -> JwtT -> EncodeResult
instance (EncoderDef a ~ ty, ClaimEncoder' ty a) => ClaimEncoder a where
encodeClaim :: String -> a -> JwtT -> EncodeResult
encodeClaim = Proxy ty -> String -> a -> JwtT -> EncodeResult
forall (ty :: EncoderType) t (proxy :: EncoderType -> *).
ClaimEncoder' ty t =>
proxy ty -> String -> t -> JwtT -> EncodeResult
encodeClaim' (Proxy ty
forall k (t :: k). Proxy t
Proxy :: Proxy ty)
class ClaimEncoder' (ty :: EncoderType) t where
encodeClaim' :: proxy ty -> String -> t -> JwtT -> EncodeResult
instance ClaimEncoder a => ClaimEncoder' 'Spec (Maybe a) where
encodeClaim' :: proxy 'Spec -> String -> Maybe a -> JwtT -> EncodeResult
encodeClaim' proxy 'Spec
_ String
name (Just a
val) = String -> a -> JwtT -> EncodeResult
forall t. ClaimEncoder t => String -> t -> JwtT -> EncodeResult
encodeClaim String
name a
val
encodeClaim' proxy 'Spec
_ String
_ Maybe a
Nothing = JwtT -> EncodeResult
forall b. b -> EncodeResult
nullEncode
instance JsonBuilder a => ClaimEncoder' 'Spec [a] where
encodeClaim' :: proxy 'Spec -> String -> [a] -> JwtT -> EncodeResult
encodeClaim' proxy 'Spec
_ String
_ [] = JwtT -> EncodeResult
forall b. b -> EncodeResult
nullEncode
encodeClaim' proxy 'Spec
_ String
name [a]
as = String -> Builder -> JwtT -> EncodeResult
fromJson String
name (Builder -> JwtT -> EncodeResult)
-> Builder -> JwtT -> EncodeResult
forall a b. (a -> b) -> a -> b
$ [a] -> Builder
forall t. JsonBuilder t => t -> Builder
jsonBuilder [a]
as
instance ClaimEncoder' 'Native ByteString where
encodeClaim' :: proxy 'Native -> String -> ByteString -> JwtT -> EncodeResult
encodeClaim' proxy 'Native
_ = String -> ByteString -> JwtT -> EncodeResult
addGrant
instance ClaimEncoder' 'Native Bool where
encodeClaim' :: proxy 'Native -> String -> Bool -> JwtT -> EncodeResult
encodeClaim' proxy 'Native
_ = String -> Bool -> JwtT -> EncodeResult
addGrantBool
instance ClaimEncoder' 'Native Int where
encodeClaim' :: proxy 'Native -> String -> Int -> JwtT -> EncodeResult
encodeClaim' proxy 'Native
_ = String -> Int -> JwtT -> EncodeResult
addGrantInt
instance ClaimEncoder' 'Native NumericDate where
encodeClaim' :: proxy 'Native -> String -> NumericDate -> JwtT -> EncodeResult
encodeClaim' proxy 'Native
_ String
name = String -> Int64 -> JwtT -> EncodeResult
addGrantInt64 String
name (Int64 -> JwtT -> EncodeResult)
-> (NumericDate -> Int64) -> NumericDate -> JwtT -> EncodeResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NumericDate -> Int64
coerce
{-# INLINE encodeClaim' #-}
fromJson :: String -> Builder -> JwtT -> JwtIO ()
fromJson :: String -> Builder -> JwtT -> EncodeResult
fromJson String
name =
ByteString -> JwtT -> EncodeResult
addGrantsFromJson
(ByteString -> JwtT -> EncodeResult)
-> (Builder -> ByteString) -> Builder -> JwtT -> EncodeResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict
(ByteString -> ByteString)
-> (Builder -> ByteString) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AllocationStrategy -> ByteString -> Builder -> ByteString
toLazyByteStringWith (Int -> Int -> AllocationStrategy
safeStrategy Int
64 Int
512) ByteString
forall a. Monoid a => a
mempty
(Builder -> ByteString)
-> (Builder -> Builder) -> Builder -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder
encodeAsObject1
where
encodeAsObject1 :: Builder -> Builder
encodeAsObject1 = Builder -> Builder
objectBrackets (Builder -> Builder) -> (Builder -> Builder) -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Builder
fieldName Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
':') Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>)
where
objectBrackets :: Builder -> Builder
objectBrackets Builder
bs = Char -> Builder
char7 Char
'{' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
bs Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
'}'
fieldName :: Builder
fieldName = Char -> Builder
char7 Char
'"' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> String -> Builder
string7 String
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char7 Char
'"'
instance ClaimEncoder' 'Native JsonByteString where
encodeClaim' :: proxy 'Native -> String -> JsonByteString -> JwtT -> EncodeResult
encodeClaim' proxy 'Native
_ String
name = String -> Builder -> JwtT -> EncodeResult
fromJson String
name (Builder -> JwtT -> EncodeResult)
-> (JsonByteString -> Builder)
-> JsonByteString
-> JwtT
-> EncodeResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Builder
lazyByteString (ByteString -> Builder)
-> (JsonByteString -> ByteString) -> JsonByteString -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JsonByteString -> ByteString
toJson
instance (JwtRep b a, EncoderDef b ~ ty, ClaimEncoder' ty b) => ClaimEncoder' 'Derived a where
encodeClaim' :: proxy 'Derived -> String -> a -> JwtT -> EncodeResult
encodeClaim' proxy 'Derived
_ String
name = Proxy ty -> String -> b -> JwtT -> EncodeResult
forall (ty :: EncoderType) t (proxy :: EncoderType -> *).
ClaimEncoder' ty t =>
proxy ty -> String -> t -> JwtT -> EncodeResult
encodeClaim' (Proxy ty
forall k (t :: k). Proxy t
Proxy :: Proxy ty) String
name (b -> JwtT -> EncodeResult)
-> (a -> b) -> a -> JwtT -> EncodeResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
forall a b. JwtRep a b => b -> a
rep
class Encode c where
encode :: c -> JwtT -> EncodeResult