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