Merge branch 'feat/routes' of gitlab.cip.ifi.lmu.de:jost/UniWorX into feat/routes

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.

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
@@ -42,14 +43,14 @@
 /course/#TermId/#Text       CourseR                           !lecturer:
   /show                       CShowR          GET POST        !free
   /edit                       CEditR          GET POST
-  /ex                         SheetListR      GET             !materials
+  /ex                         SheetListR      GET             !registered !materials
   !/ex/new                    SheetNewR       GET POST
-  /ex/#Text SheetR                                            !materials:
+  /ex/#Text SheetR:
-    /show                       SShowR        GET             !time !corrector
+    /show                       SShowR        GET             !timeANDregistered !timeANDmaterials !corrector
-    /#SheetFileType/#FilePath   SFileR        GET             !time !corrector
+    /#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

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
+pattern NewSubmission :: SubmissionMode
-newSubmission = SubmissionMode Nothing
+pattern NewSubmission = SubmissionMode Nothing
+pattern ExistingSubmission :: CryptoUUIDSubmission -> SubmissionMode
+pattern ExistingSubmission cID = SubmissionMode (Just cID)
 
 instance PathPiece SubmissionMode where
     fromPathPiece "new" = Just $ SubmissionMode Nothing

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
 
 
@@ -214,44 +214,116 @@ 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
-      CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedLecturer) $ do
+      CourseR tid csh _ -> exceptT return return $ do
-          authId <- lift $ lift requireAuthId -- TODO SJ Continue
+          authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
-          -- getBy404 would disclose that the course exists
+          [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
-          Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
+            E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
-          void . MaybeT . getBy $ UniqueLecturer authId cid
+            E.where_ $ lecturer E.^. LecturerUser 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 MsgUnauthorizedLecturer) (c > 0)
+          return Authorized
+      _ -> exceptT return return $ do
+          authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+          void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
           return Authorized
-      _ -> do
-          authId <- lift requireAuthId -- TODO SJ Continue
-          mul <- selectFirst [UserLecturerUser ==. authId] []
-          case mul of
-            Nothing  -> unauthorizedI $ MsgUnauthorizedSchoolLecturer
-            (Just _) -> return Authorized
     )
-   -- TODO: Continue here!!!
+  ,("corrector", APDB $ \route -> exceptT return return $ do
-  ,("corrector", undefined)
+       authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
-  ,("time", undefined)
+       resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
-  ,("registered", undefined)
+         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
+      CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
-        Entity cid _ <- getBy404 $ CourseTermShort tid csh
+        Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
-        undefined -- CONTINUE HERE
+        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
+   )
   ]
 
 
 tag2ap :: Text -> AccessPredicate
 tag2ap t = case Map.lookup (CI.mk t) knownTags of
     (Just acp) -> acp
-    Nothing   -> APHandler $ \_route -> do --TODO: can this be pure like falseAP?
+    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")
+      $logWarnS "AccessControl" $ "'" <> t <> "' not known to access control"
-      unauthorizedI $ MsgUnauthorized
+      unauthorizedI MsgUnauthorized
 
 route2ap :: Route UniWorX -> AccessPredicate
-route2ap r = foldr orAP adminAP attrsAND --TODO: adminAP causes all to be in DB!!!
+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)
   where
     attrsAND = map splitAND $ Set.toList $ routeAttrs r
     splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND"
@@ -581,7 +653,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
       }
   ]

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 --
 ---------------
@@ -108,6 +112,9 @@ guardMExceptT b err = 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 --