--   This Source Code Form is subject to the terms of the Mozilla Public
--   License, v. 2.0. If a copy of the MPL was not distributed with this
--   file, You can obtain one at http://mozilla.org/MPL/2.0/.

{-# OPTIONS_HADDOCK show-extensions #-}

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- | JWT encoding definition
--   
--   __This module can be considered internal to the library__
--   Users should never need to implement the `Encode` typeclass or use any of the exported functions or types directly.
--   You'll only need to know of `Encode` typeclass if you want to write a function polymorphic in the type of payloads. 
--
--   If you want to extend the types supported by the library, see "Libjwt.Classes"
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 ()

-- | Do not perform any action. It is used to encode things like empty lists or /Nothing/
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

-- | Low-level definition of JWT claims encoding.
class ClaimEncoder t where
  -- | Given a pointer to /jwt_t/, mutate the structure it points to to encode the value as a named claim
  --   It relies on the functions exported from "Libjwt.FFI.Jwt" to perform an /impure/ effect of /encoding/
  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

-- | Definition of claims encoding.
--   
--   The only use for the user is probably to write a function that is polymorphic in the payload type.
class Encode c where
  -- | Perform the encoding as /impure/ action
  encode :: c -> JwtT -> EncodeResult