(Preliminarily) Finish knownTags
This commit is contained in:
Gregor Kleen
parent
215ffd3497
commit
aea5ef41d1
@ -28,9 +28,15 @@ UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut e
|
||||
UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
|
||||
UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
|
||||
UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen.
|
||||
UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen.
|
||||
UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen.
|
||||
UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
|
||||
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
|
||||
UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
|
||||
UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
|
||||
OnlyUploadOneFile: Bitte nur eine Datei hochladen.
|
||||
DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
|
||||
UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben.
|
||||
|
||||
SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
|
||||
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
|
||||
|
||||
5
routes
5
routes
@ -12,8 +12,9 @@
|
||||
-- Access Tags:
|
||||
-- !free -- free for all
|
||||
-- !lecturer -- lecturer for this course (or the school, if route is not connected to a course)
|
||||
-- !corrector -- corrector for this sheet (or the course, if route is not connected to a sheet )
|
||||
-- !corrector -- corrector for this sheet (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course)
|
||||
-- !registered -- participant for this course (no effect outside of courses)
|
||||
-- !owner -- part of the group of owners of this submission
|
||||
--
|
||||
-- !materials -- only if course allows all materials to be free (no meaning outside of courses)
|
||||
-- !time -- access depends on time somehow
|
||||
@ -49,7 +50,7 @@
|
||||
/#SheetFileType/#FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
|
||||
/edit SEditR GET POST
|
||||
/delete SDelR GET POST
|
||||
!/submission/#SubmissionMode SubmissionR GET POST !timeANDregistered
|
||||
!/submission/#SubmissionMode SubmissionR GET POST !timeANDregistered !owner
|
||||
|
||||
|
||||
!/#UUID CryptoUUIDDispatchR GET !free -- just redirect
|
||||
|
||||
@ -5,6 +5,7 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
|
||||
{-# LANGUAGE RecordWildCards, ViewPatterns, PatternGuards #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module CryptoID
|
||||
@ -49,8 +50,10 @@ decCryptoIDs [ ''SubmissionId
|
||||
newtype SubmissionMode = SubmissionMode (Maybe CryptoUUIDSubmission)
|
||||
deriving (Show, Read, Eq)
|
||||
|
||||
newSubmission :: SubmissionMode
|
||||
newSubmission = SubmissionMode Nothing
|
||||
pattern NewSubmission :: SubmissionMode
|
||||
pattern NewSubmission = SubmissionMode Nothing
|
||||
pattern ExistingSubmission :: CryptoUUIDSubmission -> SubmissionMode
|
||||
pattern ExistingSubmission cID = SubmissionMode (Just cID)
|
||||
|
||||
instance PathPiece SubmissionMode where
|
||||
fromPathPiece "new" = Just $ SubmissionMode Nothing
|
||||
|
||||
@ -51,7 +51,7 @@ import qualified Data.Text.Encoding as Text
|
||||
import Data.List (foldr1)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map (Map)
|
||||
import Data.Map (Map, (!?))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
@ -215,7 +215,7 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
|
||||
[("free", trueAP)
|
||||
,("deprecated", APHandler $ \r -> do
|
||||
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
|
||||
setMessageI $ MsgDeprecatedRoute
|
||||
addMessageI "error" MsgDeprecatedRoute
|
||||
return Authorized
|
||||
)
|
||||
,("lecturer", APDB $ \case
|
||||
@ -234,15 +234,85 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
|
||||
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
|
||||
return Authorized
|
||||
)
|
||||
-- TODO: Continue here!!!
|
||||
,("corrector", undefined)
|
||||
,("time", undefined)
|
||||
,("registered", undefined)
|
||||
,("corrector", APDB $ \route -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
resList <- 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
|
||||
CSheetR _ _ _ (SubmissionR (ExistingSubmission cID)) -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
|
||||
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
Submission{..} <- MaybeT . lift $ get sid
|
||||
guard $ maybe False (== authId) submissionRatingBy
|
||||
return Authorized
|
||||
CSheetR tid csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
|
||||
Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh
|
||||
Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
|
||||
guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
|
||||
return Authorized
|
||||
CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
|
||||
Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh
|
||||
guard $ cid `Set.member` Map.keysSet resMap
|
||||
return Authorized
|
||||
_ -> do
|
||||
guardMExceptT (unauthorizedI MsgUnauthorizedCorrectorAny) . not $ Map.null resMap
|
||||
return Authorized
|
||||
)
|
||||
,("time", APDB $ \case
|
||||
CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
|
||||
Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
|
||||
Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
|
||||
cTime <- liftIO getCurrentTime
|
||||
case subRoute of
|
||||
SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
|
||||
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
|
||||
SubmissionR NewSubmission -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
|
||||
_ -> guard $ maybe False (<= cTime) sheetVisibleFrom
|
||||
return Authorized
|
||||
r -> do
|
||||
$logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r
|
||||
unauthorizedI MsgUnauthorized
|
||||
)
|
||||
,("registered", APDB $ \case
|
||||
CourseR tid csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
[E.Value c] <- lift . E.select . 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.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return (E.countRows :: E.SqlExpr (E.Value Int64))
|
||||
guardMExceptT (unauthorizedI MsgUnauthorizedParticipant) (c > 0)
|
||||
return Authorized
|
||||
r -> do
|
||||
$logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r
|
||||
unauthorizedI MsgUnauthorized
|
||||
)
|
||||
,("materials", APDB $ \case
|
||||
CourseR tid csh _ -> do
|
||||
Entity cid _ <- getBy404 $ CourseTermShort tid csh
|
||||
undefined -- CONTINUE HERE
|
||||
CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
|
||||
Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
|
||||
guard courseMaterialFree
|
||||
return Authorized
|
||||
r -> do
|
||||
$logErrorS "AccessControl" $ "'!materials' used on route that doesn't support it: " <> tshow r
|
||||
unauthorizedI MsgUnauthorized
|
||||
)
|
||||
,("owner", APDB $ \case
|
||||
CSheetR _ _ _ (SubmissionR (ExistingSubmission cID)) -> exceptT return return $ do
|
||||
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
|
||||
return Authorized
|
||||
CSheetR _ _ _ (SubmissionR NewSubmission) -> unauthorizedI MsgUnauthorizedSubmissionOwner
|
||||
r -> do
|
||||
$logErrorS "AccessControl" $ "'!owner' used on route that doesn't support it: " <> tshow r
|
||||
unauthorizedI MsgUnauthorized
|
||||
)
|
||||
]
|
||||
|
||||
|
||||
@ -250,8 +320,8 @@ tag2ap :: Text -> AccessPredicate
|
||||
tag2ap t = case Map.lookup (CI.mk t) knownTags of
|
||||
(Just acp) -> acp
|
||||
Nothing -> APHandler $ \_route -> do -- Can this be pure like falseAP? GK: not if we want to log a message (which we definitely should)
|
||||
$logWarnS "AccessControl" ("route tag unknown for access control")
|
||||
unauthorizedI $ MsgUnauthorized
|
||||
$logWarnS "AccessControl" $ "'" <> t <> "' not known to access control"
|
||||
unauthorizedI MsgUnauthorized
|
||||
|
||||
route2ap :: Route UniWorX -> AccessPredicate
|
||||
route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK: Due to shortCircuitM this (while still true) is no longer costly (we do a `runDB` but then only actually send off queries, if needed)
|
||||
@ -584,7 +654,7 @@ pageActions (CSheetR tid csh shn SShowR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Abgabe"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh shn (SubmissionR newSubmission)
|
||||
, menuItemRoute = CSheetR tid csh shn (SubmissionR NewSubmission)
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
|
||||
@ -22,6 +22,7 @@ import Text.Blaze (Markup, ToMarkup)
|
||||
|
||||
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Catch
|
||||
|
||||
|
||||
-----------
|
||||
@ -83,6 +84,9 @@ whenIsJust Nothing _ = return ()
|
||||
maybeT :: Monad m => m a -> MaybeT m a -> m a
|
||||
maybeT x m = runMaybeT m >>= maybe x return
|
||||
|
||||
catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
|
||||
catchIfMaybeT pred act = catchIf pred (lift act) (const mzero)
|
||||
|
||||
---------------
|
||||
-- Exception --
|
||||
---------------
|
||||
@ -102,6 +106,9 @@ guardMExceptT err b = unless b $ lift err >>= throwE
|
||||
exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
|
||||
exceptT f g = either f g <=< runExceptT
|
||||
|
||||
catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a
|
||||
catchIfMExceptT err pred act = catchIf pred (lift act) (throwE <=< lift . err)
|
||||
|
||||
|
||||
------------
|
||||
-- Monads --
|
||||
|
||||
Loading…
Reference in New Issue
Block a user