1897 lines
113 KiB
Haskell
1897 lines
113 KiB
Haskell
{-# LANGUAGE UndecidableInstances, InstanceSigs #-}
|
|
{-# OPTIONS_GHC -fno-warn-redundant-constraints -fprof-auto #-}
|
|
|
|
module Foundation.Authorization
|
|
( evalAccess, evalAccessFor, evalAccessWith
|
|
, evalAccessDB, evalAccessForDB, evalAccessWithDB
|
|
, hasReadAccessTo, hasWriteAccessTo
|
|
, wouldHaveReadAccessTo, wouldHaveWriteAccessTo
|
|
, wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
|
|
, AuthContext(..), getAuthContext
|
|
, isDryRun, isDryRunDB
|
|
, maybeBearerToken, requireBearerToken
|
|
, requireCurrentBearerRestrictions, maybeCurrentBearerRestrictions
|
|
, BearerAuthSite, MonadAP
|
|
, routeAuthTags
|
|
, orAR, andAR, notAR, trueAR, falseAR
|
|
, authoritiveApproot
|
|
, AuthorizationCacheKey(..)
|
|
) where
|
|
|
|
import Import.NoFoundation hiding (Last(..))
|
|
|
|
import Foundation.Type
|
|
import Foundation.Routes
|
|
import Foundation.I18n
|
|
|
|
import Foundation.DB
|
|
|
|
import Handler.Utils.ExamOffice.Exam
|
|
import Handler.Utils.ExamOffice.ExternalExam
|
|
import Handler.Utils.Memcached
|
|
import Handler.Utils.I18n
|
|
import Handler.Utils.Routes
|
|
import Utils.Course (courseIsVisible)
|
|
import Utils.Metrics (observeAuthTagEvaluation, AuthTagEvalOutcome(..))
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Aeson as JSON
|
|
import qualified Data.HashSet as HashSet
|
|
import qualified Data.Map as Map
|
|
import Data.Map ((!?))
|
|
import qualified Data.Text as Text
|
|
import Data.List (findIndex)
|
|
-- import Data.Semigroup (Last(..))
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Control.Monad.Error.Class (MonadError(..))
|
|
import Control.Monad.Memo.Class (MonadMemo(..), for4)
|
|
|
|
import Data.Aeson.Lens hiding (_Value, key)
|
|
|
|
-- import qualified Data.Conduit.Combinators as C
|
|
|
|
import qualified Data.Binary as Binary
|
|
|
|
import GHC.TypeLits (TypeError)
|
|
import qualified GHC.TypeLits as TypeError (ErrorMessage(..))
|
|
|
|
-- import Utils.VolatileClusterSettings
|
|
|
|
|
|
type BearerAuthSite site
|
|
= ( MonadCrypto (HandlerFor site)
|
|
, CryptoIDKey ~ MonadCryptoKey (HandlerFor site)
|
|
, MonadCrypto (ReaderT SqlBackend (HandlerFor site))
|
|
, CryptoIDKey ~ MonadCryptoKey (ReaderT SqlBackend (HandlerFor site))
|
|
, MonadCrypto (ExceptT AuthResult (HandlerFor site))
|
|
, CryptoIDKey ~ MonadCryptoKey (ExceptT AuthResult (HandlerFor site))
|
|
, MonadCrypto (MaybeT (HandlerFor site))
|
|
, CryptoIDKey ~ MonadCryptoKey (MaybeT (HandlerFor site))
|
|
, MonadCrypto (ExceptT AuthResult (ReaderT SqlReadBackend (HandlerFor site)))
|
|
, CryptoIDKey ~ MonadCryptoKey (ExceptT AuthResult (ReaderT SqlReadBackend (HandlerFor site)))
|
|
, MonadCrypto (ReaderT SqlReadBackend (HandlerFor site))
|
|
, CryptoIDKey ~ MonadCryptoKey (ReaderT SqlReadBackend (HandlerFor site))
|
|
, MonadCrypto (MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor site))))
|
|
, CryptoIDKey ~ MonadCryptoKey (MaybeT (WriterT Any (ReaderT SqlReadBackend (HandlerFor site))))
|
|
, MonadCrypto (MaybeT (ReaderT SqlReadBackend (HandlerFor site)))
|
|
, CryptoIDKey ~ MonadCryptoKey (MaybeT (ReaderT SqlReadBackend (HandlerFor site)))
|
|
, UserId ~ AuthId site, User ~ AuthEntity site
|
|
, YesodAuthPersist site
|
|
)
|
|
|
|
|
|
-- Access Control
|
|
newtype InvalidAuthTag = InvalidAuthTag Text
|
|
deriving (Eq, Ord, Show, Read, Generic, Typeable)
|
|
instance Exception InvalidAuthTag
|
|
|
|
|
|
type AuthTagsEval m = AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
|
|
|
|
data AccessPredicate
|
|
= APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
|
|
| APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult)
|
|
| APDB (ByteString -> (forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)
|
|
| APBind (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX (Either AccessPredicate AuthResult))
|
|
| APBindDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX (Either (ReaderT SqlReadBackend (HandlerFor UniWorX) (Either AccessPredicate AuthResult)) (Either AccessPredicate AuthResult)))
|
|
|
|
class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP m where
|
|
evalAccessPred :: AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
|
|
|
|
apRunDB :: forall a. ReaderT SqlReadBackend (HandlerFor UniWorX) a -> m a
|
|
|
|
type family DisabledMonadAPInstance t err :: Constraint where
|
|
DisabledMonadAPInstance t err
|
|
= TypeError ( 'TypeError.Text "Used dangerous MonadAP instance for: " 'TypeError.:<>: 'TypeError.ShowType t
|
|
'TypeError.:$$: 'TypeError.Text "This instance is currently disabled via TypeError because: " 'TypeError.:<>: err
|
|
'TypeError.:$$: 'TypeError.Text "Please consider removing the usage triggering this error message before re-enabling or removing the instance."
|
|
)
|
|
|
|
instance ( BearerAuthSite UniWorX
|
|
-- , DisabledMonadAPInstance (HandlerFor UniWorX) ('TypeError.Text "It causes too many database connections")
|
|
) => MonadAP (HandlerFor UniWorX) where
|
|
evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult
|
|
evalAccessPred aPred contCtx cont aid r w = case aPred of
|
|
(APPure p) -> runReader (p aid r w) <$> getMsgRenderer
|
|
(APHandler p) -> p aid r w
|
|
(APDB p) -> apRunDB $ p contCtx cont aid r w
|
|
(APBind p) -> evalAccessPred (APBindDB $ \aid' r' w' -> Right <$> p aid' r' w') contCtx cont aid r w
|
|
(APBindDB p) -> let contAP p' = evalAccessPred p' contCtx cont aid r w
|
|
in p aid r w >>= either apRunDB return >>= either contAP return
|
|
|
|
apRunDB :: forall a. HasCallStack => ReaderT SqlReadBackend (HandlerFor UniWorX) a -> HandlerFor UniWorX a
|
|
apRunDB = runDBRead' callStack
|
|
|
|
instance BearerAuthSite UniWorX => MonadAP (WidgetFor UniWorX) where
|
|
evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WidgetFor UniWorX AuthResult
|
|
evalAccessPred aPred contCtx cont aid r w = liftHandler $ evalAccessPred aPred contCtx cont aid r w
|
|
|
|
apRunDB :: forall a. HasCallStack => ReaderT SqlReadBackend (HandlerFor UniWorX) a -> WidgetFor UniWorX a
|
|
apRunDB = liftHandler . apRunDB
|
|
|
|
instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP (ReaderT backend m) where
|
|
evalAccessPred aPred contCtx cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of
|
|
(APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
|
|
(APHandler p) -> lift $ p aid r w
|
|
(APDB p) -> p contCtx cont aid r w
|
|
(APBind p) -> evalAccessPred (APBindDB $ \aid' r' w' -> Right <$> p aid' r' w') contCtx cont aid r w
|
|
(APBindDB p) -> let contAP p' = evalAccessPred p' contCtx cont aid r w
|
|
in lift (p aid r w) >>= either id return >>= either contAP return
|
|
|
|
apRunDB = hoist liftHandler . withReaderT projectBackend
|
|
|
|
-- cacheAP :: ( Binary k
|
|
-- , Typeable v, Binary v
|
|
-- )
|
|
-- => Maybe Expiry
|
|
-- -> k
|
|
-- -> HandlerFor UniWorX v
|
|
-- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
|
|
-- -> AccessPredicate
|
|
-- cacheAP mExp k mkV cont = APBind $ \mAuthId route isWrite -> either (return . Left) (fmap Right) . cont mAuthId route isWrite =<< memcachedBy mExp k mkV
|
|
|
|
cacheAPDB :: ( Binary k
|
|
, Typeable v, Binary v, NFData v
|
|
)
|
|
=> Maybe Expiry
|
|
-> k
|
|
-> ReaderT SqlReadBackend (HandlerFor UniWorX) v
|
|
-> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
|
|
-> AccessPredicate
|
|
cacheAPDB mExp k mkV cont = APBindDB $ \mAuthId route isWrite -> do
|
|
cachedV <- memcachedByGet k
|
|
case cachedV of
|
|
Just v -> fmap Right . either (return . Left) (fmap Right) $ cont mAuthId route isWrite v
|
|
Nothing -> return . Left $ do
|
|
v <- mkV
|
|
memcachedBySet mExp k v
|
|
either (return . Left) (fmap Right . lift) $ cont mAuthId route isWrite v
|
|
|
|
-- cacheAP' :: ( Binary k
|
|
-- , Typeable v, Binary v
|
|
-- )
|
|
-- => Maybe Expiry
|
|
-- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, HandlerFor UniWorX v))
|
|
-- -> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
|
|
-- -> AccessPredicate
|
|
-- cacheAP' mExp mkKV cont = APBind $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of
|
|
-- Just (k, mkV) -> either (return . Left) (fmap Right) . cont mAuthId route isWrite . Just =<< memcachedBy mExp k mkV
|
|
-- Nothing -> either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing
|
|
|
|
cacheAPDB' :: ( Binary k
|
|
, Typeable v, Binary v, NFData v
|
|
)
|
|
=> Maybe Expiry
|
|
-> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe (k, ReaderT SqlReadBackend (HandlerFor UniWorX) v))
|
|
-> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Maybe v -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
|
|
-> AccessPredicate
|
|
cacheAPDB' mExp mkKV cont = APBindDB $ \mAuthId route isWrite -> case mkKV mAuthId route isWrite of
|
|
Just (k, mkV) -> do
|
|
cachedV <- memcachedByGet k
|
|
case cachedV of
|
|
Just v -> fmap Right . either (return . Left) (fmap Right) . cont mAuthId route isWrite $ Just v
|
|
Nothing -> return . Left $ do
|
|
v <- mkV
|
|
memcachedBySet mExp k v
|
|
either (return . Left) (fmap Right . lift) . cont mAuthId route isWrite $ Just v
|
|
Nothing -> fmap Right . either (return . Left) (fmap Right) $ cont mAuthId route isWrite Nothing
|
|
|
|
|
|
orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
|
|
orAR _ Authorized _ = Authorized
|
|
orAR _ _ Authorized = Authorized
|
|
orAR _ AuthenticationRequired _ = AuthenticationRequired
|
|
orAR _ _ AuthenticationRequired = AuthenticationRequired
|
|
orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y
|
|
-- and
|
|
andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y
|
|
andAR _ reason@(Unauthorized _) _ = reason
|
|
andAR _ _ reason@(Unauthorized _) = reason
|
|
andAR _ Authorized other = other
|
|
andAR _ AuthenticationRequired _ = AuthenticationRequired
|
|
|
|
_orARI18n, _andARI18n :: MsgRenderer -> I18nAuthResult -> I18nAuthResult -> I18nAuthResult
|
|
_orARI18n _ AuthorizedI18n _ = AuthorizedI18n
|
|
_orARI18n _ _ AuthorizedI18n = AuthorizedI18n
|
|
_orARI18n _ AuthenticationRequiredI18n _ = AuthenticationRequiredI18n
|
|
_orARI18n _ _ AuthenticationRequiredI18n = AuthenticationRequiredI18n
|
|
_orARI18n mr (UnauthorizedI18n x) (UnauthorizedI18n y) = fmap (Unauthorized . render mr) . MsgUnauthorizedOr <$> x <*> y
|
|
_orARI18n mr _ _ = UnauthorizedI18n . opoint $ render mr MsgUnauthorizedI18nMismatch
|
|
-- and
|
|
_andARI18n mr (UnauthorizedI18n x) (UnauthorizedI18n y) = fmap (Unauthorized . render mr) . MsgUnauthorizedAnd <$> x <*> y
|
|
_andARI18n _ reason@(UnauthorizedI18n _) _ = reason
|
|
_andARI18n _ _ reason@(UnauthorizedI18n _) = reason
|
|
_andARI18n _ AuthorizedI18n other = other
|
|
_andARI18n _ AuthenticationRequiredI18n _ = AuthenticationRequiredI18n
|
|
_andARI18n mr _ _ = UnauthorizedI18n . opoint $ render mr MsgUnauthorizedI18nMismatch
|
|
|
|
notAR :: RenderMessage UniWorX msg => MsgRenderer -> msg -> AuthResult -> AuthResult
|
|
notAR _ _ (Unauthorized _) = Authorized
|
|
notAR _ _ AuthenticationRequired = AuthenticationRequired
|
|
notAR mr msg Authorized = Unauthorized . render mr . MsgUnauthorizedNot $ render mr msg
|
|
|
|
trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult
|
|
trueAR = const Authorized
|
|
falseAR = Unauthorized . ($ MsgUnauthorized) . render
|
|
|
|
trueAP, _falseAP :: AccessPredicate
|
|
trueAP = APPure . const . const . const $ trueAR <$> ask
|
|
_falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness
|
|
|
|
|
|
data AuthContext = AuthContext
|
|
{ authCtxAuth :: Maybe (AuthId UniWorX)
|
|
, authCtxBearer :: Maybe (BearerToken UniWorX)
|
|
, authActiveTags :: AuthTagActive
|
|
} deriving (Generic, Typeable)
|
|
|
|
deriving stock instance Eq (AuthId UniWorX) => Eq AuthContext
|
|
deriving stock instance Ord (AuthId UniWorX) => Ord AuthContext
|
|
deriving stock instance (Read (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Read AuthContext
|
|
deriving stock instance (Show (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Show AuthContext
|
|
deriving anyclass instance Hashable (AuthId UniWorX) => Hashable AuthContext
|
|
deriving anyclass instance (Binary (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Binary AuthContext
|
|
|
|
getAuthContext :: forall m.
|
|
( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, BearerAuthSite UniWorX
|
|
)
|
|
=> m AuthContext
|
|
getAuthContext = liftHandler $ do
|
|
authCtx <- AuthContext
|
|
<$> defaultMaybeAuthId
|
|
<*> runMaybeT (exceptTMaybe askBearerUnsafe)
|
|
<*> (fromMaybe def <$> lookupSessionJson SessionActiveAuthTags)
|
|
|
|
$logDebugS "getAuthContext" $ tshow authCtx
|
|
|
|
return authCtx
|
|
|
|
newtype IsDryRun = MkIsDryRun { unIsDryRun :: Bool }
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
isDryRun :: ( HasCallStack
|
|
, BearerAuthSite UniWorX
|
|
)
|
|
=> HandlerFor UniWorX Bool
|
|
isDryRun = fmap unIsDryRun . cached . fmap MkIsDryRun $ runDBRead isDryRunDB
|
|
|
|
isDryRunDB :: forall m backend.
|
|
( HasCallStack
|
|
, MonadAP m, MonadCatch m
|
|
, BearerAuthSite UniWorX
|
|
, WithRunDB backend (HandlerFor UniWorX) m
|
|
, BackendCompatible SqlReadBackend backend
|
|
)
|
|
=> m Bool
|
|
isDryRunDB = fmap unIsDryRun . cached . fmap MkIsDryRun $ orM
|
|
[ hasGlobalPostParam PostDryRun
|
|
, hasGlobalGetParam GetDryRun
|
|
, and2M bearerDryRun bearerRequired
|
|
]
|
|
where
|
|
bearerDryRun = has (_Just . _Object . ix "dry-run") <$> maybeCurrentBearerRestrictions @Value
|
|
bearerRequired = maybeT (return True) . catchIfMaybeT cPred $ do
|
|
mAuthId <- liftHandler defaultMaybeAuthId
|
|
currentRoute <- liftHandler $ maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
|
|
isWrite <- liftHandler $ isWriteRequest currentRoute
|
|
|
|
let noTokenAuth :: AuthDNF -> AuthDNF
|
|
noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
|
|
|
|
dnf <- throwLeft $ routeAuthTags currentRoute
|
|
let eval :: forall m'. MonadAP m' => AuthTagsEval m'
|
|
eval dnf' mAuthId' route' isWrite' = evalAuthTags 'isDryRun (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId' route' isWrite'
|
|
in guardAuthResult <=< evalWriterT $ eval dnf mAuthId currentRoute isWrite
|
|
|
|
return False
|
|
|
|
cPred err = any ($ err)
|
|
[ is $ _HCError . _PermissionDenied
|
|
, is $ _HCError . _NotAuthenticated
|
|
]
|
|
|
|
|
|
askBearerUnsafe :: forall m.
|
|
( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, BearerAuthSite UniWorX
|
|
)
|
|
=> ExceptT AuthResult m (BearerToken UniWorX)
|
|
-- | This performs /no/ meaningful validation of the `BearerToken`
|
|
--
|
|
-- Use `requireBearerToken` or `maybeBearerToken` instead
|
|
askBearerUnsafe = ExceptT . $cachedHere . liftHandler . runExceptT $ do
|
|
bearer <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askBearer
|
|
catch (decodeBearer bearer) $ \case
|
|
BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired
|
|
BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted
|
|
other -> do
|
|
$logWarnS "AuthToken" $ tshow other
|
|
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid
|
|
|
|
validateBearer :: forall m.
|
|
( HasCallStack
|
|
, MonadHandler m, HandlerSite m ~ UniWorX
|
|
, MonadCatch m, MonadAP m
|
|
, BearerAuthSite UniWorX
|
|
)
|
|
=> Maybe (AuthId UniWorX)
|
|
-> Route UniWorX
|
|
-> Bool -- ^ @isWrite@
|
|
-> BearerToken UniWorX
|
|
-> m AuthResult
|
|
validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo validateBearer' mAuthId' route' isWrite' token'
|
|
where
|
|
validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult m AuthResult
|
|
validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
|
|
iforM_ bearerRoutes $ \case
|
|
BearerTokenRouteEval -> \routes -> guardMExceptT (HashSet.member route routes) $ unauthorizedI MsgUnauthorizedTokenInvalidRoute
|
|
BearerTokenRouteAccess -> \routes -> maybeTMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidRoute) $ do
|
|
cRoute <- MaybeT getCurrentRoute
|
|
guard $ HashSet.member cRoute routes
|
|
|
|
let
|
|
-- Prevent infinite loops
|
|
noTokenAuth :: AuthDNF -> AuthDNF
|
|
noTokenAuth = over _dnfTerms . Set.filter . noneOf (re _nullable . folded) $ (== AuthToken) . plVar
|
|
|
|
eval :: forall m'. MonadAP m' => AuthTagsEval m'
|
|
eval dnf' mAuthId'' route'' isWrite'' = evalAuthTags 'validateBearer (AuthTagActive $ const True) eval (noTokenAuth dnf') mAuthId'' route'' isWrite''
|
|
|
|
bearerAuthority' <- hoist apRunDB $ do
|
|
bearerAuthority' <- flip foldMapM bearerAuthority $ \case
|
|
Left tVal
|
|
| JSON.Success groupName <- JSON.fromJSON tVal -> do
|
|
Entity _ primary <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . getBy $ UniquePrimaryUserGroupMember groupName Active
|
|
case bearerImpersonate of
|
|
Nothing -> return . Set.singleton $ userGroupMemberUser primary
|
|
Just iuid | iuid == userGroupMemberUser primary -> return . Set.singleton $ userGroupMemberUser primary
|
|
| otherwise -> do
|
|
unlessM (lift $ exists [UserGroupMemberUser ==. iuid, UserGroupMemberGroup ==. groupName]) $
|
|
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation
|
|
return $ Set.singleton iuid
|
|
| otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
|
|
Right uid -> case bearerImpersonate of
|
|
Just iuid | uid == iuid -> return $ Set.singleton uid
|
|
| otherwise -> do
|
|
cID <- encrypt iuid
|
|
unlessM (lift $ is _Authorized <$> evalAccessWithFor [(AuthToken, False)] (Just uid) (AdminHijackUserR cID) True) $
|
|
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation
|
|
return $ Set.singleton iuid
|
|
Nothing -> return $ Set.singleton uid
|
|
|
|
guardMExceptT (not $ Set.null bearerAuthority') $ unauthorizedI MsgUnauthorizedTokenInvalidNoAuthority
|
|
|
|
forM_ bearerAuthority' $ \uid -> do
|
|
User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get uid
|
|
guardMExceptT (Just bearerIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired)
|
|
|
|
return bearerAuthority'
|
|
|
|
forM_ bearerAuthority' $ \uid -> do
|
|
authorityVal <- do
|
|
dnf <- throwLeft $ routeAuthTags route
|
|
lift . evalWriterT $ eval (noTokenAuth dnf) (Just uid) route isWrite
|
|
guardExceptT (is _Authorized authorityVal) authorityVal
|
|
|
|
whenIsJust bearerAddAuth $ \addDNF -> do
|
|
$logDebugS "validateToken" $ tshow addDNF
|
|
additionalVal <- lift . evalWriterT $ eval (noTokenAuth addDNF) mAuthId route isWrite
|
|
guardExceptT (is _Authorized additionalVal) additionalVal
|
|
|
|
return Authorized
|
|
|
|
maybeBearerToken :: ( HasCallStack
|
|
, MonadHandler m, HandlerSite m ~ UniWorX
|
|
, BearerAuthSite UniWorX
|
|
, MonadAP m
|
|
, MonadCatch m
|
|
) => m (Maybe (BearerToken UniWorX))
|
|
maybeBearerToken = $cachedHere . runMaybeT $ catchIfMaybeT cPred requireBearerToken
|
|
where
|
|
cPred err = any ($ err)
|
|
[ is $ _HCError . _PermissionDenied
|
|
, is $ _HCError . _NotAuthenticated
|
|
]
|
|
|
|
requireBearerToken :: forall m.
|
|
( HasCallStack
|
|
, MonadHandler m, HandlerSite m ~ UniWorX
|
|
, BearerAuthSite UniWorX
|
|
, MonadAP m
|
|
, MonadCatch m
|
|
)
|
|
=> m (BearerToken UniWorX)
|
|
requireBearerToken = do
|
|
bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe
|
|
mAuthId <- defaultMaybeAuthId -- `maybeAuthId` would be an infinite loop; this is equivalent to `maybeAuthId` but ignoring `bearerImpersonate` from any valid token
|
|
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
|
|
isWrite <- liftHandler $ isWriteRequest currentRoute
|
|
guardAuthResult =<< validateBearer mAuthId currentRoute isWrite bearer
|
|
return bearer
|
|
|
|
requireCurrentBearerRestrictions :: forall a m.
|
|
( HasCallStack
|
|
, MonadHandler m, HandlerSite m ~ UniWorX
|
|
, FromJSON a, ToJSON a
|
|
, BearerAuthSite UniWorX
|
|
, MonadAP m
|
|
, MonadCatch m
|
|
)
|
|
=> m (Maybe a)
|
|
requireCurrentBearerRestrictions = runMaybeT $ do
|
|
bearer <- lift requireBearerToken
|
|
route <- MaybeT getCurrentRoute
|
|
hoistMaybe $ bearer ^? _bearerRestrictionIx route
|
|
|
|
maybeCurrentBearerRestrictions :: forall a m.
|
|
( HasCallStack
|
|
, MonadHandler m, HandlerSite m ~ UniWorX
|
|
, FromJSON a, ToJSON a
|
|
, BearerAuthSite UniWorX
|
|
, MonadAP m
|
|
, MonadCatch m
|
|
)
|
|
=> m (Maybe a)
|
|
maybeCurrentBearerRestrictions = runMaybeT $ do
|
|
bearer <- MaybeT maybeBearerToken
|
|
route <- MaybeT getCurrentRoute
|
|
hoistMaybe $ bearer ^? _bearerRestrictionIx route
|
|
|
|
data AuthorizationCacheKey
|
|
= AuthCacheSchoolFunctionList SchoolFunction | AuthCacheSystemFunctionList SystemFunction
|
|
| AuthCacheLecturerList | AuthCacheExternalExamStaffList | AuthCacheCorrectorList | AuthCacheExamCorrectorList | AuthCacheTutorList | AuthCacheSubmissionGroupUserList
|
|
| AuthCacheCourseRegisteredList TermId SchoolId CourseShorthand
|
|
| AuthCacheVisibleSystemMessages
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving anyclass (Hashable, Binary)
|
|
|
|
cacheAPSchoolFunction :: BearerAuthSite UniWorX
|
|
=> SchoolFunction
|
|
-> Maybe Expiry
|
|
-> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Set (AuthId UniWorX) -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
|
|
-> AccessPredicate
|
|
cacheAPSchoolFunction f mExp = cacheAPDB mExp (AuthCacheSchoolFunctionList f) mkFunctionList
|
|
where
|
|
mkFunctionList = fmap (setOf $ folded . _Value) . E.select . E.from $ \userFunction -> do
|
|
E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val f
|
|
return $ userFunction E.^. UserFunctionUser
|
|
|
|
cacheAPSystemFunction :: BearerAuthSite UniWorX
|
|
=> SystemFunction
|
|
-> Maybe Expiry
|
|
-> (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Set (AuthId UniWorX) -> Either AccessPredicate (HandlerFor UniWorX AuthResult))
|
|
-> AccessPredicate
|
|
cacheAPSystemFunction f mExp = cacheAPDB mExp (AuthCacheSystemFunctionList f) mkFunctionList
|
|
where
|
|
mkFunctionList = fmap (setOf $ folded . _Value) . E.select . E.from $ \userSystemFunction -> do
|
|
E.where_ $ userSystemFunction E.^. UserSystemFunctionFunction E.==. E.val f
|
|
E.&&. E.not_ (userSystemFunction E.^. UserSystemFunctionIsOptOut)
|
|
return $ userSystemFunction E.^. UserSystemFunctionUser
|
|
|
|
tagAccessPredicate :: ( HasCallStack
|
|
, BearerAuthSite UniWorX
|
|
)
|
|
=> AuthTag -> AccessPredicate
|
|
tagAccessPredicate AuthFree = trueAP
|
|
tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right diffHour) $ \mAuthId' route' _ adminList -> if
|
|
| maybe True (`Set.notMember` adminList) mAuthId' -> Right $ case route' of
|
|
_ | is _Nothing mAuthId' -> return AuthenticationRequired
|
|
CourseR{} -> unauthorizedI MsgUnauthorizedSchoolAdmin
|
|
AllocationR{} -> unauthorizedI MsgUnauthorizedSchoolAdmin
|
|
SchoolR _ _ -> unauthorizedI MsgUnauthorizedSchoolAdmin
|
|
_other -> unauthorizedI MsgUnauthorizedSiteAdmin
|
|
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
|
|
-- Courses: access only to school admins
|
|
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do
|
|
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool
|
|
E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId
|
|
E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
guardMExceptT isAdmin $ unauthorizedI MsgUnauthorizedSchoolAdmin
|
|
return Authorized
|
|
-- Allocations: access only to school admins
|
|
AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do
|
|
E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool
|
|
E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId
|
|
E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
|
E.&&. allocation E.^. AllocationTerm E.==. E.val tid
|
|
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
|
|
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
|
|
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
|
|
return Authorized
|
|
-- Schools: access only to school admins
|
|
SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isAdmin <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAdmin
|
|
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
|
|
return Authorized
|
|
-- other routes: access to any admin is granted here
|
|
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
|
|
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
|
|
return Authorized
|
|
tagAccessPredicate AuthSystemExamOffice = cacheAPSystemFunction SystemExamOffice (Just $ Right diffHour) $ \mAuthId' _ _ examOfficeList -> if
|
|
| maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ if
|
|
| is _Nothing mAuthId' -> return AuthenticationRequired
|
|
| otherwise -> unauthorizedI MsgUnauthorizedSystemExamOffice
|
|
| otherwise -> Left $ APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False]
|
|
guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice
|
|
return Authorized
|
|
tagAccessPredicate AuthStudent = cacheAPSystemFunction SystemStudent (Just $ Right diffHour) $ \mAuthId' _ _ studentList -> if
|
|
| maybe True (`Set.notMember` studentList) mAuthId' -> Right $ if
|
|
| is _Nothing mAuthId' -> return AuthenticationRequired
|
|
| otherwise -> unauthorizedI MsgUnauthorizedStudent
|
|
| otherwise -> Left $ APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isStudent <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemStudent, UserSystemFunctionIsOptOut ==. False]
|
|
guardMExceptT isStudent $ unauthorizedI MsgUnauthorizedStudent
|
|
return Authorized
|
|
tagAccessPredicate AuthExamOffice = cacheAPSchoolFunction SchoolExamOffice (Just $ Right diffHour) $ \mAuthId' route' _ examOfficeList -> if
|
|
| maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ case route' of
|
|
_ | is _Nothing mAuthId' -> return AuthenticationRequired
|
|
CExamR{} -> unauthorizedI MsgUnauthorizedExamExamOffice
|
|
EExamR{} -> unauthorizedI MsgUnauthorizedExternalExamExamOffice
|
|
CourseR{} -> unauthorizedI MsgUnauthorizedExamExamOffice
|
|
SchoolR _ _ -> unauthorizedI MsgUnauthorizedSchoolExamOffice
|
|
_other -> unauthorizedI MsgUnauthorizedExamOffice
|
|
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
|
|
CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
|
|
E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
|
E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
|
|
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. exam E.^. ExamName E.==. E.val examn
|
|
|
|
E.where_ $ examOfficeExamResultAuth (E.val authId) examResult
|
|
guardMExceptT hasUsers (unauthorizedI MsgUnauthorizedExamExamOffice)
|
|
return Authorized
|
|
EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
hasUsers <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do
|
|
E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam
|
|
|
|
E.where_ $ eexam E.^. ExternalExamTerm E.==. E.val tid
|
|
E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh
|
|
E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen
|
|
E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn
|
|
|
|
E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult
|
|
guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice
|
|
return Authorized
|
|
CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice
|
|
guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedExamExamOffice
|
|
return Authorized
|
|
SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice
|
|
guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedSchoolExamOffice)
|
|
return Authorized
|
|
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
|
|
guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice)
|
|
return Authorized
|
|
tagAccessPredicate AuthEvaluation = cacheAPSchoolFunction SchoolEvaluation (Just $ Right diffHour) $ \mAuthId' _ _ evaluationList -> if
|
|
| maybe True (`Set.notMember` evaluationList) mAuthId' -> Right $ if
|
|
| is _Nothing mAuthId' -> return AuthenticationRequired
|
|
| otherwise -> unauthorizedI MsgUnauthorizedEvaluation
|
|
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
|
|
ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
|
|
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
|
|
return Authorized
|
|
CourseR _ ssh _ _ -> $cachedHereBinary(mAuthId, ssh) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
|
|
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
|
|
return Authorized
|
|
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation]
|
|
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
|
|
return Authorized
|
|
tagAccessPredicate AuthAllocationAdmin = cacheAPSchoolFunction SchoolAllocation (Just $ Right diffHour) $ \mAuthId' _ _ allocationList -> if
|
|
| maybe True (`Set.notMember` allocationList) mAuthId' -> Right $ if
|
|
| is _Nothing mAuthId' -> return AuthenticationRequired
|
|
| otherwise -> unauthorizedI MsgUnauthorizedAllocationAdmin
|
|
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
|
|
AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
|
|
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
|
|
return Authorized
|
|
CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
|
|
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
|
|
return Authorized
|
|
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation]
|
|
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
|
|
return Authorized
|
|
tagAccessPredicate AuthToken = APDB $ \_ _ mAuthId route isWrite -> exceptT return return $
|
|
lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe
|
|
tagAccessPredicate AuthNoEscalation = APDB $ \_ _ mAuthId route _ -> case route of
|
|
AdminHijackUserR cID -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
|
|
myUid <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
uid <- decrypt cID
|
|
otherSchoolsFunctions <- lift . $cachedHereBinary uid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. uid] []
|
|
mySchools <- lift . $cachedHereBinary myUid $ Set.fromList . map (userFunctionSchool . entityVal) <$> selectList [UserFunctionUser ==. myUid, UserFunctionFunction ==. SchoolAdmin] []
|
|
guardMExceptT (otherSchoolsFunctions `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation)
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthNoEscalation r
|
|
tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do
|
|
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
|
|
addMessageI Error MsgDeprecatedRoute
|
|
allow <- getsYesod $ view _appAllowDeprecated
|
|
return $ bool (Unauthorized "Deprecated Route") Authorized allow
|
|
tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
|
|
$logWarnS "AccessControl" ("route in development: " <> tshow r)
|
|
#ifdef DEVELOPMENT
|
|
return Authorized
|
|
#else
|
|
return $ Unauthorized "Route under development"
|
|
#endif
|
|
|
|
tagAccessPredicate AuthLecturer = cacheAPDB' (Just $ Right diffMinute) mkLecturerList $ \mAuthId' route' _ mLecturerList -> if
|
|
| Just lecturerList <- mLecturerList
|
|
, maybe True (`Set.notMember` lecturerList) mAuthId' -> Right $ case route' of
|
|
_ | is _Nothing mAuthId' -> return AuthenticationRequired
|
|
CourseR{} -> unauthorizedI MsgUnauthorizedLecturer
|
|
AllocationR{} -> unauthorizedI MsgUnauthorizedAllocationLecturer
|
|
EExamR{} -> unauthorizedI MsgUnauthorizedExternalExamLecturer
|
|
_other -> unauthorizedI MsgUnauthorizedSchoolLecturer
|
|
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
|
|
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do
|
|
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
|
|
return Authorized
|
|
AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
|
|
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
|
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
|
|
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
|
|
E.&&. allocation E.^. AllocationTerm E.==. E.val tid
|
|
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
|
|
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
|
|
guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedAllocationLecturer
|
|
return Authorized
|
|
EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isLecturer <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` staff) -> do
|
|
E.on $ eexam E.^. ExternalExamId E.==. staff E.^. ExternalExamStaffExam
|
|
E.where_ $ staff E.^. ExternalExamStaffUser E.==. E.val authId
|
|
E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid
|
|
E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh
|
|
E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen
|
|
E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn
|
|
guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedExternalExamLecturer
|
|
return Authorized
|
|
-- lecturer for any school will do
|
|
_ -> $cachedHereBinary mAuthId . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] []
|
|
return Authorized
|
|
where
|
|
mkLecturerList _ route _ = case route of
|
|
CourseR{} -> cacheLecturerList
|
|
AllocationR{} -> cacheLecturerList
|
|
EExamR{} -> Just
|
|
( AuthCacheExternalExamStaffList
|
|
, fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExternalExamStaffUser)
|
|
)
|
|
_other -> Just
|
|
( AuthCacheSchoolFunctionList SchoolLecturer
|
|
, fmap (setOf $ folded . _Value) . E.select . E.from $ \userFunction -> do
|
|
E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolLecturer
|
|
return $ userFunction E.^. UserFunctionUser
|
|
)
|
|
where
|
|
cacheLecturerList = Just
|
|
( AuthCacheLecturerList
|
|
, fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. LecturerUser)
|
|
)
|
|
tagAccessPredicate AuthCorrector = cacheAPDB (Just $ Right diffMinute) AuthCacheCorrectorList mkCorrectorList $ \mAuthId' route' _ correctorList -> if
|
|
| maybe True (`Set.notMember` correctorList) mAuthId' -> Right $ case route' of
|
|
_ | is _Nothing mAuthId' -> return AuthenticationRequired
|
|
CSubmissionR{} -> unauthorizedI MsgUnauthorizedSubmissionCorrector
|
|
CSheetR{} -> unauthorizedI MsgUnauthorizedSheetCorrector
|
|
CourseR{} -> unauthorizedI MsgUnauthorizedCorrector
|
|
_other -> unauthorizedI MsgUnauthorizedCorrectorAny
|
|
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
case route of
|
|
CSubmissionR _ _ _ _ cID _ -> lift . $cachedHereBinary (authId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
|
|
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
guardM . lift . E.selectExists . E.from $ \submission ->
|
|
E.where_ $ submission E.^. SubmissionId E.==. E.val sid
|
|
E.&&. submission E.^. SubmissionRatingBy E.==. E.justVal authId
|
|
return Authorized
|
|
CSheetR tid ssh csh shn _ -> lift . $cachedHereBinary (authId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
|
|
guardM . lift . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
|
|
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
|
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
|
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. sheet E.^. SheetName E.==. E.val shn
|
|
return Authorized
|
|
CourseR tid ssh csh _ -> lift . $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
|
|
guardM . lift . E.selectExists . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
|
|
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
|
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
|
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
return Authorized
|
|
_ -> lift . $cachedHereBinary mAuthId . maybeT (unauthorizedI MsgUnauthorizedCorrectorAny) $ do
|
|
guardM . lift . E.selectExists . E.from $ \sheetCorrector ->
|
|
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
|
|
return Authorized
|
|
where
|
|
mkCorrectorList = do
|
|
submissionCorrectors <- E.select . E.from $ \submission -> E.distinctOnOrderBy [E.asc $ submission E.^. SubmissionRatingBy] $ do
|
|
E.where_ . E.isJust $ submission E.^. SubmissionRatingBy
|
|
return $ submission E.^. SubmissionRatingBy
|
|
let submissionCorrectors' = Set.fromDistinctAscList $ mapMaybe (preview $ _Value . _Just) submissionCorrectors
|
|
|
|
sheetCorrectors <- E.select . E.from $ \sheetCorrector -> E.distinctOnOrderBy [E.asc $ sheetCorrector E.^. SheetCorrectorUser] $
|
|
return $ sheetCorrector E.^. SheetCorrectorUser
|
|
let sheetCorrectors' = Set.fromDistinctAscList $ map (^. _Value) sheetCorrectors
|
|
|
|
return $ submissionCorrectors' `Set.union` sheetCorrectors'
|
|
tagAccessPredicate AuthExamCorrector = cacheAPDB (Just $ Right diffMinute) AuthCacheExamCorrectorList mkExamCorrectorList $ \mAuthId' route' _ examCorrectorList -> if
|
|
| maybe True (`Set.notMember` examCorrectorList) mAuthId' -> Right $ case route' of
|
|
_ | is _Nothing mAuthId' -> return AuthenticationRequired
|
|
CExamR{} -> unauthorizedI MsgUnauthorizedExamCorrector
|
|
CourseR{} -> unauthorizedI MsgUnauthorizedExamCorrector
|
|
r -> $unsupportedAuthPredicate AuthExamCorrector r
|
|
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
|
|
CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
|
|
E.on $ examCorrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId
|
|
E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
|
|
E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. exam E.^. ExamName E.==. E.val examn
|
|
guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
|
|
return Authorized
|
|
CourseR tid ssh csh _ -> $cachedHereBinary (tid, ssh, csh) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam
|
|
E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthExamCorrector r
|
|
where
|
|
mkExamCorrectorList = fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExamCorrectorUser)
|
|
tagAccessPredicate AuthTutor = cacheAPDB (Just $ Right diffMinute) AuthCacheTutorList mkTutorList $ \mAuthId' route' _ tutorList -> if
|
|
| maybe True (`Set.notMember` tutorList) mAuthId' -> Right $ case route' of
|
|
_ | is _Nothing mAuthId' -> return AuthenticationRequired
|
|
CTutorialR{} -> unauthorizedI MsgUnauthorizedTutorialTutor
|
|
CourseR{} -> unauthorizedI MsgUnauthorizedCourseTutor
|
|
_other -> unauthorizedI MsgUnauthorizedTutor
|
|
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
|
|
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
|
E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId
|
|
E.where_ $ tutor E.^. TutorUser E.==. E.val authId
|
|
return (course E.^. CourseId, tutorial E.^. TutorialId)
|
|
let
|
|
resMap :: Map CourseId (Set TutorialId)
|
|
resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ]
|
|
case route of
|
|
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do
|
|
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity tutid _ <- $cachedHereBinary (cid, tutn) . MaybeT . lift . getBy $ UniqueTutorial cid tutn
|
|
guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid)
|
|
return Authorized
|
|
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do
|
|
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
|
guard $ cid `Set.member` Map.keysSet resMap
|
|
return Authorized
|
|
_ -> do
|
|
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
|
|
return Authorized
|
|
where
|
|
mkTutorList = fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. TutorUser)
|
|
tagAccessPredicate AuthTutorControl = APDB $ \_ _ _ route _ -> case route of
|
|
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do
|
|
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
|
|
guard tutorialTutorControlled
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthTutorControl r
|
|
tagAccessPredicate AuthSubmissionGroup = APDB $ \_ _ mAuthId route _ -> case route of
|
|
CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do
|
|
course <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ Sheet{..} <- MaybeT . $cachedHereBinary (course, shn) . getBy $ CourseSheet course shn
|
|
when (is _RegisteredGroups sheetGrouping) $ do
|
|
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do
|
|
E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser
|
|
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId
|
|
return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
|
unless (Set.null groups) $ do
|
|
uid <- hoistMaybe mAuthId
|
|
guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups]
|
|
return Authorized
|
|
CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do
|
|
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ Sheet{..} <- $cachedHereBinary (course, sheetn) . MaybeT . getBy $ CourseSheet course sheetn
|
|
when (is _RegisteredGroups sheetGrouping) $ do
|
|
uid <- hoistMaybe mAuthId
|
|
guardM . lift . E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
|
|
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
|
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val course
|
|
E.&&. submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
|
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthSubmissionGroup r
|
|
tagAccessPredicate AuthTime = APDB $ \_ (runTACont -> cont) mAuthId route isWrite -> case route of
|
|
CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
|
|
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity eId Exam{..} <- $cachedHereBinary (course, examn) . MaybeT . getBy $ UniqueExam course examn
|
|
cTime <- liftIO getCurrentTime
|
|
registration <- case mAuthId of
|
|
Just uid -> $cachedHereBinary (eId, uid) . lift . getBy $ UniqueExamRegistration eId uid
|
|
Nothing -> return Nothing
|
|
|
|
let visible = NTop examVisibleFrom <= NTop (Just cTime)
|
|
|
|
case subRoute of
|
|
EShowR -> guard visible
|
|
EUsersR -> guard $ NTop examStart <= NTop (Just cTime)
|
|
&& NTop (Just cTime) <= NTop examFinished
|
|
ERegisterR
|
|
| is _Nothing registration
|
|
-> guard $ visible
|
|
&& NTop examRegisterFrom <= NTop (Just cTime)
|
|
&& NTop (Just cTime) <= NTop examRegisterTo
|
|
| otherwise
|
|
-> guard $ visible
|
|
&& NTop (Just cTime) <= NTop examDeregisterUntil
|
|
ERegisterOccR occn -> do
|
|
occId <- hoistMaybe <=< $cachedHereBinary (eId, occn) . lift . getKeyBy $ UniqueExamOccurrence eId occn
|
|
if
|
|
| (registration >>= examRegistrationOccurrence . entityVal) == Just occId
|
|
-> guard $ visible
|
|
&& NTop (Just cTime) <= NTop examDeregisterUntil
|
|
| otherwise
|
|
-> guard $ visible
|
|
&& NTop examRegisterFrom <= NTop (Just cTime)
|
|
&& NTop (Just cTime) <= NTop examRegisterTo
|
|
ECorrectR -> guard $ NTop (Just cTime) >= NTop examStart
|
|
&& NTop (Just cTime) <= NTop examFinished
|
|
_ -> return ()
|
|
|
|
return Authorized
|
|
|
|
CTutorialR tid ssh csh tutn TRegisterR -> maybeT (unauthorizedI MsgUnauthorizedTutorialTime) $ do
|
|
now <- liftIO getCurrentTime
|
|
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity tutId Tutorial{..} <- $cachedHereBinary (course, tutn) . MaybeT . getBy $ UniqueTutorial course tutn
|
|
registered <- case mAuthId of
|
|
Just uid -> $cachedHereBinary (tutId, uid) . lift . existsBy $ UniqueTutorialParticipant tutId uid
|
|
Nothing -> return False
|
|
|
|
if
|
|
| not registered
|
|
, maybe False (now >=) tutorialRegisterFrom
|
|
, maybe True (now <=) tutorialRegisterTo
|
|
-> return Authorized
|
|
| registered
|
|
, maybe True (now <=) tutorialDeregisterUntil
|
|
-> return Authorized
|
|
| otherwise
|
|
-> mzero
|
|
|
|
CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
|
|
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _sid Sheet{..} <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
|
|
cTime <- liftIO getCurrentTime
|
|
let
|
|
visible = NTop sheetVisibleFrom <= NTop (Just cTime)
|
|
active = NTop sheetActiveFrom <= NTop (Just cTime) && NTop (Just cTime) <= NTop sheetActiveTo
|
|
marking = NTop (Just cTime) > NTop sheetActiveTo
|
|
|
|
guard visible
|
|
|
|
case subRoute of
|
|
-- Single Files
|
|
SFileR SheetExercise _ -> guard $ NTop sheetActiveFrom <= NTop (Just cTime)
|
|
SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
|
|
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
|
|
SFileR _ _ -> mzero
|
|
-- Archives of SheetFileType
|
|
SZipR SheetExercise -> guard $ NTop sheetActiveFrom <= NTop (Just cTime)
|
|
SZipR SheetHint -> guard $ maybe False (<= cTime) sheetHintFrom
|
|
SZipR SheetSolution -> guard $ maybe False (<= cTime) sheetSolutionFrom
|
|
SZipR _ -> mzero
|
|
-- Submissions
|
|
SubmissionNewR -> guard active
|
|
SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change; this is assumed in Corrections.assignHandler
|
|
SubmissionR _ SubAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
|
|
SubmissionR _ _ -> guard active
|
|
_ -> return ()
|
|
|
|
return Authorized
|
|
|
|
CourseR tid ssh csh (MaterialR mnm _) -> maybeT (unauthorizedI MsgUnauthorizedMaterialTime) $ do
|
|
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _mid Material{materialVisibleFrom} <- $cachedHereBinary (cid, mnm) . MaybeT . getBy $ UniqueMaterial cid mnm
|
|
cTime <- liftIO getCurrentTime
|
|
let visible = NTop materialVisibleFrom <= NTop (Just cTime)
|
|
guard visible
|
|
return Authorized
|
|
|
|
CourseR tid ssh csh CRegisterR -> do
|
|
now <- liftIO getCurrentTime
|
|
mbc <- $cachedHereBinary (tid, ssh, csh) . getBy $ TermSchoolCourseShort tid ssh csh
|
|
registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite
|
|
case mbc of
|
|
(Just (Entity _ Course{courseRegisterFrom, courseRegisterTo}))
|
|
| not registered
|
|
, maybe False (now >=) courseRegisterFrom -- Nothing => no registration allowed
|
|
, maybe True (now <=) courseRegisterTo -> return Authorized
|
|
(Just (Entity cid Course{courseDeregisterUntil}))
|
|
| registered
|
|
-> maybeT (unauthorizedI MsgUnauthorizedCourseRegistrationTime) $ do
|
|
guard $ maybe True (now <=) courseDeregisterUntil
|
|
forM_ mAuthId $ \uid -> do
|
|
exams <- lift . E.select . E.from $ \exam -> do
|
|
E.where_ . E.exists . E.from $ \examRegistration ->
|
|
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
|
E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
|
|
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
|
|
return $ exam E.^. ExamDeregisterUntil
|
|
forM_ exams $ \(E.Value deregUntil) ->
|
|
guard $ NTop (Just now) <= NTop deregUntil
|
|
|
|
tutorials <- lift . E.select . E.from $ \tutorial -> do
|
|
E.where_ . E.exists . E.from $ \tutorialParticipant ->
|
|
E.where_ $ tutorialParticipant E.^. TutorialParticipantTutorial E.==. tutorial E.^. TutorialId
|
|
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. E.val uid
|
|
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
|
|
return $ tutorial E.^. TutorialDeregisterUntil
|
|
forM_ tutorials $ \(E.Value deregUntil) ->
|
|
guard $ NTop (Just now) <= NTop deregUntil
|
|
return Authorized
|
|
_other -> unauthorizedI MsgUnauthorizedCourseRegistrationTime
|
|
|
|
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
|
|
Entity course Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
|
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
|
|
allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation
|
|
|
|
case allocation of
|
|
Nothing -> do
|
|
cTime <- liftIO getCurrentTime
|
|
guard $ maybe False (cTime >=) courseRegisterFrom
|
|
guard $ maybe True (cTime <=) courseRegisterTo
|
|
Just Allocation{..} -> do
|
|
cTime <- liftIO getCurrentTime
|
|
guard $ NTop allocationRegisterFrom <= NTop (Just cTime)
|
|
guard $ NTop (Just cTime) <= NTop allocationRegisterTo
|
|
|
|
return Authorized
|
|
|
|
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
|
|
-- Checks `registerFrom` and `registerTo`, override as further routes become available
|
|
now <- liftIO getCurrentTime
|
|
Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash
|
|
guard $ NTop allocationRegisterFrom <= NTop (Just now)
|
|
guard $ NTop (Just now) <= NTop allocationRegisterTo
|
|
return Authorized
|
|
|
|
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
|
|
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
cTime <- liftIO getCurrentTime
|
|
let cacheTime = diffDay
|
|
massageVisible = Map.fromList . map (over _1 E.unValue . over (_2 . _1) E.unValue . over (_2 . _2) E.unValue)
|
|
visibleSystemMessages <- lift . memcacheAuth' @(Map SystemMessageId (Maybe UTCTime, Maybe UTCTime)) (Right cacheTime) AuthCacheVisibleSystemMessages . fmap massageVisible . E.select . E.from $ \systemMessage -> do
|
|
E.where_ $ E.maybe E.true (E.>=. E.val cTime) (systemMessage E.^. SystemMessageTo)
|
|
E.&&. E.maybe E.false (E.<=. E.val (realToFrac diffDay `addUTCTime` cTime)) (systemMessage E.^. SystemMessageFrom) -- good enough.
|
|
return
|
|
( systemMessage E.^. SystemMessageId
|
|
, ( systemMessage E.^. SystemMessageFrom
|
|
, systemMessage E.^. SystemMessageTo
|
|
)
|
|
)
|
|
(msgFrom, msgTo) <- hoistMaybe $ Map.lookup smId visibleSystemMessages
|
|
let cTime' = NTop $ Just cTime
|
|
guard $ NTop msgFrom <= cTime'
|
|
&& NTop msgTo >= cTime'
|
|
return Authorized
|
|
|
|
MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
|
|
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
SystemMessage{systemMessageFrom, systemMessageTo} <- $cachedHereBinary smId . MaybeT $ get smId
|
|
cTime <- NTop . Just <$> liftIO getCurrentTime
|
|
guard $ NTop systemMessageFrom <= cTime
|
|
&& NTop systemMessageTo >= cTime
|
|
return Authorized
|
|
|
|
CNewsR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedCourseNewsTime) $ do
|
|
nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
CourseNews{courseNewsVisibleFrom} <- $cachedHereBinary nId . MaybeT $ get nId
|
|
cTime <- NTop . Just <$> liftIO getCurrentTime
|
|
guard $ NTop courseNewsVisibleFrom <= cTime
|
|
return Authorized
|
|
|
|
r -> $unsupportedAuthPredicate AuthTime r
|
|
tagAccessPredicate AuthStaffTime = APDB $ \_ _ _ route isWrite -> case route of
|
|
CApplicationR tid ssh csh _ _ -> maybeT (unauthorizedI MsgUnauthorizedApplicationTime) $ do
|
|
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
allocationCourse <- $cachedHereBinary course . lift . getBy $ UniqueAllocationCourse course
|
|
allocation <- for allocationCourse $ \(Entity _ AllocationCourse{..}) -> $cachedHereBinary allocationCourseAllocation . MaybeT $ get allocationCourseAllocation
|
|
|
|
case allocation of
|
|
Nothing -> return ()
|
|
Just Allocation{..} -> do
|
|
cTime <- liftIO getCurrentTime
|
|
guard $ NTop allocationStaffAllocationFrom <= NTop (Just cTime)
|
|
when isWrite $
|
|
guard $ NTop (Just cTime) <= NTop allocationStaffAllocationTo
|
|
|
|
return Authorized
|
|
|
|
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegisterTime) $ do
|
|
-- Checks `registerFrom` and `registerTo`, override as further routes become available
|
|
now <- liftIO getCurrentTime
|
|
Entity _ Allocation{..} <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getBy $ TermSchoolAllocationShort tid ssh ash
|
|
guard $ NTop allocationStaffAllocationFrom <= NTop (Just now)
|
|
guard $ NTop (Just now) <= NTop allocationStaffAllocationTo
|
|
return Authorized
|
|
|
|
r -> $unsupportedAuthPredicate AuthStaffTime r
|
|
tagAccessPredicate AuthAllocationTime = APDB $ \_ (runTACont -> cont) mAuthId route isWrite -> case route of
|
|
CourseR tid ssh csh CRegisterR -> do
|
|
now <- liftIO getCurrentTime
|
|
mba <- mbAllocation tid ssh csh
|
|
case mba of
|
|
Nothing -> return Authorized
|
|
Just (_, Allocation{..}) -> do
|
|
registered <- cont (predDNFSingleton $ PLVariable AuthCourseRegistered) mAuthId route isWrite
|
|
if
|
|
| not registered
|
|
, NTop allocationRegisterByCourse >= NTop (Just now)
|
|
-> unauthorizedI MsgUnauthorizedAllocatedCourseRegister
|
|
| registered
|
|
, NTop (Just now) >= NTop allocationOverrideDeregister
|
|
-> unauthorizedI MsgUnauthorizedAllocatedCourseDeregister
|
|
| otherwise
|
|
-> return Authorized
|
|
|
|
CourseR tid ssh csh CAddUserR -> do
|
|
now <- liftIO getCurrentTime
|
|
mba <- mbAllocation tid ssh csh
|
|
case mba of
|
|
Just (_, Allocation{..})
|
|
| NTop allocationRegisterByStaffTo <= NTop (Just now)
|
|
|| NTop allocationRegisterByStaffFrom >= NTop (Just now)
|
|
-> unauthorizedI MsgUnauthorizedAllocatedCourseRegister
|
|
_other -> return Authorized
|
|
|
|
CourseR tid ssh csh CDeleteR -> do
|
|
now <- liftIO getCurrentTime
|
|
mba <- mbAllocation tid ssh csh
|
|
case mba of
|
|
Just (_, Allocation{..})
|
|
| NTop allocationRegisterByStaffTo <= NTop (Just now)
|
|
|| NTop allocationRegisterByStaffFrom >= NTop (Just now)
|
|
-> unauthorizedI MsgUnauthorizedAllocatedCourseDelete
|
|
_other -> return Authorized
|
|
|
|
r -> $unsupportedAuthPredicate AuthAllocationTime r
|
|
where
|
|
mbAllocation tid ssh csh = $cachedHereBinary (tid, ssh, csh) . runMaybeT $ do
|
|
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ AllocationCourse{..} <- MaybeT . getBy $ UniqueAllocationCourse cid
|
|
(cid,) <$> MaybeT (get allocationCourseAllocation)
|
|
tagAccessPredicate AuthCourseTime = APDB $ \_ _ _mAuthId route _ -> case route of
|
|
CourseR tid ssh csh _ -> exceptT return return $ do
|
|
now <- liftIO getCurrentTime
|
|
courseVisible <- $cachedHereBinary (tid, ssh, csh) . lift . E.selectExists . E.from $ \course -> do
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. courseIsVisible now course E.nothing
|
|
guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime)
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthCourseTime r
|
|
tagAccessPredicate AuthExamTime = APDB $ \_ _ _ route _ -> case route of
|
|
CSubmissionR tid ssh csh shn _cID CorrectionR -> maybeT (unauthorizedI MsgUnauthorizedCorrectionExamTime) $ do
|
|
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _sid Sheet{..} <- MaybeT . $cachedHereBinary (cid, shn) . getBy $ CourseSheet cid shn
|
|
whenIsJust (sheetType ^? _examPart . from _SqlKey) $ \epId -> do
|
|
ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId
|
|
Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam
|
|
now <- liftIO getCurrentTime
|
|
guard $ NTop (Just now) >= NTop examFinished
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthExamTime r
|
|
tagAccessPredicate AuthCourseRegistered = cacheAPDB' (Just $ Right diffMinute) mkAuthCacheCourseRegisteredList $ \mAuthId' route' _ mCourseRegisteredList -> if
|
|
| Just courseRegisteredList <- mCourseRegisteredList
|
|
, maybe True (`Set.notMember` courseRegisteredList) mAuthId' -> Right $ case route' of
|
|
_ | is _Nothing mAuthId' -> return AuthenticationRequired
|
|
CourseR{} -> unauthorizedI MsgUnauthorizedRegistered
|
|
r -> $unsupportedAuthPredicate AuthCourseRegistered r
|
|
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
|
|
CourseR tid ssh csh _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
|
|
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
|
|
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
|
|
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthCourseRegistered r
|
|
where
|
|
mkAuthCacheCourseRegisteredList _ route _ = case route of
|
|
CourseR tid ssh csh _ -> Just
|
|
( AuthCacheCourseRegisteredList tid ssh csh
|
|
, fmap (setOf $ folded . _Value) . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
|
|
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
|
|
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
return $ courseParticipant E.^. CourseParticipantUser
|
|
)
|
|
_other -> Nothing
|
|
tagAccessPredicate AuthTutorialRegistered = APDB $ \_ _ mAuthId route _ -> case route of
|
|
CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isRegistered <- $cachedHereBinary (authId, tid, ssh, csh, tutn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
|
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
|
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. tutorial E.^. TutorialName E.==. E.val tutn
|
|
guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
|
|
return Authorized
|
|
CourseR tid ssh csh _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialParticipant) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
|
|
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
|
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. E.val authId
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthTutorialRegistered r
|
|
tagAccessPredicate AuthExamOccurrenceRegistration = APDB $ \_ _ _ route _ -> case route of
|
|
CExamR tid ssh csh examn _ -> exceptT return return $ do
|
|
isOccurrenceRegistration <- $cachedHereBinary (tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam) -> do
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. exam E.^. ExamName E.==. E.val examn
|
|
E.&&. exam E.^. ExamOccurrenceRule E.==. E.val ExamRoomFifo
|
|
guardMExceptT isOccurrenceRegistration (unauthorizedI MsgUnauthorizedExamOccurrenceRegistration)
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistration r
|
|
tagAccessPredicate AuthExamOccurrenceRegistered = APDB $ \_ _ mAuthId route _ -> case route of
|
|
CExamR tid ssh csh examn (ERegisterOccR occn) -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn, occn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration `E.InnerJoin` examOccurrence) -> do
|
|
E.on $ E.just (examOccurrence E.^. ExamOccurrenceId) E.==. examRegistration E.^. ExamRegistrationOccurrence
|
|
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
|
|
E.&&. examOccurrence E.^. ExamOccurrenceName E.==. E.val occn
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. exam E.^. ExamName E.==. E.val examn
|
|
guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
|
|
return Authorized
|
|
CExamR tid ssh csh examn _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
|
|
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. exam E.^. ExamName E.==. E.val examn
|
|
E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence)
|
|
guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
|
|
return Authorized
|
|
CourseR tid ssh csh _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
|
|
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. E.not_ (E.isNothing $ examRegistration E.^. ExamRegistrationOccurrence)
|
|
guardMExceptT hasRegistration (unauthorizedI MsgUnauthorizedRegistered)
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthExamOccurrenceRegistered r
|
|
tagAccessPredicate AuthExamRegistered = APDB $ \_ _ mAuthId route _ -> case route of
|
|
CExamR tid ssh csh examn _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
|
|
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. exam E.^. ExamName E.==. E.val examn
|
|
guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredExam
|
|
return Authorized
|
|
CSheetR tid ssh csh shn _ -> exceptT return return $ do
|
|
requiredExam' <- $cachedHereBinary (tid, ssh, csh, shn) . lift . E.selectMaybe . E.from $ \(course `E.InnerJoin` sheet) -> do
|
|
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. sheet E.^. SheetName E.==. E.val shn
|
|
return $ sheet E.^. SheetRequireExamRegistration
|
|
requiredExam <- maybeMExceptT (unauthorizedI MsgUnauthorizedRegisteredExam) . return $ E.unValue <$> requiredExam'
|
|
whenIsJust requiredExam $ \eId -> do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
isRegistered <- $cachedHereBinary (authId, eId) . lift . E.selectExists . E.from $ \examRegistration ->
|
|
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId
|
|
E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val authId
|
|
guardMExceptT isRegistered $ unauthorizedI MsgUnauthorizedRegisteredExam
|
|
return Authorized
|
|
CourseR tid ssh csh _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
hasRegistration <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
|
|
E.on $ exam E.^. ExamId E.==. examRegistration E.^. ExamRegistrationExam
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val authId
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
guardMExceptT hasRegistration $ unauthorizedI MsgUnauthorizedRegisteredAnyExam
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthExamRegistered r
|
|
tagAccessPredicate AuthExamResult = APDB $ \_ _ mAuthId route _ -> case route of
|
|
CExamR tid ssh csh examn _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
hasResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
|
|
E.on $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ examResult E.^. ExamResultUser E.==. E.val authId
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. exam E.^. ExamName E.==. E.val examn
|
|
hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh, examn) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart `E.InnerJoin` examPartResult) -> do
|
|
E.on $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId
|
|
E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val authId
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. exam E.^. ExamName E.==. E.val examn
|
|
guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult)
|
|
return Authorized
|
|
EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
hasResult <- $cachedHereBinary (authId, tid, ssh, coursen, examn) . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do
|
|
E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam
|
|
E.where_ $ eexamResult E.^. ExternalExamResultUser E.==. E.val authId
|
|
E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid
|
|
E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh
|
|
E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen
|
|
E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn
|
|
guardMExceptT hasResult $ unauthorizedI MsgUnauthorizedExternalExamResult
|
|
return Authorized
|
|
CourseR tid ssh csh _ -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
hasResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
|
|
E.on $ exam E.^. ExamId E.==. examResult E.^. ExamResultExam
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ examResult E.^. ExamResultUser E.==. E.val authId
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
hasPartResult <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart `E.InnerJoin` examPartResult) -> do
|
|
E.on $ examPartResult E.^. ExamPartResultExamPart E.==. examPart E.^. ExamPartId
|
|
E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val authId
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
guardMExceptT (hasResult || hasPartResult) (unauthorizedI MsgUnauthorizedExamResult)
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthExamRegistered r
|
|
tagAccessPredicate AuthAllocationRegistered = APDB $ \_ _ mAuthId route _ -> case route of
|
|
AllocationR tid ssh ash _ -> maybeT (unauthorizedI MsgUnauthorizedAllocationRegistered) $ do
|
|
uid <- hoistMaybe mAuthId
|
|
aId <- MaybeT . $cachedHereBinary (tid, ssh, ash) . getKeyBy $ TermSchoolAllocationShort tid ssh ash
|
|
void . MaybeT . $cachedHereBinary (uid, aId) . getKeyBy $ UniqueAllocationUser aId uid
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthAllocationRegistered r
|
|
tagAccessPredicate AuthParticipant = APDB $ \_ _ mAuthId route _ -> case route of
|
|
CNewsR tid ssh csh cID _ -> maybeT (unauthorizedI MsgUnauthorizedParticipantSelf) $ do
|
|
nId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
CourseNews{courseNewsParticipantsOnly} <- $cachedHereBinary nId . MaybeT $ get nId
|
|
if | courseNewsParticipantsOnly -> do
|
|
uid <- hoistMaybe mAuthId
|
|
exceptT return (const mzero) . hoist lift $ isCourseParticipant tid ssh csh uid True
|
|
| otherwise
|
|
-> return Authorized
|
|
|
|
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
|
|
participant <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedParticipant) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
isCourseParticipant tid ssh csh participant False
|
|
unauthorizedI MsgUnauthorizedParticipant
|
|
|
|
r -> $unsupportedAuthPredicate AuthParticipant r
|
|
|
|
where
|
|
isCourseParticipant tid ssh csh participant onlyActive = do
|
|
let
|
|
authorizedIfExists :: E.From a => (a -> E.SqlQuery b) -> ExceptT AuthResult (ReaderT SqlReadBackend (HandlerFor UniWorX)) ()
|
|
authorizedIfExists = flip whenExceptT Authorized <=< lift . E.selectExists . E.from
|
|
-- participant is currently registered
|
|
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` courseParticipant) -> do
|
|
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
|
|
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
when onlyActive $
|
|
E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
-- participant has at least one submission
|
|
unless onlyActive $
|
|
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
|
|
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
|
|
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
-- participant is member of a submissionGroup
|
|
unless onlyActive $
|
|
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser) -> do
|
|
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
|
E.on $ course E.^. CourseId E.==. submissionGroup E.^. SubmissionGroupCourse
|
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
-- participant is a sheet corrector
|
|
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
|
|
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
-- participant is a tutorial user
|
|
unless onlyActive $
|
|
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutorialUser) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
|
|
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
|
E.where_ $ tutorialUser E.^. TutorialParticipantUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
-- participant is tutor for this course
|
|
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
|
|
E.on $ course E.^. CourseId E.==. tutorial E.^. TutorialCourse
|
|
E.where_ $ tutor E.^. TutorUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
-- participant is exam corrector for this course
|
|
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
|
|
E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
-- participant is lecturer for this course
|
|
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` lecturer) -> do
|
|
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
-- participant has an exam result for this course
|
|
unless onlyActive $
|
|
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do
|
|
E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ examResult E.^. ExamResultUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
-- participant is registered for an exam for this course
|
|
unless onlyActive $
|
|
mapExceptT ($cachedHereBinary (participant, tid, ssh, csh)) . authorizedIfExists $ \(course `E.InnerJoin` exam `E.InnerJoin` examRegistration) -> do
|
|
E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ examRegistration E.^. ExamRegistrationUser E.==. E.val participant
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
tagAccessPredicate AuthApplicant = APDB $ \_ _ mAuthId route _ -> case route of
|
|
CourseR tid ssh csh (CUserR cID) -> maybeT (unauthorizedI MsgUnauthorizedApplicant) $ do
|
|
uid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
isApplicant <- isCourseApplicant tid ssh csh uid
|
|
guard isApplicant
|
|
return Authorized
|
|
|
|
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedApplicantSelf) $ do
|
|
uid <- hoistMaybe mAuthId
|
|
isApplicant <- isCourseApplicant tid ssh csh uid
|
|
guard isApplicant
|
|
return Authorized
|
|
|
|
r -> $unsupportedAuthPredicate AuthApplicant r
|
|
where
|
|
isCourseApplicant tid ssh csh uid = lift . $cachedHereBinary (uid, tid, ssh, csh) . E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do
|
|
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
|
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val uid
|
|
E.&&. course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
tagAccessPredicate AuthCapacity = APDB $ \_ _ _ route _ -> case route of
|
|
CExamR tid ssh csh examn (ERegisterOccR occn) -> maybeT (unauthorizedI MsgExamOccurrenceNoCapacity) $ do
|
|
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
eid <- $cachedHereBinary (cid, examn) . MaybeT . getKeyBy $ UniqueExam cid examn
|
|
Entity occId ExamOccurrence{..} <- $cachedHereBinary (eid, occn) . MaybeT . getBy $ UniqueExamOccurrence eid occn
|
|
-- Nothing means unlimited size
|
|
whenIsJust examOccurrenceCapacity $ \capacity -> do
|
|
registered <- $cachedHereBinary occId . lift $ fromIntegral <$> count [ ExamRegistrationOccurrence ==. Just occId, ExamRegistrationExam ==. eid ]
|
|
guard $ capacity > registered
|
|
return Authorized
|
|
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgTutorialNoCapacity) $ do
|
|
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity tutId Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
|
|
registered <- $cachedHereBinary tutId . lift $ count [ TutorialParticipantTutorial ==. tutId ]
|
|
guard $ NTop tutorialCapacity > NTop (Just registered)
|
|
return Authorized
|
|
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
|
|
Entity cid Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
|
registered <- $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
|
|
guard $ NTop courseCapacity > NTop (Just registered)
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthCapacity r
|
|
tagAccessPredicate AuthRegisterGroup = APDB $ \_ _ mAuthId route _ -> case route of
|
|
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialRegisterGroup) $ do
|
|
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ Tutorial{..} <- $cachedHereBinary (cid, tutn) . MaybeT . getBy $ UniqueTutorial cid tutn
|
|
case (tutorialRegGroup, mAuthId) of
|
|
(Nothing, _) -> return Authorized
|
|
(_, Nothing) -> return AuthenticationRequired
|
|
(Just rGroup, Just uid) -> do
|
|
hasOther <- $cachedHereBinary (uid, rGroup) . lift . E.selectExists . E.from $ \(tutorial `E.InnerJoin` participant) -> do
|
|
E.on $ tutorial E.^. TutorialId E.==. participant E.^. TutorialParticipantTutorial
|
|
E.&&. tutorial E.^. TutorialCourse E.==. E.val tutorialCourse
|
|
E.&&. tutorial E.^. TutorialRegGroup E.==. E.just (E.val rGroup)
|
|
E.&&. participant E.^. TutorialParticipantUser E.==. E.val uid
|
|
guard $ not hasOther
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthRegisterGroup r
|
|
tagAccessPredicate AuthEmpty = APDB $ \_ _ mAuthId route _ -> case route of
|
|
EExamListR -> exceptT return return $ do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
hasExternalExams <- $cachedHereBinary authId . lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamStaff) -> do
|
|
E.on $ eexam E.^. ExternalExamId E.==. eexamStaff E.^. ExternalExamStaffExam
|
|
E.where_ $ eexamStaff E.^. ExternalExamStaffUser E.==. E.val authId
|
|
E.||. E.exists (E.from $ \externalExamResult ->
|
|
E.where_ $ externalExamResult E.^. ExternalExamResultExam E.==. eexam E.^. ExternalExamId
|
|
E.&&. externalExamResult E.^. ExternalExamResultUser E.==. E.val authId
|
|
)
|
|
guardMExceptT (not hasExternalExams) $ unauthorizedI MsgUnauthorizedExternalExamListNotEmpty
|
|
return Authorized
|
|
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
|
|
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
|
cid <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
assertM_ (<= 0) . $cachedHereBinary cid . lift $ count [ CourseParticipantCourse ==. cid ]
|
|
assertM_ not . $cachedHereBinary cid . lift $ E.selectExists . E.from $ \(sheet `E.InnerJoin` submission) -> do
|
|
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthEmpty r
|
|
tagAccessPredicate AuthMaterials = APDB $ \_ _ _ route _ -> case route of
|
|
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
|
|
Entity _ Course{..} <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
|
guard courseMaterialFree
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthMaterials r
|
|
tagAccessPredicate AuthOwner = APDB $ \_ _ mAuthId route _ -> case route of
|
|
CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . exceptT return return $ do
|
|
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthOwner r
|
|
tagAccessPredicate AuthPersonalisedSheetFiles = APDB $ \_ _ mAuthId route _ -> case route of
|
|
CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . exceptT return return $ do
|
|
Entity shId Sheet{..} <- maybeTMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) $ do
|
|
cid <- MaybeT . $cachedHereBinary (tid, ssh, csh) . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
|
MaybeT . $cachedHereBinary (cid, shn) . getBy $ CourseSheet cid shn
|
|
if | sheetAllowNonPersonalisedSubmission -> return Authorized
|
|
| otherwise -> do
|
|
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
|
flip guardMExceptT (unauthorizedI MsgUnauthorizedSubmissionPersonalisedSheetFiles) <=< $cachedHereBinary (shId, authId) . lift $
|
|
E.selectExists . E.from $ \psFile ->
|
|
E.where_ $ psFile E.^. PersonalisedSheetFileSheet E.==. E.val shId
|
|
E.&&. psFile E.^. PersonalisedSheetFileUser E.==. E.val authId
|
|
E.&&. E.not_ (E.isNothing $ psFile E.^. PersonalisedSheetFileContent) -- directories don't count
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthPersonalisedSheetFiles r
|
|
tagAccessPredicate AuthRated = APDB $ \_ _ _ route _ -> case route of
|
|
CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary cID . maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
|
|
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
sub <- MaybeT $ get sid
|
|
guard $ submissionRatingDone sub
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthRated r
|
|
tagAccessPredicate AuthUserSubmissions = APDB $ \_ _ _ route _ -> case route of
|
|
CSheetR tid ssh csh shn _ -> $cachedHereBinary (tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
|
|
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn
|
|
guard $ is _Just submissionModeUser
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthUserSubmissions r
|
|
tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ _ _ route _ -> case route of
|
|
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
|
|
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
|
|
guard submissionModeCorrector
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r
|
|
tagAccessPredicate AuthCorrectionAnonymous = APDB $ \_ _ _ route _ -> case route of
|
|
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectionAnonymous) $ do
|
|
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
|
Entity _ Sheet{ sheetAnonymousCorrection } <- $cachedHereBinary (cid, shn) . MaybeT . getBy $ CourseSheet cid shn
|
|
guard sheetAnonymousCorrection
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthCorrectionAnonymous r
|
|
tagAccessPredicate AuthSelf = APDB $ \_ _ mAuthId route _ -> exceptT return return $ do
|
|
referencedUser' <- case route of
|
|
AdminUserR cID -> return $ Left cID
|
|
AdminUserDeleteR cID -> return $ Left cID
|
|
AdminHijackUserR cID -> return $ Left cID
|
|
UserNotificationR cID -> return $ Left cID
|
|
UserPasswordR cID -> return $ Left cID
|
|
CourseR _ _ _ (CUserR cID) -> return $ Left cID
|
|
CApplicationR _ _ _ cID _ -> do
|
|
appId <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
CourseApplication{..} <- maybeMExceptT (unauthorizedI MsgUnauthorizedSelf) . $cachedHereBinary appId $ get appId
|
|
return $ Right courseApplicationUser
|
|
_other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
|
|
referencedUser <- case referencedUser' of
|
|
Right uid -> return uid
|
|
Left cID -> catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
case mAuthId of
|
|
Just uid
|
|
| uid == referencedUser -> return Authorized
|
|
Nothing -> return AuthenticationRequired
|
|
_other -> unauthorizedI MsgUnauthorizedSelf
|
|
tagAccessPredicate AuthIsLDAP = APDB $ \_ _ _ route _ -> exceptT return return $ do
|
|
referencedUser <- case route of
|
|
AdminUserR cID -> return cID
|
|
AdminUserDeleteR cID -> return cID
|
|
AdminHijackUserR cID -> return cID
|
|
UserNotificationR cID -> return cID
|
|
UserPasswordR cID -> return cID
|
|
CourseR _ _ _ (CUserR cID) -> return cID
|
|
_other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route
|
|
referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
|
|
maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do
|
|
User{..} <- MaybeT $ get referencedUser'
|
|
guard $ userAuthentication == AuthLDAP
|
|
return Authorized
|
|
tagAccessPredicate AuthIsPWHash = APDB $ \_ _ _ route _ -> exceptT return return $ do
|
|
referencedUser <- case route of
|
|
AdminUserR cID -> return cID
|
|
AdminUserDeleteR cID -> return cID
|
|
AdminHijackUserR cID -> return cID
|
|
UserNotificationR cID -> return cID
|
|
UserPasswordR cID -> return cID
|
|
CourseR _ _ _ (CUserR cID) -> return cID
|
|
_other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route
|
|
referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
|
|
maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do
|
|
User{..} <- MaybeT $ get referencedUser'
|
|
guard $ is _AuthPWHash userAuthentication
|
|
return Authorized
|
|
tagAccessPredicate AuthAuthentication = APDB $ \_ _ mAuthId route _ -> case route of
|
|
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
|
|
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
|
|
let isAuthenticated = isJust mAuthId
|
|
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
|
|
return Authorized
|
|
MessageHideR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
|
|
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
|
SystemMessage{..} <- $cachedHereBinary smId . MaybeT $ get smId
|
|
let isAuthenticated = isJust mAuthId
|
|
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
|
|
return Authorized
|
|
r -> $unsupportedAuthPredicate AuthAuthentication r
|
|
tagAccessPredicate AuthRead = APPure $ \_ _ isWrite -> do
|
|
MsgRenderer mr <- ask
|
|
return $ bool Authorized (Unauthorized $ mr MsgUnauthorizedWrite) isWrite
|
|
tagAccessPredicate AuthWrite = APPure $ \_ _ isWrite -> do
|
|
MsgRenderer mr <- ask
|
|
return $ bool (Unauthorized $ mr MsgUnauthorized) Authorized isWrite
|
|
|
|
runTACont :: forall m. MonadAP m
|
|
=> (forall m'. MonadAP m' => AuthTagsEval m')
|
|
-> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m Bool
|
|
runTACont cont dnf mAuthId route isWrite = is _Authorized <$> evalWriterT (cont dnf mAuthId route isWrite)
|
|
|
|
|
|
authTagSpecificity :: AuthTag -> AuthTag -> Ordering
|
|
-- ^ Heuristic for which `AuthTag`s to evaluate first
|
|
authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem
|
|
where
|
|
eqClasses :: [[AuthTag]]
|
|
-- ^ Constructors of `AuthTag` ordered (increasing) by execution order
|
|
eqClasses =
|
|
[ [ AuthFree, AuthDeprecated, AuthDevelopment ] -- Route wide
|
|
, [ AuthRead, AuthWrite, AuthToken ] -- Request wide
|
|
, [ AuthAdmin ] -- Site wide
|
|
, [ AuthLecturer, AuthCourseRegistered, AuthParticipant, AuthCourseTime, AuthTime, AuthMaterials, AuthUserSubmissions, AuthCorrectorSubmissions, AuthCapacity, AuthEmpty ] ++ [ AuthSelf, AuthNoEscalation ] ++ [ AuthAuthentication ] -- Course/User/SystemMessage wide
|
|
, [ AuthCorrector ] ++ [ AuthTutor ] ++ [ AuthTutorialRegistered, AuthRegisterGroup ] -- Tutorial/Material/Sheet wide
|
|
, [ AuthOwner, AuthRated ] -- Submission wide
|
|
]
|
|
|
|
defaultAuthDNF :: AuthDNF
|
|
defaultAuthDNF = predDNFVar AuthAdmin `predDNFOr` predDNFVar AuthToken
|
|
|
|
routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF
|
|
-- ^ DNF up to entailment, see `predDNFEntail`
|
|
routeAuthTags = fmap predDNFEntail . ofoldM parse defaultAuthDNF . routeAttrs
|
|
where
|
|
parse :: AuthDNF -> Text -> Either InvalidAuthTag AuthDNF
|
|
parse prev t = case fromNullable . Set.fromList =<< mapM fromPathPiece (Text.splitOn "AND" t) of
|
|
Just t' -> Right . predDNFOr prev . PredDNF $ Set.singleton t'
|
|
Nothing -> Left $ InvalidAuthTag t
|
|
|
|
broadenRoute :: AuthTag -> Route UniWorX -> Route UniWorX
|
|
broadenRoute aTag route = case (aTag, route) of
|
|
(AuthAdmin, CourseR tid ssh csh _) -> CourseR tid ssh csh CShowR
|
|
(AuthAdmin, AllocationR tid ssh ash _) -> AllocationR tid ssh ash AShowR
|
|
(AuthAdmin, SchoolR ssh _) -> SchoolR ssh SchoolEditR
|
|
(AuthAdmin, _) -> NewsR
|
|
|
|
(AuthStudent, _) -> NewsR
|
|
|
|
(AuthExamOffice, CExamR tid ssh csh examn _) -> CExamR tid ssh csh examn EShowR
|
|
(AuthExamOffice, EExamR tid ssh coursen examn _) -> EExamR tid ssh coursen examn EEShowR
|
|
(AuthExamOffice, CourseR _ ssh _ _) -> SchoolR ssh SchoolEditR
|
|
(AuthExamOffice, SchoolR ssh _) -> SchoolR ssh SchoolEditR
|
|
(AuthExamOffice, _) -> NewsR
|
|
|
|
(AuthLecturer, CourseR tid ssh csh _) -> CourseR tid ssh csh CShowR
|
|
(AuthLecturer, AllocationR tid ssh ash _) -> AllocationR tid ssh ash AShowR
|
|
(AuthLecturer, EExamR tid ssh coursen examn _) -> EExamR tid ssh coursen examn EEShowR
|
|
(AuthLecturer, _) -> NewsR
|
|
|
|
_other -> route
|
|
|
|
evalAuthTags :: forall ctx m. (HasCallStack, Binary ctx, MonadAP m) => ctx -> AuthTagActive -> (forall m'. MonadAP m' => AuthTagsEval m') -> AuthTagsEval m
|
|
-- ^ `tell`s disabled predicates, identified as pivots
|
|
evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF') mAuthId route isWrite
|
|
= do
|
|
mr <- getMsgRenderer
|
|
let
|
|
contCtx = toStrict $ Binary.encode (ctx, authActive)
|
|
authVarSpecificity = authTagSpecificity `on` plVar
|
|
authDNF = sortBy (authVarSpecificity `on` maximumBy authVarSpecificity . impureNonNull) $ map (sortBy authVarSpecificity) authDNF'
|
|
|
|
authTagIsInactive = not . authTagIsActive
|
|
|
|
evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult
|
|
evalAuthTag authTag = lift . ($runCachedMemoT :: CachedMemoT (ctx, AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for5 memo (const evalAccessPred') ctx authTag mAuthId route'' isWrite
|
|
where
|
|
route'' = broadenRoute authTag route
|
|
evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
|
|
$logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
|
|
observeAuthTagEvaluation authTag' (classifyHandler route') $ do
|
|
res <- evalAccessPred (tagAccessPredicate authTag') contCtx cont mAuthId' route' isWrite'
|
|
return . (res, ) $ case res of
|
|
Authorized -> OutcomeAuthorized
|
|
Unauthorized _ -> OutcomeUnauthorized
|
|
AuthenticationRequired -> OutcomeAuthenticationRequired
|
|
|
|
evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
|
|
evalAuthLiteral PLVariable{..} = evalAuthTag plVar
|
|
evalAuthLiteral PLNegated{..} = notAR mr plVar <$> evalAuthTag plVar
|
|
|
|
orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
|
|
orAR' = shortCircuitM (is _Authorized) (orAR mr)
|
|
andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
|
|
|
|
evalDNF :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult
|
|
evalDNF = maybe (return $ falseAR mr) (ofoldr1 orAR') . fromNullable . map evalConj
|
|
where
|
|
evalConj = maybe (return $ trueAR mr) (ofoldr1 andAR') . fromNullable . map evalAuthLiteral
|
|
|
|
$logDebugS "evalAuthTags" . tshow . (route, isWrite, ) $ map (map $ id &&& authTagIsActive . plVar) authDNF
|
|
|
|
result <- evalDNF $ filter (all $ authTagIsActive . plVar) authDNF
|
|
|
|
unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj ->
|
|
whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do
|
|
let pivots = filter (authTagIsInactive . plVar) conj
|
|
whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do
|
|
let pivots' = plVar <$> pivots
|
|
$logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots'}|]
|
|
tell $ Set.fromList pivots'
|
|
|
|
return result
|
|
|
|
evalAccessWithFor :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
|
|
evalAccessWithFor assumptions mAuthId route isWrite = do
|
|
isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
|
|
tagActive <- if
|
|
| isSelf -> fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
|
|
| otherwise -> return . AuthTagActive $ const True
|
|
dnf <- throwLeft $ routeAuthTags route
|
|
let adjDNF = ala Endo foldMap (map ((=<<) . uncurry dnfAssumeValue) assumptions) . Just
|
|
evalAdj :: forall m'. MonadAP m' => AuthTagsEval m'
|
|
evalAdj (adjDNF -> dnf') mAuthId' route' isWrite' = case dnf' of
|
|
Nothing -> return Authorized
|
|
Just dnf'' -> evalAuthTags ('evalAccessWithFor, assumptions) tagActive evalAdj dnf'' mAuthId' route' isWrite'
|
|
in do
|
|
(result, deactivated) <- runWriterT $ evalAdj dnf mAuthId route isWrite
|
|
when isSelf $
|
|
tellSessionJson SessionInactiveAuthTags deactivated
|
|
return result
|
|
|
|
evalAccessFor :: (HasCallStack, MonadThrow m, MonadAP m) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
|
|
evalAccessFor = evalAccessWithFor []
|
|
|
|
evalAccessForDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
|
|
evalAccessForDB = evalAccessFor
|
|
|
|
evalAccessWith :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult
|
|
evalAccessWith assumptions route isWrite = do
|
|
mAuthId <- liftHandler maybeAuthId
|
|
evalAccessWithFor assumptions mAuthId route isWrite
|
|
|
|
evalAccessWithDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
|
|
evalAccessWithDB = evalAccessWith
|
|
|
|
evalAccess :: (HasCallStack, MonadThrow m, MonadAP m) => Route UniWorX -> Bool -> m AuthResult
|
|
evalAccess = evalAccessWith []
|
|
|
|
evalAccessDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => Route UniWorX -> Bool -> ReaderT backend m AuthResult
|
|
evalAccessDB = evalAccess
|
|
|
|
-- | Check whether the current user is authorized by `evalAccess` for the given route
|
|
-- Convenience function for a commonly used code fragment
|
|
hasAccessTo :: (HasCallStack, MonadThrow m, MonadAP m) => Route UniWorX -> Bool -> m Bool
|
|
hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite
|
|
|
|
-- | Check whether the current user is authorized by `evalAccess` to read from the given route
|
|
-- Convenience function for a commonly used code fragment
|
|
hasReadAccessTo :: (HasCallStack, MonadThrow m, MonadAP m) => Route UniWorX -> m Bool
|
|
hasReadAccessTo = flip hasAccessTo False
|
|
|
|
-- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route
|
|
-- Convenience function for a commonly used code fragment
|
|
hasWriteAccessTo :: (HasCallStack, MonadThrow m, MonadAP m) => Route UniWorX -> m Bool
|
|
hasWriteAccessTo = flip hasAccessTo True
|
|
|
|
wouldHaveAccessTo :: (HasCallStack, MonadThrow m, MonadAP m)
|
|
=> [(AuthTag, Bool)] -- ^ Assumptions
|
|
-> Route UniWorX
|
|
-> Bool
|
|
-> m Bool
|
|
wouldHaveAccessTo assumptions route isWrite = (== Authorized) <$> evalAccessWith assumptions route isWrite
|
|
|
|
wouldHaveReadAccessTo, wouldHaveWriteAccessTo
|
|
:: (HasCallStack, MonadThrow m, MonadAP m)
|
|
=> [(AuthTag, Bool)] -- ^ Assumptions
|
|
-> Route UniWorX
|
|
-> m Bool
|
|
wouldHaveReadAccessTo assumptions route = wouldHaveAccessTo assumptions route False
|
|
wouldHaveWriteAccessTo assumptions route = wouldHaveAccessTo assumptions route True
|
|
|
|
wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
|
|
:: (HasCallStack, MonadThrow m, MonadAP m)
|
|
=> [(AuthTag, Bool)] -- ^ Assumptions
|
|
-> Route UniWorX
|
|
-> m Bool
|
|
wouldHaveReadAccessToIff assumptions route = and2M (not <$> hasReadAccessTo route) $ wouldHaveReadAccessTo assumptions route
|
|
wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo route) $ wouldHaveWriteAccessTo assumptions route
|
|
|
|
|
|
authoritiveApproot :: Route UniWorX -> ApprootScope
|
|
authoritiveApproot = \case
|
|
CourseR _ _ _ (MaterialR _ (MFileR _)) -> ApprootUserGenerated
|
|
CourseR _ _ _ (MaterialR _ MArchiveR) -> ApprootUserGenerated
|
|
CourseR _ _ _ (SheetR _ (SFileR _ _)) -> ApprootUserGenerated
|
|
CourseR _ _ _ (SheetR _ (SZipR _)) -> ApprootUserGenerated
|
|
CourseR _ _ _ (SheetR _ (SubmissionR _ (SubDownloadR _ _))) -> ApprootUserGenerated
|
|
CourseR _ _ _ (SheetR _ (SubmissionR _ (SubArchiveR _))) -> ApprootUserGenerated
|
|
CourseR _ _ _ (CourseNewsR _ (CNFileR _)) -> ApprootUserGenerated
|
|
CourseR _ _ _ (CourseNewsR _ CNArchiveR) -> ApprootUserGenerated
|
|
CourseR _ _ _ CRegisterTemplateR -> ApprootUserGenerated
|
|
CourseR _ _ _ CAppsFilesR -> ApprootUserGenerated
|
|
CourseR _ _ _ (CourseApplicationR _ CAFilesR) -> ApprootUserGenerated
|
|
_other -> ApprootDefault
|