{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# language DeriveGeneric, GeneralizedNewtypeDeriving, DerivingStrategies, DeriveDataTypeable #-}
{-# language OverloadedStrings #-}
{-# options_ghc -Wno-unused-imports #-}
module Network.OAuth2.Session (
withAADUser
, loginEndpoint
, replyEndpoint
, Tokens
, newTokens
, UserSub
, lookupUser
, expireUser
, tokensToList
, Scotty
, Action
) where
import Control.Exception (Exception(..), SomeException(..))
import Control.Monad.IO.Class (MonadIO(..))
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe)
import Data.String (IsString(..))
import Data.Typeable (Typeable)
import GHC.Exception (SomeException)
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.Map as M (Map, insert, lookup, alter, toList)
import Network.OAuth.OAuth2 (OAuth2Token(..), AccessToken(..), ExchangeToken(..), RefreshToken(..), OAuth2Error, IdToken(..))
import Network.OAuth2.Experiment (IdpUserInfo, conduitUserInfoRequest, mkAuthorizeRequest, conduitTokenRequest, conduitRefreshTokenRequest, HasRefreshTokenRequest(..), WithExchangeToken, IdpApplication(..), GrantTypeFlow(..))
import Network.OAuth.OAuth2.TokenRequest (Errors)
import Network.HTTP.Client (Manager)
import Network.HTTP.Types (status302, status400, status401)
import Web.Scotty (scotty, RoutePattern)
import Web.Scotty.Trans (scottyT, ActionT, ScottyT, get, raise, redirect, params, header, setHeader, status, text)
import qualified Data.Text as T (Text, pack, unwords)
import qualified Data.Text.Lazy as TL (Text, pack, unpack, toStrict, takeWhile, fromStrict)
import Data.Time (UTCTime(..), getCurrentTime, fromGregorian, diffUTCTime, addUTCTime, Day, NominalDiffTime)
import Data.Time.Format (FormatTime, formatTime, iso8601DateFormat, defaultTimeLocale)
import Control.Monad.Trans.Except (ExceptT(..), withExceptT, runExceptT, throwE)
import UnliftIO (MonadUnliftIO(..))
import UnliftIO.Concurrent (ThreadId, forkFinally, threadDelay)
import UnliftIO.Exception (throwIO)
import UnliftIO.STM (STM, TVar, atomically, newTVarIO, readTVar, writeTVar, modifyTVar)
import URI.ByteString (URI)
import Validation (Validation, failure, validationToEither)
import Network.OAuth2.Provider.AzureAD (OAuthCfg, azureADApp, AzureAD)
import Network.OAuth2.JWT (jwtClaims, UserSub(..), userSub, ApiAudience, apiAudience, decValidSub, decValidExp, decValidNbf, JWTException(..))
type Action = ActionT TL.Text
type Scotty = ScottyT TL.Text
aadHeaderIdToken :: (MonadIO m) =>
(UserSub -> Action m ())
-> Action m ()
UserSub -> Action m ()
act = do
let
hdrName :: Text
hdrName = Text
"X-MS-TOKEN-AAD-ID-TOKEN"
Maybe Text
mh <- forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m (Maybe Text)
header Text
hdrName
case Maybe Text
mh of
Maybe Text
Nothing -> do
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
text forall a b. (a -> b) -> a -> b
$ String -> Text
TL.pack forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"header", Text -> String
TL.unpack Text
hdrName, String
"not found in request"]
forall (m :: * -> *) e. Monad m => Status -> ActionT e m ()
status Status
status400
Just Text
h -> do
let
idt :: IdToken
idt = Text -> IdToken
IdToken forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict Text
h
Either (NonEmpty JWTException) UserSub
ide <- forall (m :: * -> *).
MonadIO m =>
IdToken -> m (Either (NonEmpty JWTException) UserSub)
decValidIdToken IdToken
idt
case Either (NonEmpty JWTException) UserSub
ide of
Right UserSub
usub -> UserSub -> Action m ()
act UserSub
usub
Left NonEmpty JWTException
e -> do
forall e (m :: * -> *).
(ScottyError e, Monad m) =>
Text -> ActionT e m ()
text forall a b. (a -> b) -> a -> b
$ String -> Text
TL.pack forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"AAD header ID token validation exception:", forall a. Show a => a -> String
show NonEmpty JWTException
e]
forall (m :: * -> *) e. Monad m => Status -> ActionT e m ()
status Status
status401
withAADUser :: MonadIO m =>
Tokens UserSub t
-> TL.Text
-> (t -> Action m ())
-> Action m ()
withAADUser :: forall (m :: * -> *) t.
MonadIO m =>
Tokens UserSub t -> Text -> (t -> Action m ()) -> Action m ()
withAADUser Tokens UserSub t
ts Text
loginURI t -> Action m ()
act = forall (m :: * -> *).
MonadIO m =>
(UserSub -> Action m ()) -> Action m ()
aadHeaderIdToken forall a b. (a -> b) -> a -> b
$ \UserSub
usub -> do
Maybe t
mt <- forall (m :: * -> *) uid t.
(MonadIO m, Ord uid) =>
Tokens uid t -> uid -> m (Maybe t)
lookupUser Tokens UserSub t
ts UserSub
usub
case Maybe t
mt of
Just t
t -> t -> Action m ()
act t
t
Maybe t
_ -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"User", forall a. Show a => a -> String
show UserSub
usub, String
"not authenticated. Redirecting to login:", Text -> String
TL.unpack Text
loginURI]
forall e (m :: * -> *) a.
(ScottyError e, Monad m) =>
Text -> ActionT e m a
redirect Text
loginURI
loginEndpoint :: (MonadIO m) =>
IdpApplication 'AuthorizationCode AzureAD
-> RoutePattern
-> Scotty m ()
loginEndpoint :: forall (m :: * -> *).
MonadIO m =>
IdpApplication 'AuthorizationCode AzureAD
-> RoutePattern -> Scotty m ()
loginEndpoint IdpApplication 'AuthorizationCode AzureAD
idpApp RoutePattern
path = forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get RoutePattern
path (forall (m :: * -> *).
Monad m =>
IdpApplication 'AuthorizationCode AzureAD -> Action m ()
loginH IdpApplication 'AuthorizationCode AzureAD
idpApp)
loginH :: Monad m =>
IdpApplication 'AuthorizationCode AzureAD
-> Action m ()
loginH :: forall (m :: * -> *).
Monad m =>
IdpApplication 'AuthorizationCode AzureAD -> Action m ()
loginH IdpApplication 'AuthorizationCode AzureAD
idpApp = do
forall (m :: * -> *) e. Monad m => Text -> Text -> ActionT e m ()
setHeader Text
"Location" (forall (a :: GrantTypeFlow) i.
HasAuthorizeRequest a =>
IdpApplication a i -> MkAuthorizationRequestResponse a
mkAuthorizeRequest IdpApplication 'AuthorizationCode AzureAD
idpApp)
forall (m :: * -> *) e. Monad m => Status -> ActionT e m ()
status Status
status302
replyEndpoint :: MonadIO m =>
IdpApplication 'AuthorizationCode AzureAD
-> Tokens UserSub OAuth2Token
-> Manager
-> RoutePattern
-> Scotty m ()
replyEndpoint :: forall (m :: * -> *).
MonadIO m =>
IdpApplication 'AuthorizationCode AzureAD
-> Tokens UserSub OAuth2Token
-> Manager
-> RoutePattern
-> Scotty m ()
replyEndpoint IdpApplication 'AuthorizationCode AzureAD
idpApp Tokens UserSub OAuth2Token
ts Manager
mgr RoutePattern
path =
forall e (m :: * -> *).
(ScottyError e, MonadIO m) =>
RoutePattern -> ActionT e m () -> ScottyT e m ()
get RoutePattern
path (forall (m :: * -> *).
MonadIO m =>
IdpApplication 'AuthorizationCode AzureAD
-> Tokens UserSub OAuth2Token -> Manager -> Action m ()
replyH IdpApplication 'AuthorizationCode AzureAD
idpApp Tokens UserSub OAuth2Token
ts Manager
mgr)
replyH :: MonadIO m =>
IdpApplication 'AuthorizationCode AzureAD
-> Tokens UserSub OAuth2Token
-> Manager
-> Action m ()
replyH :: forall (m :: * -> *).
MonadIO m =>
IdpApplication 'AuthorizationCode AzureAD
-> Tokens UserSub OAuth2Token -> Manager -> Action m ()
replyH IdpApplication 'AuthorizationCode AzureAD
idpApp Tokens UserSub OAuth2Token
ts Manager
mgr = do
[Param]
ps <- forall (m :: * -> *) e. Monad m => ActionT e m [Param]
params
forall (m :: * -> *) e b.
(MonadIO m, Show e) =>
ExceptT e IO b -> Action m b
excepttToActionM forall a b. (a -> b) -> a -> b
$ do
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"code" [Param]
ps of
Just Text
codeP -> do
let
etoken :: ExchangeToken
etoken = Text -> ExchangeToken
ExchangeToken forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict Text
codeP
OAuth2Token
_ <- forall (m :: * -> *).
MonadUnliftIO m =>
Tokens UserSub OAuth2Token
-> IdpApplication 'AuthorizationCode AzureAD
-> Manager
-> ExchangeToken
-> ExceptT OAuthSessionError m OAuth2Token
fetchUpdateToken Tokens UserSub OAuth2Token
ts IdpApplication 'AuthorizationCode AzureAD
idpApp Manager
mgr ExchangeToken
etoken
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Maybe Text
Nothing -> forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE OAuthSessionError
OASEExchangeTokenNotFound
fetchUpdateToken :: MonadUnliftIO m =>
Tokens UserSub OAuth2Token
-> IdpApplication 'AuthorizationCode AzureAD
-> Manager
-> ExchangeToken
-> ExceptT OAuthSessionError m OAuth2Token
fetchUpdateToken :: forall (m :: * -> *).
MonadUnliftIO m =>
Tokens UserSub OAuth2Token
-> IdpApplication 'AuthorizationCode AzureAD
-> Manager
-> ExchangeToken
-> ExceptT OAuthSessionError m OAuth2Token
fetchUpdateToken Tokens UserSub OAuth2Token
ts IdpApplication 'AuthorizationCode AzureAD
idpApp Manager
mgr ExchangeToken
etoken = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
Either (OAuth2Error Errors) OAuth2Token
tokenResp <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (a :: GrantTypeFlow) (m :: * -> *) i.
(HasTokenRequest a, MonadIO m) =>
IdpApplication a i
-> Manager
-> WithExchangeToken a (ExceptT (OAuth2Error Errors) m OAuth2Token)
conduitTokenRequest IdpApplication 'AuthorizationCode AzureAD
idpApp Manager
mgr ExchangeToken
etoken
case Either (OAuth2Error Errors) OAuth2Token
tokenResp of
Right OAuth2Token
oat -> case OAuth2Token -> Maybe IdToken
idToken OAuth2Token
oat of
Maybe IdToken
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left OAuthSessionError
OASENoOpenID
Just IdToken
idt -> do
Either (NonEmpty JWTException) UserSub
idtClaimsE <- forall (m :: * -> *).
MonadIO m =>
IdToken -> m (Either (NonEmpty JWTException) UserSub)
decValidIdToken IdToken
idt
case Either (NonEmpty JWTException) UserSub
idtClaimsE of
Right UserSub
uid -> do
ThreadId
_ <- forall (m :: * -> *) uid (a :: GrantTypeFlow) i.
(MonadUnliftIO m, Ord uid, HasRefreshTokenRequest a) =>
Tokens uid OAuth2Token
-> IdpApplication a i
-> Manager
-> uid
-> OAuth2Token
-> m ThreadId
refreshLoop Tokens UserSub OAuth2Token
ts IdpApplication 'AuthorizationCode AzureAD
idpApp Manager
mgr UserSub
uid OAuth2Token
oat
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right OAuth2Token
oat
Left NonEmpty JWTException
es -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (NonEmpty JWTException -> OAuthSessionError
OASEJWTException NonEmpty JWTException
es)
Left OAuth2Error Errors
es -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (OAuth2Error Errors -> OAuthSessionError
OASEOAuth2Errors OAuth2Error Errors
es)
refreshLoop :: (MonadUnliftIO m, Ord uid, HasRefreshTokenRequest a) =>
Tokens uid OAuth2Token
-> IdpApplication a i
-> Manager
-> uid
-> OAuth2Token
-> m ThreadId
refreshLoop :: forall (m :: * -> *) uid (a :: GrantTypeFlow) i.
(MonadUnliftIO m, Ord uid, HasRefreshTokenRequest a) =>
Tokens uid OAuth2Token
-> IdpApplication a i
-> Manager
-> uid
-> OAuth2Token
-> m ThreadId
refreshLoop Tokens uid OAuth2Token
ts IdpApplication a i
idpApp Manager
mgr uid
uid OAuth2Token
oaToken = forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally (forall {m :: * -> *} {b}. MonadIO m => OAuth2Token -> m b
act OAuth2Token
oaToken) forall {a} {b}. Either a b -> m ()
cleanup
where
cleanup :: Either a b -> m ()
cleanup = \case
Left a
_ -> do
forall (m :: * -> *) uid t.
(MonadIO m, Ord uid) =>
Tokens uid t -> uid -> m ()
expireUser Tokens uid OAuth2Token
ts uid
uid
Right b
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
act :: OAuth2Token -> m b
act OAuth2Token
oat = do
NominalDiffTime
ein <- forall (m :: * -> *) uid.
(MonadIO m, Ord uid) =>
Tokens uid OAuth2Token -> uid -> OAuth2Token -> m NominalDiffTime
updateToken Tokens uid OAuth2Token
ts uid
uid OAuth2Token
oat
let
dtSecs :: Int
dtSecs = (forall a b. (RealFrac a, Integral b) => a -> b
round NominalDiffTime
ein forall a. Num a => a -> a -> a
- Int
30)
forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int
dtSecs forall a. Num a => a -> a -> a
* Int
1000000)
case OAuth2Token -> Maybe RefreshToken
refreshToken OAuth2Token
oat of
Maybe RefreshToken
Nothing -> do
forall (m :: * -> *) uid t.
(MonadIO m, Ord uid) =>
Tokens uid t -> uid -> m ()
expireUser Tokens uid OAuth2Token
ts uid
uid
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO OAuthSessionError
OASERefreshTokenNotFound
Just RefreshToken
rt -> do
Either (OAuth2Error Errors) OAuth2Token
eo' <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (a :: GrantTypeFlow) (m :: * -> *) i.
(HasRefreshTokenRequest a, MonadIO m) =>
IdpApplication a i
-> Manager
-> RefreshToken
-> ExceptT (OAuth2Error Errors) m OAuth2Token
conduitRefreshTokenRequest IdpApplication a i
idpApp Manager
mgr RefreshToken
rt
case Either (OAuth2Error Errors) OAuth2Token
eo' of
Right OAuth2Token
oat' -> do
OAuth2Token -> m b
act OAuth2Token
oat'
Left OAuth2Error Errors
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (OAuth2Error Errors -> OAuthSessionError
OASEOAuth2Errors OAuth2Error Errors
e)
data OAuthSessionError = OASERefreshTokenNotFound
| OASEExchangeTokenNotFound
| OASEOAuth2Errors (OAuth2Error Errors)
| OASEJWTException (NonEmpty JWTException)
| OASENoOpenID
deriving (OAuthSessionError -> OAuthSessionError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OAuthSessionError -> OAuthSessionError -> Bool
$c/= :: OAuthSessionError -> OAuthSessionError -> Bool
== :: OAuthSessionError -> OAuthSessionError -> Bool
$c== :: OAuthSessionError -> OAuthSessionError -> Bool
Eq, Typeable)
instance Exception OAuthSessionError
instance Show OAuthSessionError where
show :: OAuthSessionError -> String
show = \case
OAuthSessionError
OASERefreshTokenNotFound -> [String] -> String
unwords [String
"Refresh token not found in OAT"]
OAuthSessionError
OASEExchangeTokenNotFound -> [String] -> String
unwords [String
"Exchange token not found. This shouldn't happen"]
OASEOAuth2Errors OAuth2Error Errors
oerrs ->
[String] -> String
unwords [String
"OAuth2 error(s):", forall a. Show a => a -> String
show OAuth2Error Errors
oerrs]
OASEJWTException NonEmpty JWTException
jwtes -> [String] -> String
unwords [String
"JWT error(s):", forall a. Show a => a -> String
show NonEmpty JWTException
jwtes]
OAuthSessionError
OASENoOpenID -> [String] -> String
unwords [String
"No ID token found. Ensure 'openid' scope appears in token request"]
updateToken :: (MonadIO m, Ord uid) =>
Tokens uid OAuth2Token
-> uid
-> OAuth2Token
-> m NominalDiffTime
updateToken :: forall (m :: * -> *) uid.
(MonadIO m, Ord uid) =>
Tokens uid OAuth2Token -> uid -> OAuth2Token -> m NominalDiffTime
updateToken Tokens uid OAuth2Token
ts uid
uid OAuth2Token
oat = do
let
ein :: NominalDiffTime
ein = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe Int
3600 (OAuth2Token -> Maybe Int
expiresIn OAuth2Token
oat)
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
TokensData uid OAuth2Token
thp <- forall a. TVar a -> STM a
readTVar Tokens uid OAuth2Token
ts
let
m' :: Map uid OAuth2Token
m' = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert uid
uid OAuth2Token
oat (forall uid t. TokensData uid t -> Map uid t
thUsersMap TokensData uid OAuth2Token
thp)
forall a. TVar a -> a -> STM ()
writeTVar Tokens uid OAuth2Token
ts (forall uid t. Map uid t -> TokensData uid t
TokensData Map uid OAuth2Token
m')
forall (f :: * -> *) a. Applicative f => a -> f a
pure NominalDiffTime
ein
expireUser :: (MonadIO m, Ord uid) =>
Tokens uid t
-> uid
-> m ()
expireUser :: forall (m :: * -> *) uid t.
(MonadIO m, Ord uid) =>
Tokens uid t -> uid -> m ()
expireUser Tokens uid t
ts uid
uid =
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar Tokens uid t
ts forall a b. (a -> b) -> a -> b
$ \TokensData uid t
td -> TokensData uid t
td{ thUsersMap :: Map uid t
thUsersMap = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) uid
uid (forall uid t. TokensData uid t -> Map uid t
thUsersMap TokensData uid t
td)}
lookupUser :: (MonadIO m, Ord uid) =>
Tokens uid t
-> uid
-> m (Maybe t)
lookupUser :: forall (m :: * -> *) uid t.
(MonadIO m, Ord uid) =>
Tokens uid t -> uid -> m (Maybe t)
lookupUser Tokens uid t
ts uid
uid = forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
TokensData uid t
thp <- forall a. TVar a -> STM a
readTVar Tokens uid t
ts
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup uid
uid (forall uid t. TokensData uid t -> Map uid t
thUsersMap TokensData uid t
thp)
tokensToList :: MonadIO m => Tokens k a -> m [(k, a)]
tokensToList :: forall (m :: * -> *) k a. MonadIO m => Tokens k a -> m [(k, a)]
tokensToList Tokens k a
ts = forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
(TokensData Map k a
m) <- forall a. TVar a -> STM a
readTVar Tokens k a
ts
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map k a
m
newTokens :: (MonadIO m, Ord uid) => m (Tokens uid t)
newTokens :: forall (m :: * -> *) uid t.
(MonadIO m, Ord uid) =>
m (Tokens uid t)
newTokens = forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (forall uid t. Map uid t -> TokensData uid t
TokensData forall a. Monoid a => a
mempty)
type Tokens uid t = TVar (TokensData uid t)
newtype TokensData uid t = TokensData {
forall uid t. TokensData uid t -> Map uid t
thUsersMap :: M.Map uid t
} deriving (TokensData uid t -> TokensData uid t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall uid t.
(Eq uid, Eq t) =>
TokensData uid t -> TokensData uid t -> Bool
/= :: TokensData uid t -> TokensData uid t -> Bool
$c/= :: forall uid t.
(Eq uid, Eq t) =>
TokensData uid t -> TokensData uid t -> Bool
== :: TokensData uid t -> TokensData uid t -> Bool
$c== :: forall uid t.
(Eq uid, Eq t) =>
TokensData uid t -> TokensData uid t -> Bool
Eq, Int -> TokensData uid t -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall uid t.
(Show uid, Show t) =>
Int -> TokensData uid t -> ShowS
forall uid t. (Show uid, Show t) => [TokensData uid t] -> ShowS
forall uid t. (Show uid, Show t) => TokensData uid t -> String
showList :: [TokensData uid t] -> ShowS
$cshowList :: forall uid t. (Show uid, Show t) => [TokensData uid t] -> ShowS
show :: TokensData uid t -> String
$cshow :: forall uid t. (Show uid, Show t) => TokensData uid t -> String
showsPrec :: Int -> TokensData uid t -> ShowS
$cshowsPrec :: forall uid t.
(Show uid, Show t) =>
Int -> TokensData uid t -> ShowS
Show)
decValidIdToken :: MonadIO m =>
IdToken
-> m (Either (NonEmpty JWTException) UserSub)
decValidIdToken :: forall (m :: * -> *).
MonadIO m =>
IdToken -> m (Either (NonEmpty JWTException) UserSub)
decValidIdToken (IdToken Text
idt) = do
UTCTime
t <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
let
ve :: Either (NonEmpty JWTException) (UserSub, UTCTime, UTCTime)
ve = forall e a. Validation e a -> Either e a
validationToEither forall a b. (a -> b) -> a -> b
$
case Text -> Maybe JWTClaimsSet
jwtClaims Text
idt of
Just JWTClaimsSet
c -> (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> JWTClaimsSet -> Validation (NonEmpty JWTException) UserSub
decValidSub JWTClaimsSet
c forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe NominalDiffTime
-> UTCTime
-> JWTClaimsSet
-> Validation (NonEmpty JWTException) UTCTime
decValidExp forall a. Maybe a
Nothing UTCTime
t JWTClaimsSet
c forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> UTCTime
-> JWTClaimsSet -> Validation (NonEmpty JWTException) UTCTime
decValidNbf UTCTime
t JWTClaimsSet
c
Maybe JWTClaimsSet
_ -> forall e a. e -> Validation (NonEmpty e) a
failure forall a b. (a -> b) -> a -> b
$ Text -> JWTException
JEMalformedJWT ([Text] -> Text
T.unwords [Text
"cannot decode token string"])
case Either (NonEmpty JWTException) (UserSub, UTCTime, UTCTime)
ve of
Right (UserSub
usub, UTCTime
_, UTCTime
_) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right UserSub
usub
Left NonEmpty JWTException
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left NonEmpty JWTException
e
excepttToActionM :: (MonadIO m, Show e) =>
ExceptT e IO b -> Action m b
excepttToActionM :: forall (m :: * -> *) e b.
(MonadIO m, Show e) =>
ExceptT e IO b -> Action m b
excepttToActionM ExceptT e IO b
e = do
Either e b
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e IO b
e
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e (m :: * -> *) a.
(ScottyError e, Monad m) =>
e -> ActionT e m a
raise forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure Either e b
result