feat(auth): user independent authorisation caching
BREAKING CHANGE: additional authorisation caching
This commit is contained in:
Gregor Kleen
parent
38f16ebac3
commit
63f0d3c37a
@ -36,6 +36,7 @@ import Handler.Utils.Memcached
|
||||
import Handler.Utils.I18n
|
||||
import Utils.Course (courseIsVisible)
|
||||
import Utils.Workflow
|
||||
import Utils.Metrics (observeAuthTagEvaluation, AuthTagEvalOutcome(..))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Aeson as JSON
|
||||
@ -93,21 +94,53 @@ data AccessPredicate
|
||||
= APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
|
||||
| APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> HandlerFor UniWorX AuthResult)
|
||||
| APDB (ByteString -> (forall m. MonadAP m => AuthTagsEval m) -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT SqlReadBackend (HandlerFor UniWorX) AuthResult)
|
||||
| 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
|
||||
|
||||
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
|
||||
(APPure p) -> runReader (p aid r w) <$> getMsgRenderer
|
||||
(APHandler p) -> p 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
|
||||
(APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer
|
||||
(APHandler p) -> lift $ p 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
|
||||
@ -158,9 +191,10 @@ data AuthContext = AuthContext
|
||||
, authActiveTags :: AuthTagActive
|
||||
} deriving (Generic, Typeable)
|
||||
|
||||
deriving instance Eq (AuthId UniWorX) => Eq AuthContext
|
||||
deriving instance (Read (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Read AuthContext
|
||||
deriving instance (Show (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Show AuthContext
|
||||
deriving stock instance Eq (AuthId UniWorX) => Eq AuthContext
|
||||
deriving stock instance Ord (AuthId UniWorX) => Ord AuthContext
|
||||
deriving stock instance (Read (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Read AuthContext
|
||||
deriving stock instance (Show (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Show AuthContext
|
||||
deriving anyclass instance Hashable (AuthId UniWorX) => Hashable AuthContext
|
||||
deriving anyclass instance (Binary (AuthId UniWorX), Eq (AuthId UniWorX), Hashable (AuthId UniWorX)) => Binary AuthContext
|
||||
|
||||
@ -262,7 +296,7 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
|
||||
Just iuid | uid == iuid -> return $ Set.singleton uid
|
||||
| otherwise -> do
|
||||
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
|
||||
return $ Set.singleton iuid
|
||||
Nothing -> return $ Set.singleton uid
|
||||
@ -282,12 +316,12 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
|
||||
|
||||
authorityVal <- do
|
||||
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
|
||||
|
||||
whenIsJust bearerAddAuth $ \addDNF -> do
|
||||
$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
|
||||
|
||||
return Authorized
|
||||
@ -339,134 +373,191 @@ maybeCurrentBearerRestrictions = liftHandler . runMaybeT $ do
|
||||
data AuthorizationCacheKey
|
||||
= AuthCacheWorkflowWorkflowEdgeActors CryptoFileNameWorkflowWorkflow
|
||||
| AuthCacheWorkflowWorkflowViewers CryptoFileNameWorkflowWorkflow
|
||||
| AuthCacheSchoolFunctionList SchoolFunction | AuthCacheSystemFunctionList SystemFunction
|
||||
| AuthCacheLecturerList | AuthCacheCorrectorList | AuthCacheExamCorrectorList | AuthCacheTutorList | AuthCacheSubmissionGroupUserList
|
||||
| AuthCacheCourseRegisteredList TermId SchoolId CourseShorthand
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
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
|
||||
=> AuthTag -> AccessPredicate
|
||||
tagAccessPredicate AuthFree = trueAP
|
||||
tagAccessPredicate AuthAdmin = APDB $ \_ _ mAuthId route _ -> case route of
|
||||
-- Courses: access only to school admins
|
||||
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do
|
||||
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool
|
||||
E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId
|
||||
E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
|
||||
return Authorized
|
||||
-- Allocations: access only to school admins
|
||||
AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do
|
||||
E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool
|
||||
E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId
|
||||
E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
||||
E.&&. allocation E.^. AllocationTerm E.==. E.val tid
|
||||
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
|
||||
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
|
||||
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
|
||||
return Authorized
|
||||
-- Schools: access only to school admins
|
||||
SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin]
|
||||
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
|
||||
return Authorized
|
||||
-- other routes: access to any admin is granted here
|
||||
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
|
||||
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
|
||||
return Authorized
|
||||
tagAccessPredicate AuthSystemExamOffice = APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False]
|
||||
guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice
|
||||
return Authorized
|
||||
tagAccessPredicate AuthStudent = 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 = 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
|
||||
tagAccessPredicate AuthAdmin = cacheAPSchoolFunction SchoolAdmin (Just $ Right diffHour) $ \mAuthId' route' _ adminList -> if
|
||||
| maybe True (`Set.notMember` adminList) mAuthId' -> Right $ case route' of
|
||||
_ | is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
CourseR _ _ _ _ -> unauthorizedI MsgUnauthorizedSchoolAdmin
|
||||
AllocationR _ _ _ _ -> unauthorizedI MsgUnauthorizedSchoolAdmin
|
||||
SchoolR _ _ -> unauthorizedI MsgUnauthorizedSchoolAdmin
|
||||
_other -> unauthorizedI MsgUnauthorizedSiteAdmin
|
||||
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
|
||||
-- Courses: access only to school admins
|
||||
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isAdmin <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` userAdmin) -> do
|
||||
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserFunctionSchool
|
||||
E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId
|
||||
E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
guardMExceptT isAdmin $ unauthorizedI MsgUnauthorizedSchoolAdmin
|
||||
return Authorized
|
||||
-- Allocations: access only to school admins
|
||||
AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isAdmin <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` userAdmin) -> do
|
||||
E.on $ allocation E.^. AllocationSchool E.==. userAdmin E.^. UserFunctionSchool
|
||||
E.where_ $ userAdmin E.^. UserFunctionUser E.==. E.val authId
|
||||
E.&&. userAdmin E.^. UserFunctionFunction E.==. E.val SchoolAdmin
|
||||
E.&&. allocation E.^. AllocationTerm E.==. E.val tid
|
||||
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
|
||||
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
|
||||
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
|
||||
return Authorized
|
||||
-- Schools: access only to school admins
|
||||
SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin]
|
||||
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolAdmin)
|
||||
return Authorized
|
||||
-- other routes: access to any admin is granted here
|
||||
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
adrights <- lift $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAdmin] []
|
||||
guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
|
||||
return Authorized
|
||||
tagAccessPredicate AuthSystemExamOffice = cacheAPSystemFunction SystemExamOffice (Just $ Right diffHour) $ \mAuthId' _ _ examOfficeList -> if
|
||||
| maybe True (`Set.notMember` examOfficeList) mAuthId' -> Right $ if
|
||||
| is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
| otherwise -> unauthorizedI MsgUnauthorizedSystemExamOffice
|
||||
| otherwise -> Left $ APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isExamOffice <- lift $ exists [UserSystemFunctionUser ==. authId, UserSystemFunctionFunction ==. SystemExamOffice, UserSystemFunctionIsOptOut ==. False]
|
||||
guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedSystemExamOffice
|
||||
return Authorized
|
||||
tagAccessPredicate AuthStudent = cacheAPSystemFunction SystemStudent (Just $ Right diffHour) $ \mAuthId' _ _ studentList -> if
|
||||
| maybe True (`Set.notMember` studentList) mAuthId' -> Right $ if
|
||||
| is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
| otherwise -> unauthorizedI MsgUnauthorizedStudent
|
||||
| otherwise -> Left $ APDB $ \_ _ mAuthId _ _ -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
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.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.&&. exam E.^. ExamName E.==. E.val examn
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.&&. exam E.^. ExamName E.==. E.val examn
|
||||
|
||||
E.where_ $ examOfficeExamResultAuth (E.val authId) examResult
|
||||
guardMExceptT hasUsers (unauthorizedI MsgUnauthorizedExamExamOffice)
|
||||
return Authorized
|
||||
EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
hasUsers <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do
|
||||
E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam
|
||||
E.where_ $ examOfficeExamResultAuth (E.val authId) examResult
|
||||
guardMExceptT hasUsers (unauthorizedI MsgUnauthorizedExamExamOffice)
|
||||
return Authorized
|
||||
EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
hasUsers <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` eexamResult) -> do
|
||||
E.on $ eexam E.^. ExternalExamId E.==. eexamResult E.^. ExternalExamResultExam
|
||||
|
||||
E.where_ $ eexam E.^. ExternalExamTerm E.==. E.val tid
|
||||
E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh
|
||||
E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen
|
||||
E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn
|
||||
E.where_ $ eexam E.^. ExternalExamTerm E.==. E.val tid
|
||||
E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh
|
||||
E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen
|
||||
E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn
|
||||
|
||||
E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult
|
||||
guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice
|
||||
return Authorized
|
||||
CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice
|
||||
guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedExamExamOffice
|
||||
return Authorized
|
||||
SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
|
||||
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolExamOffice)
|
||||
return Authorized
|
||||
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
|
||||
guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice)
|
||||
return Authorized
|
||||
tagAccessPredicate AuthEvaluation = APDB $ \_ _ mAuthId route _ -> case route of
|
||||
ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
|
||||
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
|
||||
return Authorized
|
||||
CourseR _ ssh _ _ -> $cachedHereBinary(mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
|
||||
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
|
||||
return Authorized
|
||||
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation]
|
||||
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
|
||||
return Authorized
|
||||
tagAccessPredicate AuthAllocationAdmin = APDB $ \_ _ mAuthId route _ -> case route of
|
||||
AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
|
||||
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
|
||||
return Authorized
|
||||
CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
|
||||
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
|
||||
return Authorized
|
||||
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation]
|
||||
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
|
||||
return Authorized
|
||||
E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult
|
||||
guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice
|
||||
return Authorized
|
||||
CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isExamOffice <- lift . existsBy $ UniqueUserFunction authId ssh SchoolExamOffice
|
||||
guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedExamExamOffice
|
||||
return Authorized
|
||||
SchoolR ssh _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isAdmin <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
|
||||
guardMExceptT isAdmin (unauthorizedI MsgUnauthorizedSchoolExamOffice)
|
||||
return Authorized
|
||||
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
|
||||
guardMExceptT isExamOffice (unauthorizedI MsgUnauthorizedExamOffice)
|
||||
return Authorized
|
||||
tagAccessPredicate AuthEvaluation = cacheAPSchoolFunction SchoolEvaluation (Just $ Right diffHour) $ \mAuthId' _ _ evaluationList -> if
|
||||
| maybe True (`Set.notMember` evaluationList) mAuthId' -> Right $ if
|
||||
| is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
| otherwise -> unauthorizedI MsgUnauthorizedEvaluation
|
||||
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
|
||||
ParticipantsR _ ssh -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
|
||||
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
|
||||
return Authorized
|
||||
CourseR _ ssh _ _ -> $cachedHereBinary(mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
|
||||
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
|
||||
return Authorized
|
||||
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation]
|
||||
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
|
||||
return Authorized
|
||||
tagAccessPredicate AuthAllocationAdmin = cacheAPSchoolFunction SchoolAllocation (Just $ Right diffHour) $ \mAuthId' _ _ allocationList -> if
|
||||
| maybe True (`Set.notMember` allocationList) mAuthId' -> Right $ if
|
||||
| is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
| otherwise -> unauthorizedI MsgUnauthorizedAllocationAdmin
|
||||
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
|
||||
AllocationR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
|
||||
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
|
||||
return Authorized
|
||||
CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
|
||||
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
|
||||
return Authorized
|
||||
_other -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation]
|
||||
guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
|
||||
return Authorized
|
||||
tagAccessPredicate AuthToken = APDB $ \_ _ mAuthId route isWrite -> exceptT return return $
|
||||
lift . validateBearer mAuthId route isWrite =<< askBearerUnsafe
|
||||
tagAccessPredicate AuthNoEscalation = APDB $ \_ _ mAuthId route _ -> case route of
|
||||
@ -490,121 +581,175 @@ tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do
|
||||
#else
|
||||
return $ Unauthorized "Route under development"
|
||||
#endif
|
||||
tagAccessPredicate AuthLecturer = 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
|
||||
|
||||
tagAccessPredicate AuthLecturer = cacheAP' (Just $ Right diffMinute) mkLecturerList $ \mAuthId' route' _ mLecturerList -> if
|
||||
| Just lecturerList <- mLecturerList
|
||||
, maybe True (`Set.notMember` lecturerList) mAuthId' -> Right $ case route' of
|
||||
_ | is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
CourseR _ _ _ _ -> unauthorizedI MsgUnauthorizedLecturer
|
||||
AllocationR _ _ _ _ -> unauthorizedI MsgUnauthorizedAllocationLecturer
|
||||
EExamR _ _ _ _ _ -> unauthorizedI MsgUnauthorizedExternalExamLecturer
|
||||
_other -> unauthorizedI MsgUnauthorizedSchoolLecturer
|
||||
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
|
||||
CourseR tid ssh csh _ -> $cachedHereBinary (mAuthId, tid, ssh, csh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isLecturer <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` lecturer) -> do
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
guardMExceptT isLecturer (unauthorizedI MsgUnauthorizedLecturer)
|
||||
return Authorized
|
||||
AllocationR tid ssh ash _ -> $cachedHereBinary (mAuthId, tid, ssh, ash) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isLecturer <- lift . E.selectExists . E.from $ \(allocation `E.InnerJoin` allocationCourse `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
|
||||
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
|
||||
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
|
||||
E.on $ allocation E.^. AllocationId E.==. allocationCourse E.^. AllocationCourseAllocation
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
|
||||
E.&&. allocation E.^. AllocationTerm E.==. E.val tid
|
||||
E.&&. allocation E.^. AllocationSchool E.==. E.val ssh
|
||||
E.&&. allocation E.^. AllocationShorthand E.==. E.val ash
|
||||
guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedAllocationLecturer
|
||||
return Authorized
|
||||
EExamR tid ssh coursen examn _ -> $cachedHereBinary (mAuthId, tid, ssh, coursen, examn) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isLecturer <- lift . E.selectExists . E.from $ \(eexam `E.InnerJoin` staff) -> do
|
||||
E.on $ eexam E.^. ExternalExamId E.==. staff E.^. ExternalExamStaffExam
|
||||
E.where_ $ staff E.^. ExternalExamStaffUser E.==. E.val authId
|
||||
E.&&. eexam E.^. ExternalExamTerm E.==. E.val tid
|
||||
E.&&. eexam E.^. ExternalExamSchool E.==. E.val ssh
|
||||
E.&&. eexam E.^. ExternalExamCourseName E.==. E.val coursen
|
||||
E.&&. eexam E.^. ExternalExamExamName E.==. E.val examn
|
||||
guardMExceptT isLecturer $ unauthorizedI MsgUnauthorizedExternalExamLecturer
|
||||
return Authorized
|
||||
-- lecturer for any school will do
|
||||
_ -> $cachedHereBinary mAuthId . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolLecturer] []
|
||||
return Authorized
|
||||
where
|
||||
mkLecturerList _ route _ = case route of
|
||||
CourseR _ _ _ _ -> cacheLecturerList
|
||||
AllocationR _ _ _ _ -> cacheLecturerList
|
||||
EExamR _ _ _ _ _ -> 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.^. 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
|
||||
tagAccessPredicate AuthCorrector = 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
|
||||
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
|
||||
E.&&. exam E.^. ExamName E.==. E.val examn
|
||||
guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
|
||||
return Authorized
|
||||
CourseR tid ssh csh _ -> $cachedHereBinary (tid, ssh, csh) . exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isCorrector <- lift . E.selectExists . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examCorrector) -> do
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
E.on $ exam E.^. ExamId E.==. examCorrector E.^. ExamCorrectorExam
|
||||
E.where_ $ examCorrector E.^. ExamCorrectorUser E.==. E.val authId
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
guardMExceptT isCorrector $ unauthorizedI MsgUnauthorizedExamCorrector
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthExamCorrector r
|
||||
where
|
||||
mkExamCorrectorList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. ExamCorrectorUser)
|
||||
tagAccessPredicate AuthTutor = cacheAP (Just $ Right diffMinute) AuthCacheTutorList mkTutorList $ \mAuthId' route' _ tutorList -> if
|
||||
| maybe False (`Set.notMember` tutorList) mAuthId' -> Right $ case route' of
|
||||
_ | is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
CTutorialR _ _ _ _ _ -> unauthorizedI MsgUnauthorizedTutorialTutor
|
||||
CourseR _ _ _ _ -> unauthorizedI MsgUnauthorizedCourseTutor
|
||||
_other -> unauthorizedI MsgUnauthorizedTutor
|
||||
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
resList <- $cachedHereBinary authId . lift . E.select . E.from $ \(course `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
|
||||
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
|
||||
E.on $ tutorial E.^. TutorialCourse E.==. course E.^. CourseId
|
||||
E.where_ $ tutor E.^. TutorUser E.==. E.val authId
|
||||
return (course E.^. CourseId, tutorial E.^. TutorialId)
|
||||
let
|
||||
resMap :: Map CourseId (Set TutorialId)
|
||||
resMap = Map.fromListWith Set.union [ (cid, Set.singleton tutid) | (E.Value cid, E.Value tutid) <- resList ]
|
||||
case route of
|
||||
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutor) $ do
|
||||
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity tutid _ <- $cachedHereBinary (cid, tutn) . MaybeT . lift . getBy $ UniqueTutorial cid tutn
|
||||
guard $ tutid `Set.member` fromMaybe Set.empty (resMap !? cid)
|
||||
return Authorized
|
||||
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCourseTutor) $ do
|
||||
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
guard $ cid `Set.member` Map.keysSet resMap
|
||||
return Authorized
|
||||
_ -> do
|
||||
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedTutor)
|
||||
return Authorized
|
||||
where
|
||||
mkTutorList = runDBRead . fmap (setOf $ folded . _Value) . E.select . E.from $ return . (E.^. TutorUser)
|
||||
tagAccessPredicate AuthTutorControl = APDB $ \_ _ _ route _ -> case route of
|
||||
CTutorialR tid ssh csh tutn _ -> maybeT (unauthorizedI MsgUnauthorizedTutorialTutorControl) $ do
|
||||
Entity cid _ <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
|
||||
@ -612,31 +757,39 @@ tagAccessPredicate AuthTutorControl = APDB $ \_ _ _ route _ -> case route of
|
||||
guard tutorialTutorControlled
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthTutorControl r
|
||||
tagAccessPredicate AuthSubmissionGroup = APDB $ \_ _ mAuthId route _ -> case route of
|
||||
CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn
|
||||
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId
|
||||
return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
||||
unless (Set.null groups || isn't _RegisteredGroups sheetGrouping) $ do
|
||||
uid <- hoistMaybe mAuthId
|
||||
guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups]
|
||||
return Authorized
|
||||
CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- $cachedHereBinary (course, sheetn) . MaybeT . getBy $ CourseSheet course sheetn
|
||||
when (is _RegisteredGroups sheetGrouping) $ do
|
||||
uid <- hoistMaybe mAuthId
|
||||
guardM . lift . E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
||||
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val course
|
||||
E.&&. submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
||||
tagAccessPredicate AuthSubmissionGroup = cacheAP (Just $ Right diffMinute) AuthCacheSubmissionGroupUserList mkSubmissionGroupUserList $ \mAuthId' route' _ submissionGroupUserList -> if
|
||||
| maybe True (`Set.notMember` submissionGroupUserList) mAuthId' -> Right $ case route' of
|
||||
_ | is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
CSubmissionR _ _ _ _ _ _ -> unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup
|
||||
CSheetR _ _ _ _ _ -> unauthorizedI MsgUnauthorizedSheetSubmissionGroup
|
||||
r -> $unsupportedAuthPredicate AuthSubmissionGroup r
|
||||
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
|
||||
CSubmissionR tid ssh csh shn cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionSubmissionGroup) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- $cachedHereBinary (course, shn) . MaybeT . getBy $ CourseSheet course shn
|
||||
smId <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
groups <- $cachedHereBinary cID . lift . fmap (Set.fromList . fmap E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionUser) -> do
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. submissionUser E.^. SubmissionUserUser
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val smId
|
||||
return $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
||||
unless (Set.null groups || isn't _RegisteredGroups sheetGrouping) $ do
|
||||
uid <- hoistMaybe mAuthId
|
||||
guardM . lift $ exists [SubmissionGroupUserUser ==. uid, SubmissionGroupUserSubmissionGroup <-. Set.toList groups]
|
||||
return Authorized
|
||||
CSheetR tid ssh csh sheetn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetSubmissionGroup) $ do
|
||||
course <- $cachedHereBinary (tid, ssh, csh) . MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
|
||||
Entity _ Sheet{..} <- $cachedHereBinary (course, sheetn) . MaybeT . getBy $ CourseSheet course sheetn
|
||||
when (is _RegisteredGroups sheetGrouping) $ do
|
||||
uid <- hoistMaybe mAuthId
|
||||
guardM . lift . E.selectExists . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
|
||||
E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
|
||||
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val course
|
||||
E.&&. submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
||||
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthSubmissionGroup r
|
||||
return Authorized
|
||||
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
|
||||
CExamR tid ssh csh examn subRoute -> maybeT (unauthorizedI MsgUnauthorizedExamTime) $ do
|
||||
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)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthCourseTime r
|
||||
tagAccessPredicate AuthCourseRegistered = APDB $ \_ _ mAuthId route _ -> case route of
|
||||
CourseR tid ssh csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
|
||||
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthCourseRegistered r
|
||||
tagAccessPredicate AuthCourseRegistered = cacheAP' (Just $ Right diffMinute) mkAuthCacheCourseRegisteredList $ \mAuthId' route' _ mCourseRegisteredList -> if
|
||||
| Just courseRegisteredList <- mCourseRegisteredList
|
||||
, maybe True (`Set.notMember` courseRegisteredList) mAuthId' -> Right $ case route' of
|
||||
_ | is _Nothing mAuthId' -> return AuthenticationRequired
|
||||
CourseR _ _ _ _ -> unauthorizedI MsgUnauthorizedRegistered
|
||||
r -> $unsupportedAuthPredicate AuthCourseRegistered r
|
||||
| otherwise -> Left $ APDB $ \_ _ mAuthId route _ -> case route of
|
||||
CourseR tid ssh csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ return mAuthId
|
||||
isRegistered <- $cachedHereBinary (authId, tid, ssh, csh) . lift . E.selectExists . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
|
||||
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
|
||||
E.&&. courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
guardMExceptT isRegistered (unauthorizedI MsgUnauthorizedRegistered)
|
||||
return Authorized
|
||||
r -> $unsupportedAuthPredicate AuthCourseRegistered r
|
||||
where
|
||||
mkAuthCacheCourseRegisteredList _ route _ = case route of
|
||||
CourseR tid ssh csh _ -> Just
|
||||
( AuthCacheCourseRegisteredList tid ssh csh
|
||||
, 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
|
||||
CTutorialR tid ssh csh tutn _ -> exceptT return return $ do
|
||||
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
|
||||
cID <- encrypt wwId
|
||||
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
|
||||
guardM . fmap not . lift . runConduit $ getWorkflowWorkflows .| C.mapM checkAccess .| C.or
|
||||
return AuthorizedI18n
|
||||
@ -1551,7 +1723,12 @@ evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable
|
||||
where
|
||||
evalAccessPred' authTag' mAuthId' route' isWrite' = lift $ do
|
||||
$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 PLVariable{..} = evalAuthTag plVar
|
||||
@ -1580,7 +1757,7 @@ evalAuthTags ctx authActive@AuthTagActive{..} cont (map (Set.toList . toNullable
|
||||
|
||||
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
|
||||
isSelf <- (== mAuthId) <$> liftHandler defaultMaybeAuthId
|
||||
tagActive <- if
|
||||
@ -1598,42 +1775,42 @@ evalAccessWithFor assumptions mAuthId route isWrite = do
|
||||
tellSessionJson SessionInactiveAuthTags deactivated
|
||||
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 []
|
||||
|
||||
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
|
||||
|
||||
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
|
||||
mAuthId <- liftHandler maybeAuthId
|
||||
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
|
||||
|
||||
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 []
|
||||
|
||||
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
|
||||
|
||||
-- | Check whether the current user is authorized by `evalAccess` for the given route
|
||||
-- Convenience function for a commonly used code fragment
|
||||
hasAccessTo :: (HasCallStack, MonadThrow m, 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
|
||||
|
||||
-- | Check whether the current user is authorized by `evalAccess` to read from the given route
|
||||
-- Convenience function for a commonly used code fragment
|
||||
hasReadAccessTo :: (HasCallStack, MonadThrow m, 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
|
||||
|
||||
-- | Check whether the current user is authorized by `evalAccess` to rwrite to the given route
|
||||
-- Convenience function for a commonly used code fragment
|
||||
hasWriteAccessTo :: (HasCallStack, MonadThrow m, 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
|
||||
|
||||
wouldHaveAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX)
|
||||
wouldHaveAccessTo :: (HasCallStack, MonadThrow m, MonadAP m)
|
||||
=> [(AuthTag, Bool)] -- ^ Assumptions
|
||||
-> Route UniWorX
|
||||
-> Bool
|
||||
@ -1641,7 +1818,7 @@ wouldHaveAccessTo :: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m
|
||||
wouldHaveAccessTo assumptions route isWrite = (== Authorized) <$> evalAccessWith assumptions route isWrite
|
||||
|
||||
wouldHaveReadAccessTo, wouldHaveWriteAccessTo
|
||||
:: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX)
|
||||
:: (HasCallStack, MonadThrow m, MonadAP m)
|
||||
=> [(AuthTag, Bool)] -- ^ Assumptions
|
||||
-> Route UniWorX
|
||||
-> m Bool
|
||||
@ -1649,7 +1826,7 @@ wouldHaveReadAccessTo assumptions route = wouldHaveAccessTo assumptions route Fa
|
||||
wouldHaveWriteAccessTo assumptions route = wouldHaveAccessTo assumptions route True
|
||||
|
||||
wouldHaveReadAccessToIff, wouldHaveWriteAccessToIff
|
||||
:: (HasCallStack, MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, BearerAuthSite UniWorX)
|
||||
:: (HasCallStack, MonadThrow m, MonadAP m)
|
||||
=> [(AuthTag, Bool)] -- ^ Assumptions
|
||||
-> Route UniWorX
|
||||
-> m Bool
|
||||
@ -1659,9 +1836,7 @@ wouldHaveWriteAccessToIff assumptions route = and2M (not <$> hasWriteAccessTo ro
|
||||
|
||||
evalWorkflowRoleFor' :: forall m backend.
|
||||
( HasCallStack
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, BearerAuthSite UniWorX
|
||||
, MonadAP m
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
)
|
||||
=> (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
|
||||
|
||||
evalWorkflowRoleFor :: ( HasCallStack
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, BearerAuthSite UniWorX
|
||||
, MonadAP m
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
)
|
||||
=> Maybe UserId
|
||||
@ -1733,9 +1906,7 @@ evalWorkflowRoleFor mAuthId mwwId wRole route isWrite = do
|
||||
return result
|
||||
|
||||
hasWorkflowRole :: ( HasCallStack
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, BearerAuthSite UniWorX
|
||||
, MonadAP m
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
)
|
||||
=> Maybe WorkflowWorkflowId
|
||||
@ -1749,9 +1920,7 @@ hasWorkflowRole mwwId wRole route isWrite = do
|
||||
|
||||
mayViewWorkflowAction' :: forall backend m fileid.
|
||||
( HasCallStack
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, BearerAuthSite UniWorX
|
||||
, MonadAP m
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
|
||||
, MonadCatch m
|
||||
@ -1780,9 +1949,7 @@ mayViewWorkflowAction' eval mAuthId wwId WorkflowAction{..} = hoist (withReaderT
|
||||
|
||||
mayViewWorkflowAction :: forall backend m fileid.
|
||||
( HasCallStack
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, BearerAuthSite UniWorX
|
||||
, MonadAP m
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
|
||||
, MonadCatch m
|
||||
|
||||
@ -70,7 +70,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
|
||||
breadcrumb UsersR = i18nCrumb MsgMenuUsers $ Just AdminR
|
||||
breadcrumb AdminUserAddR = i18nCrumb MsgMenuUserAdd $ Just UsersR
|
||||
breadcrumb (AdminUserR cID) = maybeT (i18nCrumb MsgBreadcrumbUser $ Just UsersR) $ do
|
||||
guardM . hasReadAccessTo $ AdminUserR cID
|
||||
guardM . lift . hasReadAccessTo $ AdminUserR cID
|
||||
uid <- decrypt cID
|
||||
User{..} <- MaybeT . runDBRead $ get uid
|
||||
return (userDisplayName, Just UsersR)
|
||||
@ -104,7 +104,7 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (SchoolR ssh sRoute) = case sRoute of
|
||||
SchoolEditR -> maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do
|
||||
School{..} <- MaybeT . runDBRead $ get ssh
|
||||
isAdmin <- hasReadAccessTo SchoolListR
|
||||
isAdmin <- lift $ hasReadAccessTo SchoolListR
|
||||
return (CI.original schoolName, bool Nothing (Just SchoolListR) isAdmin)
|
||||
|
||||
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 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
|
||||
guardM . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID
|
||||
guardM . lift . hasReadAccessTo . CourseR tid ssh csh $ CUserR cID
|
||||
uid <- decrypt cID
|
||||
User{userDisplayName} <- MaybeT . runDBRead $ get uid
|
||||
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
|
||||
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
|
||||
User{..} <- hoist runDBRead $ MaybeT (get appId) >>= MaybeT . get . courseApplicationUser
|
||||
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
|
||||
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)
|
||||
EEditR -> i18nCrumb MsgMenuExamEdit . 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
|
||||
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)
|
||||
TEditR -> i18nCrumb MsgMenuTutorialEdit . 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
|
||||
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)
|
||||
SEditR -> i18nCrumb MsgMenuSheetEdit . 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 (MaterialR mnm sRoute)) = case sRoute of
|
||||
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)
|
||||
MEditR -> i18nCrumb MsgMenuMaterialEdit . 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
|
||||
isEO <- hasReadAccessTo $ ExamOfficeR EOExamsR
|
||||
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
|
||||
| isEO -> ExamOfficeR EOExamsR
|
||||
| otherwise -> EExamListR
|
||||
@ -501,15 +501,15 @@ type family ChildrenNavChildren a where
|
||||
|
||||
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
|
||||
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) $
|
||||
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
|
||||
where
|
||||
shortCircuit :: HandlerContents -> m Bool
|
||||
@ -518,7 +518,7 @@ navLinkAccess NavLink{..} = handle shortCircuit $ liftHandler navAccess' `and2M`
|
||||
accessCheck :: HasRoute UniWorX route => NavType -> route -> m Bool
|
||||
accessCheck nt (urlRoute -> route) = do
|
||||
authCtx <- getAuthContext
|
||||
$memcachedByHere (Just $ Right 120) (authCtx, nt, route) $
|
||||
$memcachedByHere (Just . Right $ 2 * diffMinute) (authCtx, nt, route) $
|
||||
bool hasWriteAccessTo hasReadAccessTo (is _NavTypeLink nt) route
|
||||
|
||||
defaultLinks :: ( MonadHandler m
|
||||
@ -871,6 +871,7 @@ pageActions :: ( MonadHandler m
|
||||
, MonadCatch m
|
||||
, BearerAuthSite UniWorX
|
||||
, BackendCompatible SqlReadBackend (YesodPersistBackend UniWorX)
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Route UniWorX -> m [Nav]
|
||||
pageActions NewsR = return
|
||||
@ -2576,7 +2577,7 @@ submissionList tid csh shn uid = withReaderT (projectBackend @SqlReadBackend) .
|
||||
return $ submission E.^. SubmissionId
|
||||
|
||||
|
||||
pageQuickActions :: ( MonadCatch m
|
||||
pageQuickActions :: ( MonadCatch m, MonadUnliftIO m
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ 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
|
||||
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
|
||||
evalAccessCorrector tid ssh csh = evalAccess (CourseR tid ssh csh CNotesR) False
|
||||
|
||||
@ -2606,7 +2607,7 @@ _haveWorkflowInstances rScope = hoist liftHandler . withReaderT (projectBackend
|
||||
scope <- fromRouteWorkflowScope rScope
|
||||
|
||||
let checkAccess (Entity _ WorkflowInstance{..})
|
||||
= hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
|
||||
= lift . hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
|
||||
getInstances = E.selectSource . E.from $ \workflowInstance -> do
|
||||
E.where_ $ workflowInstance E.^. WorkflowInstanceScope E.==. E.val (scope ^. _DBWorkflowScope)
|
||||
return workflowInstance
|
||||
@ -2617,7 +2618,7 @@ haveWorkflowWorkflows rScope = hoist liftHandler . withReaderT (projectBackend @
|
||||
|
||||
let checkAccess (E.Value wwId) = do
|
||||
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
|
||||
E.where_ $ workflowWorkflow E.^. WorkflowWorkflowScope E.==. E.val (scope ^. _DBWorkflowScope)
|
||||
return $ workflowWorkflow E.^. WorkflowWorkflowId
|
||||
@ -2633,7 +2634,7 @@ haveTopWorkflowInstances, haveTopWorkflowWorkflows
|
||||
haveTopWorkflowInstances = hoist liftHandler . withReaderT (projectBackend @SqlReadBackend) . maybeT (return False) $
|
||||
let checkAccess (Entity _ WorkflowInstance{..}) = do
|
||||
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowInstanceScope
|
||||
hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
|
||||
lift . hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowInstanceR workflowInstanceName WIInitiateR)
|
||||
getInstances = selectSource [] []
|
||||
isTop (Entity _ WorkflowInstance{..}) = isTopWorkflowScope workflowInstanceScope
|
||||
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
|
||||
rScope <- toRouteWorkflowScope $ _DBWorkflowScope # workflowWorkflowScope
|
||||
cID <- lift . lift $ encrypt wwId
|
||||
hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
lift . hasReadAccessTo $ _WorkflowScopeRoute # (rScope, WorkflowWorkflowR cID WWWorkflowR)
|
||||
getWorkflows = selectSource [] []
|
||||
isTop (Entity _ WorkflowWorkflow{..}) = isTopWorkflowScope workflowWorkflowScope
|
||||
in $cachedHere . runConduit $ transPipe lift getWorkflows .| C.filter isTop .| C.mapM checkAccess .| C.or
|
||||
|
||||
@ -15,6 +15,8 @@ import Handler.Utils.Profile
|
||||
import Handler.Utils.StudyFeatures
|
||||
import Handler.Utils.SchoolLdap
|
||||
import Handler.Utils.LdapSystemFunctions
|
||||
import Handler.Utils.Memcached
|
||||
import Foundation.Authorization (AuthorizationCacheKey(..))
|
||||
|
||||
import Yesod.Auth.Message
|
||||
import Auth.LDAP
|
||||
@ -469,9 +471,10 @@ upsertCampusUser upsertMode ldapData = do
|
||||
Right str <- return $ Text.decodeUtf8' v'
|
||||
assertM' (not . Text.null) $ Text.strip str
|
||||
|
||||
iforM_ userSystemFunctions $ \func preset -> if
|
||||
| preset -> void $ upsert (UserSystemFunction userId func False False) []
|
||||
| otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
|
||||
iforM_ userSystemFunctions $ \func preset -> do
|
||||
memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
|
||||
if | preset -> void $ upsert (UserSystemFunction userId func False False) []
|
||||
| otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
|
||||
|
||||
return user
|
||||
where
|
||||
|
||||
@ -58,7 +58,7 @@ getCAppsFilesR tid ssh csh = do
|
||||
return (allocation, user, courseApplication)
|
||||
apps' <- flip filterM apps $ \(_, _, Entity appId _) -> do
|
||||
cID <- cachedByBinary appId $ encrypt appId
|
||||
hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
|
||||
lift . hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
|
||||
let
|
||||
applicationAllocs = setOf (folded . _1) apps'
|
||||
|
||||
|
||||
@ -328,7 +328,7 @@ validateCourse = do
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
uid <- liftHandler requireAuthId
|
||||
userAdmin <- hasWriteAccessTo $ SchoolR cfSchool SchoolEditR
|
||||
userAdmin <- lift . hasWriteAccessTo $ SchoolR cfSchool SchoolEditR
|
||||
newAllocationTerm <- for (acfAllocation <$> cfAllocation) $ lift . fmap allocationTerm . getJust
|
||||
|
||||
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
|
||||
insert_ $ CourseEdit aid now cid
|
||||
upsertAllocationCourse cid $ cfAllocation res
|
||||
memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
|
||||
return insertOkay
|
||||
case insertOkay of
|
||||
Just _ -> do
|
||||
@ -573,6 +574,8 @@ courseEditHandler miButtonAction mbCourseForm = do
|
||||
in void . replaceFileReferences mkFilter (CourseAppInstructionFileResidual cid) . sequence_ $ cfAppInstructionFiles res
|
||||
|
||||
upsertAllocationCourse cid $ cfAllocation res
|
||||
|
||||
memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId)
|
||||
|
||||
addMessageI Success $ MsgCourseEditOk tid ssh csh
|
||||
return True
|
||||
|
||||
@ -10,6 +10,7 @@ import Import
|
||||
|
||||
import Utils.Form
|
||||
import Handler.Utils.Invitations
|
||||
import Handler.Utils.Memcached
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
@ -75,7 +76,7 @@ lecturerInvitationConfig = InvitationConfig{..}
|
||||
toJunction jLecturerType = (JunctionLecturer{..}, ())
|
||||
lFs :: FieldSettings UniWorX
|
||||
lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical
|
||||
invitationInsertHook _ _ _ _ _ = id
|
||||
invitationInsertHook _ _ _ _ _ = (*>) (memcachedByInvalidate AuthCacheLecturerList $ Proxy @(Set UserId))
|
||||
invitationSuccessMsg (Entity _ Course{..}) (Entity _ Lecturer{..}) = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand
|
||||
|
||||
@ -92,11 +92,12 @@ participantInvitationConfig = InvitationConfig{..}
|
||||
invitationForm _ _ _ = hoistAForm lift . wFormToAForm $ do
|
||||
now <- liftIO getCurrentTime
|
||||
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
|
||||
res <- act -- insertUnique
|
||||
audit $ TransactionCourseParticipantEdit courseParticipantCourse courseParticipantUser
|
||||
void $ setUserSubmissionGroup courseParticipantCourse courseParticipantUser invTokenParticipantSubmissionGroup
|
||||
memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId))
|
||||
return res
|
||||
invitationSuccessMsg (Entity _ Course{..}) _ =
|
||||
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
|
||||
|
||||
@ -222,6 +222,7 @@ postCRegisterR tid ssh csh = do
|
||||
= return $ Just ()
|
||||
mkRegistration = do
|
||||
audit $ TransactionCourseParticipantEdit cid uid
|
||||
memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId))
|
||||
entityKey <$> upsert
|
||||
(CourseParticipant cid uid cTime Nothing CourseParticipantActive)
|
||||
[ CourseParticipantRegistration =. cTime
|
||||
@ -238,7 +239,7 @@ postCRegisterR tid ssh csh = do
|
||||
BtnCourseDeregister -> runDB . setSerializable $ do
|
||||
part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
|
||||
forM_ part $ \(Entity _partId CourseParticipant{..}) -> do
|
||||
deregisterParticipant uid cid
|
||||
deregisterParticipant uid course
|
||||
|
||||
when (is _Just courseParticipantAllocated) $ do
|
||||
updateBy (UniqueParticipant uid cid) [ CourseParticipantState =. CourseParticipantInactive courseDeregisterNoShow ]
|
||||
@ -284,12 +285,13 @@ deleteApplications uid cid = do
|
||||
deleteApplicationFiles :: CourseApplicationId -> DB ()
|
||||
deleteApplicationFiles appId = deleteWhere [ CourseApplicationFileApplication ==. appId ]
|
||||
|
||||
deregisterParticipant :: UserId -> CourseId -> DB ()
|
||||
deregisterParticipant uid cid = do
|
||||
deregisterParticipant :: UserId -> Entity Course -> DB ()
|
||||
deregisterParticipant uid (Entity cid Course{..}) = do
|
||||
part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
|
||||
forM_ part $ \(Entity partId CourseParticipant{}) -> do
|
||||
update partId [CourseParticipantState =. CourseParticipantInactive False]
|
||||
audit $ TransactionCourseParticipantDeleted cid uid
|
||||
memcachedByInvalidate (AuthCacheCourseRegisteredList courseTerm courseSchool courseShorthand) (Proxy @(Set UserId))
|
||||
|
||||
examRegistrations <- E.select . E.from $ \(examRegistration `E.InnerJoin` exam) -> do
|
||||
E.on $ examRegistration E.^. ExamRegistrationExam E.==. exam E.^. ExamId
|
||||
|
||||
@ -84,7 +84,7 @@ getCShowR tid ssh csh = do
|
||||
cTime <- NTop . Just <$> liftIO getCurrentTime
|
||||
news <- forMaybeM news' $ \(Entity nId n@CourseNews{..}) -> do
|
||||
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
|
||||
files' <- lift . lift . E.select . E.from $ \newsFile -> do
|
||||
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 . _2) E.unValue
|
||||
lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit
|
||||
mayEditNews <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR
|
||||
mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR
|
||||
mayEditNews <- lift . lift . hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR
|
||||
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
|
||||
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
|
||||
|
||||
mayViewSheets <- hasReadAccessTo $ CourseR tid ssh csh SheetListR
|
||||
mayViewSheets <- lift . hasReadAccessTo $ CourseR tid ssh csh SheetListR
|
||||
sheets <- lift . E.select . E.from $ \sheet -> do
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
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
|
||||
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
|
||||
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))
|
||||
|
||||
|
||||
@ -90,22 +90,22 @@ postCUserR tid ssh csh uCId = do
|
||||
forM_ sections . fromMaybe $ return ()
|
||||
|
||||
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
|
||||
currentRoute <- MaybeT getCurrentRoute
|
||||
|
||||
(mRegistration, studies) <- lift . runDB $ do
|
||||
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.^. 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_ $ course E.^. CourseId E.==. E.val cid
|
||||
E.where_ $ course' E.^. CourseId E.==. E.val cid
|
||||
return (studyfeat, studydegree, studyterms)
|
||||
return (registration, studies)
|
||||
|
||||
mayRegister <- hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CAddUserR
|
||||
mayRegister <- lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CAddUserR
|
||||
let regButton
|
||||
| is _Just mRegistration = BtnCourseDeregister
|
||||
| otherwise = BtnCourseRegister
|
||||
@ -138,7 +138,8 @@ courseUserProfileSection (Entity cid Course{..}) (Entity uid User{ userShowSex =
|
||||
| Just (Entity _pId CourseParticipant{..}) <- mRegistration
|
||||
-> do
|
||||
lift . runDB $ do
|
||||
deregisterParticipant courseParticipantUser courseParticipantCourse
|
||||
unless (courseParticipantCourse == cid) $ error "courseParticipantCourse does not match cid"
|
||||
deregisterParticipant courseParticipantUser course
|
||||
|
||||
whenIsJust mbReason $ \(reason, noShow) -> do
|
||||
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 cid Course{..}) (Entity uid _) = do
|
||||
guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CUsersR
|
||||
guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CUsersR
|
||||
|
||||
currentRoute <- MaybeT getCurrentRoute
|
||||
|
||||
@ -240,7 +241,7 @@ courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do
|
||||
|
||||
courseUserSubmissionsSection :: Entity Course -> Entity User -> MaybeT Handler Widget
|
||||
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
|
||||
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 cid Course{..}) (Entity uid _) = do
|
||||
guardM . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CExamNewR
|
||||
guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CExamNewR
|
||||
|
||||
uCID <- encrypt uid
|
||||
|
||||
|
||||
@ -509,7 +509,7 @@ getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCUsersR = postCUsersR
|
||||
postCUsersR tid ssh csh = do
|
||||
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
|
||||
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
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
|
||||
now <- liftIO getCurrentTime
|
||||
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
|
||||
Just (reason, noShow)
|
||||
| is _Just courseParticipantAllocated -> lift $ do
|
||||
|
||||
@ -129,7 +129,7 @@ postEAddUserR tid ssh csh examn = do
|
||||
unless registerCourse $
|
||||
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
|
||||
|
||||
@ -11,6 +11,7 @@ module Handler.Exam.CorrectorInvite
|
||||
import Import
|
||||
import Handler.Utils.Invitations
|
||||
import Handler.Utils.Exam
|
||||
import Handler.Utils.Memcached
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
@ -71,7 +72,7 @@ examCorrectorInvitationConfig = InvitationConfig{..}
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ _ _ = pure (JunctionExamCorrector, ())
|
||||
invitationInsertHook _ _ _ _ _ = id
|
||||
invitationInsertHook _ _ _ _ _ = (*>) (memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId))
|
||||
invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName
|
||||
invitationUltDest (Entity _ Exam{..}) _ = do
|
||||
Course{..} <- get404 examCourse
|
||||
|
||||
@ -113,6 +113,7 @@ postEEditR tid ssh csh examn = do
|
||||
|
||||
deleteWhere [ ExamCorrectorExam ==. eId ]
|
||||
insertMany_ $ map (ExamCorrector eId) adds
|
||||
memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId)
|
||||
|
||||
deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ]
|
||||
sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
|
||||
|
||||
@ -84,6 +84,7 @@ postCExamNewR tid ssh csh = do
|
||||
, examCorrectorUser <- adds
|
||||
]
|
||||
sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
|
||||
memcachedByInvalidate AuthCacheExamCorrectorList $ Proxy @(Set UserId)
|
||||
|
||||
let recordNoShow (Entity _ CourseParticipant{..}) = do
|
||||
didRecord <- is _Just <$> insertUnique ExamResult
|
||||
|
||||
@ -196,7 +196,7 @@ getEShowR tid ssh csh examn = do
|
||||
|
||||
notificationDiscouragedExamMode <- runMaybeT $ do
|
||||
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
|
||||
|
||||
siteLayoutMsg heading $ do
|
||||
|
||||
@ -107,13 +107,13 @@ externalExamForm template = validateForm validateExternalExam $ \html -> do
|
||||
fSettings = fslI MsgExternalExamStaff & setTooltip MsgExternalExamStaffTip
|
||||
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
|
||||
State.modify $ \eeForm -> eeForm & over _eefOfficeSchools (Set.delete $ eeForm ^. _eefSchool)
|
||||
|
||||
ExternalExamForm{..} <- State.get
|
||||
|
||||
isAdmin <- hasWriteAccessTo $ SchoolR eefSchool SchoolEditR
|
||||
isAdmin <- lift . hasWriteAccessTo $ SchoolR eefSchool SchoolEditR
|
||||
unless isAdmin $ do
|
||||
uid <- requireAuthId
|
||||
guardValidation MsgExternalExamUserMustBeStaff $ Right uid `Set.member` eefStaff
|
||||
|
||||
@ -108,6 +108,7 @@ mkMessageFor ''UniWorX ''FAQItem "messages/faq" "de-de-formal"
|
||||
|
||||
faqsWidget :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Maybe Natural -> Maybe (Route UniWorX) -> m (Maybe Widget, Bool)
|
||||
faqsWidget mLimit route = do
|
||||
@ -157,6 +158,7 @@ getFaqR =
|
||||
|
||||
showFAQ :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadThrow m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> Route UniWorX -> FAQItem -> m Bool
|
||||
showFAQ _ FAQNoCampusAccount = is _Nothing <$> maybeAuthId
|
||||
|
||||
@ -70,7 +70,7 @@ newsSystemMessages = do
|
||||
|
||||
(messages', Any anyHidden) <- liftHandler . runDB . runConduit . C.runWriterLC $
|
||||
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)
|
||||
.| C.filter (\(_, SystemMessage{..}, _) -> NTop systemMessageFrom <= NTop (Just now) && NTop (Just now) < NTop systemMessageTo)
|
||||
.| C.mapMaybeM checkHidden
|
||||
|
||||
@ -151,7 +151,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar
|
||||
notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
|
||||
notificationForm template = wFormToAForm $ do
|
||||
mbUid <- liftHandler maybeAuthId
|
||||
isAdmin <- hasReadAccessTo AdminR
|
||||
isAdmin <- lift . lift $ hasReadAccessTo AdminR
|
||||
|
||||
let
|
||||
sectionIsHidden :: NotificationTriggerKind -> DB Bool
|
||||
|
||||
@ -74,7 +74,7 @@ correctorInvitationConfig = InvitationConfig{..}
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure (JunctionSheetCorrector cLoad cState, ())
|
||||
invitationInsertHook _ _ _ _ _ = id
|
||||
invitationInsertHook _ _ _ _ _ = (*>) (memcachedByInvalidate AuthCacheCorrectorList $ Proxy @(Set UserId))
|
||||
invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
|
||||
invitationUltDest (Entity _ Sheet{..}) _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
|
||||
@ -120,6 +120,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
|
||||
deleteWhere [ SheetCorrectorSheet ==. sid ]
|
||||
insertMany_ adds
|
||||
memcachedByInvalidate AuthCacheCorrectorList (Proxy @(Set UserId))
|
||||
|
||||
deleteWhere [InvitationFor ==. invRef @SheetCorrector sid, InvitationEmail /<-. toListOf (folded . _1) invites]
|
||||
sinkInvitationsF correctorInvitationConfig invites
|
||||
|
||||
@ -120,7 +120,7 @@ makeSheetForm cId msId template = identifyForm FIDsheet . validateForm validateS
|
||||
)
|
||||
]
|
||||
)
|
||||
guardM $ hasReadAccessTo downloadRoute
|
||||
guardM . lift $ hasReadAccessTo downloadRoute
|
||||
messageIconWidget Info IconFileUser
|
||||
[whamlet|
|
||||
$newline never
|
||||
|
||||
@ -95,7 +95,7 @@ getSheetListR tid ssh csh = do
|
||||
acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
|
||||
tellStats = do
|
||||
r <- mkRoute
|
||||
showRating <- hasReadAccessTo r
|
||||
showRating <- lift $ hasReadAccessTo r
|
||||
tell . stats $ bool Nothing submissionRatingPoints showRating
|
||||
in acell & cellContents %~ (<* tellStats)
|
||||
|
||||
|
||||
@ -129,7 +129,7 @@ getSShowR tid ssh csh shn = do
|
||||
mRequiredExamLink <- runMaybeT $ do
|
||||
(etid, essh, ecsh, examn) <- hoistMaybe mRequiredExam
|
||||
let eUrl = CExamR etid essh ecsh examn EShowR
|
||||
guardM $ hasReadAccessTo eUrl
|
||||
guardM . lift $ hasReadAccessTo eUrl
|
||||
return eUrl
|
||||
mMissingExamRegistration <- for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> maybeT (return True) $ do
|
||||
uid <- MaybeT maybeAuthId
|
||||
@ -148,7 +148,7 @@ getSShowR tid ssh csh shn = do
|
||||
submissionModeNoneWithoutNotGradedWarning <- runMaybeT $ do
|
||||
guard $ classifySubmissionMode (sheetSubmissionMode sheet) == SubmissionModeNone
|
||||
&& 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
|
||||
|
||||
sTypeDesc <- runDB $ sheetTypeDescription (sheetCourse sheet) (sheetType sheet)
|
||||
@ -162,7 +162,7 @@ getSShowR tid ssh csh shn = do
|
||||
sheetTo <- traverse (formatTime SelFormatDateTime) $ sheetActiveTo sheet
|
||||
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom 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
|
||||
tr <- getTranslate
|
||||
$(widgetFile "sheetShow")
|
||||
|
||||
@ -24,7 +24,7 @@ subDownloadSource tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) p
|
||||
isRating <- lift $ (== Just submissionID) <$> isRatingFile path
|
||||
|
||||
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)
|
||||
|
||||
@ -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 tid ssh csh shn cID sfType = maybeT (return ()) $ do
|
||||
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
|
||||
submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
|
||||
|
||||
@ -21,7 +21,7 @@ postTCommR tid ssh csh tutn = do
|
||||
tuts <- selectList [TutorialCourse ==. cid] []
|
||||
usertuts <- forMaybeM tuts $ \(Entity tutid Tutorial{..}) -> do
|
||||
cID <- encrypt tutid
|
||||
guardM . hasReadAccessTo $ CTutorialR tid ssh csh tutorialName TUsersR
|
||||
guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutorialName TUsersR
|
||||
return ( RGTutorialParticipants cID
|
||||
, E.from $ \(user `E.InnerJoin` participant) -> do
|
||||
E.on $ user E.^. UserId E.==. participant E.^. TutorialParticipantUser
|
||||
|
||||
@ -78,6 +78,7 @@ postTEditR tid ssh csh tutn = do
|
||||
|
||||
deleteWhere [ InvitationFor ==. invRef @Tutor tutid, InvitationEmail /<-. invites ]
|
||||
sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites
|
||||
memcachedByInvalidate AuthCacheTutorList $ Proxy @(Set UserId)
|
||||
return insertRes
|
||||
case insertRes of
|
||||
Just _ -> addMessageI Error $ MsgTutorialNameTaken tfName
|
||||
|
||||
@ -43,6 +43,7 @@ postCTutorialNewR tid ssh csh = do
|
||||
|
||||
let (invites, adds) = partitionEithers $ Set.toList tfTutors
|
||||
insertMany_ $ map (Tutor tutid) adds
|
||||
memcachedByInvalidate AuthCacheTutorList $ Proxy @(Set UserId)
|
||||
sinkInvitationsF tutorInvitationConfig $ map (, tutid, (InvDBDataTutor, InvTokenDataTutor)) invites
|
||||
return insertRes
|
||||
case insertRes of
|
||||
|
||||
@ -9,6 +9,7 @@ module Handler.Tutorial.TutorInvite
|
||||
import Import
|
||||
import Handler.Utils.Tutorial
|
||||
import Handler.Utils.Invitations
|
||||
import Handler.Utils.Memcached
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
@ -69,7 +70,7 @@ tutorInvitationConfig = InvitationConfig{..}
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ _ _ = pure (JunctionTutor, ())
|
||||
invitationInsertHook _ _ _ _ _ = id
|
||||
invitationInsertHook _ _ _ _ _ = (*>) (memcachedByInvalidate AuthCacheTutorList $ Proxy @(Set UserId))
|
||||
invitationSuccessMsg (Entity _ Tutorial{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted tutorialName
|
||||
invitationUltDest (Entity _ Tutorial{..}) _ = do
|
||||
Course{..} <- get404 tutorialCourse
|
||||
|
||||
@ -108,7 +108,7 @@ postUsersR = do
|
||||
, formCellLens = id
|
||||
, formCellContents = do
|
||||
cID <- encrypt uid
|
||||
mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
|
||||
mayHijack <- lift . lift $ (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
|
||||
myUid <- liftHandler maybeAuthId
|
||||
if
|
||||
| mayHijack
|
||||
@ -319,7 +319,7 @@ postAdminUserR uuid = do
|
||||
|
||||
-- above data is needed for both form generation and result evaluation
|
||||
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
|
||||
| sid `Set.member` adminSchools
|
||||
-> mpopt checkBoxField "" . Just $ (function, sid) `Set.member` functions
|
||||
@ -339,6 +339,8 @@ postAdminUserR uuid = do
|
||||
if
|
||||
| not $ Set.null updates -> runDBJobs $ do
|
||||
$logInfoS "user-rights-update" $ tshow updates
|
||||
forM_ (setOf (folded . _1) updates) $ \func ->
|
||||
memcachedByInvalidate (AuthCacheSchoolFunctionList func) $ Proxy @(Set UserId)
|
||||
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)}|]
|
||||
if
|
||||
@ -394,11 +396,12 @@ postAdminUserR uuid = do
|
||||
let symmDiff = setFromFunc newFuncs `setSymmDiff` setFromFunc systemFunctions
|
||||
if
|
||||
| not $ Set.null symmDiff -> runDBJobs $ do
|
||||
forM_ symmDiff $ \func -> if
|
||||
| newFuncs func
|
||||
-> void $ upsert (UserSystemFunction uid func True False) [ UserSystemFunctionIsOptOut =. False, UserSystemFunctionManual =. True ]
|
||||
| otherwise
|
||||
-> void $ upsert (UserSystemFunction uid func True True) [ UserSystemFunctionIsOptOut =. True, UserSystemFunctionManual =. True ]
|
||||
forM_ symmDiff $ \func -> do
|
||||
memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
|
||||
if | newFuncs func
|
||||
-> void $ upsert (UserSystemFunction uid func True False) [ UserSystemFunctionIsOptOut =. False, UserSystemFunctionManual =. True ]
|
||||
| otherwise
|
||||
-> void $ upsert (UserSystemFunction uid func True True) [ UserSystemFunctionIsOptOut =. True, UserSystemFunctionManual =. True ]
|
||||
queueDBJob . JobQueueNotification . NotificationUserSystemFunctionsUpdate uid $ setFromFunc systemFunctions
|
||||
addMessageI Success MsgUserSystemFunctionsSaved
|
||||
| otherwise
|
||||
|
||||
@ -70,8 +70,9 @@ warnTermDays tid timeNames = do
|
||||
|
||||
|
||||
-- | return a value only if the current user ist authorized for a given route
|
||||
guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadThrow h
|
||||
, MonadTrans m, MonadPlus (m (ReaderT SqlBackend h)))
|
||||
guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadThrow h, MonadUnliftIO h
|
||||
, MonadTrans m, MonadPlus (m (ReaderT SqlBackend h))
|
||||
)
|
||||
=> Route UniWorX -> a -> m (ReaderT SqlBackend h) a
|
||||
guardAuthorizedFor link val =
|
||||
val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False)
|
||||
|
||||
@ -2,6 +2,7 @@ module Handler.Utils.Course where
|
||||
|
||||
import Import
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Memcached
|
||||
|
||||
import qualified Database.Esqueleto 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 ->
|
||||
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
||||
E.&&. E.subSelectForeign submissionGroupUser SubmissionGroupUserSubmissionGroup (E.^. SubmissionGroupCourse) E.==. E.val cid
|
||||
when didDelete $
|
||||
when didDelete $ do
|
||||
audit $ TransactionSubmissionGroupUnset cid uid
|
||||
memcachedByInvalidate AuthCacheSubmissionGroupUserList (Proxy @(Set UserId))
|
||||
return $ bool mempty (Sum 1) didDelete
|
||||
E.delete . E.from $ \submissionGroup ->
|
||||
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
|
||||
fmap getSum . flip foldMapM uids $ \uid -> do
|
||||
didSet <- fmap (is _Just) . insertUnique $ SubmissionGroupUser gId uid
|
||||
when didSet $
|
||||
when didSet $ do
|
||||
audit $ TransactionSubmissionGroupSet cid uid grp
|
||||
memcachedByInvalidate AuthCacheSubmissionGroupUserList (Proxy @(Set UserId))
|
||||
return $ bool mempty (Sum 1) didSet
|
||||
|
||||
showCourseEventRoom :: forall courseEvent courseId.
|
||||
|
||||
@ -34,7 +34,7 @@ resultIsSynced authId examResult = (hasSchool E.&&. allSchools) E.||. (E.not_ ha
|
||||
examOfficeExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office
|
||||
-> E.SqlExpr (Entity ExamResult)
|
||||
-> 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
|
||||
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.&&. 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
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
E.&&. exam E.^. ExamId E.==. examResult E.^. ExamResultExam
|
||||
|
||||
@ -34,7 +34,7 @@ resultIsSynced authId eexamResult = (hasSchool E.&&. allSchools) E.||. (E.not_ h
|
||||
examOfficeExternalExamResultAuth :: E.SqlExpr (E.Value UserId) -- ^ office
|
||||
-> E.SqlExpr (Entity ExternalExamResult)
|
||||
-> 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
|
||||
authByField = E.exists . E.from $ \(examOfficeField `E.InnerJoin` studyFeatures) -> do
|
||||
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.&&. 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
|
||||
E.on $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolExamOffice
|
||||
E.&&. userFunction E.^. UserFunctionSchool E.==. eexam E.^. ExternalExamSchool
|
||||
|
||||
@ -1199,14 +1199,17 @@ sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> tem
|
||||
|
||||
sheetTypeAFormReq :: CourseId -> FieldSettings UniWorX -> Maybe (SheetType ExamPartId) -> AForm Handler (SheetType ExamPartId)
|
||||
sheetTypeAFormReq cId fs template = wFormToAForm $ do
|
||||
examParts'' <- liftHandler . runDB . E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart) -> do
|
||||
E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
E.where_ $ exam E.^. ExamCourse E.==. E.val cId
|
||||
return (exam, course, examPart)
|
||||
(examParts'', editableExams) <- liftHandler . runDB $ do
|
||||
examParts'' <- E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart) -> do
|
||||
E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
|
||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
||||
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{..}) ->
|
||||
hasWriteAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR
|
||||
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
|
||||
|
||||
return (examParts'', editableExams)
|
||||
|
||||
let
|
||||
examParts' = flip foldMap examParts'' $ \(eEnt@(Entity eId _), _, epEnt) -> guardOn @[] (eId `Set.member` editableExams) (eEnt, epEnt)
|
||||
|
||||
@ -56,6 +56,8 @@ import qualified Crypto.Saltine.Core.AEAD as AEAD
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
||||
|
||||
|
||||
type Expiry = Either UTCTime DiffTime
|
||||
|
||||
@ -141,13 +143,9 @@ data MemcachedException = MemcachedException Memcached.MemcachedException
|
||||
deriving anyclass (Exception)
|
||||
|
||||
|
||||
memcachedKey :: ( Typeable a
|
||||
, Binary k
|
||||
)
|
||||
=> 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
|
||||
memcachedKey :: Typeable a
|
||||
=> AEAD.Key -> Proxy a -> Lazy.ByteString -> ByteString
|
||||
memcachedKey (Saltine.encode -> kmacKey) p = BA.convert . kmaclazy @(SHAKE256 256) (encodeUtf8 . tshow $ typeRep p) kmacKey
|
||||
|
||||
memcachedAAD :: ByteString -> Maybe POSIXTime -> ByteString
|
||||
memcachedAAD cKey mExpiry = toStrict . Binary.runPut $ do
|
||||
@ -160,35 +158,38 @@ memcachedByGet :: forall a k m.
|
||||
, Binary k
|
||||
)
|
||||
=> k -> m (Maybe a)
|
||||
memcachedByGet k = runMaybeT $ do
|
||||
(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
|
||||
memcachedByGet (Binary.encode -> k) = runMaybeT $ requestCache <|> memcache
|
||||
where
|
||||
runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of
|
||||
Right (bs', _, x) | null bs' -> Just x
|
||||
_other -> Nothing
|
||||
clockLeniency :: NominalDiffTime
|
||||
clockLeniency = 2
|
||||
requestCache = MaybeT . cacheByGet $ toStrict k
|
||||
memcache = do
|
||||
(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
|
||||
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.
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
@ -197,7 +198,7 @@ memcachedBySet :: forall a k m.
|
||||
, Binary k
|
||||
)
|
||||
=> 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
|
||||
mConn <- getsYesod appMemcached
|
||||
for_ mConn $ \(aeadKey, conn) -> do
|
||||
@ -209,6 +210,7 @@ memcachedBySet mExp k v = do
|
||||
aad = memcachedAAD cKey mExpiry
|
||||
mCiphertext = AEAD.aead aeadKey mNonce (toStrict $ Binary.encode v) aad
|
||||
liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (Binary.runPut $ putMemcachedValue MemcachedValue{..}) conn
|
||||
cacheBySet (toStrict k) v
|
||||
$logDebugS "memcached" $ "Cache store: " <> tshow mExpiry
|
||||
|
||||
memcachedByInvalidate :: forall a k m p.
|
||||
@ -217,7 +219,7 @@ memcachedByInvalidate :: forall a k m p.
|
||||
, Binary k
|
||||
)
|
||||
=> k -> p a -> m ()
|
||||
memcachedByInvalidate k _ = maybeT_ $ do
|
||||
memcachedByInvalidate (Binary.encode -> k) _ = maybeT_ $ do
|
||||
(aeadKey, conn) <- MaybeT $ getsYesod appMemcached
|
||||
let cKey = memcachedKey aeadKey (Proxy @a) k
|
||||
hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey conn
|
||||
|
||||
@ -91,13 +91,12 @@ resolveSheetTypeRating cId dbST = do
|
||||
}
|
||||
|
||||
sheetTypeDescription :: forall m.
|
||||
( MonadThrow m
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> CourseId
|
||||
-> SheetType SqlBackendKey
|
||||
-> ReaderT SqlBackend m (HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
|
||||
sheetTypeDescription cId dbST = do
|
||||
sheetTypeDescription cId dbST = hoist liftHandler $ do
|
||||
sType' <- resolveSheetType cId dbST
|
||||
sType <- for sType' $ \(Entity _epId ExamPart{..}) -> do
|
||||
Exam{..} <- getJust examPartExam
|
||||
|
||||
@ -359,7 +359,7 @@ submissionMultiArchive anonymous (Set.toList -> ids) = do
|
||||
|
||||
notAnonymized' <- and2M
|
||||
(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)
|
||||
|
||||
@ -811,7 +811,7 @@ sinkMultiSubmission userId isUpdate = do
|
||||
Submission{..} <- get404 sId
|
||||
Sheet{..} <- get404 submissionSheet
|
||||
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
|
||||
sink' <- lift $ yield val ++$$ sink
|
||||
case sink' of
|
||||
|
||||
@ -73,6 +73,7 @@ workflowEdgeForm :: ( MonadHandler m
|
||||
, MonadHandler m'
|
||||
, HandlerSite m' ~ UniWorX
|
||||
, MonadCatch m'
|
||||
, MonadUnliftIO m'
|
||||
)
|
||||
=> Either WorkflowInstanceId WorkflowWorkflowId
|
||||
-> Maybe WorkflowEdgeForm
|
||||
|
||||
@ -85,7 +85,7 @@ sourceWorkflowActionInfos
|
||||
( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, BackendCompatible SqlReadBackend backend
|
||||
, MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey
|
||||
, MonadCatch m
|
||||
, MonadCatch m, MonadUnliftIO m
|
||||
)
|
||||
=> WorkflowWorkflowId
|
||||
-> WorkflowState FileReference UserId
|
||||
|
||||
@ -151,9 +151,9 @@ workflowInstanceListR rScope = do
|
||||
Entity _ desc@WorkflowInstanceDescription{..} <- descs
|
||||
guard $ workflowInstanceDescriptionLanguage == lang
|
||||
return desc
|
||||
mayInitiate <- hasWriteAccessTo $ toInitiateRoute workflowInstanceName
|
||||
mayEdit <- hasReadAccessTo $ toEditRoute workflowInstanceName
|
||||
mayList <- hasReadAccessTo $ toListRoute workflowInstanceName
|
||||
mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute workflowInstanceName
|
||||
mayEdit <- lift . hasReadAccessTo $ toEditRoute workflowInstanceName
|
||||
mayList <- lift . hasReadAccessTo $ toListRoute workflowInstanceName
|
||||
guard $ mayInitiate || mayEdit || mayList
|
||||
return (wi, desc)
|
||||
|
||||
@ -192,9 +192,9 @@ getTopWorkflowInstanceListR = do
|
||||
Entity _ desc@WorkflowInstanceDescription{..} <- descs
|
||||
guard $ workflowInstanceDescriptionLanguage == lang
|
||||
return desc
|
||||
mayInitiate <- hasWriteAccessTo $ toInitiateRoute' rScope workflowInstanceName
|
||||
mayEdit <- hasReadAccessTo $ toEditRoute' rScope workflowInstanceName
|
||||
mayList <- hasReadAccessTo $ toListRoute' rScope workflowInstanceName
|
||||
mayInitiate <- lift . hasWriteAccessTo $ toInitiateRoute' rScope workflowInstanceName
|
||||
mayEdit <- lift . hasReadAccessTo $ toEditRoute' rScope workflowInstanceName
|
||||
mayList <- lift . hasReadAccessTo $ toListRoute' rScope workflowInstanceName
|
||||
guard $ mayInitiate || mayEdit || mayList
|
||||
return (rScope, [(wi, desc)])
|
||||
|
||||
|
||||
@ -367,6 +367,7 @@ workflowWorkflowList (title, heading) WWListColumns{..} sqlPred = do
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> WorkflowActionInfo FileReference UserId
|
||||
-> WriterT (Maybe (Last (CryptoUUIDWorkflowStateIndex, Maybe WorkflowGraphNodeLabel, Maybe JsonWorkflowUser, UTCTime, Map WorkflowPayloadLabel JsonWorkflowPayload))) (SqlPersistT m) ()
|
||||
|
||||
@ -107,6 +107,7 @@ workflowR rScope cID = do
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, MonadCatch m
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> WorkflowActionInfo FileReference UserId
|
||||
-> RWST () (Maybe (Last WorkflowCurrentState), [WorkflowHistoryItem]) (Map WorkflowPayloadLabel (Set (WorkflowFieldPayloadW FileReference UserId))) (SqlPersistT m) ()
|
||||
|
||||
@ -196,7 +196,7 @@ dispatchNotificationAllocationNewCourse nAllocation nCourse jRecipient = userMai
|
||||
editNotifications <- mkEditNotifications jRecipient
|
||||
|
||||
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 $ AApplyR cID) True
|
||||
]
|
||||
|
||||
@ -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_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)")
|
||||
, ("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
|
||||
addIndex :: Text -> Sql -> Migration
|
||||
|
||||
@ -79,13 +79,12 @@ data BearerToken site = BearerToken
|
||||
, bearerStartsAt :: Maybe UTCTime
|
||||
} deriving (Generic, Typeable)
|
||||
|
||||
deriving 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 instance (Show (AuthId site), Show (Route site), Hashable (AuthId site)) => Show (BearerToken site)
|
||||
|
||||
instance (Hashable (AuthId site), Hashable (Route site)) => Hashable (BearerToken site)
|
||||
|
||||
instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site), Hashable (AuthId site), Eq (AuthId site)) => Binary (BearerToken site)
|
||||
deriving stock instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
|
||||
deriving stock instance (Ord (AuthId site), Ord (Route site)) => Ord (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)
|
||||
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)
|
||||
|
||||
makeLenses_ ''BearerToken
|
||||
instance HasTokenIdentifier (BearerToken site) TokenId where
|
||||
|
||||
@ -19,3 +19,4 @@ nullaryPathPiece ''SchoolFunction $ camelToPathPiece' 1
|
||||
pathPieceJSON ''SchoolFunction
|
||||
pathPieceJSONKey ''SchoolFunction
|
||||
derivePersistFieldPathPiece ''SchoolFunction
|
||||
pathPieceBinary ''SchoolFunction
|
||||
|
||||
@ -15,3 +15,4 @@ nullaryPathPiece ''SystemFunction $ camelToPathPiece' 1
|
||||
pathPieceJSON ''SystemFunction
|
||||
pathPieceJSONKey ''SystemFunction
|
||||
derivePersistFieldPathPiece ''SystemFunction
|
||||
pathPieceBinary ''SystemFunction
|
||||
|
||||
@ -24,6 +24,7 @@ module Utils.Metrics
|
||||
, poolMetrics
|
||||
, observeDatabaseConnectionOpened, observeDatabaseConnectionClosed
|
||||
, onUseDBConn, onReleaseDBConn, DBConnUseState, DBConnLabel
|
||||
, AuthTagEvalOutcome(..), observeAuthTagEvaluation
|
||||
) where
|
||||
|
||||
import Import.NoModel hiding (Vector, Info)
|
||||
@ -416,6 +417,19 @@ onReleaseDBConn DBConnUseState{..} _ = liftIO $ do
|
||||
[] -> "unlabeled"
|
||||
(_, SrcLoc{..}) : _ -> pack srcLocModule
|
||||
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
|
||||
@ -564,3 +578,17 @@ observeMissingFiles refIdent = liftIO . withLabel missingFiles refIdent . flip s
|
||||
observeDatabaseConnectionOpened, observeDatabaseConnectionClosed :: MonadIO m => m ()
|
||||
observeDatabaseConnectionOpened = liftIO $ incCounter databaseConnectionsOpened
|
||||
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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user