fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(auth): user independent authorisation caching

Browse Source 
BREAKING CHANGE: additional authorisation caching
This commit is contained in:
Gregor Kleen 2021-03-08 12:08:43 +01:00
parent 38f16ebac3
commit 63f0d3c37a
50 changed files with 698 additions and 448 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

779
src/Foundation/Authorization.hs
View File

@ -36,6 +36,7 @@ import Handler.Utils.Memcached
import Handler.Utils.I18n import Handler.Utils.I18n
import Utils.Course (courseIsVisible) import Utils.Course (courseIsVisible)
import Utils.Workflow import Utils.Workflow
import Utils.Metrics (observeAuthTagEvaluation, AuthTagEvalOutcome(..))
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Aeson as JSON import qualified Data.Aeson as JSON
@ -93,21 +94,53 @@ data AccessPredicate
= APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) = APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
| APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX 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) | APDB (ByteString -> (forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)
| APCache (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX (Either AccessPredicate AuthResult))
class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where class (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP m where
evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessPred :: HasCallStack => AccessPredicate -> ByteString -> (forall m'. MonadAP m' => AuthTagsEval m') -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => MonadAP m where instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, MonadUnliftIO m) => MonadAP m where
evalAccessPred aPred contCtx cont aid r w = liftHandler $ case aPred of evalAccessPred aPred contCtx cont aid r w = liftHandler $ case aPred of
(APPure p) -> runReader (p aid r w) <$> getMsgRenderer (APPure p) -> runReader (p aid r w) <$> getMsgRenderer
(APHandler p) -> p aid r w (APHandler p) -> p aid r w
(APDB p) -> runDBRead' callStack $ p contCtx cont aid r w (APDB p) -> runDBRead' callStack $ p contCtx cont aid r w
(APCache p) -> do
res <- p aid r w
case res of
Right res' -> return res'
Left p' -> evalAccessPred p' contCtx cont aid r w
instance (MonadHandler m, HandlerSite m ~ UniWorX, BackendCompatible SqlReadBackend backend, BearerAuthSite UniWorX) => MonadAP (ReaderT backend m) where 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 evalAccessPred aPred contCtx cont aid r w = mapReaderT liftHandler . withReaderT (projectBackend @SqlReadBackend) $ case aPred of
(APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
(APHandler p) -> lift $ p aid r w (APHandler p) -> lift $ p aid r w
(APDB p) -> p contCtx cont aid r w (APDB p) -> p contCtx cont aid r w
(APCache p) -> do
res <- lift $ p aid r w
case res of
Right res' -> return res'
Left p' -> evalAccessPred p' contCtx cont aid r w
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 = APCache $ \mAuthId route isWrite -> either (return . Left) (fmap Right) . cont mAuthId route isWrite =<< memcachedBy mExp k mkV
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 = APCache $ \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
orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
@ -158,9 +191,10 @@ data AuthContext = AuthContext
, authActiveTags :: AuthTagActive , authActiveTags :: AuthTagActive
} deriving (Generic, Typeable) } deriving (Generic, Typeable)
deriving instance Eq (AuthId UniWorX) => Eq AuthContext deriving stock instance Eq (AuthId UniWorX) => Eq AuthContext
deriving instance (Read (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Read AuthContext deriving stock instance Ord (AuthId UniWorX) => Ord AuthContext
deriving instance (Show (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Show 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 Hashable (AuthId UniWorX) => Hashable AuthContext
deriving anyclass instance (Binary (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Binary AuthContext deriving anyclass instance (Binary (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Binary AuthContext
@ -262,7 +296,7 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
Just iuid | uid == iuid -> return $ Set.singleton uid Just iuid | uid == iuid -> return $ Set.singleton uid
| otherwise -> do | otherwise -> do
cID <- encrypt iuid cID <- encrypt iuid
unlessM (is _Authorized <$> evalAccessWithFor [(AuthToken, False)] (Just uid) (AdminHijackUserR cID) True) $ unlessM (lift $ is _Authorized <$> evalAccessWithFor [(AuthToken, False)] (Just uid) (AdminHijackUserR cID) True) $
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation
return $ Set.singleton iuid return $ Set.singleton iuid
Nothing -> return $ Set.singleton uid Nothing -> return $ Set.singleton uid
@ -282,12 +316,12 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
authorityVal <- do authorityVal <- do
dnf <- either throwM return $ routeAuthTags route dnf <- either throwM return $ routeAuthTags route
evalWriterT $ eval (noTokenAuth dnf) (Just uid) route isWrite lift . evalWriterT $ eval (noTokenAuth dnf) (Just uid) route isWrite
guardExceptT (is _Authorized authorityVal) authorityVal guardExceptT (is _Authorized authorityVal) authorityVal
whenIsJust bearerAddAuth $ \addDNF -> do whenIsJust bearerAddAuth $ \addDNF -> do
$logDebugS "validateToken" $ tshow addDNF $logDebugS "validateToken" $ tshow addDNF
additionalVal <- evalWriterT $ eval (noTokenAuth addDNF) mAuthId route isWrite additionalVal <- lift . evalWriterT $ eval (noTokenAuth addDNF) mAuthId route isWrite
guardExceptT (is _Authorized additionalVal) additionalVal guardExceptT (is _Authorized additionalVal) additionalVal
return Authorized return Authorized
@ -339,134 +373,191 @@ maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do
data AuthorizationCacheKey data AuthorizationCacheKey
= AuthCacheWorkflowWorkflowEdgeActors CryptoFileNameWorkflowWorkflow = AuthCacheWorkflowWorkflowEdgeActors CryptoFileNameWorkflowWorkflow
| AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow | AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow
| AuthCacheSchoolFunctionList SchoolFunction | AuthCacheSystemFunctionList SystemFunction
| AuthCacheLecturerList | AuthCacheCorrectorList | AuthCacheExamCorrectorList | AuthCacheTutorList | AuthCacheSubmissionGroupUserList
| AuthCacheCourseRegisteredList TermId SchoolId CourseShorthand
deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving anyclass (Binary) deriving anyclass (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 = cacheAP mExp (AuthCacheSchoolFunctionList f) mkFunctionList
where
mkFunctionList = runDBRead . 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 = cacheAP mExp (AuthCacheSystemFunctionList f) mkFunctionList
where
mkFunctionList = runDBRead . 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 :: BearerAuthSite UniWorX tagAccessPredicate :: BearerAuthSite UniWorX
=> AuthTag -> AccessPredicate => AuthTag -> AccessPredicate
tagAccessPredicate AuthFree = trueAP tagAccessPredicate AuthFree = trueAP
tagAccessPredicate AuthAdmin = APDB $ \_ _ mAuthId route _ -> case route of tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right diffHour) $ \mAuthId' route' _ adminList -> if
-- Courses: access only to school admins | maybe True (`Set.notMember` adminList) mAuthId' -> Right $ case route' of
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do _ | is _Nothing mAuthId' -> return AuthenticationRequired
authId <- maybeExceptT AuthenticationRequired $ return mAuthId CourseR _ _ _ _ -> unauthorizedI MsgUnauthorizedSchoolAdmin
isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do AllocationR _ _ _ _ -> unauthorizedI MsgUnauthorizedSchoolAdmin
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool SchoolR _ _ -> unauthorizedI MsgUnauthorizedSchoolAdmin
E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId _other -> unauthorizedI MsgUnauthorizedSiteAdmin
E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
E.&&. course E.^. CourseTerm E.==. E.val tid -- Courses: access only to school admins
E.&&. course E.^. CourseSchool E.==. E.val ssh CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
E.&&. course E.^. CourseShorthand E.==. E.val csh authId <- maybeExceptT AuthenticationRequired $ return mAuthId
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do
return Authorized E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool
-- Allocations: access only to school admins E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId
AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
authId <- maybeExceptT AuthenticationRequired $ return mAuthId E.&&. course E.^. CourseTerm E.==. E.val tid
isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do E.&&. course E.^. CourseSchool E.==. E.val ssh
E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool E.&&. course E.^. CourseShorthand E.==. E.val csh
E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId guardMExceptT isAdmin $ unauthorizedI MsgUnauthorizedSchoolAdmin
E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin return Authorized
E.&&. allocation E.^. AllocationTerm E.==. E.val tid -- Allocations: access only to school admins
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash authId <- maybeExceptT AuthenticationRequired $ return mAuthId
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do
return Authorized E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool
-- Schools: access only to school admins E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId
SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
authId <- maybeExceptT AuthenticationRequired $ return mAuthId E.&&. allocation E.^. AllocationTerm E.==. E.val tid
isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin) E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
return Authorized guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
-- other routes: access to any admin is granted here return Authorized
_other -> $cachedHereBinary mAuthId . exceptT return return $ do -- Schools: access only to school admins
authId <- maybeExceptT AuthenticationRequired $ return mAuthId SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] [] authId <- maybeExceptT AuthenticationRequired $ return mAuthId
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin]
return Authorized guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
tagAccessPredicate AuthSystemExamOffice = APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do return Authorized
authId <- maybeExceptT AuthenticationRequired $ return mAuthId -- other routes: access to any admin is granted here
isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False] _other -> $cachedHereBinary mAuthId . exceptT return return $ do
guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice authId <- maybeExceptT AuthenticationRequired $ return mAuthId
return Authorized adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
tagAccessPredicate AuthStudent = APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
authId <- maybeExceptT AuthenticationRequired $ return mAuthId return Authorized
isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemStudent, UserSystemFunctionIsOptOut ==. False] tagAccessPredicate AuthSystemExamOffice = cacheAPSystemFunction SystemExamOffice (Just $ Right diffHour) $ \mAuthId' _ _ examOfficeList -> if
guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedStudent | maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ if
return Authorized | is _Nothing mAuthId' -> return AuthenticationRequired
tagAccessPredicate AuthExamOffice = APDB $ \_ _ mAuthId route _ -> case route of | otherwise -> unauthorizedI MsgUnauthorizedSystemExamOffice
CExamR tid ssh csh examn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, examn) . exceptT return return $ do | otherwise -> Left $ APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
hasUsers <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examResult) -> do isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False]
E.on $ examResult E.^. ExamResultExam E.==. exam E.^. ExamId guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice
E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId 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
isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemStudent, UserSystemFunctionIsOptOut ==. False]
guardMExceptT isExamOffice $ 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.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. exam E.^. ExamName E.==. E.val examn E.&&. exam E.^. ExamName E.==. E.val examn
E.where_ $ examOfficeExamResultAuth (E.val authId) examResult E.where_ $ examOfficeExamResultAuth (E.val authId) examResult
guardMExceptT hasUsers (unauthorizedI MsgUnauthorizedExamExamOffice) guardMExceptT hasUsers (unauthorizedI MsgUnauthorizedExamExamOffice)
return Authorized return Authorized
EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
hasUsers <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do hasUsers <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do
E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam
E.where_ $ eexam E.^. ExternalExamTerm E.==. E.val tid E.where_ $ eexam E.^. ExternalExamTerm E.==. E.val tid
E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh
E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen
E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn
E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult
guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice
return Authorized return Authorized
CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice
guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedExamExamOffice guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedExamExamOffice
return Authorized return Authorized
SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolExamOffice) guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolExamOffice)
return Authorized return Authorized
_other -> $cachedHereBinary mAuthId . exceptT return return $ do _other -> $cachedHereBinary mAuthId . exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice] isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice) guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice)
return Authorized return Authorized
tagAccessPredicate AuthEvaluation = APDB $ \_ _ mAuthId route _ -> case route of tagAccessPredicate AuthEvaluation = cacheAPSchoolFunction SchoolEvaluation (Just $ Right diffHour) $ \mAuthId' _ _ evaluationList -> if
ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do | maybe True (`Set.notMember` evaluationList) mAuthId' -> Right $ if
authId <- maybeExceptT AuthenticationRequired $ return mAuthId | is _Nothing mAuthId' -> return AuthenticationRequired
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation | otherwise -> unauthorizedI MsgUnauthorizedEvaluation
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
return Authorized ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
CourseR _ ssh _ _ -> $cachedHereBinary(mAuthId, ssh) . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId
authId <- maybeExceptT AuthenticationRequired $ return mAuthId isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation return Authorized
return Authorized CourseR _ ssh _ _ -> $cachedHereBinary(mAuthId, ssh) . exceptT return return $ do
_other -> $cachedHereBinary mAuthId . exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ return mAuthId
authId <- maybeExceptT AuthenticationRequired $ return mAuthId isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation] guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation return Authorized
return Authorized _other -> $cachedHereBinary mAuthId . exceptT return return $ do
tagAccessPredicate AuthAllocationAdmin = APDB $ \_ _ mAuthId route _ -> case route of authId <- maybeExceptT AuthenticationRequired $ return mAuthId
AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation]
authId <- maybeExceptT AuthenticationRequired $ return mAuthId guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation return Authorized
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin tagAccessPredicate AuthAllocationAdmin = cacheAPSchoolFunction SchoolAllocation (Just $ Right diffHour) $ \mAuthId' _ _ allocationList -> if
return Authorized | maybe True (`Set.notMember` allocationList) mAuthId' -> Right $ if
CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do | is _Nothing mAuthId' -> return AuthenticationRequired
authId <- maybeExceptT AuthenticationRequired $ return mAuthId | otherwise -> unauthorizedI MsgUnauthorizedAllocationAdmin
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
return Authorized authId <- maybeExceptT AuthenticationRequired $ return mAuthId
_other -> $cachedHereBinary mAuthId . exceptT return return $ do isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
authId <- maybeExceptT AuthenticationRequired $ return mAuthId guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation] return Authorized
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
return Authorized 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 $ tagAccessPredicate AuthToken = APDB $ \_ _ mAuthId route isWrite -> exceptT return return $
lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe
tagAccessPredicate AuthNoEscalation = APDB $ \_ _ mAuthId route _ -> case route of tagAccessPredicate AuthNoEscalation = APDB $ \_ _ mAuthId route _ -> case route of
@ -490,121 +581,175 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
#else #else
return $ Unauthorized "Route under development" return $ Unauthorized "Route under development"
#endif #endif
tagAccessPredicate AuthLecturer = APDB $ \_ _ mAuthId route _ -> case route of
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do tagAccessPredicate AuthLecturer = cacheAP' (Just $ Right diffMinute) mkLecturerList $ \mAuthId' route' _ mLecturerList -> if
authId <- maybeExceptT AuthenticationRequired $ return mAuthId | Just lecturerList <- mLecturerList
isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do , maybe True (`Set.notMember` lecturerList) mAuthId' -> Right $ case route' of
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse _ | is _Nothing mAuthId' -> return AuthenticationRequired
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId 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 _ _ _ _ _ -> cacheLecturerList
_other -> Just
( AuthCacheSchoolFunctionList SchoolLecturer
, runDBRead . 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
, runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. LecturerUser)
)
tagAccessPredicate AuthCorrector = cacheAP (Just $ Right diffMinute) AuthCacheCorrectorList mkCorrectorList $ \mAuthId' route' _ correctorList -> if
| maybe False (`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
resList <- $cachedHereBinary mAuthId . lift . E.select . 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
return (course E.^. CourseId, sheet E.^. SheetId)
let
resMap :: Map CourseId (Set SheetId)
resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
case route of
CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
Submission{..} <- MaybeT . lift $ get sid
guard $ Just authId == submissionRatingBy
return Authorized
CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
return Authorized
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
guard $ cid `Set.member` Map.keysSet resMap
return Authorized
_ -> do
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
return Authorized
where
mkCorrectorList = runDBRead . execWriterT $ do
tellM . fmap (setOf $ folded . _Value . _Just) . E.select . E.from $ \submission -> do
E.where_ . E.isJust $ submission E.^. SubmissionRatingBy
return $ submission E.^. SubmissionRatingBy
tellM . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. SheetCorrectorUser)
tagAccessPredicate AuthExamCorrector = cacheAP (Just $ Right diffMinute) AuthCacheExamCorrectorList mkExamCorrectorList $ \mAuthId' route' _ examCorrectorList -> if
| maybe False (`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.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer) E.&&. exam E.^. ExamName E.==. E.val examn
return Authorized guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do return Authorized
authId <- maybeExceptT AuthenticationRequired $ return mAuthId CourseR tid ssh csh _ -> $cachedHereBinary (tid, ssh, csh) . exceptT return return $ do
isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do authId <- maybeExceptT AuthenticationRequired $ return mAuthId
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId
E.&&. allocation E.^. AllocationTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash E.&&. course E.^. CourseShorthand E.==. E.val csh
guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedAllocationLecturer guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
return Authorized return Authorized
EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do r -> $unsupportedAuthPredicate AuthExamCorrector r
authId <- maybeExceptT AuthenticationRequired $ return mAuthId where
isLecturer <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` staff) -> do mkExamCorrectorList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExamCorrectorUser)
E.on $ eexam E.^. ExternalExamId E.==. staff E.^. ExternalExamStaffExam tagAccessPredicate AuthTutor = cacheAP (Just $ Right diffMinute) AuthCacheTutorList mkTutorList $ \mAuthId' route' _ tutorList -> if
E.where_ $ staff E.^. ExternalExamStaffUser E.==. E.val authId | maybe False (`Set.notMember` tutorList) mAuthId' -> Right $ case route' of
E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid _ | is _Nothing mAuthId' -> return AuthenticationRequired
E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh CTutorialR _ _ _ _ _ -> unauthorizedI MsgUnauthorizedTutorialTutor
E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen CourseR _ _ _ _ -> unauthorizedI MsgUnauthorizedCourseTutor
E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn _other -> unauthorizedI MsgUnauthorizedTutor
guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedExternalExamLecturer | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> exceptT return return $ do
return Authorized authId <- maybeExceptT AuthenticationRequired $ return mAuthId
-- lecturer for any school will do resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
_ -> $cachedHereBinary mAuthId . exceptT return return $ do E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
authId <- maybeExceptT AuthenticationRequired $ return mAuthId E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] [] E.where_ $ tutor E.^. TutorUser E.==. E.val authId
return Authorized return (course E.^. CourseId, tutorial E.^. TutorialId)
tagAccessPredicate AuthCorrector = APDB $ \_ _ mAuthId route _ -> exceptT return return $ do let
authId <- maybeExceptT AuthenticationRequired $ return mAuthId resMap :: Map CourseId (Set TutorialId)
resList <- $cachedHereBinary mAuthId . lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ]
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId case route of
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
return (course E.^. CourseId, sheet E.^. SheetId) Entity tutid _ <- $cachedHereBinary (cid, tutn) . MaybeT . lift . getBy $ UniqueTutorial cid tutn
let guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid)
resMap :: Map CourseId (Set SheetId) return Authorized
resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do
case route of Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
CSubmissionR _ _ _ _ cID _ -> $cachedHereBinary (mAuthId, cID) . maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do guard $ cid `Set.member` Map.keysSet resMap
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID return Authorized
Submission{..} <- MaybeT . lift $ get sid _ -> do
guard $ Just authId == submissionRatingBy guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
return Authorized return Authorized
CSheetR tid ssh csh shn _ -> $cachedHereBinary (mAuthId, tid, ssh, csh, shn) . maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do where
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh mkTutorList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. TutorUser)
Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
return Authorized
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
guard $ cid `Set.member` Map.keysSet resMap
return Authorized
_ -> do
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
return Authorized
tagAccessPredicate AuthExamCorrector = 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
tagAccessPredicate AuthTutor = 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
tagAccessPredicate AuthTutorControl = APDB $ \_ _ _ route _ -> case route of tagAccessPredicate AuthTutorControl = APDB $ \_ _ _ route _ -> case route of
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
@ -612,31 +757,39 @@ tagAccessPredicate AuthTutorControl = APDB $ \_ _ _ route _ -> case route of
guard tutorialTutorControlled guard tutorialTutorControlled
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthTutorControl r r -> $unsupportedAuthPredicate AuthTutorControl r
tagAccessPredicate AuthSubmissionGroup = APDB $ \_ _ mAuthId route _ -> case route of tagAccessPredicate AuthSubmissionGroup = cacheAP (Just $ Right diffMinute) AuthCacheSubmissionGroupUserList mkSubmissionGroupUserList $ \mAuthId' route' _ submissionGroupUserList -> if
CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do | maybe True (`Set.notMember` submissionGroupUserList) mAuthId' -> Right $ case route' of
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh _ | is _Nothing mAuthId' -> return AuthenticationRequired
Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn CSubmissionR _ _ _ _ _ _ -> unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID CSheetR _ _ _ _ _ -> unauthorizedI MsgUnauthorizedSheetSubmissionGroup
groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do r -> $unsupportedAuthPredicate AuthSubmissionGroup r
E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do
return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
unless (Set.null groups || isn't _RegisteredGroups sheetGrouping) $ do Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn
uid <- hoistMaybe mAuthId smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups] groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do
return Authorized E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser
CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
Entity _ Sheet{..} <- $cachedHereBinary (course, sheetn) . MaybeT . getBy $ CourseSheet course sheetn unless (Set.null groups || isn't _RegisteredGroups sheetGrouping) $ do
when (is _RegisteredGroups sheetGrouping) $ do uid <- hoistMaybe mAuthId
uid <- hoistMaybe mAuthId guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups]
guardM . lift . E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do return Authorized
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val course course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
E.&&. submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid 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 return Authorized
r -> $unsupportedAuthPredicate AuthSubmissionGroup r r -> $unsupportedAuthPredicate AuthSubmissionGroup r
where
mkSubmissionGroupUserList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. SubmissionGroupUserUser)
tagAccessPredicate AuthTime = APDB $ \_ (runTACont -> cont) mAuthId route isWrite -> case route of tagAccessPredicate AuthTime = APDB $ \_ (runTACont -> cont) mAuthId route isWrite -> case route of
CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
@ -897,19 +1050,38 @@ tagAccessPredicate AuthCourseTime = APDB $ \_ _ _mAuthId route _ -> case route o
guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime) guardMExceptT courseVisible (unauthorizedI MsgUnauthorizedCourseTime)
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthCourseTime r r -> $unsupportedAuthPredicate AuthCourseTime r
tagAccessPredicate AuthCourseRegistered = APDB $ \_ _ mAuthId route _ -> case route of tagAccessPredicate AuthCourseRegistered = cacheAP' (Just $ Right diffMinute) mkAuthCacheCourseRegisteredList $ \mAuthId' route' _ mCourseRegisteredList -> if
CourseR tid ssh csh _ -> exceptT return return $ do | Just courseRegisteredList <- mCourseRegisteredList
authId <- maybeExceptT AuthenticationRequired $ return mAuthId , maybe True (`Set.notMember` courseRegisteredList) mAuthId' -> Right $ case route' of
isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do _ | is _Nothing mAuthId' -> return AuthenticationRequired
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse CourseR _ _ _ _ -> unauthorizedI MsgUnauthorizedRegistered
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId r -> $unsupportedAuthPredicate AuthCourseRegistered r
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive | otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
E.&&. course E.^. CourseTerm E.==. E.val tid CourseR tid ssh csh _ -> exceptT return return $ do
E.&&. course E.^. CourseSchool E.==. E.val ssh authId <- maybeExceptT AuthenticationRequired $ return mAuthId
E.&&. course E.^. CourseShorthand E.==. E.val csh isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered) E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
return Authorized E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
r -> $unsupportedAuthPredicate AuthCourseRegistered r 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
, runDBRead . 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 tagAccessPredicate AuthTutorialRegistered = APDB $ \_ _ mAuthId route _ -> case route of
CTutorialR tid ssh csh tutn _ -> exceptT return return $ do CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ return mAuthId authId <- maybeExceptT AuthenticationRequired $ return mAuthId
@ -1268,7 +1440,7 @@ tagAccessPredicate AuthEmpty = APDB $ \_ _ mAuthId route _
checkAccess (E.Value wwId, E.Value wwScope) = maybeT (return False) $ do checkAccess (E.Value wwId, E.Value wwScope) = maybeT (return False) $ do
cID <- encrypt wwId cID <- encrypt wwId
rScope' <- toRouteWorkflowScope $ _DBWorkflowScope # wwScope rScope' <- toRouteWorkflowScope $ _DBWorkflowScope # wwScope
guardM . fmap (is _Authorized) . flip (evalAccessFor mAuthId) False $ _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR) guardM . lift . fmap (is _Authorized) . flip (evalAccessFor mAuthId) False $ _WorkflowScopeRoute # (rScope', WorkflowWorkflowR cID WWWorkflowR)
return True return True
guardM . fmap not . lift . runConduit $ getWorkflowWorkflows .| C.mapM checkAccess .| C.or guardM . fmap not . lift . runConduit $ getWorkflowWorkflows .| C.mapM checkAccess .| C.or
return AuthorizedI18n return AuthorizedI18n
@ -1551,7 +1723,12 @@ evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable
where where
evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
$logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite') $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite')
evalAccessPred (tagAccessPredicate authTag') contCtx cont mAuthId' route' isWrite' observeAuthTagEvaluation authTag' $ 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 :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult
evalAuthLiteral PLVariable{..} = evalAuthTag plVar evalAuthLiteral PLVariable{..} = evalAuthTag plVar
@ -1580,7 +1757,7 @@ evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable
return result return result
evalAccessWithFor :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessWithFor :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
evalAccessWithFor assumptions mAuthId route isWrite = do evalAccessWithFor assumptions mAuthId route isWrite = do
isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
tagActive <- if tagActive <- if
@ -1598,42 +1775,42 @@ evalAccessWithFor assumptions mAuthId route isWrite = do
tellSessionJson SessionInactiveAuthTags deactivated tellSessionJson SessionInactiveAuthTags deactivated
return result return result
evalAccessFor :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult evalAccessFor :: (HasCallStack, MonadThrow m, MonadAP m) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult
evalAccessFor = evalAccessWithFor [] evalAccessFor = evalAccessWithFor []
evalAccessForDB :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessForDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessForDB = evalAccessFor evalAccessForDB = evalAccessFor
evalAccessWith :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult evalAccessWith :: (HasCallStack, MonadThrow m, MonadAP m) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> m AuthResult
evalAccessWith assumptions route isWrite = do evalAccessWith assumptions route isWrite = do
mAuthId <- liftHandler maybeAuthId mAuthId <- liftHandler maybeAuthId
evalAccessWithFor assumptions mAuthId route isWrite evalAccessWithFor assumptions mAuthId route isWrite
evalAccessWithDB :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessWithDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => [(AuthTag, Bool)] -> Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessWithDB = evalAccessWith evalAccessWithDB = evalAccessWith
evalAccess :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> Bool -> m AuthResult evalAccess :: (HasCallStack, MonadThrow m, MonadAP m) => Route UniWorX -> Bool -> m AuthResult
evalAccess = evalAccessWith [] evalAccess = evalAccessWith []
evalAccessDB :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, BackendCompatible SqlReadBackend backend) => Route UniWorX -> Bool -> ReaderT backend m AuthResult evalAccessDB :: (HasCallStack, MonadThrow m, MonadAP m, BackendCompatible SqlReadBackend backend) => Route UniWorX -> Bool -> ReaderT backend m AuthResult
evalAccessDB = evalAccess evalAccessDB = evalAccess
-- | Check whether the current user is authorized by `evalAccess` for the given route -- | Check whether the current user is authorized by `evalAccess` for the given route
-- Convenience function for a commonly used code fragment -- Convenience function for a commonly used code fragment
hasAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> Bool -> m Bool hasAccessTo :: (HasCallStack, MonadThrow m, MonadAP m) => Route UniWorX -> Bool -> m Bool
hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite hasAccessTo route isWrite = (== Authorized) <$> evalAccess route isWrite
-- | Check whether the current user is authorized by `evalAccess` to read from the given route -- | Check whether the current user is authorized by `evalAccess` to read from the given route
-- Convenience function for a commonly used code fragment -- Convenience function for a commonly used code fragment
hasReadAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> m Bool hasReadAccessTo :: (HasCallStack, MonadThrow m, MonadAP m) => Route UniWorX -> m Bool
hasReadAccessTo = flip hasAccessTo False hasReadAccessTo = flip hasAccessTo False
-- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route -- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route
-- Convenience function for a commonly used code fragment -- Convenience function for a commonly used code fragment
hasWriteAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) => Route UniWorX -> m Bool hasWriteAccessTo :: (HasCallStack, MonadThrow m, MonadAP m) => Route UniWorX -> m Bool
hasWriteAccessTo = flip hasAccessTo True hasWriteAccessTo = flip hasAccessTo True
wouldHaveAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) wouldHaveAccessTo :: (HasCallStack, MonadThrow m, MonadAP m)
=> [(AuthTag, Bool)] -- ^ Assumptions => [(AuthTag, Bool)] -- ^ Assumptions
-> Route UniWorX -> Route UniWorX
-> Bool -> Bool
@ -1641,7 +1818,7 @@ wouldHaveAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m
wouldHaveAccessTo assumptions route isWrite = (== Authorized) <$> evalAccessWith assumptions route isWrite wouldHaveAccessTo assumptions route isWrite = (== Authorized) <$> evalAccessWith assumptions route isWrite
wouldHaveReadAccessTo, wouldHaveWriteAccessTo wouldHaveReadAccessTo, wouldHaveWriteAccessTo
:: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) :: (HasCallStack, MonadThrow m, MonadAP m)
=> [(AuthTag, Bool)] -- ^ Assumptions => [(AuthTag, Bool)] -- ^ Assumptions
-> Route UniWorX -> Route UniWorX
-> m Bool -> m Bool
@ -1649,7 +1826,7 @@ wouldHaveReadAccessTo assumptions route = wouldHaveAccessTo assumptions route Fa
wouldHaveWriteAccessTo assumptions route = wouldHaveAccessTo assumptions route True wouldHaveWriteAccessTo assumptions route = wouldHaveAccessTo assumptions route True
wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
:: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) :: (HasCallStack, MonadThrow m, MonadAP m)
=> [(AuthTag, Bool)] -- ^ Assumptions => [(AuthTag, Bool)] -- ^ Assumptions
-> Route UniWorX -> Route UniWorX
-> m Bool -> m Bool
@ -1659,9 +1836,7 @@ wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo ro
evalWorkflowRoleFor' :: forall m backend. evalWorkflowRoleFor' :: forall m backend.
( HasCallStack ( HasCallStack
, MonadHandler m , MonadAP m
, HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend backend , BackendCompatible SqlReadBackend backend
) )
=> (forall m'. MonadAP m' => AuthTagsEval m') => (forall m'. MonadAP m' => AuthTagsEval m')
@ -1708,9 +1883,7 @@ evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = do
WorkflowRoleAuthorized{..} -> eval (predDNFEntail $ workflowRoleAuthorized `predDNFOr` defaultAuthDNF) mAuthId route isWrite WorkflowRoleAuthorized{..} -> eval (predDNFEntail $ workflowRoleAuthorized `predDNFOr` defaultAuthDNF) mAuthId route isWrite
evalWorkflowRoleFor :: ( HasCallStack evalWorkflowRoleFor :: ( HasCallStack
, MonadHandler m , MonadAP m
, HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend backend , BackendCompatible SqlReadBackend backend
) )
=> Maybe UserId => Maybe UserId
@ -1733,9 +1906,7 @@ evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do
return result return result
hasWorkflowRole :: ( HasCallStack hasWorkflowRole :: ( HasCallStack
, MonadHandler m , MonadAP m
, HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend backend , BackendCompatible SqlReadBackend backend
) )
=> Maybe WorkflowWorkflowId => Maybe WorkflowWorkflowId
@ -1749,9 +1920,7 @@ hasWorkflowRole mwwId wRole route isWrite = do
mayViewWorkflowAction' :: forall backend m fileid. mayViewWorkflowAction' :: forall backend m fileid.
( HasCallStack ( HasCallStack
, MonadHandler m , MonadAP m
, HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend backend , BackendCompatible SqlReadBackend backend
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey , MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
, MonadCatch m , MonadCatch m
@ -1780,9 +1949,7 @@ mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT
mayViewWorkflowAction :: forall backend m fileid. mayViewWorkflowAction :: forall backend m fileid.
( HasCallStack ( HasCallStack
, MonadHandler m , MonadAP m
, HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend backend , BackendCompatible SqlReadBackend backend
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey , MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
, MonadCatch m , MonadCatch m

41
src/Foundation/Navigation.hs
View File

@ -70,7 +70,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR
breadcrumb AdminUserAddR = i18nCrumb MsgMenuUserAdd $ Just UsersR breadcrumb AdminUserAddR = i18nCrumb MsgMenuUserAdd $ Just UsersR
breadcrumb (AdminUserR cID) = maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do breadcrumb (AdminUserR cID) = maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do
guardM . hasReadAccessTo $ AdminUserR cID guardM . lift . hasReadAccessTo $ AdminUserR cID
uid <- decrypt cID uid <- decrypt cID
User{..} <- MaybeT . runDBRead $ get uid User{..} <- MaybeT . runDBRead $ get uid
return (userDisplayName, Just UsersR) return (userDisplayName, Just UsersR)
@ -104,7 +104,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
breadcrumb (SchoolR ssh sRoute) = case sRoute of breadcrumb (SchoolR ssh sRoute) = case sRoute of
SchoolEditR -> maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do SchoolEditR -> maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
School{..} <- MaybeT . runDBRead $ get ssh School{..} <- MaybeT . runDBRead $ get ssh
isAdmin <- hasReadAccessTo SchoolListR isAdmin <- lift $ hasReadAccessTo SchoolListR
return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin) return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin)
SchoolWorkflowInstanceListR -> i18nCrumb MsgBreadcrumbWorkflowInstanceList . Just $ SchoolR ssh SchoolEditR SchoolWorkflowInstanceListR -> i18nCrumb MsgBreadcrumbWorkflowInstanceList . Just $ SchoolR ssh SchoolEditR
@ -212,7 +212,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh CInviteR) = i18nCrumb MsgBreadcrumbCourseParticipantInvitation . Just $ CourseR tid ssh csh CShowR
breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh CExamOfficeR) = i18nCrumb MsgMenuCourseExamOffice . Just $ CourseR tid ssh csh CShowR
breadcrumb (CourseR tid ssh csh (CUserR cID)) = maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do breadcrumb (CourseR tid ssh csh (CUserR cID)) = maybeT (i18nCrumb MsgBreadcrumbUser . Just $ CourseR tid ssh csh CUsersR) $ do
guardM . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID guardM . lift . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID
uid <- decrypt cID uid <- decrypt cID
User{userDisplayName} <- MaybeT . runDBRead $ get uid User{userDisplayName} <- MaybeT . runDBRead $ get uid
return (userDisplayName, Just $ CourseR tid ssh csh CUsersR) return (userDisplayName, Just $ CourseR tid ssh csh CUsersR)
@ -254,7 +254,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute of breadcrumb (CourseR tid ssh csh (CourseApplicationR cID sRoute)) = case sRoute of
CAEditR -> maybeT (i18nCrumb MsgBreadcrumbApplicant . Just $ CourseR tid ssh csh CApplicationsR) $ do CAEditR -> maybeT (i18nCrumb MsgBreadcrumbApplicant . Just $ CourseR tid ssh csh CApplicationsR) $ do
guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR guardM . lift . hasReadAccessTo $ CApplicationR tid ssh csh cID CAEditR
appId <- decrypt cID appId <- decrypt cID
User{..} <- hoist runDBRead $ MaybeT (get appId) >>= MaybeT . get . courseApplicationUser User{..} <- hoist runDBRead $ MaybeT (get appId) >>= MaybeT . get . courseApplicationUser
return (userDisplayName, Just $ CourseR tid ssh csh CApplicationsR) return (userDisplayName, Just $ CourseR tid ssh csh CApplicationsR)
@ -262,7 +262,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of breadcrumb (CourseR tid ssh csh (ExamR examn sRoute)) = case sRoute of
EShowR -> maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do EShowR -> maybeT (i18nCrumb MsgBreadcrumbExam . Just $ CourseR tid ssh csh CExamListR) $ do
guardM . hasReadAccessTo $ CExamR tid ssh csh examn EShowR guardM . lift . hasReadAccessTo $ CExamR tid ssh csh examn EShowR
return (CI.original examn, Just $ CourseR tid ssh csh CExamListR) return (CI.original examn, Just $ CourseR tid ssh csh CExamListR)
EEditR -> i18nCrumb MsgMenuExamEdit . Just $ CExamR tid ssh csh examn EShowR EEditR -> i18nCrumb MsgMenuExamEdit . Just $ CExamR tid ssh csh examn EShowR
EUsersR -> i18nCrumb MsgMenuExamUsers . Just $ CExamR tid ssh csh examn EShowR EUsersR -> i18nCrumb MsgMenuExamUsers . Just $ CExamR tid ssh csh examn EShowR
@ -277,7 +277,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of
TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do TUsersR -> maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do
guardM . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR
return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR) return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR
TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR
@ -287,7 +287,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of
SShowR -> maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do SShowR -> maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do
guardM . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR guardM . lift . hasReadAccessTo $ CSheetR tid ssh csh shn SShowR
return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
SEditR -> i18nCrumb MsgMenuSheetEdit . Just $ CSheetR tid ssh csh shn SShowR SEditR -> i18nCrumb MsgMenuSheetEdit . Just $ CSheetR tid ssh csh shn SShowR
SDelR -> i18nCrumb MsgMenuSheetDelete . Just $ CSheetR tid ssh csh shn SShowR SDelR -> i18nCrumb MsgMenuSheetDelete . Just $ CSheetR tid ssh csh shn SShowR
@ -321,7 +321,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR breadcrumb (CourseR tid ssh csh MaterialNewR ) = i18nCrumb MsgMenuMaterialNew . Just $ CourseR tid ssh csh MaterialListR
breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of breadcrumb (CourseR tid ssh csh (MaterialR mnm sRoute)) = case sRoute of
MShowR -> maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do MShowR -> maybeT (i18nCrumb MsgBreadcrumbMaterial . Just $ CourseR tid ssh csh MaterialListR) $ do
guardM . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR guardM . lift . hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR
return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR) return (CI.original mnm, Just $ CourseR tid ssh csh MaterialListR)
MEditR -> i18nCrumb MsgMenuMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR MEditR -> i18nCrumb MsgMenuMaterialEdit . Just $ CMaterialR tid ssh csh mnm MShowR
MDelR -> i18nCrumb MsgMenuMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR MDelR -> i18nCrumb MsgMenuMaterialDelete . Just $ CMaterialR tid ssh csh mnm MShowR
@ -359,7 +359,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
EEShowR -> do EEShowR -> do
isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR
maybeT (i18nCrumb MsgBreadcrumbExternalExam . Just $ bool EExamListR (ExamOfficeR EOExamsR) isEO) $ do maybeT (i18nCrumb MsgBreadcrumbExternalExam . Just $ bool EExamListR (ExamOfficeR EOExamsR) isEO) $ do
guardM . hasReadAccessTo $ EExamR tid ssh coursen examn EEShowR guardM . lift . hasReadAccessTo $ EExamR tid ssh coursen examn EEShowR
i18nCrumb (MsgBreadcrumbExternalExamShow coursen examn) . Just $ if i18nCrumb (MsgBreadcrumbExternalExamShow coursen examn) . Just $ if
| isEO -> ExamOfficeR EOExamsR | isEO -> ExamOfficeR EOExamsR
| otherwise -> EExamListR | otherwise -> EExamListR
@ -501,15 +501,15 @@ type family ChildrenNavChildren a where
ChildrenNavChildren a = Children ChGeneric a ChildrenNavChildren a = Children ChGeneric a
navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX) => Nav -> MaybeT m Nav navAccess :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX, MonadUnliftIO m) => Nav -> MaybeT m Nav
navAccess = execStateT $ do navAccess = execStateT $ do
guardM $ preuse _navLink >>= maybe (return True) navLinkAccess guardM $ preuse _navLink >>= lift . lift . maybe (return True) navLinkAccess
_navChildren <~ (filterM navLinkAccess =<< use _navChildren) _navChildren <~ (filterM (lift . lift . navLinkAccess) =<< use _navChildren)
whenM (hasn't _navLink <$> use id) $ whenM (hasn't _navLink <$> use id) $
guardM $ not . null <$> use _navChildren guardM $ not . null <$> use _navChildren
navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX) => NavLink -> m Bool navLinkAccess :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, BearerAuthSite UniWorX, MonadUnliftIO m) => NavLink -> m Bool
navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M` accessCheck navType navRoute navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M` accessCheck navType navRoute
where where
shortCircuit :: HandlerContents -> m Bool shortCircuit :: HandlerContents -> m Bool
@ -518,7 +518,7 @@ navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M`
accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool
accessCheck nt (urlRoute -> route) = do accessCheck nt (urlRoute -> route) = do
authCtx <- getAuthContext authCtx <- getAuthContext
$memcachedByHere (Just $ Right 120) (authCtx, nt, route) $ $memcachedByHere (Just . Right $ 2 * diffMinute) (authCtx, nt, route) $
bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route
defaultLinks :: ( MonadHandler m defaultLinks :: ( MonadHandler m
@ -871,6 +871,7 @@ pageActions :: ( MonadHandler m
, MonadCatch m , MonadCatch m
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX) , BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
, MonadUnliftIO m
) )
=> Route UniWorX -> m [Nav] => Route UniWorX -> m [Nav]
pageActions NewsR = return pageActions NewsR = return
@ -2576,7 +2577,7 @@ submissionList tid csh shn uid = withReaderT (projectBackend @SqlReadBackend) .
return $ submission E.^. SubmissionId return $ submission E.^. SubmissionId
pageQuickActions :: ( MonadCatch m pageQuickActions :: ( MonadCatch m, MonadUnliftIO m
, MonadHandler m , MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
@ -2590,7 +2591,7 @@ pageQuickActions qView route = do
-- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course -- | Verify that the currently logged in user is lecturer or corrector for at least one sheet for the given course
evalAccessCorrector evalAccessCorrector
:: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX) :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX, MonadUnliftIO m)
=> TermId -> SchoolId -> CourseShorthand -> m AuthResult => TermId -> SchoolId -> CourseShorthand -> m AuthResult
evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False
@ -2606,7 +2607,7 @@ _haveWorkflowInstances rScope = hoist liftHandler . withReaderT (projectBackend
scope <- fromRouteWorkflowScope rScope scope <- fromRouteWorkflowScope rScope
let checkAccess (Entity _ WorkflowInstance{..}) let checkAccess (Entity _ WorkflowInstance{..})
= hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR) = lift . hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
getInstances = E.selectSource . E.from $ \workflowInstance -> do getInstances = E.selectSource . E.from $ \workflowInstance -> do
E.where_ $ workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope) E.where_ $ workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope)
return workflowInstance return workflowInstance
@ -2617,7 +2618,7 @@ haveWorkflowWorkflows rScope = hoist liftHandler . withReaderT (projectBackend @
let checkAccess (E.Value wwId) = do let checkAccess (E.Value wwId) = do
cID <- lift . lift $ encrypt wwId cID <- lift . lift $ encrypt wwId
hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) lift . hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
getWorkflows = E.selectSource . E.from $ \workflowWorkflow -> do getWorkflows = E.selectSource . E.from $ \workflowWorkflow -> do
E.where_ $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope) E.where_ $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
return $ workflowWorkflow E.^. WorkflowWorkflowId return $ workflowWorkflow E.^. WorkflowWorkflowId
@ -2633,7 +2634,7 @@ haveTopWorkflowInstances, haveTopWorkflowWorkflows
haveTopWorkflowInstances = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $ haveTopWorkflowInstances = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $
let checkAccess (Entity _ WorkflowInstance{..}) = do let checkAccess (Entity _ WorkflowInstance{..}) = do
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR) lift . hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
getInstances = selectSource [] [] getInstances = selectSource [] []
isTop (Entity _ WorkflowInstance{..}) = isTopWorkflowScope workflowInstanceScope isTop (Entity _ WorkflowInstance{..}) = isTopWorkflowScope workflowInstanceScope
in $cachedHere . runConduit $ transPipe lift getInstances .| C.filter isTop .| C.mapM checkAccess .| C.or in $cachedHere . runConduit $ transPipe lift getInstances .| C.filter isTop .| C.mapM checkAccess .| C.or
@ -2641,7 +2642,7 @@ haveTopWorkflowWorkflows = hoist liftHandler . withReaderT (projectBackend @SqlR
let checkAccess (Entity wwId WorkflowWorkflow{..}) = do let checkAccess (Entity wwId WorkflowWorkflow{..}) = do
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
cID <- lift . lift $ encrypt wwId cID <- lift . lift $ encrypt wwId
hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR) lift . hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
getWorkflows = selectSource [] [] getWorkflows = selectSource [] []
isTop (Entity _ WorkflowWorkflow{..}) = isTopWorkflowScope workflowWorkflowScope isTop (Entity _ WorkflowWorkflow{..}) = isTopWorkflowScope workflowWorkflowScope
in $cachedHere . runConduit $ transPipe lift getWorkflows .| C.filter isTop .| C.mapM checkAccess .| C.or in $cachedHere . runConduit $ transPipe lift getWorkflows .| C.filter isTop .| C.mapM checkAccess .| C.or

9
src/Foundation/Yesod/Auth.hs
View File

@ -15,6 +15,8 @@ import Handler.Utils.Profile
import Handler.Utils.StudyFeatures import Handler.Utils.StudyFeatures
import Handler.Utils.SchoolLdap import Handler.Utils.SchoolLdap
import Handler.Utils.LdapSystemFunctions import Handler.Utils.LdapSystemFunctions
import Handler.Utils.Memcached
import Foundation.Authorization (AuthorizationCacheKey(..))
import Yesod.Auth.Message import Yesod.Auth.Message
import Auth.LDAP import Auth.LDAP
@ -469,9 +471,10 @@ upsertCampusUser upsertMode ldapData = do
Right str <- return $ Text.decodeUtf8' v' Right str <- return $ Text.decodeUtf8' v'
assertM' (not . Text.null) $ Text.strip str assertM' (not . Text.null) $ Text.strip str
iforM_ userSystemFunctions $ \func preset -> if iforM_ userSystemFunctions $ \func preset -> do
| preset -> void $ upsert (UserSystemFunction userId func False False) [] memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
| otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False] if | preset -> void $ upsert (UserSystemFunction userId func False False) []
| otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
return user return user
where where

2
src/Handler/Course/Application/Files.hs
View File

@ -58,7 +58,7 @@ getCAppsFilesR tid ssh csh = do
return (allocation, user, courseApplication) return (allocation, user, courseApplication)
apps' <- flip filterM apps $ \(_, _, Entity appId _) -> do apps' <- flip filterM apps $ \(_, _, Entity appId _) -> do
cID <- cachedByBinary appId $ encrypt appId cID <- cachedByBinary appId $ encrypt appId
hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR lift . hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
let let
applicationAllocs = setOf (folded . _1) apps' applicationAllocs = setOf (folded . _1) apps'

5
src/Handler/Course/Edit.hs
View File

@ -328,7 +328,7 @@ validateCourse = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
uid <- liftHandler requireAuthId uid <- liftHandler requireAuthId
userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR userAdmin <- lift . hasWriteAccessTo $ SchoolR cfSchool SchoolEditR
newAllocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust newAllocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust
prevAllocationCourse <- join <$> traverse (lift . getBy . UniqueAllocationCourse) cfCourseId prevAllocationCourse <- join <$> traverse (lift . getBy . UniqueAllocationCourse) cfCourseId
@ -514,6 +514,7 @@ courseEditHandler miButtonAction mbCourseForm = do
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
insert_ $ CourseEdit aid now cid insert_ $ CourseEdit aid now cid
upsertAllocationCourse cid $ cfAllocation res upsertAllocationCourse cid $ cfAllocation res
memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
return insertOkay return insertOkay
case insertOkay of case insertOkay of
Just _ -> do Just _ -> do
@ -573,6 +574,8 @@ courseEditHandler miButtonAction mbCourseForm = do
in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . sequence_ $ cfAppInstructionFiles res in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . sequence_ $ cfAppInstructionFiles res
upsertAllocationCourse cid $ cfAllocation res upsertAllocationCourse cid $ cfAllocation res
memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
addMessageI Success $ MsgCourseEditOk tid ssh csh addMessageI Success $ MsgCourseEditOk tid ssh csh
return True return True

3
src/Handler/Course/LecturerInvite.hs
View File

@ -10,6 +10,7 @@ import Import
import Utils.Form import Utils.Form
import Handler.Utils.Invitations import Handler.Utils.Invitations
import Handler.Utils.Memcached
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
@ -75,7 +76,7 @@ lecturerInvitationConfig = InvitationConfig{..}
toJunction jLecturerType = (JunctionLecturer{..}, ()) toJunction jLecturerType = (JunctionLecturer{..}, ())
lFs :: FieldSettings UniWorX lFs :: FieldSettings UniWorX
lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical
invitationInsertHook _ _ _ _ _ = id invitationInsertHook _ _ _ _ _ = (*>) (memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId))
invitationSuccessMsg (Entity _ Course{..}) (Entity _ Lecturer{..}) = do invitationSuccessMsg (Entity _ Course{..}) (Entity _ Lecturer{..}) = do
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer
return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand

3
src/Handler/Course/ParticipantInvite.hs
View File

@ -92,11 +92,12 @@ participantInvitationConfig = InvitationConfig{..}
invitationForm _ _ _ = hoistAForm lift . wFormToAForm $ do invitationForm _ _ _ = hoistAForm lift . wFormToAForm $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
return . pure . (, ()) $ JunctionParticipant now Nothing CourseParticipantActive return . pure . (, ()) $ JunctionParticipant now Nothing CourseParticipantActive
invitationInsertHook _ _ (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do invitationInsertHook _ (Entity _ Course{..}) (_, InvTokenDataParticipant{..}) CourseParticipant{..} _ act = do
deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert deleteBy $ UniqueParticipant courseParticipantUser courseParticipantCourse -- there are no foreign key references to @{CourseParticipant}; therefor we can delete and recreate to simulate upsert
res <- act -- insertUnique res <- act -- insertUnique
audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
void $ setUserSubmissionGroup courseParticipantCourse courseParticipantUser invTokenParticipantSubmissionGroup void $ setUserSubmissionGroup courseParticipantCourse courseParticipantUser invTokenParticipantSubmissionGroup
memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId))
return res return res
invitationSuccessMsg (Entity _ Course{..}) _ = invitationSuccessMsg (Entity _ Course{..}) _ =
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName) return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)

8
src/Handler/Course/Register.hs
View File

@ -222,6 +222,7 @@ postCRegisterR tid ssh csh = do
= return $ Just () = return $ Just ()
mkRegistration = do mkRegistration = do
audit $ TransactionCourseParticipantEdit cid uid audit $ TransactionCourseParticipantEdit cid uid
memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId))
entityKey <$> upsert entityKey <$> upsert
(CourseParticipant cid uid cTime Nothing CourseParticipantActive) (CourseParticipant cid uid cTime Nothing CourseParticipantActive)
[ CourseParticipantRegistration =. cTime [ CourseParticipantRegistration =. cTime
@ -238,7 +239,7 @@ postCRegisterR tid ssh csh = do
BtnCourseDeregister -> runDB . setSerializable $ do BtnCourseDeregister -> runDB . setSerializable $ do
part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
forM_ part $ \(Entity _partId CourseParticipant{..}) -> do forM_ part $ \(Entity _partId CourseParticipant{..}) -> do
deregisterParticipant uid cid deregisterParticipant uid course
when (is _Just courseParticipantAllocated) $ do when (is _Just courseParticipantAllocated) $ do
updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive courseDeregisterNoShow ] updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive courseDeregisterNoShow ]
@ -284,12 +285,13 @@ deleteApplications uid cid = do
deleteApplicationFiles :: CourseApplicationId -> DB () deleteApplicationFiles :: CourseApplicationId -> DB ()
deleteApplicationFiles appId = deleteWhere [ CourseApplicationFileApplication ==. appId ] deleteApplicationFiles appId = deleteWhere [ CourseApplicationFileApplication ==. appId ]
deregisterParticipant :: UserId -> CourseId -> DB () deregisterParticipant :: UserId -> Entity Course -> DB ()
deregisterParticipant uid cid = do deregisterParticipant uid (Entity cid Course{..}) = do
part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
forM_ part $ \(Entity partId CourseParticipant{}) -> do forM_ part $ \(Entity partId CourseParticipant{}) -> do
update partId [CourseParticipantState =. CourseParticipantInactive False] update partId [CourseParticipantState =. CourseParticipantInactive False]
audit $ TransactionCourseParticipantDeleted cid uid audit $ TransactionCourseParticipantDeleted cid uid
memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId))
examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do
E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId

14
src/Handler/Course/Show.hs
View File

@ -84,7 +84,7 @@ getCShowR tid ssh csh = do
cTime <- NTop . Just <$> liftIO getCurrentTime cTime <- NTop . Just <$> liftIO getCurrentTime
news <- forMaybeM news' $ \(Entity nId n@CourseNews{..}) -> do news <- forMaybeM news' $ \(Entity nId n@CourseNews{..}) -> do
cID <- encrypt nId :: MaybeT (MaybeT DB) CryptoUUIDCourseNews cID <- encrypt nId :: MaybeT (MaybeT DB) CryptoUUIDCourseNews
guardM . hasReadAccessTo $ CNewsR tid ssh csh cID CNShowR guardM . lift . lift . hasReadAccessTo $ CNewsR tid ssh csh cID CNShowR
let visible = cTime >= NTop courseNewsVisibleFrom let visible = cTime >= NTop courseNewsVisibleFrom
files' <- lift . lift . E.select . E.from $ \newsFile -> do files' <- lift . lift . E.select . E.from $ \newsFile -> do
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
@ -93,8 +93,8 @@ getCShowR tid ssh csh = do
& over (mapped . _1) E.unValue & over (mapped . _1) E.unValue
& over (mapped . _2) E.unValue & over (mapped . _2) E.unValue
lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit
mayEditNews <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR mayEditNews <- lift . lift . hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR
mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR mayDelete <- lift . lift . hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR
files <- lift . lift $ forM files'' $ \f@(_isDir, fPath) -> fmap (f ,) . toTextUrl . CNewsR tid ssh csh cID $ CNFileR fPath files <- lift . lift $ forM files'' $ \f@(_isDir, fPath) -> fmap (f ,) . toTextUrl . CNewsR tid ssh csh cID $ CNFileR fPath
archiveUrl <- lift . lift . toTextUrl $ CNewsR tid ssh csh cID CNArchiveR archiveUrl <- lift . lift . toTextUrl $ CNewsR tid ssh csh cID CNArchiveR
@ -121,17 +121,17 @@ getCShowR tid ssh csh = do
mayReRegister <- lift . courseMayReRegister $ Entity cid course mayReRegister <- lift . courseMayReRegister $ Entity cid course
mayViewSheets <- hasReadAccessTo $ CourseR tid ssh csh SheetListR mayViewSheets <- lift . hasReadAccessTo $ CourseR tid ssh csh SheetListR
sheets <- lift . E.select . E.from $ \sheet -> do sheets <- lift . E.select . E.from $ \sheet -> do
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return $ sheet E.^. SheetName return $ sheet E.^. SheetName
mayViewAnySheet <- anyM sheets $ \(E.Value shn) -> hasReadAccessTo $ CSheetR tid ssh csh shn SShowR mayViewAnySheet <- lift . anyM sheets $ \(E.Value shn) -> hasReadAccessTo $ CSheetR tid ssh csh shn SShowR
mayViewMaterials <- hasReadAccessTo $ CourseR tid ssh csh MaterialListR mayViewMaterials <- lift . hasReadAccessTo $ CourseR tid ssh csh MaterialListR
materials <- lift . E.select . E.from $ \material -> do materials <- lift . E.select . E.from $ \material -> do
E.where_ $ material E.^. MaterialCourse E.==. E.val cid E.where_ $ material E.^. MaterialCourse E.==. E.val cid
return $ material E.^. MaterialName return $ material E.^. MaterialName
mayViewAnyMaterial <- anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR mayViewAnyMaterial <- lift . anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR
return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial))

19
src/Handler/Course/User.hs
View File

@ -90,22 +90,22 @@ postCUserR tid ssh csh uCId = do
forM_ sections . fromMaybe $ return () forM_ sections . fromMaybe $ return ()
courseUserProfileSection :: Entity Course -> Entity User -> MaybeT Handler Widget courseUserProfileSection :: Entity Course -> Entity User -> MaybeT Handler Widget
courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex = _, ..}) = do courseUserProfileSection course@(Entity cid Course{..}) (Entity uid User{ userShowSex = _, ..}) = do
showSex <- maybe False (userShowSex . entityVal) <$> maybeAuth showSex <- maybe False (userShowSex . entityVal) <$> maybeAuth
currentRoute <- MaybeT getCurrentRoute currentRoute <- MaybeT getCurrentRoute
(mRegistration, studies) <- lift . runDB $ do (mRegistration, studies) <- lift . runDB $ do
registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid registration <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
studies <- E.select $ E.from $ \(course `E.InnerJoin` studyfeat `E.InnerJoin` studydegree `E.InnerJoin` studyterms) -> do studies <- E.select $ E.from $ \(course' `E.InnerJoin` studyfeat `E.InnerJoin` studydegree `E.InnerJoin` studyterms) -> do
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
E.on $ isCourseStudyFeature course studyfeat E.on $ isCourseStudyFeature course' studyfeat
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.where_ $ course E.^. CourseId E.==. E.val cid E.where_ $ course' E.^. CourseId E.==. E.val cid
return (studyfeat, studydegree, studyterms) return (studyfeat, studydegree, studyterms)
return (registration, studies) return (registration, studies)
mayRegister <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CAddUserR mayRegister <- lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CAddUserR
let regButton let regButton
| is _Just mRegistration = BtnCourseDeregister | is _Just mRegistration = BtnCourseDeregister
| otherwise = BtnCourseRegister | otherwise = BtnCourseRegister
@ -138,7 +138,8 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
| Just (Entity _pId CourseParticipant{..}) <- mRegistration | Just (Entity _pId CourseParticipant{..}) <- mRegistration
-> do -> do
lift . runDB $ do lift . runDB $ do
deregisterParticipant courseParticipantUser courseParticipantCourse unless (courseParticipantCourse == cid) $ error "courseParticipantCourse does not match cid"
deregisterParticipant courseParticipantUser course
whenIsJust mbReason $ \(reason, noShow) -> do whenIsJust mbReason $ \(reason, noShow) -> do
updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive noShow ] updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive noShow ]
@ -181,7 +182,7 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
courseUserNoteSection :: Entity Course -> Entity User -> MaybeT Handler Widget courseUserNoteSection :: Entity Course -> Entity User -> MaybeT Handler Widget
courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do
guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CUsersR guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CUsersR
currentRoute <- MaybeT getCurrentRoute currentRoute <- MaybeT getCurrentRoute
@ -240,7 +241,7 @@ courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do
courseUserSubmissionsSection :: Entity Course -> Entity User -> MaybeT Handler Widget courseUserSubmissionsSection :: Entity Course -> Entity User -> MaybeT Handler Widget
courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do
guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR
let whereClause = (E.&&.) <$> courseIs cid <*> userIs uid let whereClause = (E.&&.) <$> courseIs cid <*> userIs uid
colonnade = mconcat -- should match getSSubsR for consistent UX colonnade = mconcat -- should match getSSubsR for consistent UX
@ -279,7 +280,7 @@ courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do
courseUserExamsSection :: Entity Course -> Entity User -> MaybeT Handler Widget courseUserExamsSection :: Entity Course -> Entity User -> MaybeT Handler Widget
courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do courseUserExamsSection (Entity cid Course{..}) (Entity uid _) = do
guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CExamNewR guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CExamNewR
uCID <- encrypt uid uCID <- encrypt uid

5
src/Handler/Course/Users.hs
View File

@ -509,7 +509,7 @@ getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCUsersR = postCUsersR getCUsersR = postCUsersR
postCUsersR tid ssh csh = do postCUsersR tid ssh csh = do
showSex <- getShowSex showSex <- getShowSex
(Entity cid Course{..}, numParticipants, (participantRes,participantTable)) <- runDB $ do (course@(Entity cid Course{..}), numParticipants, (participantRes,participantTable)) <- runDB $ do
mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR mayRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
hasTutorials <- exists [TutorialCourse ==. cid] hasTutorials <- exists [TutorialCourse ==. cid]
@ -607,7 +607,8 @@ postCUsersR tid ssh csh = do
Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do Sum nrDel <- fmap mconcat . runDB . forM (Set.toList selectedUsers) $ \uid -> fmap (maybe mempty Sum) . runMaybeT $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
Entity _ CourseParticipant{..} <- MaybeT . fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid Entity _ CourseParticipant{..} <- MaybeT . fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
lift $ deregisterParticipant courseParticipantUser courseParticipantCourse unless (courseParticipantCourse == cid) $ error "courseParticipantCourse does not match cid"
lift $ deregisterParticipant courseParticipantUser course
case deregisterSelfImposed of case deregisterSelfImposed of
Just (reason, noShow) Just (reason, noShow)
| is _Just courseParticipantAllocated -> lift $ do | is _Just courseParticipantAllocated -> lift $ do

2
src/Handler/Exam/AddUser.hs
View File

@ -129,7 +129,7 @@ postEAddUserR tid ssh csh examn = do
unless registerCourse $ unless registerCourse $
throwError $ mempty { aurNoCourseRegistration = pure userEmail } throwError $ mempty { aurNoCourseRegistration = pure userEmail }
guardAuthResult =<< lift (lift $ evalAccessDB (CourseR tid ssh csh CAddUserR) True) lift . lift . hoist lift $ guardAuthResult =<< evalAccessDB (CourseR tid ssh csh CAddUserR) True
lift . lift . void $ upsert lift . lift . void $ upsert

3
src/Handler/Exam/CorrectorInvite.hs
View File

@ -11,6 +11,7 @@ module Handler.Exam.CorrectorInvite
import Import import Import
import Handler.Utils.Invitations import Handler.Utils.Invitations
import Handler.Utils.Exam import Handler.Utils.Exam
import Handler.Utils.Memcached
import Data.Aeson hiding (Result(..)) import Data.Aeson hiding (Result(..))
@ -71,7 +72,7 @@ examCorrectorInvitationConfig = InvitationConfig{..}
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure (JunctionExamCorrector, ()) invitationForm _ _ _ = pure (JunctionExamCorrector, ())
invitationInsertHook _ _ _ _ _ = id invitationInsertHook _ _ _ _ _ = (*>) (memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId))
invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName
invitationUltDest (Entity _ Exam{..}) _ = do invitationUltDest (Entity _ Exam{..}) _ = do
Course{..} <- get404 examCourse Course{..} <- get404 examCourse

1
src/Handler/Exam/Edit.hs
View File

@ -113,6 +113,7 @@ postEEditR tid ssh csh examn = do
deleteWhere [ ExamCorrectorExam ==. eId ] deleteWhere [ ExamCorrectorExam ==. eId ]
insertMany_ $ map (ExamCorrector eId) adds insertMany_ $ map (ExamCorrector eId) adds
memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId)
deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ] deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ]
sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites

1
src/Handler/Exam/New.hs
View File

@ -84,6 +84,7 @@ postCExamNewR tid ssh csh = do
, examCorrectorUser <- adds , examCorrectorUser <- adds
] ]
sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId)
let recordNoShow (Entity _ CourseParticipant{..}) = do let recordNoShow (Entity _ CourseParticipant{..}) = do
didRecord <- is _Just <$> insertUnique ExamResult didRecord <- is _Just <$> insertUnique ExamResult

2
src/Handler/Exam/Show.hs
View File

@ -196,7 +196,7 @@ getEShowR tid ssh csh examn = do
notificationDiscouragedExamMode <- runMaybeT $ do notificationDiscouragedExamMode <- runMaybeT $ do
guard $ evalExamModeDNF schoolExamDiscouragedModes examExamMode guard $ evalExamModeDNF schoolExamDiscouragedModes examExamMode
guardM . hasWriteAccessTo $ CExamR tid ssh csh examn EEditR guardM . lift . hasWriteAccessTo $ CExamR tid ssh csh examn EEditR
return $ notification NotificationBroad =<< messageI Warning MsgExamModeSchoolDiscouraged return $ notification NotificationBroad =<< messageI Warning MsgExamModeSchoolDiscouraged
siteLayoutMsg heading $ do siteLayoutMsg heading $ do

4
src/Handler/ExternalExam/Form.hs
View File

@ -107,13 +107,13 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do
fSettings = fslI MsgExternalExamStaff & setTooltip MsgExternalExamStaffTip fSettings = fslI MsgExternalExamStaff & setTooltip MsgExternalExamStaffTip
fRequired = True fRequired = True
validateExternalExam :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExternalExamForm m () validateExternalExam :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m) => FormValidator ExternalExamForm m ()
validateExternalExam = do validateExternalExam = do
State.modify $ \eeForm -> eeForm & over _eefOfficeSchools (Set.delete $ eeForm ^. _eefSchool) State.modify $ \eeForm -> eeForm & over _eefOfficeSchools (Set.delete $ eeForm ^. _eefSchool)
ExternalExamForm{..} <- State.get ExternalExamForm{..} <- State.get
isAdmin <- hasWriteAccessTo $ SchoolR eefSchool SchoolEditR isAdmin <- lift . hasWriteAccessTo $ SchoolR eefSchool SchoolEditR
unless isAdmin $ do unless isAdmin $ do
uid <- requireAuthId uid <- requireAuthId
guardValidation MsgExternalExamUserMustBeStaff $ Right uid `Set.member` eefStaff guardValidation MsgExternalExamUserMustBeStaff $ Right uid `Set.member` eefStaff

2
src/Handler/Info.hs
View File

@ -108,6 +108,7 @@ mkMessageFor ''UniWorX ''FAQItem "messages/faq" "de-de-formal"
faqsWidget :: ( MonadHandler m, HandlerSite m ~ UniWorX faqsWidget :: ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, MonadUnliftIO m
) )
=> Maybe Natural -> Maybe (Route UniWorX) -> m (Maybe Widget, Bool) => Maybe Natural -> Maybe (Route UniWorX) -> m (Maybe Widget, Bool)
faqsWidget mLimit route = do faqsWidget mLimit route = do
@ -157,6 +158,7 @@ getFaqR =
showFAQ :: ( MonadHandler m, HandlerSite m ~ UniWorX showFAQ :: ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadThrow m , MonadThrow m
, MonadUnliftIO m
) )
=> Route UniWorX -> FAQItem -> m Bool => Route UniWorX -> FAQItem -> m Bool
showFAQ _ FAQNoCampusAccount = is _Nothing <$> maybeAuthId showFAQ _ FAQNoCampusAccount = is _Nothing <$> maybeAuthId

2
src/Handler/News.hs
View File

@ -70,7 +70,7 @@ newsSystemMessages = do
(messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $ (messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $
transPipe lift (selectKeys [] []) transPipe lift (selectKeys [] [])
.| C.filterM (hasReadAccessTo . MessageR <=< encrypt) .| C.filterM (lift . hasReadAccessTo . MessageR <=< encrypt)
.| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage smId) .| transPipe lift (C.mapMaybeM $ \smId -> fmap (\args@(sm, _) -> (smId, sm, systemMessageToTranslation smId args)) <$> getSystemMessage smId)
.| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo) .| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo)
.| C.mapMaybeM checkHidden .| C.mapMaybeM checkHidden

2
src/Handler/Profile.hs
View File

@ -151,7 +151,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
notificationForm template = wFormToAForm $ do notificationForm template = wFormToAForm $ do
mbUid <- liftHandler maybeAuthId mbUid <- liftHandler maybeAuthId
isAdmin <- hasReadAccessTo AdminR isAdmin <- lift . lift $ hasReadAccessTo AdminR
let let
sectionIsHidden :: NotificationTriggerKind -> DB Bool sectionIsHidden :: NotificationTriggerKind -> DB Bool

2
src/Handler/Sheet/CorrectorInvite.hs
View File

@ -74,7 +74,7 @@ correctorInvitationConfig = InvitationConfig{..}
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized invitationRestriction _ _ = return Authorized
invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure (JunctionSheetCorrector cLoad cState, ()) invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure (JunctionSheetCorrector cLoad cState, ())
invitationInsertHook _ _ _ _ _ = id invitationInsertHook _ _ _ _ _ = (*>) (memcachedByInvalidate AuthCacheCorrectorList $ Proxy @(Set UserId))
invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
invitationUltDest (Entity _ Sheet{..}) _ = do invitationUltDest (Entity _ Sheet{..}) _ = do
Course{..} <- get404 sheetCourse Course{..} <- get404 sheetCourse

1
src/Handler/Sheet/Edit.hs
View File

@ -120,6 +120,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
deleteWhere [ SheetCorrectorSheet ==. sid ] deleteWhere [ SheetCorrectorSheet ==. sid ]
insertMany_ adds insertMany_ adds
memcachedByInvalidate AuthCacheCorrectorList (Proxy @(Set UserId))
deleteWhere [InvitationFor ==. invRef @SheetCorrector sid, InvitationEmail /<-. toListOf (folded . _1) invites] deleteWhere [InvitationFor ==. invRef @SheetCorrector sid, InvitationEmail /<-. toListOf (folded . _1) invites]
sinkInvitationsF correctorInvitationConfig invites sinkInvitationsF correctorInvitationConfig invites

2
src/Handler/Sheet/Form.hs
View File

@ -120,7 +120,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
) )
] ]
) )
guardM $ hasReadAccessTo downloadRoute guardM . lift $ hasReadAccessTo downloadRoute
messageIconWidget Info IconFileUser messageIconWidget Info IconFileUser
[whamlet| [whamlet|
$newline never $newline never

2
src/Handler/Sheet/List.hs
View File

@ -95,7 +95,7 @@ getSheetListR tid ssh csh = do
acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating") acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
tellStats = do tellStats = do
r <- mkRoute r <- mkRoute
showRating <- hasReadAccessTo r showRating <- lift $ hasReadAccessTo r
tell . stats $ bool Nothing submissionRatingPoints showRating tell . stats $ bool Nothing submissionRatingPoints showRating
in acell & cellContents %~ (<* tellStats) in acell & cellContents %~ (<* tellStats)

6
src/Handler/Sheet/Show.hs
View File

@ -129,7 +129,7 @@ getSShowR tid ssh csh shn = do
mRequiredExamLink <- runMaybeT $ do mRequiredExamLink <- runMaybeT $ do
(etid, essh, ecsh, examn) <- hoistMaybe mRequiredExam (etid, essh, ecsh, examn) <- hoistMaybe mRequiredExam
let eUrl = CExamR etid essh ecsh examn EShowR let eUrl = CExamR etid essh ecsh examn EShowR
guardM $ hasReadAccessTo eUrl guardM . lift $ hasReadAccessTo eUrl
return eUrl return eUrl
mMissingExamRegistration <- for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> maybeT (return True) $ do mMissingExamRegistration <- for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> maybeT (return True) $ do
uid <- MaybeT maybeAuthId uid <- MaybeT maybeAuthId
@ -148,7 +148,7 @@ getSShowR tid ssh csh shn = do
submissionModeNoneWithoutNotGradedWarning <- runMaybeT $ do submissionModeNoneWithoutNotGradedWarning <- runMaybeT $ do
guard $ classifySubmissionMode (sheetSubmissionMode sheet) == SubmissionModeNone guard $ classifySubmissionMode (sheetSubmissionMode sheet) == SubmissionModeNone
&& sheetType sheet /= NotGraded && sheetType sheet /= NotGraded
guardM . hasWriteAccessTo $ CSheetR tid ssh csh shn SEditR guardM . lift . hasWriteAccessTo $ CSheetR tid ssh csh shn SEditR
return $ notification NotificationBroad =<< messageI Warning MsgSheetSubmissionModeNoneWithoutNotGraded return $ notification NotificationBroad =<< messageI Warning MsgSheetSubmissionModeNoneWithoutNotGraded
sTypeDesc <- runDB $ sheetTypeDescription (sheetCourse sheet) (sheetType sheet) sTypeDesc <- runDB $ sheetTypeDescription (sheetCourse sheet) (sheetType sheet)
@ -162,7 +162,7 @@ getSShowR tid ssh csh shn = do
sheetTo <- traverse (formatTime SelFormatDateTime) $ sheetActiveTo sheet sheetTo <- traverse (formatTime SelFormatDateTime) $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet) markingText <- runMaybeT $ assertM_ (Authorized ==) (lift $ evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet)
submissionTip <- messageI Info MsgSheetCorrectorSubmissionsTip submissionTip <- messageI Info MsgSheetCorrectorSubmissionsTip
tr <- getTranslate tr <- getTranslate
$(widgetFile "sheetShow") $(widgetFile "sheetShow")

4
src/Handler/Submission/Download.hs
View File

@ -24,7 +24,7 @@ subDownloadSource tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) p
isRating <- lift $ (== Just submissionID) <$> isRatingFile path isRating <- lift $ (== Just submissionID) <$> isRatingFile path
when (isUpdate || isRating) $ when (isUpdate || isRating) $
guardM . hasReadAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR guardM . lift . hasReadAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR
return (submissionID, isRating) return (submissionID, isRating)
@ -59,7 +59,7 @@ getSubDownloadR tid ssh csh shn cID sft@(submissionFileTypeIsUpdate -> isUpdate)
subArchiveSource :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> ConduitT () (Either SubmissionFile DBFile) (YesodDB UniWorX) () subArchiveSource :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> ConduitT () (Either SubmissionFile DBFile) (YesodDB UniWorX) ()
subArchiveSource tid ssh csh shn cID sfType = maybeT (return ()) $ do subArchiveSource tid ssh csh shn cID sfType = maybeT (return ()) $ do
when (sfType == SubmissionCorrected) $ when (sfType == SubmissionCorrected) $
guardM . hasReadAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR guardM . lift . lift . hasReadAccessTo $ CSubmissionR tid ssh csh shn cID CorrectionR
lift $ do lift $ do
submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID

2
src/Handler/Tutorial/Communication.hs
View File

@ -21,7 +21,7 @@ postTCommR tid ssh csh tutn = do
tuts <- selectList [TutorialCourse ==. cid] [] tuts <- selectList [TutorialCourse ==. cid] []
usertuts <- forMaybeM tuts $ \(Entity tutid Tutorial{..}) -> do usertuts <- forMaybeM tuts $ \(Entity tutid Tutorial{..}) -> do
cID <- encrypt tutid cID <- encrypt tutid
guardM . hasReadAccessTo $ CTutorialR tid ssh csh tutorialName TUsersR guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutorialName TUsersR
return ( RGTutorialParticipants cID return ( RGTutorialParticipants cID
, E.from $ \(user `E.InnerJoin` participant) -> do , E.from $ \(user `E.InnerJoin` participant) -> do
E.on $ user E.^. UserId E.==. participant E.^. TutorialParticipantUser E.on $ user E.^. UserId E.==. participant E.^. TutorialParticipantUser

1
src/Handler/Tutorial/Edit.hs
View File

@ -78,6 +78,7 @@ postTEditR tid ssh csh tutn = do
deleteWhere [ InvitationFor ==. invRef @Tutor tutid, InvitationEmail /<-. invites ] deleteWhere [ InvitationFor ==. invRef @Tutor tutid, InvitationEmail /<-. invites ]
sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites
memcachedByInvalidate AuthCacheTutorList $ Proxy @(Set UserId)
return insertRes return insertRes
case insertRes of case insertRes of
Just _ -> addMessageI Error $ MsgTutorialNameTaken tfName Just _ -> addMessageI Error $ MsgTutorialNameTaken tfName

1
src/Handler/Tutorial/New.hs
View File

@ -43,6 +43,7 @@ postCTutorialNewR tid ssh csh = do
let (invites, adds) = partitionEithers $ Set.toList tfTutors let (invites, adds) = partitionEithers $ Set.toList tfTutors
insertMany_ $ map (Tutor tutid) adds insertMany_ $ map (Tutor tutid) adds
memcachedByInvalidate AuthCacheTutorList $ Proxy @(Set UserId)
sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites
return insertRes return insertRes
case insertRes of case insertRes of

3
src/Handler/Tutorial/TutorInvite.hs
View File

@ -9,6 +9,7 @@ module Handler.Tutorial.TutorInvite
import Import import Import
import Handler.Utils.Tutorial import Handler.Utils.Tutorial
import Handler.Utils.Invitations import Handler.Utils.Invitations
import Handler.Utils.Memcached
import Data.Aeson hiding (Result(..)) import Data.Aeson hiding (Result(..))
@ -69,7 +70,7 @@ tutorInvitationConfig = InvitationConfig{..}
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure (JunctionTutor, ()) invitationForm _ _ _ = pure (JunctionTutor, ())
invitationInsertHook _ _ _ _ _ = id invitationInsertHook _ _ _ _ _ = (*>) (memcachedByInvalidate AuthCacheTutorList $ Proxy @(Set UserId))
invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
invitationUltDest (Entity _ Tutorial{..}) _ = do invitationUltDest (Entity _ Tutorial{..}) _ = do
Course{..} <- get404 tutorialCourse Course{..} <- get404 tutorialCourse

17
src/Handler/Users.hs
View File

@ -108,7 +108,7 @@ postUsersR = do
, formCellLens = id , formCellLens = id
, formCellContents = do , formCellContents = do
cID <- encrypt uid cID <- encrypt uid
mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True mayHijack <- lift . lift $ (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
myUid <- liftHandler maybeAuthId myUid <- liftHandler maybeAuthId
if if
| mayHijack | mayHijack
@ -319,7 +319,7 @@ postAdminUserR uuid = do
-- above data is needed for both form generation and result evaluation -- above data is needed for both form generation and result evaluation
let userRightsForm :: Form (Set (SchoolFunction, SchoolId)) let userRightsForm :: Form (Set (SchoolFunction, SchoolId))
userRightsForm = identifyForm FIDuserRights $ \csrf -> do userRightsForm csrf = do
boxRights <- sequence . flip Map.fromSet (allFunctions `setProduct` allSchools) $ \(function, sid) -> if boxRights <- sequence . flip Map.fromSet (allFunctions `setProduct` allSchools) $ \(function, sid) -> if
| sid `Set.member` adminSchools | sid `Set.member` adminSchools
-> mpopt checkBoxField "" . Just $ (function, sid) `Set.member` functions -> mpopt checkBoxField "" . Just $ (function, sid) `Set.member` functions
@ -339,6 +339,8 @@ postAdminUserR uuid = do
if if
| not $ Set.null updates -> runDBJobs $ do | not $ Set.null updates -> runDBJobs $ do
$logInfoS "user-rights-update" $ tshow updates $logInfoS "user-rights-update" $ tshow updates
forM_ (setOf (folded . _1) updates) $ \func ->
memcachedByInvalidate (AuthCacheSchoolFunctionList func) $ Proxy @(Set UserId)
forM_ updates $ \(function, sid) -> do forM_ updates $ \(function, sid) -> do
$logDebugS "user-rights-update" [st|#{tshow (function, sid)}: #{tshow (Set.member (function, sid) functions)} → #{tshow (Set.member (function,sid) changes)}|] $logDebugS "user-rights-update" [st|#{tshow (function, sid)}: #{tshow (Set.member (function, sid) functions)} → #{tshow (Set.member (function,sid) changes)}|]
if if
@ -394,11 +396,12 @@ postAdminUserR uuid = do
let symmDiff = setFromFunc newFuncs `setSymmDiff` setFromFunc systemFunctions let symmDiff = setFromFunc newFuncs `setSymmDiff` setFromFunc systemFunctions
if if
| not $ Set.null symmDiff -> runDBJobs $ do | not $ Set.null symmDiff -> runDBJobs $ do
forM_ symmDiff $ \func -> if forM_ symmDiff $ \func -> do
| newFuncs func memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
-> void $ upsert (UserSystemFunction uid func True False) [ UserSystemFunctionIsOptOut =. False, UserSystemFunctionManual =. True ] if | newFuncs func
| otherwise -> void $ upsert (UserSystemFunction uid func True False) [ UserSystemFunctionIsOptOut =. False, UserSystemFunctionManual =. True ]
-> void $ upsert (UserSystemFunction uid func True True) [ UserSystemFunctionIsOptOut =. True, UserSystemFunctionManual =. True ] | otherwise
-> void $ upsert (UserSystemFunction uid func True True) [ UserSystemFunctionIsOptOut =. True, UserSystemFunctionManual =. True ]
queueDBJob . JobQueueNotification . NotificationUserSystemFunctionsUpdate uid $ setFromFunc systemFunctions queueDBJob . JobQueueNotification . NotificationUserSystemFunctionsUpdate uid $ setFromFunc systemFunctions
addMessageI Success MsgUserSystemFunctionsSaved addMessageI Success MsgUserSystemFunctionsSaved
| otherwise | otherwise

5
src/Handler/Utils.hs
View File

@ -70,8 +70,9 @@ warnTermDays tid timeNames = do
-- | return a value only if the current user ist authorized for a given route -- | return a value only if the current user ist authorized for a given route
guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadThrow h guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadThrow h, MonadUnliftIO h
, MonadTrans m, MonadPlus (m (ReaderT SqlBackend h))) , MonadTrans m, MonadPlus (m (ReaderT SqlBackend h))
)
=> Route UniWorX -> a -> m (ReaderT SqlBackend h) a => Route UniWorX -> a -> m (ReaderT SqlBackend h) a
guardAuthorizedFor link val = guardAuthorizedFor link val =
val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False) val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False)

7
src/Handler/Utils/Course.hs
View File

@ -2,6 +2,7 @@ module Handler.Utils.Course where
import Import import Import
import Handler.Utils.Delete import Handler.Utils.Delete
import Handler.Utils.Memcached
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
@ -48,8 +49,9 @@ setUsersSubmissionGroup cid uids Nothing = do
didDelete <- fmap (> 0) . E.deleteCount . E.from $ \submissionGroupUser -> didDelete <- fmap (> 0) . E.deleteCount . E.from $ \submissionGroupUser ->
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
E.&&. E.subSelectForeign submissionGroupUser SubmissionGroupUserSubmissionGroup (E.^. SubmissionGroupCourse) E.==. E.val cid E.&&. E.subSelectForeign submissionGroupUser SubmissionGroupUserSubmissionGroup (E.^. SubmissionGroupCourse) E.==. E.val cid
when didDelete $ when didDelete $ do
audit $ TransactionSubmissionGroupUnset cid uid audit $ TransactionSubmissionGroupUnset cid uid
memcachedByInvalidate AuthCacheSubmissionGroupUserList (Proxy @(Set UserId))
return $ bool mempty (Sum 1) didDelete return $ bool mempty (Sum 1) didDelete
E.delete . E.from $ \submissionGroup -> E.delete . E.from $ \submissionGroup ->
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cid
@ -68,8 +70,9 @@ setUsersSubmissionGroup cid uids (Just grp) = do
E.&&. submissionGroup E.^. SubmissionGroupId E.!=. E.val gId E.&&. submissionGroup E.^. SubmissionGroupId E.!=. E.val gId
fmap getSum . flip foldMapM uids $ \uid -> do fmap getSum . flip foldMapM uids $ \uid -> do
didSet <- fmap (is _Just) . insertUnique $ SubmissionGroupUser gId uid didSet <- fmap (is _Just) . insertUnique $ SubmissionGroupUser gId uid
when didSet $ when didSet $ do
audit $ TransactionSubmissionGroupSet cid uid grp audit $ TransactionSubmissionGroupSet cid uid grp
memcachedByInvalidate AuthCacheSubmissionGroupUserList (Proxy @(Set UserId))
return $ bool mempty (Sum 1) didSet return $ bool mempty (Sum 1) didSet
showCourseEventRoom :: forall courseEvent courseId. showCourseEventRoom :: forall courseEvent courseId.

10
src/Handler/Utils/ExamOffice/Exam.hs
View File

@ -34,7 +34,7 @@ resultIsSynced authId examResult = (hasSchool E.&&. allSchools) E.||. (E.not_ ha
examOfficeExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office examOfficeExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office
-> E.SqlExpr (Entity ExamResult) -> E.SqlExpr (Entity ExamResult)
-> E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool)
examOfficeExamResultAuth authId examResult = authByUser E.||. authByField E.||. authBySchool E.||. authByExtraSchool examOfficeExamResultAuth authId examResult = ((isOffice E.||. isSystemOffice) E.&&. authByUser) E.||. authByField E.||. authBySchool E.||. authByExtraSchool
where where
cId = E.subSelectForeign examResult ExamResultExam (\exam -> E.subSelectForeign exam ExamCourse (E.^. CourseId)) cId = E.subSelectForeign examResult ExamResultExam (\exam -> E.subSelectForeign exam ExamCourse (E.^. CourseId))
@ -61,6 +61,14 @@ examOfficeExamResultAuth authId examResult = authByUser E.||. authByField E.||.
E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. authId E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. authId
E.&&. examOfficeUser E.^. ExamOfficeUserUser E.==. examResult E.^. ExamResultUser E.&&. examOfficeUser E.^. ExamOfficeUserUser E.==. examResult E.^. ExamResultUser
isOffice = E.exists . E.from $ \userFunction ->
E.where_ $ userFunction E.^. UserFunctionUser E.==. authId
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
isSystemOffice = E.exists . E.from $ \userSystemFunction ->
E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. authId
E.&&. userSystemFunction E.^. UserSystemFunctionFunction E.==. E.val SystemExamOffice
E.&&. E.not_ (userSystemFunction E.^. UserSystemFunctionIsOptOut)
authBySchool = E.exists . E.from $ \(userFunction `E.InnerJoin` course `E.InnerJoin` exam) -> do authBySchool = E.exists . E.from $ \(userFunction `E.InnerJoin` course `E.InnerJoin` exam) -> do
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.&&. exam E.^. ExamId E.==. examResult E.^. ExamResultExam E.&&. exam E.^. ExamId E.==. examResult E.^. ExamResultExam

10
src/Handler/Utils/ExamOffice/ExternalExam.hs
View File

@ -34,7 +34,7 @@ resultIsSynced authId eexamResult = (hasSchool E.&&. allSchools) E.||. (E.not_ h
examOfficeExternalExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office examOfficeExternalExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office
-> E.SqlExpr (Entity ExternalExamResult) -> E.SqlExpr (Entity ExternalExamResult)
-> E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool)
examOfficeExternalExamResultAuth authId eexamResult = authByUser E.||. authByField E.||. authBySchool E.||. authByExtraSchool examOfficeExternalExamResultAuth authId eexamResult = ((isOffice E.||. isSystemOffice) E.&&. authByUser) E.||. authByField E.||. authBySchool E.||. authByExtraSchool
where where
authByField = E.exists . E.from $ \(examOfficeField `E.InnerJoin` studyFeatures) -> do authByField = E.exists . E.from $ \(examOfficeField `E.InnerJoin` studyFeatures) -> do
E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField E.on $ studyFeatures E.^. StudyFeaturesField E.==. examOfficeField E.^. ExamOfficeFieldField
@ -54,6 +54,14 @@ examOfficeExternalExamResultAuth authId eexamResult = authByUser E.||. authByFie
E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. authId E.where_ $ examOfficeUser E.^. ExamOfficeUserOffice E.==. authId
E.&&. examOfficeUser E.^. ExamOfficeUserUser E.==. eexamResult E.^. ExternalExamResultUser E.&&. examOfficeUser E.^. ExamOfficeUserUser E.==. eexamResult E.^. ExternalExamResultUser
isOffice = E.exists . E.from $ \userFunction ->
E.where_ $ userFunction E.^. UserFunctionUser E.==. authId
E.&&. userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
isSystemOffice = E.exists . E.from $ \userSystemFunction ->
E.where_ $ userSystemFunction E.^. UserSystemFunctionUser E.==. authId
E.&&. userSystemFunction E.^. UserSystemFunctionFunction E.==. E.val SystemExamOffice
E.&&. E.not_ (userSystemFunction E.^. UserSystemFunctionIsOptOut)
authBySchool = E.exists . E.from $ \(userFunction `E.InnerJoin` eexam) -> do authBySchool = E.exists . E.from $ \(userFunction `E.InnerJoin` eexam) -> do
E.on $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice E.on $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
E.&&. userFunction E.^. UserFunctionSchool E.==. eexam E.^. ExternalExamSchool E.&&. userFunction E.^. UserFunctionSchool E.==. eexam E.^. ExternalExamSchool

17
src/Handler/Utils/Form.hs
View File

@ -1199,14 +1199,17 @@ sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> tem
sheetTypeAFormReq :: CourseId -> FieldSettings UniWorX -> Maybe (SheetType ExamPartId) -> AForm Handler (SheetType ExamPartId) sheetTypeAFormReq :: CourseId -> FieldSettings UniWorX -> Maybe (SheetType ExamPartId) -> AForm Handler (SheetType ExamPartId)
sheetTypeAFormReq cId fs template = wFormToAForm $ do sheetTypeAFormReq cId fs template = wFormToAForm $ do
examParts'' <- liftHandler . runDB . E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart) -> do (examParts'', editableExams) <- liftHandler . runDB $ do
E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam examParts'' <- E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart) -> do
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
E.where_ $ exam E.^. ExamCourse E.==. E.val cId E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
return (exam, course, examPart) E.where_ $ exam E.^. ExamCourse E.==. E.val cId
return (exam, course, examPart)
editableExams <- fmap Map.keysSet . flip mapFilterM (foldMap (\(Entity eId exam, Entity _ course, _) -> Map.singleton eId (exam, course)) examParts'') $ \(Exam{..}, Course{..}) -> editableExams <- fmap Map.keysSet . flip mapFilterM (foldMap (\(Entity eId exam, Entity _ course, _) -> Map.singleton eId (exam, course)) examParts'') $ \(Exam{..}, Course{..}) ->
hasWriteAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR hasWriteAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR
return (examParts'', editableExams)
let let
examParts' = flip foldMap examParts'' $ \(eEnt@(Entity eId _), _, epEnt) -> guardOn @[] (eId `Set.member` editableExams) (eEnt, epEnt) examParts' = flip foldMap examParts'' $ \(eEnt@(Entity eId _), _, epEnt) -> guardOn @[] (eId `Set.member` editableExams) (eEnt, epEnt)

76
src/Handler/Utils/Memcached.hs
View File

@ -56,6 +56,8 @@ import qualified Crypto.Saltine.Core.AEAD as AEAD
import qualified Control.Monad.State.Class as State import qualified Control.Monad.State.Class as State
import qualified Data.ByteString.Lazy as Lazy (ByteString)
type Expiry = Either UTCTime DiffTime type Expiry = Either UTCTime DiffTime
@ -141,13 +143,9 @@ data MemcachedException = MemcachedException Memcached.MemcachedException
deriving anyclass (Exception) deriving anyclass (Exception)
memcachedKey :: ( Typeable a memcachedKey :: Typeable a
, Binary k => AEAD.Key -> Proxy a -> Lazy.ByteString -> ByteString
) memcachedKey (Saltine.encode -> kmacKey) p = BA.convert . kmaclazy @(SHAKE256 256) (encodeUtf8 . tshow $ typeRep p) kmacKey
=> AEAD.Key -> Proxy a -> k -> ByteString
memcachedKey (Saltine.encode -> kmacKey) p k = Binary.encode k
& kmaclazy @(SHAKE256 256) (encodeUtf8 . tshow $ typeRep p) kmacKey
& BA.convert
memcachedAAD :: ByteString -> Maybe POSIXTime -> ByteString memcachedAAD :: ByteString -> Maybe POSIXTime -> ByteString
memcachedAAD cKey mExpiry = toStrict . Binary.runPut $ do memcachedAAD cKey mExpiry = toStrict . Binary.runPut $ do
@ -160,35 +158,38 @@ memcachedByGet :: forall a k m.
, Binary k , Binary k
) )
=> k -> m (Maybe a) => k -> m (Maybe a)
memcachedByGet k = runMaybeT $ do memcachedByGet (Binary.encode -> k) = runMaybeT $ requestCache <|> memcache
(aeadKey, conn) <- MaybeT $ getsYesod appMemcached
let cKey = memcachedKey aeadKey (Proxy @a) k
encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey conn
$logDebugS "memcached" "Cache hit"
let withExp doExp = do
MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp
$logDebugS "memcached" "Decode valid"
for_ mExpiry $ \expiry -> do
now <- liftIO getPOSIXTime
guard $ expiry > now + clockLeniency
$logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry
let aad = memcachedAAD cKey mExpiry
decrypted <- hoistMaybe $ AEAD.aeadOpen aeadKey mNonce mCiphertext aad
$logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration"
hoistMaybe $ runGetMaybe Binary.get decrypted
withExp True <|> withExp False
where where
runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of requestCache = MaybeT . cacheByGet $ toStrict k
Right (bs', _, x) | null bs' -> Just x memcache = do
_other -> Nothing (aeadKey, conn) <- MaybeT $ getsYesod appMemcached
clockLeniency :: NominalDiffTime let cKey = memcachedKey aeadKey (Proxy @a) k
clockLeniency = 2
encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey conn
$logDebugS "memcached" "Cache hit"
let withExp doExp = do
MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp
$logDebugS "memcached" "Decode valid"
for_ mExpiry $ \expiry -> do
now <- liftIO getPOSIXTime
guard $ expiry > now + clockLeniency
$logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry
let aad = memcachedAAD cKey mExpiry
decrypted <- hoistMaybe $ AEAD.aeadOpen aeadKey mNonce mCiphertext aad
$logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration"
hoistMaybe $ runGetMaybe Binary.get decrypted
withExp True <|> withExp False
where
runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of
Right (bs', _, x) | null bs' -> Just x
_other -> Nothing
clockLeniency :: NominalDiffTime
clockLeniency = 2
memcachedBySet :: forall a k m. memcachedBySet :: forall a k m.
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
@ -197,7 +198,7 @@ memcachedBySet :: forall a k m.
, Binary k , Binary k
) )
=> Maybe Expiry -> k -> a -> m () => Maybe Expiry -> k -> a -> m ()
memcachedBySet mExp k v = do memcachedBySet mExp (Binary.encode -> k) v = do
mExp' <- for mExp $ \exp -> maybe (throwM $ MemcachedInvalidExpiry exp) return $ exp ^? _MemcachedExpiry mExp' <- for mExp $ \exp -> maybe (throwM $ MemcachedInvalidExpiry exp) return $ exp ^? _MemcachedExpiry
mConn <- getsYesod appMemcached mConn <- getsYesod appMemcached
for_ mConn $ \(aeadKey, conn) -> do for_ mConn $ \(aeadKey, conn) -> do
@ -209,6 +210,7 @@ memcachedBySet mExp k v = do
aad = memcachedAAD cKey mExpiry aad = memcachedAAD cKey mExpiry
mCiphertext = AEAD.aead aeadKey mNonce (toStrict $ Binary.encode v) aad mCiphertext = AEAD.aead aeadKey mNonce (toStrict $ Binary.encode v) aad
liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (Binary.runPut $ putMemcachedValue MemcachedValue{..}) conn liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (Binary.runPut $ putMemcachedValue MemcachedValue{..}) conn
cacheBySet (toStrict k) v
$logDebugS "memcached" $ "Cache store: " <> tshow mExpiry $logDebugS "memcached" $ "Cache store: " <> tshow mExpiry
memcachedByInvalidate :: forall a k m p. memcachedByInvalidate :: forall a k m p.
@ -217,7 +219,7 @@ memcachedByInvalidate :: forall a k m p.
, Binary k , Binary k
) )
=> k -> p a -> m () => k -> p a -> m ()
memcachedByInvalidate k _ = maybeT_ $ do memcachedByInvalidate (Binary.encode -> k) _ = maybeT_ $ do
(aeadKey, conn) <- MaybeT $ getsYesod appMemcached (aeadKey, conn) <- MaybeT $ getsYesod appMemcached
let cKey = memcachedKey aeadKey (Proxy @a) k let cKey = memcachedKey aeadKey (Proxy @a) k
hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey conn hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey conn

5
src/Handler/Utils/Sheet.hs
View File

@ -91,13 +91,12 @@ resolveSheetTypeRating cId dbST = do
} }
sheetTypeDescription :: forall m. sheetTypeDescription :: forall m.
( MonadThrow m ( MonadHandler m, HandlerSite m ~ UniWorX
, MonadHandler m, HandlerSite m ~ UniWorX
) )
=> CourseId => CourseId
-> SheetType SqlBackendKey -> SheetType SqlBackendKey
-> ReaderT SqlBackend m (HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)) -> ReaderT SqlBackend m (HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
sheetTypeDescription cId dbST = do sheetTypeDescription cId dbST = hoist liftHandler $ do
sType' <- resolveSheetType cId dbST sType' <- resolveSheetType cId dbST
sType <- for sType' $ \(Entity _epId ExamPart{..}) -> do sType <- for sType' $ \(Entity _epId ExamPart{..}) -> do
Exam{..} <- getJust examPartExam Exam{..} <- getJust examPartExam

4
src/Handler/Utils/Submission.hs
View File

@ -359,7 +359,7 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do
notAnonymized' <- and2M notAnonymized' <- and2M
(return $ isn't _SubmissionDownloadAnonymous anonymous) (return $ isn't _SubmissionDownloadAnonymous anonymous)
(or2M (return $ not sheetAnonymous) (hasReadAccessTo $ CourseR tid ssh csh CCorrectionsR)) (or2M (return $ not sheetAnonymous) (lift . hasReadAccessTo $ CourseR tid ssh csh CCorrectionsR))
submissionDirectory <- bool return withNames notAnonymized' $ dirFrag (cID :: CryptoFileNameSubmission) submissionDirectory <- bool return withNames notAnonymized' $ dirFrag (cID :: CryptoFileNameSubmission)
@ -811,7 +811,7 @@ sinkMultiSubmission userId isUpdate = do
Submission{..} <- get404 sId Submission{..} <- get404 sId
Sheet{..} <- get404 submissionSheet Sheet{..} <- get404 submissionSheet
Course{..} <- get404 sheetCourse Course{..} <- get404 sheetCourse
guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseSchool courseShorthand sheetName cID CorrectionR) True hoist lift $ guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseSchool courseShorthand sheetName cID CorrectionR) True
return . newResumableSink $ sinkSubmission (Just userId) (Right sId) isUpdate return . newResumableSink $ sinkSubmission (Just userId) (Right sId) isUpdate
sink' <- lift $ yield val ++$$ sink sink' <- lift $ yield val ++$$ sink
case sink' of case sink' of

1
src/Handler/Utils/Workflow/EdgeForm.hs
View File

@ -73,6 +73,7 @@ workflowEdgeForm :: ( MonadHandler m
, MonadHandler m' , MonadHandler m'
, HandlerSite m' ~ UniWorX , HandlerSite m' ~ UniWorX
, MonadCatch m' , MonadCatch m'
, MonadUnliftIO m'
) )
=> Either WorkflowInstanceId WorkflowWorkflowId => Either WorkflowInstanceId WorkflowWorkflowId
-> Maybe WorkflowEdgeForm -> Maybe WorkflowEdgeForm

2
src/Handler/Utils/Workflow/Workflow.hs
View File

@ -85,7 +85,7 @@ sourceWorkflowActionInfos
( MonadHandler m, HandlerSite m ~ UniWorX ( MonadHandler m, HandlerSite m ~ UniWorX
, BackendCompatible SqlReadBackend backend , BackendCompatible SqlReadBackend backend
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey , MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
, MonadCatch m , MonadCatch m, MonadUnliftIO m
) )
=> WorkflowWorkflowId => WorkflowWorkflowId
-> WorkflowState FileReference UserId -> WorkflowState FileReference UserId

12
src/Handler/Workflow/Instance/List.hs
View File

@ -151,9 +151,9 @@ workflowInstanceListR rScope = do
Entity _ desc@WorkflowInstanceDescription{..} <- descs Entity _ desc@WorkflowInstanceDescription{..} <- descs
guard $ workflowInstanceDescriptionLanguage == lang guard $ workflowInstanceDescriptionLanguage == lang
return desc return desc
mayInitiate <- hasWriteAccessTo $ toInitiateRoute workflowInstanceName mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute workflowInstanceName
mayEdit <- hasReadAccessTo $ toEditRoute workflowInstanceName mayEdit <- lift . hasReadAccessTo $ toEditRoute workflowInstanceName
mayList <- hasReadAccessTo $ toListRoute workflowInstanceName mayList <- lift . hasReadAccessTo $ toListRoute workflowInstanceName
guard $ mayInitiate || mayEdit || mayList guard $ mayInitiate || mayEdit || mayList
return (wi, desc) return (wi, desc)
@ -192,9 +192,9 @@ getTopWorkflowInstanceListR = do
Entity _ desc@WorkflowInstanceDescription{..} <- descs Entity _ desc@WorkflowInstanceDescription{..} <- descs
guard $ workflowInstanceDescriptionLanguage == lang guard $ workflowInstanceDescriptionLanguage == lang
return desc return desc
mayInitiate <- hasWriteAccessTo $ toInitiateRoute' rScope workflowInstanceName mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute' rScope workflowInstanceName
mayEdit <- hasReadAccessTo $ toEditRoute' rScope workflowInstanceName mayEdit <- lift . hasReadAccessTo $ toEditRoute' rScope workflowInstanceName
mayList <- hasReadAccessTo $ toListRoute' rScope workflowInstanceName mayList <- lift . hasReadAccessTo $ toListRoute' rScope workflowInstanceName
guard $ mayInitiate || mayEdit || mayList guard $ mayInitiate || mayEdit || mayList
return (rScope, [(wi, desc)]) return (rScope, [(wi, desc)])

1
src/Handler/Workflow/Workflow/List.hs
View File

@ -367,6 +367,7 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
( MonadHandler m ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, MonadCatch m , MonadCatch m
, MonadUnliftIO m
) )
=> WorkflowActionInfo FileReference UserId => WorkflowActionInfo FileReference UserId
-> WriterT (Maybe (Last (CryptoUUIDWorkflowStateIndex, Maybe WorkflowGraphNodeLabel, Maybe JsonWorkflowUser, UTCTime, Map WorkflowPayloadLabel JsonWorkflowPayload))) (SqlPersistT m) () -> WriterT (Maybe (Last (CryptoUUIDWorkflowStateIndex, Maybe WorkflowGraphNodeLabel, Maybe JsonWorkflowUser, UTCTime, Map WorkflowPayloadLabel JsonWorkflowPayload))) (SqlPersistT m) ()

1
src/Handler/Workflow/Workflow/Workflow.hs
View File

@ -107,6 +107,7 @@ workflowR rScope cID = do
( MonadHandler m ( MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, MonadCatch m , MonadCatch m
, MonadUnliftIO m
) )
=> WorkflowActionInfo FileReference UserId => WorkflowActionInfo FileReference UserId
-> RWST () (Maybe (Last WorkflowCurrentState), [WorkflowHistoryItem]) (Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))) (SqlPersistT m) () -> RWST () (Maybe (Last WorkflowCurrentState), [WorkflowHistoryItem]) (Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))) (SqlPersistT m) ()

2
src/Jobs/Handler/SendNotification/Allocation.hs
View File

@ -196,7 +196,7 @@ dispatchNotificationAllocationNewCourse nAllocation nCourse jRecipient = userMai
editNotifications <- mkEditNotifications jRecipient editNotifications <- mkEditNotifications jRecipient
cID <- encrypt nCourse cID <- encrypt nCourse
mayApply <- orM mayApply <- lift $ orM
[ is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand ARegisterR) True [ is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand ARegisterR) True
, is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand $ AApplyR cID) True , is _Authorized <$> evalAccessFor (Just jRecipient) (AllocationR allocationTerm allocationSchool allocationShorthand $ AApplyR cID) True
] ]

2
src/Model/Migration/Definitions.hs
View File

@ -140,6 +140,8 @@ migrateManual = do
, ("sent_mail_bounce_secret", "CREATE INDEX sent_mail_bounce_secret ON \"sent_mail\" (bounce_secret) WHERE bounce_secret IS NOT NULL") , ("sent_mail_bounce_secret", "CREATE INDEX sent_mail_bounce_secret ON \"sent_mail\" (bounce_secret) WHERE bounce_secret IS NOT NULL")
, ("sent_mail_recipient", "CREATE INDEX sent_mail_recipient ON \"sent_mail\" (recipient) WHERE recipient IS NOT NULL") , ("sent_mail_recipient", "CREATE INDEX sent_mail_recipient ON \"sent_mail\" (recipient) WHERE recipient IS NOT NULL")
, ("study_features_relevance_cached", "CREATE INDEX study_features_relevance_cached ON \"study_features\" (relevance_cached)") , ("study_features_relevance_cached", "CREATE INDEX study_features_relevance_cached ON \"study_features\" (relevance_cached)")
, ("submission_rating_by", "CREATE INDEX submission_rating_by ON submission (rating_by) WHERE rating_by IS NOT NULL" )
, ("exam_corrector_user", "CREATE INDEX exam_corrector_user ON exam_corrector (\"user\")" )
] ]
where where
addIndex :: Text -> Sql -> Migration addIndex :: Text -> Sql -> Migration

13
src/Model/Tokens/Bearer.hs
View File

@ -79,13 +79,12 @@ data BearerToken site = BearerToken
, bearerStartsAt :: Maybe UTCTime , bearerStartsAt :: Maybe UTCTime
} deriving (Generic, Typeable) } deriving (Generic, Typeable)
deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site) deriving stock instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site), Hashable (AuthId site), Eq (AuthId site)) => Read (BearerToken site) deriving stock instance (Ord (AuthId site), Ord (Route site)) => Ord (BearerToken site)
deriving instance (Show (AuthId site), Show (Route site), Hashable (AuthId site)) => Show (BearerToken site) deriving stock instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site), Hashable (AuthId site), Eq (AuthId site)) => Read (BearerToken site)
deriving stock instance (Show (AuthId site), Show (Route site), Hashable (AuthId site)) => Show (BearerToken site)
instance (Hashable (AuthId site), Hashable (Route site)) => Hashable (BearerToken site) deriving anyclass instance (Hashable (AuthId site), Hashable (Route site)) => Hashable (BearerToken site)
deriving anyclass instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site), Hashable (AuthId site), Eq (AuthId site)) => Binary (BearerToken site)
instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site), Hashable (AuthId site), Eq (AuthId site)) => Binary (BearerToken site)
makeLenses_ ''BearerToken makeLenses_ ''BearerToken
instance HasTokenIdentifier (BearerToken site) TokenId where instance HasTokenIdentifier (BearerToken site) TokenId where

1
src/Model/Types/School.hs
View File

@ -19,3 +19,4 @@ nullaryPathPiece ''SchoolFunction $ camelToPathPiece' 1
pathPieceJSON ''SchoolFunction pathPieceJSON ''SchoolFunction
pathPieceJSONKey ''SchoolFunction pathPieceJSONKey ''SchoolFunction
derivePersistFieldPathPiece ''SchoolFunction derivePersistFieldPathPiece ''SchoolFunction
pathPieceBinary ''SchoolFunction

1
src/Model/Types/User.hs
View File

@ -15,3 +15,4 @@ nullaryPathPiece ''SystemFunction $ camelToPathPiece' 1
pathPieceJSON ''SystemFunction pathPieceJSON ''SystemFunction
pathPieceJSONKey ''SystemFunction pathPieceJSONKey ''SystemFunction
derivePersistFieldPathPiece ''SystemFunction derivePersistFieldPathPiece ''SystemFunction
pathPieceBinary ''SystemFunction

28
src/Utils/Metrics.hs
View File

@ -24,6 +24,7 @@ module Utils.Metrics
, poolMetrics , poolMetrics
, observeDatabaseConnectionOpened, observeDatabaseConnectionClosed , observeDatabaseConnectionOpened, observeDatabaseConnectionClosed
, onUseDBConn, onReleaseDBConn, DBConnUseState, DBConnLabel , onUseDBConn, onReleaseDBConn, DBConnUseState, DBConnLabel
, AuthTagEvalOutcome(..), observeAuthTagEvaluation
) where ) where
import Import.NoModel hiding (Vector, Info) import Import.NoModel hiding (Vector, Info)
@ -416,6 +417,19 @@ onReleaseDBConn DBConnUseState{..} _ = liftIO $ do
[] -> "unlabeled" [] -> "unlabeled"
(_, SrcLoc{..}) : _ -> pack srcLocModule (_, SrcLoc{..}) : _ -> pack srcLocModule
withLabel databaseConnDuration lbl $ flip observe diff withLabel databaseConnDuration lbl $ flip observe diff
data AuthTagEvalOutcome = OutcomeAuthorized | OutcomeUnauthorized | OutcomeAuthenticationRequired | OutcomeException
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving (Universe, Finite)
nullaryPathPiece ''AuthTagEvalOutcome $ camelToPathPiece' 1
{-# NOINLINE authTagEvaluationDuration #-}
authTagEvaluationDuration :: Vector Label2 Histogram
authTagEvaluationDuration = unsafeRegister . vector ("tag", "outcome") $ histogram info buckets
where
info = Info "uni2work_auth_tag_evaluation_duration_seconds"
"Duration of auth tag evaluations"
buckets = histogramBuckets 50e-6 1
withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport withHealthReportMetrics :: MonadIO m => m HealthReport -> m HealthReport
@ -564,3 +578,17 @@ observeMissingFiles refIdent = liftIO . withLabel missingFiles refIdent . flip s
observeDatabaseConnectionOpened, observeDatabaseConnectionClosed :: MonadIO m => m () observeDatabaseConnectionOpened, observeDatabaseConnectionClosed :: MonadIO m => m ()
observeDatabaseConnectionOpened = liftIO $ incCounter databaseConnectionsOpened observeDatabaseConnectionOpened = liftIO $ incCounter databaseConnectionsOpened
observeDatabaseConnectionClosed = liftIO $ incCounter databaseConnectionsClosed observeDatabaseConnectionClosed = liftIO $ incCounter databaseConnectionsClosed
observeAuthTagEvaluation :: MonadUnliftIO m => AuthTag -> m (a, AuthTagEvalOutcome) -> m a
observeAuthTagEvaluation aTag act = do
start <- liftIO $ getTime Monotonic
res <- tryAny act
end <- liftIO $ getTime Monotonic
let outcome = case res of
Right (_, outcome') -> outcome'
Left _ -> OutcomeException
liftIO . withLabel authTagEvaluationDuration (toPathPiece aTag, toPathPiece outcome) . flip observe . realToFrac $ end - start
either throwIO (views _1 return) res