{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DataKinds #-}
{-# language DeriveGeneric, GeneralizedNewtypeDeriving, DerivingStrategies, DeriveDataTypeable  #-}
{-# language OverloadedStrings #-}
{-# options_ghc -Wno-unused-imports #-}
-- | OAuth user session
module Network.OAuth2.Session (
  -- * Azure App Service
  withAADUser
  -- * OAuth2 endpoints
  , loginEndpoint
  , replyEndpoint
  -- * In-memory user session
  , Tokens
  , UserSub
  , lookupUser
  , expireUser
  -- * Scotty misc
  , 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)

-- aeson
import Data.Aeson
-- bytestring
import qualified Data.ByteString.Lazy.Char8 as BSL
-- containers
import qualified Data.Map as M (Map, insert, lookup, alter)
-- -- 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)
-- http-types
import Network.HTTP.Types (status302, status400, status401)
-- 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 (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


-- * OAuth flow

-- | 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) -- $ azureADApp oacfg)
  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
--
-- see 'azureADApp'
replyEndpoint :: MonadIO m =>
                 IdpApplication 'AuthorizationCode AzureAD
              -> Tokens UserSub OAuth2Token
              -> 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 :: * -> *).
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 -- $ T.pack $ unwords ["cannot decode token"]

--

-- 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


-- | 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
fetchUpdateToken :: MonadUnliftIO m =>
                    Tokens UserSub OAuth2Token
                 -> IdpApplication 'AuthorizationCode AzureAD
                 -> Manager
                 -> ExchangeToken -- ^ also called 'code'. Expires in 10 minutes
                 -> ExceptT OAuthSessionError m OAuth2Token -- IO (Either T.Text 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 -- 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.
(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 -- 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) -- $ T.pack (show e) -- ^ 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)

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 -- auth error(s), remove user from memory
      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 -- replace new token 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 -> m b
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)
                       | 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 -- ^ user id
            -> OAuth2Token -- ^ new token
            -> m NominalDiffTime -- ^ token expires in
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) -- 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

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)}

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)

-- | transactional token store
type Tokens uid t = TVar (TokensData uid t)
data TokensData uid t = TokensData {
  forall uid t. TokensData uid t -> Map uid t
thUsersMap :: M.Map 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