--   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_GHC -Wno-unused-binds -Wno-missing-signatures #-}

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Web.Libjwt.Tutorial
  ()
where

import           Web.Libjwt

import           Control.Arrow                  ( left )
import           Control.Exception              ( catch
                                                , displayException
                                                )
import           Data.ByteString                ( ByteString )
import           Data.Default
import           Data.Either.Validation         ( validationToEither )
import           Data.List.NonEmpty             ( NonEmpty(..) )
import           Data.Text                      ( Text )
import           Data.Time.Clock                ( UTCTime )
import           Data.UUID                      ( UUID )
import           GHC.Generics

import           Prelude                 hiding ( exp )


data UserClaims = UserClaims { UserClaims -> UUID
userId :: UUID
                             , UserClaims -> Text
userName :: Text
                             , UserClaims -> Bool
isRoot :: Bool
                             , UserClaims -> UTCTime
createdAt :: UTCTime
                             , UserClaims -> NonEmpty UUID
accounts :: NonEmpty UUID
                             }
  deriving stock (UserClaims -> UserClaims -> Bool
(UserClaims -> UserClaims -> Bool)
-> (UserClaims -> UserClaims -> Bool) -> Eq UserClaims
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserClaims -> UserClaims -> Bool
$c/= :: UserClaims -> UserClaims -> Bool
== :: UserClaims -> UserClaims -> Bool
$c== :: UserClaims -> UserClaims -> Bool
Eq, Int -> UserClaims -> ShowS
[UserClaims] -> ShowS
UserClaims -> String
(Int -> UserClaims -> ShowS)
-> (UserClaims -> String)
-> ([UserClaims] -> ShowS)
-> Show UserClaims
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserClaims] -> ShowS
$cshowList :: [UserClaims] -> ShowS
show :: UserClaims -> String
$cshow :: UserClaims -> String
showsPrec :: Int -> UserClaims -> ShowS
$cshowsPrec :: Int -> UserClaims -> ShowS
Show, (forall x. UserClaims -> Rep UserClaims x)
-> (forall x. Rep UserClaims x -> UserClaims) -> Generic UserClaims
forall x. Rep UserClaims x -> UserClaims
forall x. UserClaims -> Rep UserClaims x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep UserClaims x -> UserClaims
$cfrom :: forall x. UserClaims -> Rep UserClaims x
Generic)

instance ToPrivateClaims UserClaims
instance FromPrivateClaims UserClaims

hmac512 :: Algorithm Secret
hmac512 :: Algorithm Secret
hmac512 =
  Secret -> Algorithm Secret
HMAC512
    Secret
"MjZkMDY2OWFiZmRjYTk5YjczZWFiZjYzMmRjMzU5NDYyMjMxODBjMTg3ZmY5OTZjM2NhM2NhN2Mx\
    \YzFiNDNlYjc4NTE1MjQxZGI0OWM1ZWI2ZDUyZmMzZDlhMmFiNjc5OWJlZTUxNjE2ZDRlYTNkYjU5\
    \Y2IwMDZhYWY1MjY1OTQgIC0K"

mkPayload :: UserClaims
-> UTCTime
-> Payload
     '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,
       "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]
     'NoNs
mkPayload UserClaims {Bool
NonEmpty UUID
Text
UTCTime
UUID
accounts :: NonEmpty UUID
createdAt :: UTCTime
isRoot :: Bool
userName :: Text
userId :: UUID
accounts :: UserClaims -> NonEmpty UUID
createdAt :: UserClaims -> UTCTime
isRoot :: UserClaims -> Bool
userName :: UserClaims -> Text
userId :: UserClaims -> UUID
..} UTCTime
currentTime =
  let now :: NumericDate
now = UTCTime -> NumericDate
fromUTC UTCTime
currentTime
  in  Payload '[] 'NoNs
forall a. Default a => a
def
        { iss :: Iss
iss           = Maybe String -> Iss
Iss (String -> Maybe String
forall a. a -> Maybe a
Just String
"myApp")
        , aud :: Aud
aud           = [String] -> Aud
Aud [String
"https://myApp.com"]
        , iat :: Iat
iat           = Maybe NumericDate -> Iat
Iat (NumericDate -> Maybe NumericDate
forall a. a -> Maybe a
Just NumericDate
now)
        , exp :: Exp
exp           = Maybe NumericDate -> Exp
Exp (NumericDate -> Maybe NumericDate
forall a. a -> Maybe a
Just (NumericDate -> Maybe NumericDate)
-> NumericDate -> Maybe NumericDate
forall a b. (a -> b) -> a -> b
$ NumericDate
now NumericDate -> NominalDiffTime -> NumericDate
`plusSeconds` NominalDiffTime
300)
        , privateClaims :: PrivateClaims
  '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,
    "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]
  'NoNs
privateClaims = (ClaimWitness "user_name" Text, ClaimWitness "is_root" Bool,
 ClaimWitness "user_id" UUID, ClaimWitness "created" UTCTime,
 ClaimWitness "accounts" (NonEmpty UUID))
-> PrivateClaims
     (Claims
        (ClaimWitness "user_name" Text, ClaimWitness "is_root" Bool,
         ClaimWitness "user_id" UUID, ClaimWitness "created" UTCTime,
         ClaimWitness "accounts" (NonEmpty UUID)))
     (OutNs
        (ClaimWitness "user_name" Text, ClaimWitness "is_root" Bool,
         ClaimWitness "user_id" UUID, ClaimWitness "created" UTCTime,
         ClaimWitness "accounts" (NonEmpty UUID)))
forall a.
ToPrivateClaims a =>
a -> PrivateClaims (Claims a) (OutNs a)
toPrivateClaims
                            ( IsLabel "user_name" (ClaimName "user_name")
ClaimName "user_name"
#user_name ClaimName "user_name" -> Text -> ClaimWitness "user_name" Text
forall (name :: Symbol) a.
ClaimName name -> a -> ClaimWitness name a
->> Text
userName
                            , IsLabel "is_root" (ClaimName "is_root")
ClaimName "is_root"
#is_root ClaimName "is_root" -> Bool -> ClaimWitness "is_root" Bool
forall (name :: Symbol) a.
ClaimName name -> a -> ClaimWitness name a
->> Bool
isRoot
                            , IsLabel "user_id" (ClaimName "user_id")
ClaimName "user_id"
#user_id ClaimName "user_id" -> UUID -> ClaimWitness "user_id" UUID
forall (name :: Symbol) a.
ClaimName name -> a -> ClaimWitness name a
->> UUID
userId
                            , IsLabel "created" (ClaimName "created")
ClaimName "created"
#created ClaimName "created" -> UTCTime -> ClaimWitness "created" UTCTime
forall (name :: Symbol) a.
ClaimName name -> a -> ClaimWitness name a
->> UTCTime
createdAt
                            , IsLabel "accounts" (ClaimName "accounts")
ClaimName "accounts"
#accounts ClaimName "accounts"
-> NonEmpty UUID -> ClaimWitness "accounts" (NonEmpty UUID)
forall (name :: Symbol) a.
ClaimName name -> a -> ClaimWitness name a
->> NonEmpty UUID
accounts
                            )
        }

mkPayload' :: UserClaims
-> m (Payload
        '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,
          "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]
        'NoNs)
mkPayload' UserClaims {Bool
NonEmpty UUID
Text
UTCTime
UUID
accounts :: NonEmpty UUID
createdAt :: UTCTime
isRoot :: Bool
userName :: Text
userId :: UUID
accounts :: UserClaims -> NonEmpty UUID
createdAt :: UserClaims -> UTCTime
isRoot :: UserClaims -> Bool
userName :: UserClaims -> Text
userId :: UserClaims -> UUID
..} = JwtBuilder
  '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,
    "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]
  'NoNs
-> (ClaimWitness "user_name" Text, ClaimWitness "is_root" Bool,
    ClaimWitness "user_id" UUID, ClaimWitness "created" UTCTime,
    ClaimWitness "accounts" (NonEmpty UUID))
-> m (Payload
        '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,
          "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]
        'NoNs)
forall (m :: * -> *) a (b :: [Claim *]) (ns :: Namespace).
(MonadTime m, ToPrivateClaims a, Claims a ~ b, OutNs a ~ ns) =>
JwtBuilder b ns -> a -> m (Payload b ns)
jwtPayload
  (String
-> JwtBuilder
     '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,
       "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]
     'NoNs
forall (any1 :: [Claim *]) (any2 :: Namespace).
String -> JwtBuilder any1 any2
withIssuer String
"myApp" JwtBuilder
  '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,
    "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]
  'NoNs
-> JwtBuilder
     '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,
       "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]
     'NoNs
-> JwtBuilder
     '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,
       "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]
     'NoNs
forall a. Semigroup a => a -> a -> a
<> String
-> JwtBuilder
     '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,
       "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]
     'NoNs
forall (any1 :: [Claim *]) (any2 :: Namespace).
String -> JwtBuilder any1 any2
withRecipient String
"https://myApp.com" JwtBuilder
  '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,
    "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]
  'NoNs
-> JwtBuilder
     '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,
       "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]
     'NoNs
-> JwtBuilder
     '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,
       "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]
     'NoNs
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime
-> JwtBuilder
     '["user_name" ->> Text, "is_root" ->> Bool, "user_id" ->> UUID,
       "created" ->> UTCTime, "accounts" ->> NonEmpty UUID]
     'NoNs
forall (any1 :: [Claim *]) (any2 :: Namespace).
NominalDiffTime -> JwtBuilder any1 any2
setTtl NominalDiffTime
300)
  ( IsLabel "user_name" (ClaimName "user_name")
ClaimName "user_name"
#user_name ClaimName "user_name" -> Text -> ClaimWitness "user_name" Text
forall (name :: Symbol) a.
ClaimName name -> a -> ClaimWitness name a
->> Text
userName
  , IsLabel "is_root" (ClaimName "is_root")
ClaimName "is_root"
#is_root ClaimName "is_root" -> Bool -> ClaimWitness "is_root" Bool
forall (name :: Symbol) a.
ClaimName name -> a -> ClaimWitness name a
->> Bool
isRoot
  , IsLabel "user_id" (ClaimName "user_id")
ClaimName "user_id"
#user_id ClaimName "user_id" -> UUID -> ClaimWitness "user_id" UUID
forall (name :: Symbol) a.
ClaimName name -> a -> ClaimWitness name a
->> UUID
userId
  , IsLabel "created" (ClaimName "created")
ClaimName "created"
#created ClaimName "created" -> UTCTime -> ClaimWitness "created" UTCTime
forall (name :: Symbol) a.
ClaimName name -> a -> ClaimWitness name a
->> UTCTime
createdAt
  , IsLabel "accounts" (ClaimName "accounts")
ClaimName "accounts"
#accounts ClaimName "accounts"
-> NonEmpty UUID -> ClaimWitness "accounts" (NonEmpty UUID)
forall (name :: Symbol) a.
ClaimName name -> a -> ClaimWitness name a
->> NonEmpty UUID
accounts
  )

mkPayload'' :: m (Payload
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs)
mkPayload'' = JwtBuilder
  '[ 'Grant "userId" UUID, 'Grant "userName" Text,
     'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
     "accounts" ->> NonEmpty UUID]
  'NoNs
-> UserClaims
-> m (Payload
        '[ 'Grant "userId" UUID, 'Grant "userName" Text,
           'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
           "accounts" ->> NonEmpty UUID]
        'NoNs)
forall (m :: * -> *) a (b :: [Claim *]) (ns :: Namespace).
(MonadTime m, ToPrivateClaims a, Claims a ~ b, OutNs a ~ ns) =>
JwtBuilder b ns -> a -> m (Payload b ns)
jwtPayload
  (String
-> JwtBuilder
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs
forall (any1 :: [Claim *]) (any2 :: Namespace).
String -> JwtBuilder any1 any2
withIssuer String
"myApp" JwtBuilder
  '[ 'Grant "userId" UUID, 'Grant "userName" Text,
     'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
     "accounts" ->> NonEmpty UUID]
  'NoNs
-> JwtBuilder
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs
-> JwtBuilder
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs
forall a. Semigroup a => a -> a -> a
<> String
-> JwtBuilder
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs
forall (any1 :: [Claim *]) (any2 :: Namespace).
String -> JwtBuilder any1 any2
withRecipient String
"https://myApp.com" JwtBuilder
  '[ 'Grant "userId" UUID, 'Grant "userName" Text,
     'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
     "accounts" ->> NonEmpty UUID]
  'NoNs
-> JwtBuilder
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs
-> JwtBuilder
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime
-> JwtBuilder
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs
forall (any1 :: [Claim *]) (any2 :: Namespace).
NominalDiffTime -> JwtBuilder any1 any2
setTtl NominalDiffTime
300)
  UserClaims :: UUID -> Text -> Bool -> UTCTime -> NonEmpty UUID -> UserClaims
UserClaims { userId :: UUID
userId    = String -> UUID
forall a. Read a => String -> a
read String
"5a7c5cdd-3909-456b-9dd2-6ba84bfeeb25"
             , userName :: Text
userName  = Text
"JohnDoe"
             , isRoot :: Bool
isRoot    = Bool
False
             , createdAt :: UTCTime
createdAt = String -> UTCTime
forall a. Read a => String -> a
read String
"2020-07-31 11:45:00 UTC"
             , accounts :: NonEmpty UUID
accounts  = String -> UUID
forall a. Read a => String -> a
read String
"0bdf91cc-48bb-47f5-b633-920c34bd2352" UUID -> [UUID] -> NonEmpty UUID
forall a. a -> [a] -> NonEmpty a
:| []
             }

mkPayload''' :: m (Payload
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     ('SomeNs "https://myApp.com"))
mkPayload''' =
  JwtBuilder
  '[ 'Grant "userId" UUID, 'Grant "userName" Text,
     'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
     "accounts" ->> NonEmpty UUID]
  ('SomeNs "https://myApp.com")
-> PrivateClaims
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     ('SomeNs "https://myApp.com")
-> m (Payload
        '[ 'Grant "userId" UUID, 'Grant "userName" Text,
           'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
           "accounts" ->> NonEmpty UUID]
        ('SomeNs "https://myApp.com"))
forall (m :: * -> *) a (b :: [Claim *]) (ns :: Namespace).
(MonadTime m, ToPrivateClaims a, Claims a ~ b, OutNs a ~ ns) =>
JwtBuilder b ns -> a -> m (Payload b ns)
jwtPayload
      (String
-> JwtBuilder
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     ('SomeNs "https://myApp.com")
forall (any1 :: [Claim *]) (any2 :: Namespace).
String -> JwtBuilder any1 any2
withIssuer String
"myApp" JwtBuilder
  '[ 'Grant "userId" UUID, 'Grant "userName" Text,
     'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
     "accounts" ->> NonEmpty UUID]
  ('SomeNs "https://myApp.com")
-> JwtBuilder
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     ('SomeNs "https://myApp.com")
-> JwtBuilder
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     ('SomeNs "https://myApp.com")
forall a. Semigroup a => a -> a -> a
<> String
-> JwtBuilder
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     ('SomeNs "https://myApp.com")
forall (any1 :: [Claim *]) (any2 :: Namespace).
String -> JwtBuilder any1 any2
withRecipient String
"https://myApp.com" JwtBuilder
  '[ 'Grant "userId" UUID, 'Grant "userName" Text,
     'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
     "accounts" ->> NonEmpty UUID]
  ('SomeNs "https://myApp.com")
-> JwtBuilder
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     ('SomeNs "https://myApp.com")
-> JwtBuilder
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     ('SomeNs "https://myApp.com")
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime
-> JwtBuilder
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     ('SomeNs "https://myApp.com")
forall (any1 :: [Claim *]) (any2 :: Namespace).
NominalDiffTime -> JwtBuilder any1 any2
setTtl NominalDiffTime
300)
    (PrivateClaims
   '[ 'Grant "userId" UUID, 'Grant "userName" Text,
      'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
      "accounts" ->> NonEmpty UUID]
   ('SomeNs "https://myApp.com")
 -> m (Payload
         '[ 'Grant "userId" UUID, 'Grant "userName" Text,
            'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
            "accounts" ->> NonEmpty UUID]
         ('SomeNs "https://myApp.com")))
-> PrivateClaims
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     ('SomeNs "https://myApp.com")
-> m (Payload
        '[ 'Grant "userId" UUID, 'Grant "userName" Text,
           'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
           "accounts" ->> NonEmpty UUID]
        ('SomeNs "https://myApp.com"))
forall a b. (a -> b) -> a -> b
$ Ns "https://myApp.com"
-> UserClaims
-> PrivateClaims (Claims UserClaims) ('SomeNs "https://myApp.com")
forall a (ns :: Symbol).
ToPrivateClaims a =>
Ns ns -> a -> PrivateClaims (Claims a) ('SomeNs ns)
withNs
        (Ns "https://myApp.com"
forall (ns :: Symbol). Ns ns
Ns @"https://myApp.com")
        UserClaims :: UUID -> Text -> Bool -> UTCTime -> NonEmpty UUID -> UserClaims
UserClaims
          { userId :: UUID
userId    = String -> UUID
forall a. Read a => String -> a
read String
"5a7c5cdd-3909-456b-9dd2-6ba84bfeeb25"
          , userName :: Text
userName  = Text
"JohnDoe"
          , isRoot :: Bool
isRoot    = Bool
False
          , createdAt :: UTCTime
createdAt = String -> UTCTime
forall a. Read a => String -> a
read String
"2020-07-31 11:45:00 UTC"
          , accounts :: NonEmpty UUID
accounts  = String -> UUID
forall a. Read a => String -> a
read String
"0bdf91cc-48bb-47f5-b633-920c34bd2352" UUID -> [UUID] -> NonEmpty UUID
forall a. a -> [a] -> NonEmpty a
:| []
          }

token :: IO ByteString
token :: IO ByteString
token = Encoded
  (Jwt
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs)
-> ByteString
forall t. Encoded t -> ByteString
getToken (Encoded
   (Jwt
      '[ 'Grant "userId" UUID, 'Grant "userName" Text,
         'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
         "accounts" ->> NonEmpty UUID]
      'NoNs)
 -> ByteString)
-> (Payload
      '[ 'Grant "userId" UUID, 'Grant "userName" Text,
         'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
         "accounts" ->> NonEmpty UUID]
      'NoNs
    -> Encoded
         (Jwt
            '[ 'Grant "userId" UUID, 'Grant "userName" Text,
               'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
               "accounts" ->> NonEmpty UUID]
            'NoNs))
-> Payload
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Algorithm Secret
-> Payload
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs
-> Encoded
     (Jwt
        '[ 'Grant "userId" UUID, 'Grant "userName" Text,
           'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
           "accounts" ->> NonEmpty UUID]
        'NoNs)
forall (pc :: [Claim *]) (ns :: Namespace) k.
(Encode (PrivateClaims pc ns), SigningKey k) =>
Algorithm k -> Payload pc ns -> Encoded (Jwt pc ns)
sign Algorithm Secret
hmac512 (Payload
   '[ 'Grant "userId" UUID, 'Grant "userName" Text,
      'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
      "accounts" ->> NonEmpty UUID]
   'NoNs
 -> ByteString)
-> IO
     (Payload
        '[ 'Grant "userId" UUID, 'Grant "userName" Text,
           'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
           "accounts" ->> NonEmpty UUID]
        'NoNs)
-> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO
  (Payload
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs)
forall (m :: * -> *).
MonadTime m =>
m (Payload
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs)
mkPayload''

type MyJwt
  = Jwt
      '["userId" ->> UUID, "userName" ->> Text, "isRoot" ->> Bool, "createdAt" ->> UTCTime, "accounts" ->> NonEmpty UUID]
      'NoNs

decodeDoNotUse :: IO (Decoded MyJwt)
decodeDoNotUse :: IO
  (Decoded
     (Jwt
        '[ 'Grant "userId" UUID, 'Grant "userName" Text,
           'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
           "accounts" ->> NonEmpty UUID]
        'NoNs))
decodeDoNotUse = Algorithm Secret
-> ByteString
-> IO
     (Decoded
        (Jwt
           '[ 'Grant "userId" UUID, 'Grant "userName" Text,
              'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
              "accounts" ->> NonEmpty UUID]
           'NoNs))
forall (ns :: Namespace) (pc :: [Claim *]) (m :: * -> *) k.
(MonadThrow m, Decode (PrivateClaims pc ns), DecodingKey k) =>
Algorithm k -> ByteString -> m (Decoded (Jwt pc ns))
decodeByteString Algorithm Secret
hmac512 (ByteString
 -> IO
      (Decoded
         (Jwt
            '[ 'Grant "userId" UUID, 'Grant "userName" Text,
               'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
               "accounts" ->> NonEmpty UUID]
            'NoNs)))
-> IO ByteString
-> IO
     (Decoded
        (Jwt
           '[ 'Grant "userId" UUID, 'Grant "userName" Text,
              'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
              "accounts" ->> NonEmpty UUID]
           'NoNs))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ByteString
token

decodeAndValidate :: IO (ValidationNEL ValidationFailure (Validated MyJwt))
decodeAndValidate :: IO
  (ValidationNEL
     ValidationFailure
     (Validated
        (Jwt
           '[ 'Grant "userId" UUID, 'Grant "userName" Text,
              'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
              "accounts" ->> NonEmpty UUID]
           'NoNs)))
decodeAndValidate = ValidationSettings
-> JwtValidation
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs
-> Algorithm Secret
-> ByteString
-> IO
     (ValidationNEL
        ValidationFailure
        (Validated
           (Jwt
              '[ 'Grant "userId" UUID, 'Grant "userName" Text,
                 'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
                 "accounts" ->> NonEmpty UUID]
              'NoNs)))
forall (pc :: [Claim *]) (ns :: Namespace) (m :: * -> *) k.
(Decode (PrivateClaims pc ns), MonadTime m, MonadThrow m,
 DecodingKey k) =>
ValidationSettings
-> JwtValidation pc ns
-> Algorithm k
-> ByteString
-> m (ValidationNEL ValidationFailure (Validated (Jwt pc ns)))
jwtFromByteString ValidationSettings
settings JwtValidation
  '[ 'Grant "userId" UUID, 'Grant "userName" Text,
     'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
     "accounts" ->> NonEmpty UUID]
  'NoNs
forall a. Monoid a => a
mempty Algorithm Secret
hmac512 (ByteString
 -> IO
      (ValidationNEL
         ValidationFailure
         (Validated
            (Jwt
               '[ 'Grant "userId" UUID, 'Grant "userName" Text,
                  'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
                  "accounts" ->> NonEmpty UUID]
               'NoNs))))
-> IO ByteString
-> IO
     (ValidationNEL
        ValidationFailure
        (Validated
           (Jwt
              '[ 'Grant "userId" UUID, 'Grant "userName" Text,
                 'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
                 "accounts" ->> NonEmpty UUID]
              'NoNs)))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO ByteString
token
  where settings :: ValidationSettings
settings = Settings :: NominalDiffTime -> Maybe String -> ValidationSettings
Settings { leeway :: NominalDiffTime
leeway = NominalDiffTime
5, appName :: Maybe String
appName = String -> Maybe String
forall a. a -> Maybe a
Just String
"https://myApp.com" }

decodeAndValidateFull :: IO (Either String UserClaims)
decodeAndValidateFull :: IO (Either String UserClaims)
decodeAndValidateFull =
  (   (NonEmpty ValidationFailure -> String)
-> Either (NonEmpty ValidationFailure) UserClaims
-> Either String UserClaims
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left ((String
"Token not valid: " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS
-> (NonEmpty ValidationFailure -> String)
-> NonEmpty ValidationFailure
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ValidationFailure -> String
forall a. Show a => a -> String
show)
    (Either (NonEmpty ValidationFailure) UserClaims
 -> Either String UserClaims)
-> (ValidationNEL
      ValidationFailure
      (Validated
         (Jwt
            '[ 'Grant "userId" UUID, 'Grant "userName" Text,
               'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
               "accounts" ->> NonEmpty UUID]
            'NoNs))
    -> Either (NonEmpty ValidationFailure) UserClaims)
-> ValidationNEL
     ValidationFailure
     (Validated
        (Jwt
           '[ 'Grant "userId" UUID, 'Grant "userName" Text,
              'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
              "accounts" ->> NonEmpty UUID]
           'NoNs))
-> Either String UserClaims
forall b c a. (b -> c) -> (a -> b) -> a -> c
.   (Validated
   (Jwt
      '[ 'Grant "userId" UUID, 'Grant "userName" Text,
         'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
         "accounts" ->> NonEmpty UUID]
      'NoNs)
 -> UserClaims)
-> Either
     (NonEmpty ValidationFailure)
     (Validated
        (Jwt
           '[ 'Grant "userId" UUID, 'Grant "userName" Text,
              'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
              "accounts" ->> NonEmpty UUID]
           'NoNs))
-> Either (NonEmpty ValidationFailure) UserClaims
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Validated
  (Jwt
     '[ 'Grant "userId" UUID, 'Grant "userName" Text,
        'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
        "accounts" ->> NonEmpty UUID]
     'NoNs)
-> UserClaims
forall c (ns :: Namespace).
FromPrivateClaims c =>
Validated (Jwt (Claims c) ns) -> c
toUserClaims
    (Either
   (NonEmpty ValidationFailure)
   (Validated
      (Jwt
         '[ 'Grant "userId" UUID, 'Grant "userName" Text,
            'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
            "accounts" ->> NonEmpty UUID]
         'NoNs))
 -> Either (NonEmpty ValidationFailure) UserClaims)
-> (ValidationNEL
      ValidationFailure
      (Validated
         (Jwt
            '[ 'Grant "userId" UUID, 'Grant "userName" Text,
               'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
               "accounts" ->> NonEmpty UUID]
            'NoNs))
    -> Either
         (NonEmpty ValidationFailure)
         (Validated
            (Jwt
               '[ 'Grant "userId" UUID, 'Grant "userName" Text,
                  'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
                  "accounts" ->> NonEmpty UUID]
               'NoNs)))
-> ValidationNEL
     ValidationFailure
     (Validated
        (Jwt
           '[ 'Grant "userId" UUID, 'Grant "userName" Text,
              'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
              "accounts" ->> NonEmpty UUID]
           'NoNs))
-> Either (NonEmpty ValidationFailure) UserClaims
forall b c a. (b -> c) -> (a -> b) -> a -> c
.   ValidationNEL
  ValidationFailure
  (Validated
     (Jwt
        '[ 'Grant "userId" UUID, 'Grant "userName" Text,
           'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
           "accounts" ->> NonEmpty UUID]
        'NoNs))
-> Either
     (NonEmpty ValidationFailure)
     (Validated
        (Jwt
           '[ 'Grant "userId" UUID, 'Grant "userName" Text,
              'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
              "accounts" ->> NonEmpty UUID]
           'NoNs))
forall e a. Validation e a -> Either e a
validationToEither
    (ValidationNEL
   ValidationFailure
   (Validated
      (Jwt
         '[ 'Grant "userId" UUID, 'Grant "userName" Text,
            'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
            "accounts" ->> NonEmpty UUID]
         'NoNs))
 -> Either String UserClaims)
-> IO
     (ValidationNEL
        ValidationFailure
        (Validated
           (Jwt
              '[ 'Grant "userId" UUID, 'Grant "userName" Text,
                 'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
                 "accounts" ->> NonEmpty UUID]
              'NoNs)))
-> IO (Either String UserClaims)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO
  (ValidationNEL
     ValidationFailure
     (Validated
        (Jwt
           '[ 'Grant "userId" UUID, 'Grant "userName" Text,
              'Grant "isRoot" Bool, 'Grant "createdAt" UTCTime,
              "accounts" ->> NonEmpty UUID]
           'NoNs)))
decodeAndValidate
    )
    IO (Either String UserClaims)
-> (SomeDecodeException -> IO (Either String UserClaims))
-> IO (Either String UserClaims)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeDecodeException -> IO (Either String UserClaims)
forall (m :: * -> *) b.
Monad m =>
SomeDecodeException -> m (Either String b)
onError
 where
  toUserClaims :: Validated (Jwt (Claims c) ns) -> c
toUserClaims = PrivateClaims (Claims c) ns -> c
forall a (ts :: [Claim *]) (ns :: Namespace).
(FromPrivateClaims a, ts ~ Claims a) =>
PrivateClaims ts ns -> a
fromPrivateClaims (PrivateClaims (Claims c) ns -> c)
-> (Validated (Jwt (Claims c) ns) -> PrivateClaims (Claims c) ns)
-> Validated (Jwt (Claims c) ns)
-> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Payload (Claims c) ns -> PrivateClaims (Claims c) ns
forall (pc :: [Claim *]) (ns :: Namespace).
Payload pc ns -> PrivateClaims pc ns
privateClaims (Payload (Claims c) ns -> PrivateClaims (Claims c) ns)
-> (Validated (Jwt (Claims c) ns) -> Payload (Claims c) ns)
-> Validated (Jwt (Claims c) ns)
-> PrivateClaims (Claims c) ns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Jwt (Claims c) ns -> Payload (Claims c) ns
forall (pc :: [Claim *]) (ns :: Namespace).
Jwt pc ns -> Payload pc ns
payload (Jwt (Claims c) ns -> Payload (Claims c) ns)
-> (Validated (Jwt (Claims c) ns) -> Jwt (Claims c) ns)
-> Validated (Jwt (Claims c) ns)
-> Payload (Claims c) ns
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Validated (Jwt (Claims c) ns) -> Jwt (Claims c) ns
forall t. Validated t -> t
getValid
  onError :: SomeDecodeException -> m (Either String b)
onError (SomeDecodeException
e :: SomeDecodeException) =
    Either String b -> m (Either String b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String b -> m (Either String b))
-> Either String b -> m (Either String b)
forall a b. (a -> b) -> a -> b
$ String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ String
"Cannot decode token " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeDecodeException -> String
forall e. Exception e => e -> String
displayException SomeDecodeException
e