after Discussion today

messages/de.msg

@@ -21,12 +21,16 @@ 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.
 UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
 OnlyUploadOneFile: Bitte nur eine Datei hochladen.
+DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
 
 SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
 SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.

routes

@@ -9,7 +9,7 @@
 
   Admins always have access to entities within their assigned schools.
 
-  Tags:
+  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 )
@@ -39,7 +39,7 @@
 -- For Pattern Synonyms see Foundation
 /course/                    CourseListR       GET             !free
 !/course/new                CourseNewR        GET POST        !lecturer
-/course/#TermId/#Text       CourseR                           !lecturer !updateFavourite:
+/course/#TermId/#Text       CourseR                           !lecturer:
   /show                       CShowR      GET POST            !free
   /edit                       CEditR      GET POST
   /ex                         SheetListR  GET                 !materials

src/Foundation.hs

@@ -59,7 +59,8 @@ import System.FilePath
 
 import Handler.Utils.Templates
 import Handler.Utils.StudyFeatures
-
+import Control.Lens
+import Utils.Lens
 
 -- infixl 9 :$:
 -- pattern a :$: b = a b
@@ -144,22 +145,31 @@ knownTags =
       return Authorized
    )
   ,("lecturer", APDB $ \case
-      CourseR tid csh ->
-        (>>= maybe (unauthorizedI MsgUnauthorizedLecturer) return) . runMaybeT $ do
+      CourseR tid csh -> maybeT (unauthorizedI MsgUnauthorizedLecturer) $ do
           authId <- lift requireAuthId
           Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
           void . MaybeT . getBy $ UniqueLecturer authId cid
           return Authorized
-
       _ -> do
-        authId <- requireAuthId
-        mul <- selectFirst [UserLecturerUser ==. authId] []
-        case mul of
-          Nothing  -> unauthorizedI $ MsgUnauthorizedSchoolLecturer
-          (Just _) -> return Authorized
+          authId <- requireAuthId
+          mul <- selectFirst [UserLecturerUser ==. authId] []
+          case mul of
+            Nothing  -> unauthorizedI $ MsgUnauthorizedSchoolLecturer
+            (Just _) -> return Authorized
    )
   ]
 
+declareWrapped [d|
+    newtype DNF a = DNF (Set (Set a)) -- disjunctive Normalform
+  |]
+
+
+getAccess :: Route UniWorX -> DNF AccessPredicate
+getAccess r = DNF $ Set.map attrsAND attrsOR
+ where
+    attrsOR  = routeAttrs r
+    attrsAND = Set.fromList . Map.elems . Map.restrictKeys knownTags . Set.fromList . splitOn "AND"
+
 
 
 -- Menus and Favourites

src/Utils/Common.hs

@@ -5,7 +5,7 @@ module Utils.Common where
 -- Common Utility Functions
 
 import Language.Haskell.TH
-
+import Control.Monad.Trans.Maybe
 
 ------------
 -- Tuples --
@@ -50,3 +50,11 @@ altFun perm = lamE pat rhs
         ps  = [ xs !! (j-1) | j <- perm ]
         fn  = mkName "fn" 
         
+
+-----------
+-- Maybe --
+-----------
+
+maybeT :: Monad m => m a -> MaybeT m a -> m a
+maybeT x m = runMaybeT m >>= maybe x return
+