From aea5ef41d16c448a9fd7426edcd6f4b0d0fa483d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Tue, 29 May 2018 17:42:02 +0200 Subject: [PATCH] (Preliminarily) Finish knownTags --- messages/de.msg | 6 +++ routes | 5 ++- src/CryptoID.hs | 7 +++- src/Foundation.hs | 94 +++++++++++++++++++++++++++++++++++++++++------ src/Utils.hs | 7 ++++ 5 files changed, 103 insertions(+), 16 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index a5fc04be3..5332201d5 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -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. diff --git a/routes b/routes index b96b3d6b0..f864ff89c 100644 --- a/routes +++ b/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 diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 5eda0a941..d13e98425 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index cd5bcd763..3678b20f4 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 } ] diff --git a/src/Utils.hs b/src/Utils.hs index 0024dc117..3f5480d1b 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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 --