Merge branch 'master' into feat/exercises

FragenSJ.txt

@@ -1,7 +1,7 @@
 ** Sicherheitsabfragen?
  - Verschlüsselung des Zugriffs?
 
- - SheetDelR tid csh sn : GET zeigt Sicherheitsabfrage
+ - SDelR tid csh sn : GET zeigt Sicherheitsabfrage
                           POST löscht.
   Ist das so sinnvoll?
   Sicherheitsabfrage als PopUpMessage?
@@ -9,7 +9,7 @@
  - Utils.getKeyBy404 effiziente Variante, welche nur den Key liefert? Esq?
     (Sheet.hs -> fetchSheet)
 
- - Handler.Sheet.postSheetDelR: deleteCascade für Files? Klappt das?
+ - Handler.Sheet.postSDelR: deleteCascade für Files? Klappt das?
   Kann man abfragen, was bei deleteCascade alles gelöscht wird?
 
 
@@ -19,7 +19,7 @@
       Links       -> MenuItems verwenden wie bisher
       Page Titles -> setTitleI
       Buttons?    -> Kann leicht geändert werden!
-   Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getCourseListTermR, Zeile 66 "pageActions" für menuItemLabel?
+   Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getTermCourseListR, Zeile 66 "pageActions" für menuItemLabel?
 
 ** Page pageActions  - Berechtigungen prüfen?
  => Eigener Constructor statt NavbarLeft/Right?!

README.md

@@ -109,7 +109,7 @@ TABLE "user";
 DROP TABLE "course" CASCADE;
 
 -- UserId 5 zum Lecturer in SchoolId 1 machen (27 ist laufende Nummer)
-INSERT INTO "user_lecturer" (id,"user",school) VALUES (27,5,1);
+INSERT INTO "user_lecturer" (id,"user","school") VALUES (27,5,1);
 
 -- Beenden:
 \q

messages/de.msg

@@ -21,12 +21,22 @@ SheetDelTitle      tid@TermIdentifier courseShortHand@Text sheetName@Text: Übun
 SheetDelText       submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{show submissionNo} Abgaben.
 SheetDelOk         tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht.
 
+Unauthorized: Sie haben hierfür keine explizite Berechtigung.
+UnauthorizedAnd l@Text r@Text: "#{l}" und "#{r}"
+UnauthorizedOr  l@Text r@Text: "#{l}" oder "#{r}"
 UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
 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

@@ -1,44 +1,66 @@
-/static StaticR Static appStatic
+--
-/auth   AuthR   Auth   getAuth
+--  Accesss granted via tags; default is no accesss.
+--  Permission must be explicitly granted.
+--
+--  Access permission is the disjunction of permit tags
+--  Tags are split on "AND" to encode conjunction.
+--
+--  Note that nested routes automatically inherit all tags from the parent.
+--
+--  Admins always have access to entities within their assigned schools.
+--
+--  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 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
+--
+--    !deprecated -- like free, but logs and gives a warning
+--
 
-/favicon.ico FaviconR GET
+/static StaticR Static appStatic                              !free
-/robots.txt RobotsR GET
+/auth   AuthR   Auth   getAuth                                !free
 
-/        HomeR    GET POST
+/favicon.ico FaviconR GET                                     !free
-/profile ProfileR GET
+/robots.txt RobotsR GET                                       !free
-/users   UsersR   GET                                         !adminAny
 
-/term                       TermShowR         GET
+/        HomeR    GET POST                                    !free
-/term/edit                  TermEditR         GET POST        !adminAny
+/profile ProfileR GET                                         !free
-/term/#TermId/edit          TermEditExistR    GET             !adminAny
+/users   UsersR   GET                                         -- no tags, i.e. admins only
+
+/term                       TermShowR         GET             !free
+/term/edit                  TermEditR         GET POST
+/term/#TermId/edit          TermEditExistR    GET
+!/term/#TermId              TermCourseListR   GET             !free
 
 -- For Pattern Synonyms see Foundation
-/course/                    CourseListR       GET
+/course/                    CourseListR       GET             !free
-!/course/new                CourseNewR        GET POST        !lecturerAny
+!/course/new                CourseNewR        GET POST        !lecturer
-!/course/#TermId            CourseListTermR   GET
+/course/#TermId/#Text       CourseR                           !lecturer:
-/course/#TermId/#Text CourseR !updateFavourite:
+  /show                       CShowR          GET POST        !free
-  /show                       CourseShowR GET POST
+  /edit                       CEditR          GET POST
-  /edit                       CourseEditR GET POST            !lecturer
+  /ex                         SheetListR      GET             !registered !materials
-
+  !/ex/new                    SheetNewR       GET POST
-  /ex SheetR                                                  !registered:
+  /ex/#Text SheetR:
-    /                                SheetListR GET
+    /show                       SShowR        GET             !timeANDregistered !timeANDmaterials !corrector
-    /#Text/show                      SheetShowR GET            !time
+    /#SheetFileType/#FilePath   SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
-    /#Text/#SheetFileType/#FilePath  SheetFileR GET            !time
+    /edit                       SEditR        GET POST
-    /new                             SheetNewR  GET POST       !lecturer
+    /delete                     SDelR         GET POST
-    /#Text/edit                      SheetEditR GET POST       !lecturer
+    !/sub/new                   SubmissionNewR GET POST        !timeANDregistered
-    /#Text/delete                    SheetDelR  GET POST       !lecturer
+    !/sub/own                   SubmissionOwnR GET             !free
-    !/#Text/submission/#SubmissionMode SubmissionR GET POST    !time
+    !/sub/#CryptoUUIDSubmission SubmissionR    GET POST        !owner !corrector
 
 
-!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET
+!/#UUID CryptoUUIDDispatchR GET                               !free -- just redirect
-!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET
-
-!/#UUID CryptoUUIDDispatchR GET
 
 -- TODO below
-/submission                 SubmissionListR GET POST
+!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated
-/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST
+!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET !deprecated
-/submissions.zip SubmissionDownloadMultiArchiveR POST
 
--- For demonstration
+/submission                 SubmissionListR GET                 !deprecated
-/course/#CryptoUUIDCourse/edit CourseEditIDR GET
+/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST      !deprecated
+/submissions.zip SubmissionDownloadMultiArchiveR POST           !deprecated

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

@@ -1,9 +1,11 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE RecordWildCards #-}
@@ -30,6 +32,7 @@ import LDAP.Search (LDAPEntry(..))
 import Yesod.Default.Util   (addStaticContentExternal)
 import Yesod.Core.Types     (Logger)
 import qualified Yesod.Core.Unsafe as Unsafe
+import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Text.Encoding as TE
 
@@ -45,6 +48,13 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString
 import qualified Data.Text as Text
 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 qualified Data.Map as Map
+
+
 import Data.Conduit (($$))
 import Data.Conduit.List (sourceList)
 
@@ -52,12 +62,14 @@ import qualified Database.Esqueleto as E
 
 import Control.Monad.Except (MonadError(..), runExceptT)
 import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Trans.Reader (runReader)
 
 import System.FilePath
 
 import Handler.Utils.Templates
 import Handler.Utils.StudyFeatures
-
+import Control.Lens
+import Utils.Lens
 
 -- infixl 9 :$:
 -- pattern a :$: b = a b
@@ -89,10 +101,17 @@ data UniWorX = UniWorX
 -- type Widget  = WidgetT  UniWorX IO ()
 mkYesodData "UniWorX" $(parseRoutesFile "routes")
 
+-- | Convenient Type Synonyms:
+type DB a = YesodDB UniWorX a
+type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
+type MsgRenderer = MsgRendererS UniWorX -- see Utils
+
 -- Pattern Synonyms for convenience
-pattern CSheetR tid csh ptn = CourseR tid csh (SheetR ptn)
+pattern CSheetR tid csh shn ptn
+  = CourseR tid csh (SheetR shn ptn)
 
 
+-- Menus and Favourites
 data MenuItem = MenuItem
     { menuItemLabel :: Text
     , menuItemIcon :: Maybe Text
@@ -113,10 +132,7 @@ data MenuTypes                                 -- Semantische Rolle:
     | PageActionPrime     { menuItem :: MenuItem } --   Seitenspezifische Aktion, häufig
     | PageActionSecondary { menuItem :: MenuItem } --   Seitenspezifische Aktion, selten
 
--- | Convenient Type Synonyms:
+-- Messages
-type DB a = YesodDB UniWorX a
-type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
-
 mkMessage "UniWorX" "messages" "de"
 
 -- This instance is required to use forms. You can modify renderMessage to
@@ -131,6 +147,204 @@ instance RenderMessage UniWorX TermIdentifier where
     where renderMessage' = renderMessage foundation ls
 
 
+-- Access Control
+data AccessPredicate
+  = APPure     (Route UniWorX -> Reader MsgRenderer AuthResult)
+  | APHandler  (Route UniWorX -> Handler AuthResult)
+  | APDB       (Route UniWorX -> DB AuthResult)
+
+orAR, andAR :: MsgRenderer ->  AuthResult -> AuthResult -> AuthResult
+orAR  _  Authorized _ = Authorized
+orAR  _  _ Authorized = Authorized
+orAR  _  AuthenticationRequired _  = AuthenticationRequired
+orAR  _  _ AuthenticationRequired  = AuthenticationRequired
+orAR  mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $  MsgUnauthorizedOr x y
+-- and
+andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $  MsgUnauthorizedAnd x y
+andAR _  reason@(Unauthorized x) _ = reason
+andAR _  _ reason@(Unauthorized x) = reason
+andAR _  Authorized          other = other
+andAR _  AuthenticationRequired  _ = AuthenticationRequired
+
+orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate
+orAP  = liftAR  orAR (== Authorized)
+andAP = liftAR andAR (const False)
+
+liftAR :: (MsgRenderer ->  AuthResult -> AuthResult -> AuthResult)
+          -> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument
+          -> AccessPredicate -> AccessPredicate -> AccessPredicate
+-- Ensure to first evaluate Pure conditions, then Handler before DB
+liftAR op sc (APPure    f) (APPure     g) = APPure     $ \r -> shortCircuitM sc (f r) (g r) . op =<< ask
+liftAR op sc (APHandler f) (APHandler  g) = APHandler  $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer
+liftAR op sc (APDB      f) (APDB       g) = APDB       $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer
+liftAR op sc (APPure    f) apg  = liftAR op sc (APHandler $ \r -> runReader (f r) <$> getMsgRenderer) apg
+liftAR op sc apf           apg@(APPure _)    = liftAR op sc apg apf
+liftAR op sc (APHandler f) apdb = liftAR op sc (APDB      $ lift . f) apdb
+liftAR op sc apdb          apg@(APHandler _) = liftAR op sc apg apdb
+
+
+trueAP,falseAP :: AccessPredicate
+trueAP  = APPure . const $ return Authorized
+falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask
+-- TODO: I believe falseAP := adminAP
+
+adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes)
+adminAP = APDB $ \case
+    -- Courses: access only to school admins
+    CourseR tid csh _ -> exceptT return return $ do
+        authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+        [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
+          E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
+          E.where_  $ userAdmin E.^. UserAdminUser 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 (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
+        return Authorized
+    -- other routes: access to any admin is granted here
+    _other -> exceptT return return $ do
+        authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+        adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
+        guardMExceptT (isJust adrights) (unauthorizedI $ MsgUnauthorized)
+        return Authorized
+
+
+knownTags :: Map (CI Text) AccessPredicate
+knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
+  [("free", trueAP)
+  ,("deprecated", APHandler $ \r -> do
+      $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
+      addMessageI "error" MsgDeprecatedRoute
+      return Authorized
+    )
+  ,("lecturer", 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` 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.^. CourseShorthand E.==. E.val csh
+            return (E.countRows :: E.SqlExpr (E.Value Int64))
+          guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
+          return Authorized
+      _ -> exceptT return return $ do
+          authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
+          void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
+          return Authorized
+    )
+  ,("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 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 (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
+           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
+           SubmissionNewR -> 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 (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
+         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 _ -> 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 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 _ _ _ SubmissionNewR -> 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 -- Can this be pure like falseAP? GK: not if we want to log a message (which we definitely should)
+      $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)
+  where
+    attrsAND = map splitAND $ Set.toList $ routeAttrs r
+    splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND"
+
+evalAccessDB :: Route UniWorX -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise
+evalAccessDB r = case route2ap r of
+  (APPure    p) -> lift $ runReader (p r) <$> getMsgRenderer
+  (APHandler p) -> lift $ p r
+  (APDB      p) -> p r
+
+evalAccess :: Route UniWorX -> Handler AuthResult
+evalAccess r = case route2ap r of
+  (APPure    p) -> runReader (p r) <$> getMsgRenderer
+  (APHandler p) -> p r
+  (APDB      p) -> runDB $ p r
+
+-- TODO: isAuthorized = evalAccess'
+
+
+
+
 -- Please see the documentation for the Yesod typeclass. There are a number
 -- of settings which can be configured by overriding methods here.
 instance Yesod UniWorX where
@@ -157,9 +371,9 @@ instance Yesod UniWorX where
     yesodMiddleware handler = do
       res <- defaultYesodMiddleware handler
       void . runMaybeT $ do
-        route@(routeAttrs -> attrs) <- MaybeT getCurrentRoute
+        route <- MaybeT getCurrentRoute
-        case route of
+        case route of -- update Course Favourites here
-          CourseR tid csh _  | "updateFavourite" `elem` attrs -> do
+          CourseR tid csh _  -> do
             uid <- MaybeT maybeAuthId
             $(logDebug) "Favourites save"
             now <- liftIO $ getCurrentTime
@@ -167,7 +381,7 @@ instance Yesod UniWorX where
               cid  <- MaybeT . getKeyBy $ CourseTermShort tid csh
               user <- MaybeT $ get uid
               -- update Favourites
-              lift $ upsertBy
+              void . lift $ upsertBy
                       (UniqueCourseFavourite uid cid)
                       (CourseFavourite uid now cid)
                       [CourseFavouriteTime =. now]
@@ -209,7 +423,7 @@ instance Yesod UniWorX where
 
         favourites <- forM favourites' $ \(Entity _ c@Course{..})
             -> let
-                   courseRoute = CourseR courseTerm courseShorthand CourseShowR
+                   courseRoute = CourseR courseTerm courseShorthand CShowR
                in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
 
         -- We break up the default layout into two components:
@@ -253,21 +467,7 @@ instance Yesod UniWorX where
     -- The page to be redirected to when authentication is required.
     authRoute _ = Just $ AuthR LoginR
 
-    isAuthorized (AuthR _)           _ = return Authorized
+    isAuthorized route _isWrite = evalAccess route
-    isAuthorized  HomeR              _ = return Authorized
-    isAuthorized  FaviconR           _ = return Authorized
-    isAuthorized  RobotsR            _ = return Authorized
-    isAuthorized (StaticR _)         _ = return Authorized
-    isAuthorized  ProfileR           _ = isAuthenticated
-    isAuthorized  TermShowR          _ = return Authorized
-    isAuthorized  CourseListR        _ = return Authorized
-    isAuthorized (CourseListTermR _) _ = return Authorized
-    isAuthorized (CourseR _ _ CourseShowR) _ = return Authorized
-    isAuthorized (CryptoUUIDDispatchR _) _ = return Authorized
-    isAuthorized  SubmissionListR    _ = isAuthenticated
-    isAuthorized  SubmissionDownloadMultiArchiveR _ = isAuthenticated
---     isAuthorized  TestR        _ = return Authorized
-    isAuthorized route isWrite = runDB $ isAuthorizedDB route isWrite
 
     -- This function creates static content files in the static folder
     -- and names them based on a hash of their content. This allows
@@ -308,13 +508,14 @@ instance Yesod UniWorX where
 
     makeLogger = return . appLogger
 
+
+{- ALL DEPRECATED and will be deleted, once knownTags is completed
+
 isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult
 isAuthorizedDB route@(routeAttrs -> attrs) writeable
   | "adminAny"    `member` attrs = adminAccess    Nothing
   | "lecturerAny" `member` attrs = lecturerAccess Nothing
 
-
-
 isAuthorizedDB UsersR _ = adminAccess Nothing
 isAuthorizedDB (SubmissionDemoR cID)       _ =  return Authorized -- submissionAccess $ Right cID
 isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID
@@ -322,14 +523,14 @@ isAuthorizedDB (SubmissionDownloadArchiveR (ZIPArchiveName cID)) _ = submissionA
 isAuthorizedDB TermEditR               _ = adminAccess Nothing
 isAuthorizedDB (TermEditExistR _)      _ = adminAccess Nothing
 isAuthorizedDB CourseNewR              _ = lecturerAccess Nothing
-isAuthorizedDB (CourseR t c CourseEditR)       _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (CourseR t c CEditR)       _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
 isAuthorizedDB (CourseR t c (SheetR SheetListR))  False  = return Authorized --
 isAuthorizedDB (CourseR t c (SheetR SheetListR)) _       = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
-isAuthorizedDB (CourseR t c (SheetR (SheetShowR s))) _   = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
+isAuthorizedDB (CourseR t c (SheetR (SShowR s))) _   = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
 isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _)))  _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
 isAuthorizedDB (CourseR t c (SheetR SheetNewR))           _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
-isAuthorizedDB (CourseR t c (SheetR (SheetEditR s)))      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (CourseR t c (SheetR (SEditR s)))      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
-isAuthorizedDB (CourseR t c (SheetR (SheetDelR  s)))      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (CourseR t c (SheetR (SDelR  s)))      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
 isAuthorizedDB (CourseR t c (SheetR (SubmissionR s m)))   _ = return Authorized -- TODO -- submissionAccess $ Right cID
 isAuthorizedDB (CourseEditIDR cID)     _ = do
   courseId <- decrypt cID
@@ -395,6 +596,8 @@ isAuthorizedDB' route isWrite = (== Authorized) <$> isAuthorizedDB route isWrite
 
 isAuthorized' :: Route UniWorX -> Bool -> Handler Bool
 isAuthorized' route isWrite = runDB $ isAuthorizedDB' route isWrite
+-}
+
 
 -- Define breadcrumbs.
 instance YesodBreadcrumbs UniWorX where
@@ -403,17 +606,17 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR)
 
   breadcrumb  CourseListR              = return ("Kurs", Just HomeR)
-  breadcrumb (CourseListTermR term)    = return (toPathPiece term, Just TermShowR)
+  breadcrumb (TermCourseListR term)    = return (toPathPiece term, Just TermShowR)
-  breadcrumb (CourseR term course CourseShowR) = return (course, Just $ CourseListTermR term)
+  breadcrumb (CourseR term course CShowR) = return (course, Just $ TermCourseListR term)
   breadcrumb  CourseNewR               = return ("Neu", Just CourseListR)
-  breadcrumb (CourseR _ _ CourseEditR)         = return ("Editieren", Just CourseListR)
+  breadcrumb (CourseR _ _ CEditR)         = return ("Editieren", Just CourseListR)
 
-  breadcrumb (CourseR tid csh (SheetR SheetListR))       = return ("Übungen",Just $ CourseR tid csh CourseShowR)
+  breadcrumb (CourseR tid csh SheetListR) = return ("Übungen",Just $ CourseR tid csh CShowR)
-  breadcrumb (CourseR tid csh (SheetR SheetNewR ))       = return ("Neu",    Just $ CourseR tid csh $ SheetR SheetListR)
+  breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu",    Just $ CourseR tid csh SheetListR)
-  breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn,      Just $ CourseR tid csh $ SheetR SheetListR)
+  breadcrumb (CSheetR tid csh shn SShowR) = return (shn,      Just $ CourseR tid csh SheetListR)
-  breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit",   Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
+  breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit",   Just $ CSheetR tid csh shn SShowR)
-  breadcrumb (CourseR tid csh (SheetR (SheetDelR  shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
+  breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR)
-  breadcrumb (CourseR tid csh (SheetR (SubmissionR shn _))) = return ("Abgabe", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
+  breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
 
   breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
 
@@ -424,34 +627,40 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb  _ = return ("home", Nothing)
 
 pageActions :: Route UniWorX -> [MenuTypes]
-pageActions (CourseR tid csh CourseShowR) =
+pageActions (CourseR tid csh CShowR) =
   [ PageActionPrime $ MenuItem
       { menuItemLabel = "Übungsblätter"
       , menuItemIcon  = Nothing
-      , menuItemRoute = CSheetR tid csh SheetListR
+      , menuItemRoute = CourseR tid csh SheetListR
       , menuItemAccessCallback' = return True
       }
   , PageActionPrime $ MenuItem
       { menuItemLabel = "Kurs Editieren"
       , menuItemIcon  = Nothing
-      , menuItemRoute = CourseR tid csh CourseEditR
+      , menuItemRoute = CourseR tid csh CEditR
       , menuItemAccessCallback' = return True
       }
   ]
-pageActions (CSheetR tid csh SheetListR) =
+pageActions (CourseR tid csh SheetListR) =
   [ PageActionPrime $ MenuItem
       { menuItemLabel = "Neues Übungsblatt"
       , menuItemIcon  = Nothing
-      , menuItemRoute = CSheetR tid csh SheetNewR
+      , menuItemRoute = CourseR tid csh SheetNewR
       , menuItemAccessCallback' = return True
       }
   ]
-pageActions (CSheetR tid csh (SheetShowR shn)) =
+pageActions (CSheetR tid csh shn SShowR) =
   [ PageActionPrime $ MenuItem
+      { menuItemLabel = "Abgabe anlegen"
+      , menuItemIcon  = Nothing
+      , menuItemRoute = CSheetR tid csh shn SubmissionNewR
+      , menuItemAccessCallback' = return True -- TODO: check that no submission already exists
+      }
+  , PageActionPrime $ MenuItem
       { menuItemLabel = "Abgabe"
       , menuItemIcon  = Nothing
-      , menuItemRoute = CSheetR tid csh (SubmissionR shn newSubmission)
+      , menuItemRoute = CSheetR tid csh shn SubmissionOwnR
-      , menuItemAccessCallback' = return True
+      , menuItemAccessCallback' = return True -- TODO: check that a submission already exists
       }
   ]
 pageActions TermShowR =
@@ -462,7 +671,7 @@ pageActions TermShowR =
       , menuItemAccessCallback' = return True
       }
   ]
-pageActions (CourseListTermR _) =
+pageActions (TermCourseListR _) =
   [ PageActionPrime $ MenuItem
       { menuItemLabel = "Neuer Kurs"
       , menuItemIcon  = Just "book"

src/Handler/Course.hs

@@ -26,8 +26,8 @@ import qualified Data.UUID.Cryptographic as UUID
 getCourseListR :: Handler TypedContent
 getCourseListR = redirect TermShowR
 
-getCourseListTermR :: TermId -> Handler Html
+getTermCourseListR :: TermId -> Handler Html
-getCourseListTermR tidini = do
+getTermCourseListR tidini = do
   (term,courses) <- runDB $ (,)
       <$> get tidini
       <*> selectList [CourseTerm ==. tidini] [Asc CourseShorthand]
@@ -40,7 +40,7 @@ getCourseListTermR tidini = do
             let c   = entityVal ckv
                 shd = courseShorthand c
                 tid = courseTerm c
-            in [whamlet| <a href=@{CourseR tid shd CourseShowR}>#{shd} |] )
+            in [whamlet| <a href=@{CourseR tid shd CShowR}>#{shd} |] )
 --         , headed "Institut" $ [shamlet| #{course} |]
         , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal
         , headed "Ende Anmeldung"   $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal
@@ -54,11 +54,11 @@ getCourseListTermR tidini = do
                 shd = courseShorthand c
                 tid = courseTerm c
             in do
-              adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CourseEditR) False
+              adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CEditR) False
-              -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else ""
+              -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CEditR tid shd) else ""
               [whamlet|
                 $if adminLink == Authorized
-                  <a href=@{CourseR tid shd CourseEditR}>
+                  <a href=@{CourseR tid shd CEditR}>
                     editieren
               |]
           )
@@ -68,8 +68,8 @@ getCourseListTermR tidini = do
     setTitle "Semesterkurse"
     $(widgetFile "courses")
 
-getCourseShowR :: TermId -> Text -> Handler Html
+getCShowR :: TermId -> Text -> Handler Html
-getCourseShowR tid csh = do
+getCShowR tid csh = do
   mbAid <- maybeAuthId
   (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
       courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh
@@ -95,8 +95,8 @@ registerButton registered = renderAForm FormStandard $
     msg    = if registered then "Abmelden" else "Anmelden"
     regMsg = msg :: BootstrapSubmit Text
 
-postCourseShowR :: TermId -> Text -> Handler Html
+postCShowR :: TermId -> Text -> Handler Html
-postCourseShowR tid csh = do
+postCShowR tid csh = do
   aid <- requireAuthId
   (cid, registered) <- runDB $ do
       (Entity cid _) <- getBy404 $ CourseTermShort tid csh
@@ -114,7 +114,7 @@ postCourseShowR tid csh = do
           when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!"
     (_other) -> return () -- TODO check this!
   -- redirect or not?! I guess not, since we want GET now
-  getCourseShowR tid csh
+  getCShowR tid csh
 
 getCourseNewR :: Handler Html
 getCourseNewR = do
@@ -124,13 +124,13 @@ getCourseNewR = do
 postCourseNewR :: Handler Html
 postCourseNewR = courseEditHandler Nothing
 
-getCourseEditR :: TermId -> Text -> Handler Html
+getCEditR :: TermId -> Text -> Handler Html
-getCourseEditR tid csh = do
+getCEditR tid csh = do
   course <- runDB $ getBy $ CourseTermShort tid csh
   courseEditHandler course
 
-postCourseEditR :: TermId -> Text -> Handler Html
+postCEditR :: TermId -> Text -> Handler Html
-postCourseEditR = getCourseEditR
+postCEditR = getCEditR
 
 getCourseEditIDR :: CryptoUUIDCourse -> Handler Html
 getCourseEditIDR cID = do
@@ -147,7 +147,7 @@ courseDeleteHandler = undefined
             runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
             let cti = toPathPiece $ cfTerm res
             addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
-            redirect $ CourseListTermR $ cfTerm res
+            redirect $ TermCourseListR $ cfTerm res
 -}
 
 courseEditHandler :: Maybe (Entity Course) -> Handler Html
@@ -183,7 +183,7 @@ courseEditHandler course = do
                 insert_ $ CourseEdit aid now cid
                 insert_ $ Lecturer aid cid
               addMessageI "info" $ MsgCourseNewOk tident csh
-              redirect $ CourseListTermR tid
+              redirect $ TermCourseListR tid
             Nothing ->
               addMessageI "danger" $ MsgCourseNewDupShort tident csh
 
@@ -238,7 +238,7 @@ courseEditHandler course = do
 --                 if (isNothing updOkay)
 --                   then do
                 addMessageI "info" $ MsgCourseEditOk tident csh
-                -- redirect $ CourseListTermR tid
+                -- redirect $ TermCourseListR tid
 --                   else addMessageI "danger" $ MsgCourseEditDupShort tident csh
 
       (FormFailure _) -> addMessageI "warning" MsgInvalidInput

src/Handler/CryptoIDDispatch.hs

@@ -38,7 +38,7 @@ instance CryptoRoute UUID SubmissionId where
       Sheet{..}  <- get404 shid
       Course{..} <- get404 sheetCourse
       return (courseTerm, courseShorthand, sheetName)
-    return $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
+    return $ CSheetR tid csh shn $ SubmissionR cID
 
 
 class Dispatch ciphertext (x :: [*]) where

src/Handler/Sheet.hs

@@ -154,7 +154,7 @@ getSheetList courseEnt = do
         rated       <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
         return (sid, sheet, (submissions, rated))
   let colBase = mconcat
-        [ headed "Blatt"       $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CourseR tid csh $ SheetR $ SheetShowR $ sheetName sheet
+        [ headed "Blatt"       $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CSheetR tid csh (sheetName sheet) SShowR
         , headed "Abgabe ab"   $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
         , headed "Abgabe bis"  $ toWgt . formatTimeGerWD . sheetActiveTo   . snd3
         , headed "Bewertung"   $ toWgt . show . sheetType . snd3
@@ -162,13 +162,13 @@ getSheetList courseEnt = do
   let colAdmin = mconcat -- only show edit button for allowed course assistants
         [ headed "Korrigiert"  $ toWgt . snd . trd3
         , headed "Eingereicht" $ toWgt . fst . trd3
-        , headed ""            $ \s -> linkButton "Edit"   BCLink $ CourseR tid csh $ SheetR $ SheetEditR $ sheetName $ snd3 s
+        , headed ""            $ \s -> linkButton "Edit"   BCLink $ CSheetR tid csh (sheetName $ snd3 s) SEditR
-        , headed ""            $ \s -> linkButton "Delete" BCLink $ CourseR tid csh $ SheetR $ SheetDelR  $ sheetName $ snd3 s
+        , headed ""            $ \s -> linkButton "Delete" BCLink $ CSheetR tid csh (sheetName $ snd3 s) SDelR
         ]
   showAdmin <- case sheets of
     ((_,firstSheet,_):_) -> do
       setUltDestCurrent
-      (Authorized ==) <$> isAuthorized (CourseR tid csh $ SheetR $ SheetEditR $ sheetName firstSheet) False
+      (Authorized ==) <$> isAuthorized (CSheetR tid csh (sheetName firstSheet) SEditR) False
     _otherwise   -> return False
   let colSheets = if showAdmin
         then colBase `mappend` colAdmin
@@ -181,8 +181,8 @@ getSheetList courseEnt = do
 
 
 -- Show single sheet
-getSheetShowR :: TermId -> Text -> Text -> Handler Html
+getSShowR :: TermId -> Text -> Text -> Handler Html
-getSheetShowR tid csh shn = do
+getSShowR tid csh shn = do
   entSheet <- runDB $ fetchSheet tid csh shn
   let sheet = entityVal entSheet
       sid   = entityKey entSheet
@@ -210,7 +210,7 @@ getSheetShowR tid csh shn = do
         return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
   let colonnadeFiles = mconcat
         [ sortable (Just "type") "Typ" $ \(_, (_,_, E.Value ftype)) -> textCell $ toPathPiece ftype
-        , sortable (Just "path") "Dateiname" $ anchorCell (\(_, (E.Value fName,_,E.Value fType)) -> CSheetR tid csh (SheetFileR shn fType fName))
+        , sortable (Just "path") "Dateiname" $ anchorCell (\(_, (E.Value fName,_,E.Value fType)) -> CSheetR tid csh shn (SFileR fType fName))
                                                           (\(_, (E.Value fName,_,_)) -> str2widget fName)
         , sortable (Just "time") "Modifikation" $ \(_, (_,E.Value modified,_)) -> stringCell $ formatTimeGerWDT modified
         ]
@@ -235,8 +235,8 @@ getSheetShowR tid csh shn = do
     $(widgetFile "sheetShow")
     [whamlet| Under Construction !!! |] -- TODO
 
-getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
+getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
-getSheetFileR tid csh shn typ title = do
+getSFileR tid csh shn typ title = do
   content <- runDB $ E.select $ E.from $
     \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
       -- Restrict to consistent rows that correspond to each other
@@ -272,8 +272,8 @@ postSheetNewR :: TermId -> Text -> Handler Html
 postSheetNewR = getSheetNewR
 
 
-getSheetEditR :: TermId -> Text -> Text -> Handler Html
+getSEditR :: TermId -> Text -> Text -> Handler Html
-getSheetEditR tid csh shn = do
+getSEditR tid csh shn = do
   (sheetEnt, sheetFileIds) <- runDB $ do
     ent <- fetchSheet tid csh shn
     fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
@@ -307,8 +307,8 @@ getSheetEditR tid csh shn = do
           (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
   handleSheetEdit tid csh (Just sid) template action
 
-postSheetEditR :: TermId -> Text -> Text -> Handler Html
+postSEditR :: TermId -> Text -> Text -> Handler Html
-postSheetEditR = getSheetEditR
+postSEditR = getSEditR
 
 handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
 handleSheetEdit tid csh msId template dbAction = do
@@ -344,44 +344,44 @@ handleSheetEdit tid csh msId template dbAction = do
             insert_ $ SheetEdit aid actTime sid
             addMessageI "info" $ MsgSheetEditOk tident csh sfName
             return True
-      when saveOkay $ redirect $ CSheetR tid csh $ SheetShowR sfName -- redirect must happen outside of runDB
+      when saveOkay $ redirect $ CSheetR tid csh sfName SShowR -- redirect must happen outside of runDB
     (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
     _ -> return ()
   let pageTitle = maybe (MsgSheetTitleNew tident csh)
                         (MsgSheetTitle    tident csh) mbshn
   let formTitle = pageTitle
   let formText  = Nothing :: Maybe UniWorXMessage
-  actionUrl <- fromMaybe (CSheetR tid csh SheetNewR) <$> getCurrentRoute
+  actionUrl <- fromMaybe (CourseR tid csh SheetNewR) <$> getCurrentRoute
   defaultLayout $ do
     setTitleI pageTitle
     $(widgetFile "formPageI18n")
 
 
 
-getSheetDelR :: TermId -> Text -> Text -> Handler Html
+getSDelR :: TermId -> Text -> Text -> Handler Html
-getSheetDelR tid csh shn = do
+getSDelR tid csh shn = do
   let tident = unTermKey tid
   ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
   case result of
-    (FormSuccess BtnAbort)  -> redirectUltDest $ CSheetR tid csh $ SheetShowR shn
+    (FormSuccess BtnAbort)  -> redirectUltDest $ CSheetR tid csh shn SShowR
     (FormSuccess BtnDelete) -> do
       runDB $ fetchSheetId tid csh shn >>= deleteCascade
       -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
       addMessageI "info" $ MsgSheetDelOk tident csh shn
-      redirect $ CSheetR tid csh SheetListR
+      redirect $ CourseR tid csh SheetListR
     _other -> do
       submissionno <- runDB $ do
           sid <- fetchSheetId tid csh shn
           count [SubmissionSheet ==. sid]
       let formTitle = MsgSheetDelTitle tident csh shn
       let formText  = Just $ MsgSheetDelText submissionno
-      let actionUrl = CSheetR tid csh $ SheetDelR shn
+      let actionUrl = CSheetR tid csh shn SDelR
       defaultLayout $ do
         setTitleI $ MsgSheetTitle tident csh shn
         $(widgetFile "formPageI18n")
 
-postSheetDelR :: TermId -> Text -> Text -> Handler Html
+postSDelR :: TermId -> Text -> Text -> Handler Html
-postSheetDelR = getSheetDelR
+postSDelR = getSDelR
 
 
 

src/Handler/Submission.hs

@@ -74,10 +74,33 @@ makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $
     aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
     aforced' _ _  _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary"
 
+getSubmissionNewR, postSubmissionNewR :: TermId -> Text -> Text -> Handler Html
+getSubmissionNewR = postSubmissionNewR
+postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission
 
-getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> SubmissionMode -> Handler Html
+
+getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> CryptoUUIDSubmission -> Handler Html
 getSubmissionR = postSubmissionR
-postSubmissionR tid csh shn (SubmissionMode mcid) = do
+postSubmissionR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid
+
+getSubmissionOwnR :: TermId -> Text -> Text -> Handler Html
+getSubmissionOwnR tid csh shn = do
+  authId <- requireAuthId
+  sid <- runDB $ do
+    shid <- fetchSheetId tid csh shn
+    submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
+      E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
+      E.where_ $ submissionUser E.^. SubmissionUserUser   E.==. E.val authId
+           E.&&. submission     E.^. SubmissionSheet    E.==. E.val shid
+      return $ submission E.^. SubmissionId
+    case submissions of
+      ((E.Value sid):_) -> return sid
+      []      -> notFound
+  cID <- encrypt sid
+  redirect . CourseR tid csh . SheetR shn $ SubmissionR cID
+
+submissionHelper :: TermId -> Text -> Text -> SubmissionMode -> Handler Html
+submissionHelper tid csh shn (SubmissionMode mcid) = do
   uid   <- requireAuthId
   msmid <- traverse decrypt mcid
   (Entity shid Sheet{..}, buddies, lastEdits)  <- runDB $ do
@@ -112,7 +135,7 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
           (E.Value smid:_) -> do
             cID <- encrypt smid
             addMessageI "info" $ MsgSubmissionAlreadyExists
-            redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
+            redirect $ CSheetR tid csh shn $ SubmissionR cID
       (Just smid) -> do
         shid' <- submissionSheet <$> get404 smid
         when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet]
@@ -203,7 +226,7 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do
       _other -> return Nothing
   
   case mCID of
-    Just cID -> redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID
+    Just cID -> redirect $ CSheetR tid csh shn $ SubmissionR cID
     Nothing  -> return ()
 
   mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid
@@ -327,7 +350,7 @@ submissionTable = do
     (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
 
   let
-    anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CourseShowR
+    anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CShowR
     courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
     anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID
     submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID

src/Handler/Term.hs

@@ -60,7 +60,7 @@ getTermShowR = do
                 textCell $ bool "" tickmark termActive
             , sortable Nothing "Kursliste" $ \(_, (Entity tid Term{..}, E.Value numCourses)) ->
                 cell [whamlet|
-                  <a href=@{CourseListTermR tid}>
+                  <a href=@{TermCourseListR tid}>
                     #{show numCourses} Kurse
                 |]
             , sortable (Just "start") "Semesteranfang" $ \(_, (Entity _ Term{..},_)) ->

src/Utils.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
 {-# LANGUAGE QuasiQuotes #-}
 
@@ -14,10 +16,30 @@ import Utils.Common as Utils
 
 import Text.Blaze (Markup, ToMarkup)
 
-import Data.Map (Map)
+-- import Data.Map (Map)
-import qualified Data.Map as Map
+-- import qualified Data.Map as Map
-import qualified Data.List as List
+-- import qualified Data.List as List
 
+import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Catch
+
+
+-----------
+-- Yesod --
+-----------
+
+newtype MsgRendererS site = MsgRenderer { render :: (forall msg. RenderMessage site msg => msg -> Text) }
+
+getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site)
+getMsgRenderer = do
+  mr <- getMessageRender
+  return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)
+
+
+---------------------
+-- Text and String --
+---------------------
 
 tickmark :: IsString a => a
 tickmark = fromString "✔"
@@ -42,12 +64,6 @@ withFragment :: ( Monad m
                 ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
 withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
 
------------
--- Maybe --
------------
-whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
-whenIsJust (Just x) f = f x
-whenIsJust Nothing  _ = return ()
 
 ------------
 -- Tuples --
@@ -56,3 +72,57 @@ whenIsJust Nothing  _ = return ()
 ----------
 -- Maps --
 ----------
+
+
+-----------
+-- Maybe --
+-----------
+whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
+whenIsJust (Just x) f = f x
+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 p act = catchIf p (lift act) (const mzero)
+
+---------------
+-- Exception --
+---------------
+
+maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
+maybeExceptT err act = lift act >>= maybe (throwE err) return
+
+maybeMExceptT :: Monad m => (m e) -> m (Maybe b) -> ExceptT e m b
+maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
+
+whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
+whenExceptT b err = when b $ throwE err
+
+whenMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
+whenMExceptT b err = when b $ lift err >>= throwE
+
+guardExceptT :: Monad m => Bool -> e -> ExceptT e m ()
+guardExceptT b err = unless b $ throwE err
+
+guardMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
+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 p act = catchIf p (lift act) (throwE <=< lift . err)
+
+
+------------
+-- Monads --
+------------
+
+shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a
+shortCircuitM sc mx my op = do
+  x <- mx
+  case sc x of
+    True  -> return x
+    False -> op <$> pure x <*> my

src/Utils/Common.hs

@@ -5,7 +5,10 @@ module Utils.Common where
 -- Common Utility Functions
 
 import Language.Haskell.TH
-
+-- import Control.Monad
+-- import Control.Monad.Trans.Class
+-- import Control.Monad.Trans.Maybe
+-- import Control.Monad.Trans.Except
 
 ------------
 -- Tuples --
@@ -50,3 +53,4 @@ altFun perm = lamE pat rhs
         ps  = [ xs !! (j-1) | j <- perm ]
         fn  = mkName "fn" 
         
+

templates/course.hamlet

@@ -34,7 +34,7 @@
         <div .course__registration>
           <a href="#">Anmelden
 
-  $# <form method=post action=@{CourseR tid csh CourseShowR} enctype=#{regEnctype}>
+  $# <form method=post action=@{CourseR tid csh CShow} enctype=#{regEnctype}>
   $#   ^{regWidget}
 
 <div .container>