35 lines
1.3 KiB
Haskell
35 lines
1.3 KiB
Haskell
module Handler.Utils.Tokens
|
|
( maybeBearerToken, requireBearerToken
|
|
, currentTokenRestrictions
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Utils.Lens
|
|
|
|
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 = liftHandlerT $ 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
|
|
|
|
currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, MonadLogger m, FromJSON a, ToJSON a) => m (Maybe a)
|
|
currentTokenRestrictions = runMaybeT $ do
|
|
token <- requireBearerToken
|
|
route <- MaybeT getCurrentRoute
|
|
hoistMaybe $ preview (_tokenRestrictionIx route) token
|