48 lines
1.9 KiB
Haskell
48 lines
1.9 KiB
Haskell
module Handler.Utils.Tokens
|
|
( maybeBearerToken, requireBearerToken
|
|
, maybeCurrentBearerRestrictions, requireCurrentBearerRestrictions
|
|
) where
|
|
|
|
import Import
|
|
|
|
|
|
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
|
|
bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe
|
|
mAuthId <- maybeAuthId
|
|
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
|
|
isWrite <- isWriteRequest currentRoute
|
|
guardAuthResult <=< runDB $ validateBearer mAuthId currentRoute isWrite bearer
|
|
return bearer
|
|
|
|
requireCurrentBearerRestrictions :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, FromJSON a
|
|
, ToJSON a
|
|
)
|
|
=> m (Maybe a)
|
|
requireCurrentBearerRestrictions = runMaybeT $ do
|
|
bearer <- requireBearerToken
|
|
route <- MaybeT getCurrentRoute
|
|
hoistMaybe $ bearer ^? _bearerRestrictionIx route
|
|
|
|
maybeCurrentBearerRestrictions :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadCatch m
|
|
, FromJSON a
|
|
, ToJSON a
|
|
)
|
|
=> m (Maybe a)
|
|
maybeCurrentBearerRestrictions = runMaybeT $ do
|
|
bearer <- MaybeT maybeBearerToken
|
|
route <- MaybeT getCurrentRoute
|
|
hoistMaybe $ bearer ^? _bearerRestrictionIx route
|