{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds, TypeFamilies #-}
{-# language DeriveGeneric, GeneralizedNewtypeDeriving, DerivingStrategies, DeriveDataTypeable  #-}
{-# language OverloadedStrings #-}
{-# options_ghc -Wno-unused-imports #-}
-- | MS Identity user session based on OAuth tokens
--
-- The library supports the following authentication scenarios :
--
-- * [Client Credentials](https://learn.microsoft.com/en-us/azure/active-directory/develop/v2-oauth2-client-creds-grant-flow) (server/server or automation accounts), see also https://oauth.net/2/grant-types/client-credentials/
--
-- * [Authorization Code](https://learn.microsoft.com/en-us/azure/active-directory/develop/v2-oauth2-auth-code-flow) (with human users being prompted to delegate some access rights to the app), see also https://oauth.net/2/grant-types/authorization-code/
--
-- and provides functions to keep tokens up to date in the background.
module Network.OAuth2.Session (
  -- * A Client Credentials Grant (i.e. server-to-server)
  Token
  -- , newNoToken
  , tokenUpdateLoop
  , expireToken
  , readToken
  -- , fetchUpdateToken
  -- ** Default Azure Credential
  , defaultAzureCredential
  -- * B Auth Code Grant (i.e. with user auth in the loop)
  -- ** OAuth endpoints
  , loginEndpoint
  , replyEndpoint
  -- ** In-memory user session
  , Tokens
  , newTokens
  , UserSub
  , lookupUser
  , expireUser
  , tokensToList
  -- * Scotty misc
  -- ** Azure App Service
  , withAADUser
  , Scotty
  , Action
  ) where

import Control.Applicative (Alternative(..))
import Control.Exception (Exception(..), SomeException(..))
import Control.Monad.IO.Class (MonadIO(..))
import Data.Functor (void)
import Data.List.NonEmpty (NonEmpty)
import Data.Maybe (fromMaybe)
import Data.String (IsString(..))
import Data.Typeable (Typeable)
import GHC.Exception (SomeException)
import System.Environment (lookupEnv)

-- aeson
import qualified Data.Aeson as A (FromJSON(..), eitherDecode)
-- bytestring
import qualified Data.ByteString.Char8 as BS (pack)
import qualified Data.ByteString.Lazy.Char8 as BSL
-- containers
import qualified Data.Map as M (Map, insert, lookup, alter, toList)
-- -- heaps
-- import qualified Data.Heap as H (Heap, empty, null, size, insert, viewMin, deleteMin, Entry(..), )
-- hoauth2
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)
-- http-client
import Network.HTTP.Client (Manager, parseRequest, requestHeaders, httpLbs, responseBody, responseStatus)
-- http-types
import Network.HTTP.Types (status302, status400, status401, statusCode)
import Network.HTTP.Types.Header (RequestHeaders, Header)
-- scotty
import Web.Scotty (scotty, RoutePattern)
import Web.Scotty.Trans (scottyT, ActionT, ScottyT, get, raise, redirect, params, header, setHeader, status, text)
-- text
import qualified Data.Text as T (Text, pack, unwords)
import qualified Data.Text.Lazy as TL (Text, pack, unpack, toStrict, takeWhile, fromStrict)
-- time
import Data.Time (UTCTime(..), getCurrentTime, fromGregorian, diffUTCTime, addUTCTime, Day, NominalDiffTime)
import Data.Time.Format (FormatTime, formatTime, iso8601DateFormat, defaultTimeLocale)
-- transformers
import Control.Monad.Trans.Except (ExceptT(..), withExceptT, runExceptT, throwE)
-- unliftio
import UnliftIO (MonadUnliftIO(..))
import UnliftIO.Concurrent (ThreadId, forkFinally, threadDelay)
import UnliftIO.Exception (throwIO)
import UnliftIO.STM (STM, TVar, atomically, newTVarIO, readTVar, writeTVar, modifyTVar)
-- uri-bytestring
import URI.ByteString (URI)
-- validation-selective
import Validation.Micro (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

-- * Azure App Service adds headers into each request, which the backend can access to identify the user
--
-- https://learn.microsoft.com/en-us/azure/app-service/configure-authentication-user-identities#access-user-claims-in-app-code

-- | The JWT identity token from the @X-MS-TOKEN-AAD-ID-TOKEN@ header injected by App Service can be decoded for its claims e.g. @sub@ (which is unique for each user for a given app)
--
-- https://bogdan.bynapse.com/azure/the-app-service-token-store-was-added-to-app-service-authentication-authorization-and-it-is-a-repository-of-oauth-tokens-associated-with-your-app-users-when-a-user-logs-into-your-app-via-an-iden/
--
-- https://stackoverflow.com/questions/46757665/authentication-for-azure-functions/
aadHeaderIdToken :: (MonadIO m) =>
                    (UserSub -> Action m ()) -- ^ look up the UserSub's token, do stuff with it
                 -> Action m ()
aadHeaderIdToken :: forall (m :: * -> *).
MonadIO m =>
(UserSub -> Action m ()) -> Action m ()
aadHeaderIdToken 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

-- | Decode the App Service ID token header @X-MS-TOKEN-AAD-ID-TOKEN@, look its user up in the local token store, supply token @t@ to continuation. If the user @sub@ cannot be found in the token store the browser is redirected to the login URI.
--
-- Special case of 'aadHeaderIdToken'
withAADUser :: MonadIO m =>
               Tokens UserSub t
            -> TL.Text -- ^ login URI
            -> (t -> Action m ()) -- ^ call MSGraph APIs with token @t@, etc.
            -> 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





-- * App-only authorization scenarios, called "CLient credentials grant" https://oauth.net/2/grant-types/client-credentials/ (i.e via automation accounts. Human users not involved)



-- | App has (at most) one token at a time
type Token t = TVar (Maybe t)

-- | Create an empty 'Token' store
newNoToken :: MonadIO m => m (Token t)
newNoToken :: forall (m :: * -> *) t. MonadIO m => m (Token t)
newNoToken = forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO forall a. Maybe a
Nothing
-- | Delete the current token
expireToken :: MonadIO m => Token t -> m ()
expireToken :: forall (m :: * -> *) t. MonadIO m => Token t -> m ()
expireToken Token t
ts = 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 Token t
ts (forall a b. a -> b -> a
const forall a. Maybe a
Nothing)
-- | Read the current value of the token
readToken :: MonadIO m => Token t -> m (Maybe t)
readToken :: forall (m :: * -> *) t. MonadIO m => Token t -> m (Maybe t)
readToken Token t
ts = forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> STM a
readTVar Token t
ts

updateToken :: (MonadIO m) =>
               Token OAuth2Token -> OAuth2Token -> m NominalDiffTime
updateToken :: forall (m :: * -> *).
MonadIO m =>
Token OAuth2Token -> OAuth2Token -> m NominalDiffTime
updateToken Token OAuth2Token
ts 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) -- expires in [sec]
  forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically forall a b. (a -> b) -> a -> b
$ do
    forall a. TVar a -> a -> STM ()
writeTVar Token OAuth2Token
ts (forall a. a -> Maybe a
Just OAuth2Token
oat)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure NominalDiffTime
ein

-- | Forks a thread and keeps the OAuth token up to date inside a TVar
tokenUpdateLoop :: MonadIO m =>
                   IdpApplication 'ClientCredentials AzureAD -- ^ client credentials grant only
                -> Manager
                -> m (Token OAuth2Token)
tokenUpdateLoop :: forall (m :: * -> *).
MonadIO m =>
IdpApplication 'ClientCredentials AzureAD
-> Manager -> m (Token OAuth2Token)
tokenUpdateLoop IdpApplication 'ClientCredentials AzureAD
idp Manager
mgr = do
  Token OAuth2Token
t <- forall (m :: * -> *) t. MonadIO m => m (Token t)
newNoToken
  forall (m :: * -> *).
MonadIO m =>
IdpApplication 'ClientCredentials AzureAD
-> Token OAuth2Token -> Manager -> m ()
fetchUpdateToken IdpApplication 'ClientCredentials AzureAD
idp Token OAuth2Token
t Manager
mgr
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Token OAuth2Token
t


fetchUpdateTokenWith :: MonadIO m =>
                        (t1 -> t2 -> ExceptT [String] IO OAuth2Token)
                     -> t1 -> Token OAuth2Token -> t2 -> m ()
fetchUpdateTokenWith :: forall (m :: * -> *) t1 t2.
MonadIO m =>
(t1 -> t2 -> ExceptT [String] IO OAuth2Token)
-> t1 -> Token OAuth2Token -> t2 -> m ()
fetchUpdateTokenWith t1 -> t2 -> ExceptT [String] IO OAuth2Token
f t1
idpApp Token OAuth2Token
ts t2
mgr = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally IO Any
loop forall {b}. Either SomeException b -> IO ()
cleanup
  where
    cleanup :: Either SomeException b -> IO ()
cleanup = \case
      Left SomeException
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e
      Right b
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    loop :: IO Any
loop = do
      Either [String] OAuth2Token
tokenResp <- forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ t1 -> t2 -> ExceptT [String] IO OAuth2Token
f t1
idpApp t2
mgr -- allows different mechanisms of fetching OAuth2 token
      case Either [String] OAuth2Token
tokenResp of
        Left [String]
es -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO ([String] -> OAuthSessionError
OASEDefaultAzureCredentialsE [String]
es)
        Right OAuth2Token
oat -> do
          NominalDiffTime
ein <- forall (m :: * -> *).
MonadIO m =>
Token OAuth2Token -> OAuth2Token -> m NominalDiffTime
updateToken Token OAuth2Token
ts 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) -- 30 seconds before expiry
          forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int
dtSecs forall a. Num a => a -> a -> a
* Int
1000000) -- pause thread
          IO Any
loop

-- | DefaultAzureCredential mechanism as in the Python SDK https://pypi.org/project/azure-identity/
--
-- Order of authentication attempts:
--
-- 1) token request with client secret
--
-- 2) token request via managed identity (App Service and Azure Functions) https://learn.microsoft.com/en-us/azure/app-service/overview-managed-identity?tabs=portal%2Chttp#rest-endpoint-reference
defaultAzureCredential :: MonadIO m =>
                          String -- ^ Client ID
                       -> String -- ^ Azure Resource URI (for @managed identity@ auth flow)
                       -> IdpApplication 'ClientCredentials AzureAD
                       -> Token OAuth2Token
                       -> Manager
                       -> m ()
defaultAzureCredential :: forall (m :: * -> *).
MonadIO m =>
String
-> String
-> IdpApplication 'ClientCredentials AzureAD
-> Token OAuth2Token
-> Manager
-> m ()
defaultAzureCredential String
clid String
resuri = forall (m :: * -> *) t1 t2.
MonadIO m =>
(t1 -> t2 -> ExceptT [String] IO OAuth2Token)
-> t1 -> Token OAuth2Token -> t2 -> m ()
fetchUpdateTokenWith (
  \IdpApplication 'ClientCredentials AzureAD
ip Manager
mgr ->
    forall (m :: * -> *).
MonadIO m =>
IdpApplication 'ClientCredentials AzureAD
-> Manager -> ExceptT [String] m OAuth2Token
tokenRequestNoExchange IdpApplication 'ClientCredentials AzureAD
ip Manager
mgr forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    Manager -> String -> String -> ExceptT [String] IO OAuth2Token
managedIdentity Manager
mgr String
clid String
resuri
    )

tokenRequestNoExchange :: (MonadIO m) =>
                          IdpApplication 'ClientCredentials AzureAD
                       -> Manager
                       -> ExceptT [String] m OAuth2Token
tokenRequestNoExchange :: forall (m :: * -> *).
MonadIO m =>
IdpApplication 'ClientCredentials AzureAD
-> Manager -> ExceptT [String] m OAuth2Token
tokenRequestNoExchange IdpApplication 'ClientCredentials AzureAD
ip Manager
mgr = forall (m :: * -> *) e e' a.
Functor m =>
(e -> e') -> ExceptT e m a -> ExceptT e' m a
withExceptT (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (forall (a :: GrantTypeFlow) (m :: * -> *) i.
(HasTokenRequest a, MonadIO m) =>
IdpApplication a i
-> Manager
-> WithExchangeToken a (ExceptT (OAuth2Error Errors) m OAuth2Token)
conduitTokenRequest IdpApplication 'ClientCredentials AzureAD
ip Manager
mgr)

-- | Token refresh loop for Client Credentials Grant scenarios (Bot Framework auth etc)
--
-- Fetch an OAuth token and keep it updated. Should be called as a first thing in the app
--
-- NB : forks a thread in the background
--
-- https://learn.microsoft.com/en-us/azure/active-directory/develop/v2-oauth2-client-creds-grant-flow
fetchUpdateToken :: MonadIO m =>
                    IdpApplication 'ClientCredentials AzureAD
                 -> Token OAuth2Token -- ^ the app manages a single token at a time
                 -> Manager -- ^ HTTP connection manager
                 -> m ()
fetchUpdateToken :: forall (m :: * -> *).
MonadIO m =>
IdpApplication 'ClientCredentials AzureAD
-> Token OAuth2Token -> Manager -> m ()
fetchUpdateToken IdpApplication 'ClientCredentials AzureAD
idpApp Token OAuth2Token
ts Manager
mgr = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally IO Any
loop forall {b}. Either SomeException b -> IO ()
cleanup
  where
    cleanup :: Either SomeException b -> IO ()
cleanup = \case
      Left SomeException
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO SomeException
e
      Right b
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    loop :: IO Any
loop = 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 'ClientCredentials AzureAD
idpApp Manager
mgr -- OAuth2 token
      case Either (OAuth2Error Errors) OAuth2Token
tokenResp of
        Left OAuth2Error Errors
es -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (OAuth2Error Errors -> OAuthSessionError
OASEOAuth2Errors OAuth2Error Errors
es)
        Right OAuth2Token
oat -> do
          NominalDiffTime
ein <- forall (m :: * -> *).
MonadIO m =>
Token OAuth2Token -> OAuth2Token -> m NominalDiffTime
updateToken Token OAuth2Token
ts 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) -- 30 seconds before expiry
          forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int
dtSecs forall a. Num a => a -> a -> a
* Int
1000000) -- pause thread
          IO Any
loop





-- * Managed identity

-- | With its managed identity, an app can obtain tokens for Azure resources that are protected by Azure Active Directory, such as Azure SQL Database, Azure Key Vault, and Azure Storage. These tokens represent the application accessing the resource, and not any specific user of the application.
--
-- App Service and Azure Functions provide an internally accessible REST endpoint for token retrieval. 
--
-- https://learn.microsoft.com/en-us/azure/app-service/overview-managed-identity?tabs=portal%2Chttp#rest-endpoint-reference
managedIdentity :: Manager
                -> String -- ^ client ID
                -> String -- ^ Azure resource URI
                -> ExceptT [String] IO OAuth2Token
managedIdentity :: Manager -> String -> String -> ExceptT [String] IO OAuth2Token
managedIdentity Manager
mgr String
clid String
resUri = forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT forall a b. (a -> b) -> a -> b
$ do
  Maybe String
mih <- String -> IO (Maybe String)
lookupEnv String
"IDENTITY_ENDPOINT"
  Maybe String
mie <- String -> IO (Maybe String)
lookupEnv String
"IDENTITY_HEADER"
  case (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe String
mih forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe String
mie of
    Just (String
idEndpoint, String
ih) -> do
      let
        apiVer :: String
apiVer = String
"2019-08-01"
        xIdentityHeader :: String
xIdentityHeader = String
ih
      Request
r <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [String
idEndpoint, String
"?", [(String, String)] -> String
kvs [(String
"resource", String
resUri), (String
"api-version", String
apiVer), (String
"client_id", String
clid)]]
      let
        r' :: Request
r' = Request
r {
          requestHeaders :: RequestHeaders
requestHeaders = [
              (HeaderName
"X-IDENTITY-HEADER", String -> ByteString
BS.pack String
xIdentityHeader)
                           ]
               }
      Response ByteString
res <- Request -> Manager -> IO (Response ByteString)
httpLbs Request
r' Manager
mgr
      let
        rstat :: Status
rstat = forall body. Response body -> Status
responseStatus Response ByteString
res
        sci :: Int
sci = Status -> Int
statusCode Status
rstat
      if Int
200 forall a. Ord a => a -> a -> Bool
<= Int
sci Bool -> Bool -> Bool
&& Int
sci forall a. Ord a => a -> a -> Bool
< Int
300
        then
        case forall a. FromJSON a => ByteString -> Either String a
A.eitherDecode (forall body. Response body -> body
responseBody Response ByteString
res) of
          Right 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 String
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either [a] b
lefts forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"managedIdentity: Cannot decode OAuth token:", String
e]
        else
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either [a] b
lefts forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"managedIdentity: status code exception:", forall a. Show a => a -> String
show Status
rstat]
    Maybe (String, String)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
          forall a b. a -> Either [a] b
lefts forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"managedIdentity: Cannot find either IDENTITY_ENDPOINT or IDENTITY_HEADER env vars."]
lefts :: a -> Either [a] b
lefts :: forall a b. a -> Either [a] b
lefts a
s = forall a b. a -> Either a b
Left [a
s]

kvs :: [(String, String)] -> String
kvs :: [(String, String)] -> String
kvs = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}. (Semigroup a, IsString a) => (a, a) -> a -> a
ins forall a. Monoid a => a
mempty
  where
    ins :: (a, a) -> a -> a
ins (a
k, a
v) a
acc = a
acc forall a. Semigroup a => a -> a -> a
<> (a
"&" forall a. Semigroup a => a -> a -> a
<> a
k forall a. Semigroup a => a -> a -> a
<> a
"=" forall a. Semigroup a => a -> a -> a
<> a
v)




-- * Auth code grant flow (i.e. human user involved)

-- | Login endpoint
--
-- see 'azureADApp'
loginEndpoint :: (MonadIO m) =>
                 IdpApplication 'AuthorizationCode AzureAD
              -> RoutePattern -- ^ e.g. @"/login"@
              -> 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)

-- | login endpoint handler
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) -- redirect to OAuth consent screen
  forall (m :: * -> *) e. Monad m => Status -> ActionT e m ()
status Status
status302

-- | The identity provider redirects the client to the 'reply' endpoint as part of the OAuth flow : https://learn.microsoft.com/en-us/graph/auth-v2-user?view=graph-rest-1.0&tabs=http#authorization-response
--
-- NB : forks a thread per logged in user to keep their tokens up to date
replyEndpoint :: MonadIO m =>
                 IdpApplication 'AuthorizationCode AzureAD
              -> Tokens UserSub OAuth2Token -- ^ token TVar
              -> Manager
              -> RoutePattern -- ^ e.g. @"/oauth\/reply"@
              -> 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 :: * -> *).
MonadIO m =>
Tokens UserSub OAuth2Token
-> IdpApplication 'AuthorizationCode AzureAD
-> Manager
-> ExchangeToken
-> ExceptT OAuthSessionError m OAuth2Token
fetchUpdateTokenACG 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

--

-- oauth2ErrorToText :: Show a => a -> T.Text
-- oauth2ErrorToText e = T.pack $ "Unable to fetch access token. Details : " ++ show e

-- bslToText :: BSL.ByteString -> T.Text
-- bslToText = T.pack . BSL.unpack


-- | Token refresh loop for Auth Code Grant scenarios
--
-- 1) the ExchangeToken arrives with the redirect once the user has approved the scopes in the browser
-- https://learn.microsoft.com/en-us/graph/auth-v2-user?view=graph-rest-1.0&tabs=http#authorization-response
fetchUpdateTokenACG :: MonadIO m =>
                       Tokens UserSub OAuth2Token -- ^ the app manages one token per user
                    -> IdpApplication 'AuthorizationCode AzureAD
                    -> Manager -- ^ HTTP connection manager
                    -> ExchangeToken -- ^ also called 'code'. Expires in 10 minutes
                    -> ExceptT OAuthSessionError m OAuth2Token
fetchUpdateTokenACG :: forall (m :: * -> *).
MonadIO m =>
Tokens UserSub OAuth2Token
-> IdpApplication 'AuthorizationCode AzureAD
-> Manager
-> ExchangeToken
-> ExceptT OAuthSessionError m OAuth2Token
fetchUpdateTokenACG 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 -- OAuth2 token
  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 -- decode and validate ID token
        case Either (NonEmpty JWTException) UserSub
idtClaimsE of
          Right UserSub
uid -> do
            ThreadId
_ <- forall (m :: * -> *) uid (a :: GrantTypeFlow) i.
(MonadIO m, Ord uid, HasRefreshTokenRequest a) =>
Tokens uid OAuth2Token
-> IdpApplication a i
-> Manager
-> uid
-> OAuth2Token
-> m ThreadId
refreshLoopACG Tokens UserSub OAuth2Token
ts IdpApplication 'AuthorizationCode AzureAD
idpApp Manager
mgr UserSub
uid OAuth2Token
oat -- fork a thread and start refresh loop for this user
            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) -- id token validation failed
    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)


-- | 2) fork a thread and start token refresh loop for user @uid@
--
-- ACG stands for "authorization code grant" flow, i.e. the user consent is in the auth loop.
refreshLoopACG :: (MonadIO m, Ord uid, HasRefreshTokenRequest a) =>
                  Tokens uid OAuth2Token
               -> IdpApplication a i
               -> Manager
               -> uid -- ^ user ID
               -> OAuth2Token
               -> m ThreadId
refreshLoopACG :: forall (m :: * -> *) uid (a :: GrantTypeFlow) i.
(MonadIO m, Ord uid, HasRefreshTokenRequest a) =>
Tokens uid OAuth2Token
-> IdpApplication a i
-> Manager
-> uid
-> OAuth2Token
-> m ThreadId
refreshLoopACG Tokens uid OAuth2Token
ts IdpApplication a i
idpApp Manager
mgr uid
uid OAuth2Token
oaToken = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (Either SomeException a -> m ()) -> m ThreadId
forkFinally (OAuth2Token -> IO Any
act OAuth2Token
oaToken) Either SomeException Any -> IO ()
cleanup
  where
    cleanup :: Either SomeException Any -> IO ()
cleanup = \case
      Left SomeException
_ -> do
        forall (m :: * -> *) uid t.
(MonadIO m, Ord uid) =>
Tokens uid t -> uid -> m ()
expireUser Tokens uid OAuth2Token
ts uid
uid -- auth error(s), remove user from memory
      Right Any
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    act :: OAuth2Token -> IO Any
act OAuth2Token
oat = do
      NominalDiffTime
ein <- forall (m :: * -> *) uid.
(MonadIO m, Ord uid) =>
Tokens uid OAuth2Token -> uid -> OAuth2Token -> m NominalDiffTime
upsertToken Tokens uid OAuth2Token
ts uid
uid OAuth2Token
oat -- replace new token for user uid in memory
      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) -- 30 seconds before expiry
      forall (m :: * -> *). MonadIO m => Int -> m ()
threadDelay (Int
dtSecs forall a. Num a => a -> a -> a
* Int
1000000) -- pause thread
      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 -- cannot refresh, remove user from memory
          forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO OAuthSessionError
OASERefreshTokenNotFound -- no refresh token
        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 -- get a new OAuth2 token
          case Either (OAuth2Error Errors) OAuth2Token
eo' of
            Right OAuth2Token
oat' -> do
              OAuth2Token -> IO Any
act OAuth2Token
oat' -- loop
            Left OAuth2Error Errors
e -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (OAuth2Error Errors -> OAuthSessionError
OASEOAuth2Errors OAuth2Error Errors
e) -- refresh token request failed

data OAuthSessionError = OASERefreshTokenNotFound
                       | OASEExchangeTokenNotFound
                       | OASEOAuth2Errors (OAuth2Error Errors)
                       | OASEDefaultAzureCredentialsE [String]
                       | 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]
    OASEDefaultAzureCredentialsE [String]
es ->
      [String] -> String
unwords [String
"defaultAzureCredential error(s):", forall a. Monoid a => [a] -> a
mconcat [String]
es]
    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"]

-- | Insert or update a token in the 'Tokens' object
upsertToken :: (MonadIO m, Ord uid) =>
               Tokens uid OAuth2Token
            -> uid -- ^ user id
            -> OAuth2Token -- ^ new token
            -> m NominalDiffTime -- ^ token expires in
upsertToken :: forall (m :: * -> *) uid.
(MonadIO m, Ord uid) =>
Tokens uid OAuth2Token -> uid -> OAuth2Token -> m NominalDiffTime
upsertToken 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) -- expires in [sec]
  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

-- | Remove a user, i.e. they will have to authenticate once more
expireUser :: (MonadIO m, Ord uid) =>
              Tokens uid t
           -> uid -- ^ user identifier e.g. @sub@
           -> 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)}

-- | Look up a user identifier and return their current token, if any
lookupUser :: (MonadIO m, Ord uid) =>
              Tokens uid t
           -> uid -- ^ user identifier e.g. @sub@
           -> 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)

-- | return a list representation of the 'Tokens' object
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

-- | Create an empty 'Tokens' object
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)

-- | transactional token store
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)

-- class HasTokens r where
--   hasTokens :: r -> Tokens uid t

-- | Decode and validate ID token
-- https://learn.microsoft.com/en-us/azure/active-directory/develop/userinfo#consider-using-an-id-token-instead
decValidIdToken :: MonadIO m =>
                   IdToken -- ^ appears in the OAuth2Token if scopes include @openid@
                -> m (Either (NonEmpty JWTException) UserSub) -- ^ (sub)
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



-- | Lift ExceptT to ActionM which is basically the handler Monad in Scotty.
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


-- playground

-- atomicallyWithAfter :: MonadUnliftIO m =>
--                        TVar a
--                     -> Int -- ^ delay in microseconds (see 'threadDelay')
--                     -> (a -> a)
--                     -> m ThreadId
-- atomicallyWithAfter tv dt f = forkFinally act (\_ -> pure ())
--   where
--     act = do
--       threadDelay dt
--       atomically $ modifyTVar tv f