  | This module provides convenient wrappers around JWT provided by @jwt@ 
 Haskell library . These tokens are used to authenticate users and store 
 additional payload on user log in , for example , user i d. 

Haskell library. These tokens are used to authenticate users and store
additional payload on user log in, for example, user id.
-}

module CakeSlayer.Jwt
       ( -- * Secret
         JwtSecret (..)

         -- * Token and payloads
         -- ** Data types
       , JwtToken (..)
       , JwtPayload (..)
         -- ** Coders
       , encodeIntIdPayload
       , decodeIntIdPayload
       , encodeTextIdPayload
       , decodeTextIdPayload
         -- ** Helpers to write coders
       , payloadToMap
       , payloadFromMap

         -- * Jwt Effect
         -- ** Monad
       , MonadJwt (..)
  * * Internals of ' MonadJwt '
       , mkJwtTokenImpl
       , verifyJwtTokenImpl
       ) where

import Data.Aeson (FromJSON, ToJSON, Value)
import Data.Scientific (toBoundedInteger)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Database.PostgreSQL.Simple.FromField (FromField)
import Database.PostgreSQL.Simple.ToField (ToField)
import Elm (Elm)
import Web.HttpApiData (FromHttpApiData)

import CakeSlayer.Time (Seconds (..))

import qualified Data.Aeson as Json
import qualified Data.Map as Map
import qualified Web.JWT as Jwt

----------------------------------------------------------------------------
-- Secret
----------------------------------------------------------------------------

  | JWT secret that is used to sign and verify JSON web tokens . 

 You can use functions from " CakeSlayer . Random " module to create random 
 ' JwtSecret ' at the start of your application like this : 

 @ 
     JwtSecret ' \<$\ > mkRandomString 10 
 @ 


You can use functions from "CakeSlayer.Random" module to create random
'JwtSecret' at the start of your application like this:

@
jwtSecret <- 'JwtSecret' \<$\> mkRandomString 10
@
-}
newtype JwtSecret = JwtSecret
    { unJwtSecret :: Text
    }

----------------------------------------------------------------------------
-- Token and payload
----------------------------------------------------------------------------

{- | Encoded JSON web token.
-}
newtype JwtToken = JwtToken
    { unJwtToken :: Text
    } deriving stock (Show, Generic)
      deriving newtype (Eq, Ord, Hashable, FromField, ToField, FromHttpApiData, FromJSON, ToJSON)
      deriving anyclass Elm

  | Stores arbitrary payload . If you want to store your custom payload , you 
 need to specify two functions : 

 1 . How to encode ' JwtPayload ' as ' Jwt .  ' . 
 2 . How to decode ' JwtPayload ' from ' Jwt .  ' . 

 See examples in this module : ' encodeIntIdPayload ' , ' decodeIntIdPayload ' , 
 ' encodeTextIdPayload ' , ' decodeTextIdPayload ' . 

need to specify two functions:

1. How to encode 'JwtPayload' as 'Jwt.ClaimsMap'.
2. How to decode 'JwtPayload' from 'Jwt.ClaimsMap'.

See examples in this module: 'encodeIntIdPayload', 'decodeIntIdPayload',
'encodeTextIdPayload', 'decodeTextIdPayload'.
-}
newtype JwtPayload a = JwtPayload
    { unJwtPayload :: a
    } deriving stock (Show, Functor)
      deriving newtype (Eq)

  | Encodes ' JwtPayload ' that stores ' Int ' as payload with name  Use it if 
 you store ids as integer values . Dual to ' decodeIntIdPayload ' . 

you store ids as integer values. Dual to 'decodeIntIdPayload'.
-}
encodeIntIdPayload :: JwtPayload Int -> Jwt.ClaimsMap
encodeIntIdPayload = payloadToMap . Json.Number . fromIntegral . unJwtPayload
# INLINE encodeIntIdPayload #

  | Decodes ' JwtPayload ' from ' Jwt .  ' that stores ' Int ' under name 
   to ' encodeIntIdPayload ' . 

@id@. Dual to 'encodeIntIdPayload'.
-}
decodeIntIdPayload :: Jwt.ClaimsMap -> Maybe (JwtPayload Int)
decodeIntIdPayload = fmap JwtPayload . payloadFromMap (\case
    Json.Number jwtId -> toBoundedInteger jwtId
    _ -> Nothing)
# INLINE decodeIntIdPayload #

  | Encodes ' JwtPayload ' that stores ' Text ' as payload with name  Use it if 
 you store ids as text or UUID values . Dual to ' decodeTextIdPayload ' . 

you store ids as text or UUID values. Dual to 'decodeTextIdPayload'.
-}
encodeTextIdPayload :: JwtPayload Text -> Jwt.ClaimsMap
encodeTextIdPayload = payloadToMap . Json.String . unJwtPayload
# INLINE encodeTextIdPayload #

  | Decodes ' JwtPayload ' from ' Jwt .  ' that stores ' Int ' under name 
   to ' encodeIntIdPayload ' . 

@id@. Dual to 'encodeIntIdPayload'.
-}
decodeTextIdPayload :: Jwt.ClaimsMap -> Maybe (JwtPayload Text)
decodeTextIdPayload = fmap JwtPayload . payloadFromMap (\case
    Json.String jwtId -> Just jwtId
    _ -> Nothing)
# INLINE decodeTextIdPayload #

  | Creates ' Jwt .  ' from ' Json . Value ' under name 
payloadToMap :: Json.Value -> Jwt.ClaimsMap
payloadToMap val = Jwt.ClaimsMap $ Map.fromList [("id", val)]
# INLINE payloadToMap #

  | Decodes payload from ' Jwt .  ' under @id@ name given ' Json . Value ' 
 extractor . 

extractor.
-}
payloadFromMap :: (Value -> Maybe a) -> Jwt.ClaimsMap -> Maybe a
payloadFromMap fromValue (Jwt.ClaimsMap claimsMap) =
    Map.lookup "id" claimsMap >>= fromValue
{-# INLINE payloadFromMap #-}

----------------------------------------------------------------------------
-- Secret
----------------------------------------------------------------------------

  | This monad represents effect to create and verify JWT . It has two type 
 variables : 

 * @payload@ : type of JWT payload . 
 * @m@ : monad itself 

variables:

* @payload@: type of JWT payload.
* @m@: monad itself
-}
class Monad m => MonadJwt payload m where
    mkJwtToken
  ^ Token expiry in seconds
        -> JwtPayload payload  -- ^ Payload to code
        -> m JwtToken          -- ^ Encoded token

    verifyJwtToken
        :: JwtToken  -- ^ Token which stores payload
        -> m (Maybe (JwtPayload payload))  -- ^ Decoded payload if token valid

-- | Default implementation of token creation.
mkJwtTokenImpl
    :: MonadIO m
    => (JwtPayload payload -> Jwt.ClaimsMap)
    -> JwtSecret
    -> Seconds
    -> JwtPayload payload
    -> m JwtToken
mkJwtTokenImpl encode (JwtSecret jwtSecret) expiry payload = do
    let secret = Jwt.hmacSecret jwtSecret
    timeNow <- liftIO getPOSIXTime
    let expiryTime = timeNow + fromIntegral (unSeconds expiry)
    let claimsSet = mempty
            { Jwt.exp = Jwt.numericDate expiryTime
            , Jwt.unregisteredClaims = encode payload
            }
    pure $ JwtToken $ Jwt.encodeSigned secret mempty claimsSet

-- | Default implementation of token validation.
verifyJwtTokenImpl
    :: MonadIO m
    => (Jwt.ClaimsMap -> Maybe (JwtPayload payload))
    -> JwtSecret
    -> JwtToken
    -> m (Maybe (JwtPayload payload))
verifyJwtTokenImpl decode (JwtSecret jwtSecret) (JwtToken token) = do
    let secret = Jwt.hmacSecret jwtSecret
    timeNow <- Jwt.numericDate <$> liftIO getPOSIXTime
    pure $ do
        claimsSet <- Jwt.claims <$> Jwt.decodeAndVerifySignature secret token
        expiryTimeStatedInToken <- Jwt.exp claimsSet
        now <- timeNow
        guard (expiryTimeStatedInToken >= now)
        decode $ Jwt.unregisteredClaims claimsSet

 * Secret
 * Token and payloads
 ** Data types
 ** Coders
 ** Helpers to write coders
 * Jwt Effect
 ** Monad
--------------------------------------------------------------------------
 Secret
--------------------------------------------------------------------------
--------------------------------------------------------------------------
 Token and payload
--------------------------------------------------------------------------
 | Encoded JSON web token.

# INLINE payloadFromMap #
--------------------------------------------------------------------------
 Secret
--------------------------------------------------------------------------
 ^ Payload to code
 ^ Encoded token
 ^ Token which stores payload
 ^ Decoded payload if token valid
 | Default implementation of token creation.
 | Default implementation of token validation.
  | This module provides convenient wrappers around JWT provided by @jwt@ 
 Haskell library . These tokens are used to authenticate users and store 
 additional payload on user log in , for example , user i d. 

Haskell library. These tokens are used to authenticate users and store
additional payload on user log in, for example, user id.
-}

module CakeSlayer.Jwt
         JwtSecret (..)

       , JwtToken (..)
       , JwtPayload (..)
       , encodeIntIdPayload
       , decodeIntIdPayload
       , encodeTextIdPayload
       , decodeTextIdPayload
       , payloadToMap
       , payloadFromMap

       , MonadJwt (..)
  * * Internals of ' MonadJwt '
       , mkJwtTokenImpl
       , verifyJwtTokenImpl
       ) where

import Data.Aeson (FromJSON, ToJSON, Value)
import Data.Scientific (toBoundedInteger)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Database.PostgreSQL.Simple.FromField (FromField)
import Database.PostgreSQL.Simple.ToField (ToField)
import Elm (Elm)
import Web.HttpApiData (FromHttpApiData)

import CakeSlayer.Time (Seconds (..))

import qualified Data.Aeson as Json
import qualified Data.Map as Map
import qualified Web.JWT as Jwt


  | JWT secret that is used to sign and verify JSON web tokens . 

 You can use functions from " CakeSlayer . Random " module to create random 
 ' JwtSecret ' at the start of your application like this : 

 @ 
     JwtSecret ' \<$\ > mkRandomString 10 
 @ 


You can use functions from "CakeSlayer.Random" module to create random
'JwtSecret' at the start of your application like this:

@
jwtSecret <- 'JwtSecret' \<$\> mkRandomString 10
@
-}
newtype JwtSecret = JwtSecret
    { unJwtSecret :: Text
    }


newtype JwtToken = JwtToken
    { unJwtToken :: Text
    } deriving stock (Show, Generic)
      deriving newtype (Eq, Ord, Hashable, FromField, ToField, FromHttpApiData, FromJSON, ToJSON)
      deriving anyclass Elm

  | Stores arbitrary payload . If you want to store your custom payload , you 
 need to specify two functions : 

 1 . How to encode ' JwtPayload ' as ' Jwt .  ' . 
 2 . How to decode ' JwtPayload ' from ' Jwt .  ' . 

 See examples in this module : ' encodeIntIdPayload ' , ' decodeIntIdPayload ' , 
 ' encodeTextIdPayload ' , ' decodeTextIdPayload ' . 

need to specify two functions:

1. How to encode 'JwtPayload' as 'Jwt.ClaimsMap'.
2. How to decode 'JwtPayload' from 'Jwt.ClaimsMap'.

See examples in this module: 'encodeIntIdPayload', 'decodeIntIdPayload',
'encodeTextIdPayload', 'decodeTextIdPayload'.
-}
newtype JwtPayload a = JwtPayload
    { unJwtPayload :: a
    } deriving stock (Show, Functor)
      deriving newtype (Eq)

  | Encodes ' JwtPayload ' that stores ' Int ' as payload with name  Use it if 
 you store ids as integer values . Dual to ' decodeIntIdPayload ' . 

you store ids as integer values. Dual to 'decodeIntIdPayload'.
-}
encodeIntIdPayload :: JwtPayload Int -> Jwt.ClaimsMap
encodeIntIdPayload = payloadToMap . Json.Number . fromIntegral . unJwtPayload
# INLINE encodeIntIdPayload #

  | Decodes ' JwtPayload ' from ' Jwt .  ' that stores ' Int ' under name 
   to ' encodeIntIdPayload ' . 

@id@. Dual to 'encodeIntIdPayload'.
-}
decodeIntIdPayload :: Jwt.ClaimsMap -> Maybe (JwtPayload Int)
decodeIntIdPayload = fmap JwtPayload . payloadFromMap (\case
    Json.Number jwtId -> toBoundedInteger jwtId
    _ -> Nothing)
# INLINE decodeIntIdPayload #

  | Encodes ' JwtPayload ' that stores ' Text ' as payload with name  Use it if 
 you store ids as text or UUID values . Dual to ' decodeTextIdPayload ' . 

you store ids as text or UUID values. Dual to 'decodeTextIdPayload'.
-}
encodeTextIdPayload :: JwtPayload Text -> Jwt.ClaimsMap
encodeTextIdPayload = payloadToMap . Json.String . unJwtPayload
# INLINE encodeTextIdPayload #

  | Decodes ' JwtPayload ' from ' Jwt .  ' that stores ' Int ' under name 
   to ' encodeIntIdPayload ' . 

@id@. Dual to 'encodeIntIdPayload'.
-}
decodeTextIdPayload :: Jwt.ClaimsMap -> Maybe (JwtPayload Text)
decodeTextIdPayload = fmap JwtPayload . payloadFromMap (\case
    Json.String jwtId -> Just jwtId
    _ -> Nothing)
# INLINE decodeTextIdPayload #

  | Creates ' Jwt .  ' from ' Json . Value ' under name 
payloadToMap :: Json.Value -> Jwt.ClaimsMap
payloadToMap val = Jwt.ClaimsMap $ Map.fromList [("id", val)]
# INLINE payloadToMap #

  | Decodes payload from ' Jwt .  ' under @id@ name given ' Json . Value ' 
 extractor . 

extractor.
-}
payloadFromMap :: (Value -> Maybe a) -> Jwt.ClaimsMap -> Maybe a
payloadFromMap fromValue (Jwt.ClaimsMap claimsMap) =
    Map.lookup "id" claimsMap >>= fromValue


  | This monad represents effect to create and verify JWT . It has two type 
 variables : 

 * @payload@ : type of JWT payload . 
 * @m@ : monad itself 

variables:

* @payload@: type of JWT payload.
* @m@: monad itself
-}
class Monad m => MonadJwt payload m where
    mkJwtToken
  ^ Token expiry in seconds

    verifyJwtToken

mkJwtTokenImpl
    :: MonadIO m
    => (JwtPayload payload -> Jwt.ClaimsMap)
    -> JwtSecret
    -> Seconds
    -> JwtPayload payload
    -> m JwtToken
mkJwtTokenImpl encode (JwtSecret jwtSecret) expiry payload = do
    let secret = Jwt.hmacSecret jwtSecret
    timeNow <- liftIO getPOSIXTime
    let expiryTime = timeNow + fromIntegral (unSeconds expiry)
    let claimsSet = mempty
            { Jwt.exp = Jwt.numericDate expiryTime
            , Jwt.unregisteredClaims = encode payload
            }
    pure $ JwtToken $ Jwt.encodeSigned secret mempty claimsSet

verifyJwtTokenImpl
    :: MonadIO m
    => (Jwt.ClaimsMap -> Maybe (JwtPayload payload))
    -> JwtSecret
    -> JwtToken
    -> m (Maybe (JwtPayload payload))
verifyJwtTokenImpl decode (JwtSecret jwtSecret) (JwtToken token) = do
    let secret = Jwt.hmacSecret jwtSecret
    timeNow <- Jwt.numericDate <$> liftIO getPOSIXTime
    pure $ do
        claimsSet <- Jwt.claims <$> Jwt.decodeAndVerifySignature secret token
        expiryTimeStatedInToken <- Jwt.exp claimsSet
        now <- timeNow
        guard (expiryTimeStatedInToken >= now)
        decode $ Jwt.unregisteredClaims claimsSet
