50 lines
1.9 KiB
Haskell
50 lines
1.9 KiB
Haskell
module Handler.Utils.Tokens
|
|
( maybeBearerToken, requireBearerToken
|
|
, maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Control.Monad.Trans.Maybe (runMaybeT)
|
|
|
|
|
|
maybeBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => m (Maybe (BearerToken UniWorX))
|
|
maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken
|
|
where
|
|
cPred err = any ($ err)
|
|
[ is $ _HCError . _PermissionDenied
|
|
, is $ _HCError . _NotAuthenticated
|
|
]
|
|
|
|
requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX)
|
|
requireBearerToken = liftHandler $ do
|
|
token <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askTokenUnsafe
|
|
mAuthId <- maybeAuthId
|
|
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
|
|
isWrite <- isWriteRequest currentRoute
|
|
guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
|
|
return token
|
|
|
|
requireCurrentTokenRestrictions :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, FromJSON a
|
|
, ToJSON a
|
|
)
|
|
=> m (Maybe a)
|
|
requireCurrentTokenRestrictions = runMaybeT $ do
|
|
token <- requireBearerToken
|
|
route <- MaybeT getCurrentRoute
|
|
hoistMaybe $ token ^? _tokenRestrictionIx route
|
|
|
|
maybeCurrentTokenRestrictions :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadCatch m
|
|
, FromJSON a
|
|
, ToJSON a
|
|
)
|
|
=> m (Maybe a)
|
|
maybeCurrentTokenRestrictions = runMaybeT $ do
|
|
token <- MaybeT maybeBearerToken
|
|
route <- MaybeT getCurrentRoute
|
|
hoistMaybe $ token ^? _tokenRestrictionIx route
|