Merge branch 'master' into feat/datepicker

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

fill-db.hs

@@ -89,8 +89,8 @@ main = db $ do
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
     , courseShorthand = "ffp"
-    , courseTermId = TermKey summer2018
-    , courseSchoolId = ifi
+    , courseTerm = TermKey summer2018
+    , courseSchool = ifi
     , courseCapacity = Just 20
     , courseHasRegistration = True
     , courseRegisterFrom = Just now
@@ -104,8 +104,11 @@ main = db $ do
   void . insert $ DegreeCourse ffp sdMst sdInf
   void . insert $ Lecturer jost   ffp
   void . insert $ Lecturer gkleen ffp
-  insert_ $ Corrector gkleen ffp (ByProportion 1)
-  sheetkey <- insert $ Sheet ffp "Blatt 1" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing
+  sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing
+  insert_ $ SheetEdit gkleen now sheetkey
+  sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing
+  insert_ $ SheetEdit gkleen now sheetkey
+  sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing
   insert_ $ SheetEdit gkleen now sheetkey
   -- EIP
   eip <- insert Course
@@ -113,8 +116,8 @@ main = db $ do
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
     , courseShorthand = "eip"
-    , courseTermId = TermKey summer2017
-    , courseSchoolId = ifi
+    , courseTerm = TermKey summer2017
+    , courseSchool = ifi
     , courseCapacity = Just 20
     , courseHasRegistration = False
     , courseRegisterFrom = Nothing
@@ -132,8 +135,8 @@ main = db $ do
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
     , courseShorthand = "ixd"
-    , courseTermId = TermKey summer2018
-    , courseSchoolId = ifi
+    , courseTerm = TermKey summer2018
+    , courseSchool = ifi
     , courseCapacity = Just 20
     , courseHasRegistration = True
     , courseRegisterFrom = Just now
@@ -151,8 +154,8 @@ main = db $ do
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
     , courseShorthand = "ux3"
-    , courseTermId = TermKey winter2017
-    , courseSchoolId = ifi
+    , courseTerm = TermKey winter2017
+    , courseSchool = ifi
     , courseCapacity = Just 30
     , courseHasRegistration = False
     , courseRegisterFrom = Nothing
@@ -170,8 +173,8 @@ main = db $ do
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
     , courseShorthand = "pmo"
-    , courseTermId = TermKey summer2017
-    , courseSchoolId = ifi
+    , courseTerm = TermKey summer2017
+    , courseSchool = ifi
     , courseCapacity = Just 50
     , courseHasRegistration = False
     , courseRegisterFrom = Nothing
@@ -189,8 +192,8 @@ main = db $ do
     , courseDescription = Nothing
     , courseLinkExternal = Nothing
     , courseShorthand = "dbs"
-    , courseTermId = TermKey summer2018
-    , courseSchoolId = ifi
+    , courseTerm = TermKey summer2018
+    , courseSchool = ifi
     , courseCapacity = Just 50
     , courseHasRegistration = False
     , courseRegisterFrom = Nothing

messages/de.msg

@@ -1,15 +1,17 @@
 SummerTerm year@Integer: Sommersemester #{tshow year}
 WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year}
 PSLimitNonPositive: “pagesize” muss größer als null sein
-Page n@Int64 num@Int64: Seite #{tshow n} von #{tshow num}
+Page n@Int64: #{tshow n}
 TermEdited tid@TermIdentifier: Semester #{termToText tid} erfolgreich editiert.
 TermNewTitle: Semester editiere/anlegen.
 InvalidInput: Eingaben bitte korrigieren.
+
 CourseNewOk        tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich erstellt.
 CourseEditOk       tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich geändert.
 CourseNewDupShort  tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
 CourseEditDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
 FFSheetName: Name
+
 SheetNewOk         tid@TermIdentifier courseShortHand@Text sheetName@Text: Neues Übungsblatt #{sheetName} wurde im Kurs #{termToText tid}-#{courseShortHand} erfolgreich erstellt.
 SheetTitle         tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName}
 SheetTitleNew      tid@TermIdentifier courseShortHand@Text               : #{termToText tid}-#{courseShortHand}: Neues Übungsblatt
@@ -18,9 +20,37 @@ SheetNameDup       tid@TermIdentifier courseShortHand@Text sheetName@Text: Es gi
 SheetDelTitle      tid@TermIdentifier courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} wirklich aus Kurs #{termToText tid}-#{courseShortHand} herauslöschen?
 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.
-OnlyUploadOneFile: Bitte nur eine Datei hochladen.
+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.
+UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
+
+SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
+SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
+SubmissionTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
+SubmissionMember g@Int: Mitabgebende(r) ##{tshow g}
+SubmissionArchive: Zip-Archiv der Abgabedatei(en)
+SubmissionFile: Datei zur Abgabe
+SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem Übungsblatt.
+
+EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer.
+NotAParticipant user@Text tid@TermIdentifier csh@Text: #{user} ist nicht im Kurs #{termToText tid}-#{csh} angemeldet.
+
+HomeHeading: Startseite
+TermsHeading: Semesterübersicht
+
+NumCourses n@Int64: #{tshow n} Kurse

models

@@ -1,11 +1,12 @@
 User
-    plugin Text
-    ident Text
+    plugin         Text
+    ident          Text
     matrikelnummer Text Maybe
-    email Text
-    displayName Text
-    maxFavourites Int default=12
+    email          Text
+    displayName    Text
+    maxFavourites  Int default=12
     UniqueAuthentication plugin ident
+    UniqueEmail email
 UserAdmin
     user   UserId
     school SchoolId
@@ -51,20 +52,20 @@ DegreeCourse json
     terms        StudyTermsId
     UniqueDegreeCourse course degree terms
 Course 
-    name         Text
-    description  Html Maybe
-    linkExternal Text Maybe    
-    shorthand    Text
-    termId       TermId
-    schoolId     SchoolId    
-    capacity     Int Maybe    
+    name             Text
+    description      Html Maybe
+    linkExternal     Text Maybe
+    shorthand        Text
+    term             TermId
+    school           SchoolId
+    capacity         Int Maybe
     hasRegistration  Bool -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
     registerFrom     UTCTime Maybe
     registerTo       UTCTime Maybe
     deregisterUntil  UTCTime Maybe
     registerSecret   Text Maybe        -- Falls ein Passwort erforderlich ist
     materialFree     Bool default=true
-    CourseTermShort  termId shorthand
+    CourseTermShort  term shorthand
 CourseEdit
     user         UserId
     time         UTCTime
@@ -75,29 +76,28 @@ CourseFavourite
     course       CourseId
     UniqueCourseFavourite user course
 Lecturer 
-    userId       UserId
-    courseId     CourseId
-    UniqueLecturer userId courseId 
-Corrector 
-    userId       UserId
-    courseId     CourseId
+    user         UserId
+    course       CourseId
+    UniqueLecturer user course
+Corrector                  -- deprecated
+    user         UserId
+    course       CourseId
     load         Load 
     -- SELECT submissionID FROM Tutorial, TutorialUser, Submission, Sheet
     -- WHERE ( tutorialTutor = correctorUserId
     --      && tutorialCourse = correctorCourseId
     --      && tutorialUserTutorial = tutorialId 
     --      && submissionUser = tutorialUserUser
-    --      && sheetId = submissionSheetId
+    --      && sheetId = SubmissionSheet
     --      && sheetCourse = correctorCourseId
     --      )
-    UniqueCorrector userId courseId
 CourseParticipant
-    courseId        CourseId
-    userId          UserId
+    course          CourseId
+    user            UserId
     registration    UTCTime
-    UniqueParticipant userId courseId
+    UniqueParticipant user course
 Sheet
-    courseId        CourseId
+    course          CourseId
     name            Text
     description     Html Maybe
     type            SheetType
@@ -108,23 +108,28 @@ Sheet
     activeTo        UTCTime
     hintFrom        UTCTime Maybe
     solutionFrom    UTCTime Maybe
-    CourseSheet courseId name
+    CourseSheet course name
 SheetEdit
     user            UserId
     time            UTCTime
     sheet           SheetId
+SheetCorrector
+    user            UserId
+    sheet           SheetId
+    load            Load
+    UniqueSheetCorrector user sheet
 SheetFile
-    sheetId         SheetId
-    fileId          FileId
+    sheet           SheetId
+    file            FileId
     type            SheetFileType
-    UniqueSheetFile fileId sheetId type
+    UniqueSheetFile file sheet type
 File        
     title           FilePath
     content         ByteString Maybe -- Nothing iff this is a directory
     modified        UTCTime
     deriving Show Eq
 Submission
-    sheetId         SheetId    
+    sheet           SheetId
     ratingPoints    Points  Maybe
     ratingComment   Text    Maybe 
     ratingBy        UserId  Maybe
@@ -135,37 +140,37 @@ SubmissionEdit
     time            UTCTime
     submission      SubmissionId
 SubmissionFile
-    submissionId    SubmissionId
-    fileId          FileId 
-    isUpdate        Bool
-    isDeletion      Bool
-    UniqueSubmissionFile fileId submissionId isUpdate
+    submission      SubmissionId
+    file            FileId
+    isUpdate        Bool         -- is this the file updated by a corrector (original will always be retained)
+    isDeletion      Bool         -- only set if isUpdate is also set, but file was deleted by corrector
+    UniqueSubmissionFile file submission isUpdate
     deriving Show
 SubmissionUser
-    userId          UserId
-    submissionId    SubmissionId
-    UniqueSubmissionUser userId submissionId
+    user            UserId
+    submission      SubmissionId
+    UniqueSubmissionUser user submission
 SubmissionGroup
-    courseId        CourseId
-    name            Text
+    course          CourseId
+    name            Text Maybe
 SubmissionGroupEdit
     user            UserId
     time            UTCTime
     submissionGroup SubmissionGroupId
 SubmissionGroupUser
-    submissionGroupId   SubmissionGroupId
-    userId              UserId   
-    UniqueSubmissionGroupUser submissionGroupId userId
+    submissionGroup     SubmissionGroupId
+    user                UserId
+    UniqueSubmissionGroupUser submissionGroup   user
 Tutorial json
     name        Text
-    tutor       UserId    
+    tutor       UserId
     course      CourseId
 TutorialUser
-    userId      UserId
-    tutorialId  TutorialId
-    UniqueTutorialUser userId tutorialId
+    user        UserId
+    tutorial    TutorialId
+    UniqueTutorialUser user   tutorial
 Booking
-    termId      TermId
+    term        TermId
     begin       UTCTime
     end         UTCTime
     weekly      Bool
@@ -182,17 +187,17 @@ Room
     building    Text Maybe
 -- BookingRoom
 --    subject     RoomForId
---    roomId      RoomId
---    bookingId   BookingId
---    UniqueRoomCourse subject roomId bookingId
+--    room        RoomId
+--    booking     BookingId
+--    UniqueRoomCourse subject room   booking
 +RoomFor
-    courseId    CourseId
-    tutorialId  TutorialId
-    examId      ExamId
--- data RoomFor = RoomForCourseIdSum CourseId | RoomForTutorialIdSum TutorialId ...
+    course      CourseId
+    tutorial    TutorialId
+    exam        ExamId
+-- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ...
 -- EXAMS ARE TODO:
 Exam
-    courseId            CourseId
+    course              CourseId
     name                Text
     description         Text
     begin               UTCTime
@@ -207,8 +212,8 @@ Exam
 --    time                UTCTime
 --    exam                ExamId
 --ExamUser
---    userId              UserId
+--    user                UserId
 --    examId              ExamId
 --    -- CONTINUE HERE: Include rating in this table or separately?
---    UniqueExamUser userId examId
+--    UniqueExamUser user   examId
 -- By default this file is used in Model.hs (which is imported by Foundation.hs)

package.yaml

@@ -79,6 +79,8 @@ dependencies:
 - parsec
 - uuid
 - exceptions
+- lens
+- MonadRandom
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.
@@ -91,6 +93,7 @@ library:
       - -Wall
       - -fwarn-tabs
       - -O0
+      - -ddump-splices
       cpp-options: -DDEVELOPMENT
     else:
       ghc-options:

routes

@@ -1,41 +1,69 @@
-/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
+--    !isRead     -- only if it is read-only access (i.e. GET but not POST)
+--    !isWrite    -- only if it is write access     (i.e. POST only) why needed???
+--
+--    !deprecated -- like free, but logs and gives a warning
+--
 
-/favicon.ico FaviconR GET
-/robots.txt RobotsR GET
+/static StaticR Static appStatic                              !free
+/auth   AuthR   Auth   getAuth                                !free
 
-/        HomeR    GET POST
-/profile ProfileR GET
-/users   UsersR   GET                                         !adminAny
+/favicon.ico FaviconR GET                                     !free
+/robots.txt RobotsR GET                                       !free
 
-/term                       TermShowR         GET
-/term/edit                  TermEditR         GET POST        !adminAny
-/term/#TermId/edit          TermEditExistR    GET             !adminAny
+/        HomeR    GET POST                                    !free
+/profile ProfileR GET                                         !free
+/users   UsersR   GET                                         -- no tags, i.e. admins only
 
-/course/                    CourseListR       GET
-!/course/new                CourseNewR        GET POST        !lecturerAny
-!/course/#TermId            CourseListTermR   GET
-/course/#TermId/#Text CourseR !updateFavourite:
-  /show                       CourseShowR GET POST
-  /edit                       CourseEditR GET POST            !lecturer
+/terms                       TermShowR         GET            !free
+/terms/current               TermCurrentR      GET            !free
+/terms/edit                  TermEditR         GET POST
+/terms/#TermId/edit          TermEditExistR    GET
+!/terms/#TermId              TermCourseListR   GET            !free
 
-  /ex SheetR                                                  !registered:
-    /                               SheetListR GET
-    /#Text/show                     SheetShowR GET            !time
-    /#Text/#SheetFileType/#FilePath SheetFileR GET            !time
-    /new                            SheetNewR  GET POST       !lecturer
-    /#Text/edit                     SheetEditR GET POST       !lecturer
-    /#Text/delete                   SheetDelR  GET POST       !lecturer
+-- For Pattern Synonyms see Foundation
+/course/                    CourseListR       GET             !free
+!/course/new                CourseNewR        GET POST        !lecturer
+/course/#TermId/#Text       CourseR                           !lecturer:
+  /show                       CShowR          GET POST        !free
+  /edit                       CEditR          GET POST
+  /ex                         SheetListR      GET             !registered !materials
+  !/ex/new                    SheetNewR       GET POST
+  /ex/#Text SheetR:
+    /show                       SShowR        GET             !timeANDregistered !timeANDmaterials !corrector
+    /#SheetFileType/#FilePath   SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
+    /edit                       SEditR        GET POST
+    /delete                     SDelR         GET POST
+    !/sub/new                   SubmissionNewR GET POST        !timeANDregistered
+    !/sub/own                   SubmissionOwnR GET             !free
+    !/sub/#CryptoUUIDSubmission SubmissionR    GET POST        !owner !corrector
 
 
+!/#UUID CryptoUUIDDispatchR GET                               !free -- just redirect
+
 -- TODO below
-/submission                 SubmissionListR GET POST
-/submission/#CryptoUUIDSubmission SubmissionR GET POST
-/submissions.zip SubmissionDownloadMultiArchiveR POST
-!/submission/archive/#FilePath SubmissionDownloadArchiveR GET
-!/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET
+!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated
+!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET !deprecated
 
-!/#UUID CryptoUUIDDispatchR GET
-
--- For demonstration
-/course/#CryptoUUIDCourse/edit CourseEditIDR GET
+/submission                 SubmissionListR GET                 !deprecated
+/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST      !deprecated
+/submissions.zip SubmissionDownloadMultiArchiveR POST           !deprecated

shell.nix

@@ -24,13 +24,12 @@ let
   override = oldAttrs: {
     nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql cabal-install ]) ++ (with haskellPackages; [ stack yesod-bin ]);
     shellHook = ''
-      ${oldAttrs.shellHook}
       export PROMPT_INFO="${oldAttrs.name}"
 
       pgDir=$(mktemp -d)
       pgSockDir=$(mktemp -d)
       pgLogFile=$(mktemp)
-      pg_ctl init -D ''${pgDir}
+      initdb --no-locale -D ''${pgDir}
       pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700"
       export PGHOST=''${pgSockDir} PGLOG=''${pgLogFile}
       psql -f ${postgresSchema} postgres
@@ -42,6 +41,8 @@ let
       }
 
       trap cleanup EXIT
+
+      ${oldAttrs.shellHook}
     '';
   };
 

src/CryptoID.hs

@@ -1,8 +1,11 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE RecordWildCards, ViewPatterns, PatternGuards #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module CryptoID
@@ -24,6 +27,9 @@ import System.FilePath.Cryptographic.ImplicitNamespace
 import Data.UUID.Types
 import Web.PathPieces
 
+import           Data.CaseInsensitive   (CI)
+import qualified Data.CaseInsensitive as CI
+
 
 instance PathPiece UUID where
   fromPathPiece = fromString . unpack
@@ -35,5 +41,33 @@ decCryptoIDs [ ''SubmissionId
              , ''CourseId
              , ''SheetId
              , ''FileId
+             , ''UserId
              ]
 {- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}
+
+
+
+newtype SubmissionMode = SubmissionMode (Maybe CryptoUUIDSubmission)
+  deriving (Show, Read, Eq)
+
+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
+    fromPathPiece s     = SubmissionMode . Just <$> fromPathPiece s
+
+    toPathPiece (SubmissionMode Nothing)  = "new"
+    toPathPiece (SubmissionMode (Just x)) = toPathPiece x
+
+newtype ZIPArchiveName objID = ZIPArchiveName (CryptoID (CI FilePath) objID)
+  deriving (Show, Read, Eq)
+
+instance PathPiece (ZIPArchiveName objID) where
+    fromPathPiece (map CI.mk . unpack -> s)
+      | Just s' <- stripSuffix (map CI.mk ".zip") s = Just . ZIPArchiveName . CryptoID . CI.mk $ map CI.original s'
+      | otherwise = Nothing
+
+    toPathPiece (ZIPArchiveName CryptoID{..}) = pack (CI.foldedCase ciphertext) <> ".zip"

src/Foundation.hs

@@ -1,14 +1,17 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
 
 module Foundation where
@@ -29,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
 
@@ -44,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)
 
@@ -51,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
@@ -88,17 +101,29 @@ 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
     , menuItemRoute :: Route UniWorX
-    , menuItemAccessCallback :: Handler Bool
+    , menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked)
     }
 
+menuItemAccessCallback :: MenuItem -> Handler Bool
+menuItemAccessCallback MenuItem{..} = (&&) <$> ((==) Authorized <$> authCheck) <*> menuItemAccessCallback'
+  where
+    authCheck = handleAny (\_ -> return . Unauthorized $ error "authCheck caught exception") $ isAuthorized menuItemRoute False
+
 data MenuTypes                                 -- Semantische Rolle:
     = NavbarAside         { menuItem :: MenuItem } --   TODO
     | NavbarExtra         { menuItem :: MenuItem } --   TODO
@@ -107,10 +132,7 @@ data MenuTypes                                 -- Semantische Rolle:
     | PageActionPrime     { menuItem :: MenuItem } --   Seitenspezifische Aktion, häufig
     | PageActionSecondary { menuItem :: MenuItem } --   Seitenspezifische Aktion, selten
 
--- | Convenient Type Synonyms:
-type DB a = YesodDB UniWorX a
-type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
-
+-- Messages
 mkMessage "UniWorX" "messages" "de"
 
 -- This instance is required to use forms. You can modify renderMessage to
@@ -125,6 +147,217 @@ 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 SheetExercise _ -> guard $ maybe False (<= cTime) sheetVisibleFrom
+           SFileR SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
+           SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
+           SFileR SheetMarking  _ -> mzero -- only for correctors and lecturers
+           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
+   )
+  ,("isRead",  APHandler $ \route ->
+      bool  <$> return Authorized
+            <*> unauthorizedI MsgUnauthorizedWrite
+            <*> isWriteRequest route
+   )
+  ,("isWrite", APHandler $ \route -> do
+      write <- isWriteRequest route
+      if write
+        then return Authorized
+        else 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
@@ -151,9 +384,9 @@ instance Yesod UniWorX where
     yesodMiddleware handler = do
       res <- defaultYesodMiddleware handler
       void . runMaybeT $ do
-        route@(routeAttrs -> attrs) <- MaybeT getCurrentRoute
-        case route of
-          CourseR tid csh _  | "updateFavourite" `elem` attrs -> do
+        route <- MaybeT getCurrentRoute
+        case route of -- update Course Favourites here
+          CourseR tid csh _  -> do
             uid <- MaybeT maybeAuthId
             $(logDebug) "Favourites save"
             now <- liftIO $ getCurrentTime
@@ -161,7 +394,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]
@@ -176,26 +409,84 @@ instance Yesod UniWorX where
           _other -> return ()
       return res
 
-    defaultLayout = defaultLinkLayout []
+    defaultLayout widget = do
+        master <- getYesod
+        mmsgs  <- getMessages
+
+        mcurrentRoute <- getCurrentRoute
+
+        -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
+        (title, parents) <- breadcrumbs
+
+        let
+            menu = defaultLinks ++ maybe [] pageActions mcurrentRoute
+
+        menuTypes <- filterM (menuItemAccessCallback . menuItem) menu
+
+        -- Lookup Favourites if possible
+        favourites' <- do
+            muid <- maybeAuthId
+            case muid of
+                Nothing    -> return []
+                (Just uid) -> runDB . E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do
+                    E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse)
+                    E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid)
+                    E.orderBy [ E.asc $ course E.^. CourseShorthand ]
+                    return course
+
+        favourites <- forM favourites' $ \(Entity _ c@Course{..})
+            -> let
+                   courseRoute = CourseR courseTerm courseShorthand CShowR
+               in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
+
+        -- We break up the default layout into two components:
+        -- default-layout is the contents of the body tag, and
+        -- default-layout-wrapper is the entire page. Since the final
+        -- value passed to hamletToRepHtml cannot be a widget, this allows
+        -- you to use normal widget features in default-layout.
+
+
+        let
+            navbar :: Widget
+            navbar = $(widgetFile "widgets/navbar")
+            asidenav :: Widget
+            asidenav = $(widgetFile "widgets/asidenav")
+            contentHeadline :: Maybe Widget
+            contentHeadline = pageHeading =<< mcurrentRoute
+            breadcrumbs :: Widget
+            breadcrumbs = $(widgetFile "widgets/breadcrumbs")
+            pageactionprime :: Widget
+            pageactionprime = $(widgetFile "widgets/pageactionprime")
+            -- functions to determine if there are page-actions
+            isPageActionPrime :: MenuTypes -> Bool
+            isPageActionPrime (PageActionPrime _) = True
+            isPageActionPrime _ = False
+            hasPageActions :: Bool
+            hasPageActions = any isPageActionPrime menuTypes
+
+        pc <- widgetToPageContent $ do
+            addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900"
+            addScript $ StaticR js_zepto_js
+            addScript $ StaticR js_fetchPolyfill_js
+            addScript $ StaticR js_urlPolyfill_js
+            addScript $ StaticR js_featureChecker_js
+            addScript $ StaticR js_flatpickr_js
+            addScript $ StaticR js_tabber_js
+            addStylesheet $ StaticR css_flatpickr_css
+            addStylesheet $ StaticR css_tabber_css
+            addStylesheet $ StaticR css_fonts_css
+            addStylesheet $ StaticR css_icons_css
+            $(widgetFile "default-layout")
+            $(widgetFile "standalone/modal")
+            $(widgetFile "standalone/showHide")
+            $(widgetFile "standalone/inputs")
+            $(widgetFile "standalone/tabber")
+        withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
 
     -- The page to be redirected to when authentication is required.
     authRoute _ = Just $ AuthR LoginR
 
-    isAuthorized (AuthR _)           _ = return Authorized
-    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
+    isAuthorized route _isWrite = evalAccess route
 
     -- This function creates static content files in the static folder
     -- and names them based on a hash of their content. This allows
@@ -236,92 +527,8 @@ instance Yesod UniWorX where
 
     makeLogger = return . appLogger
 
-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 (SubmissionR cID)       _ = submissionAccess $ Right cID
-isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID
-isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName
-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 (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 (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 (SheetDelR  s)))     _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
-isAuthorizedDB (CourseEditIDR cID)     _ = do
-  courseId <- decrypt cID
-  courseLecturerAccess courseId
-isAuthorizedDB _route _isWrite = return  $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop!
-
-submissionAccess :: Either CryptoFileNameSubmission CryptoUUIDSubmission -> YesodDB UniWorX AuthResult
-submissionAccess cID = do
-  authId <- lift requireAuthId
-  submissionId <- either decrypt decrypt cID
-  Submission{..} <- get404 submissionId
-  submissionUsers <- map (submissionUserUserId . entityVal) <$> selectList [SubmissionUserSubmissionId ==. submissionId] []
-  let auth = authId `elem` submissionUsers || Just authId == submissionRatingBy
-  return $ case auth of
-    True  -> Authorized
-    False -> Unauthorized "No access to this submission"
-
-adminAccess :: Maybe SchoolId -- ^ If @Just@, matched exactly against 'userAdminSchool'
-            -> YesodDB UniWorX AuthResult
-adminAccess school = do
-  authId <- lift requireAuthId
-  adrights <- selectList ((UserAdminUser ==. authId) : maybe [] (\s -> [UserAdminSchool ==. s]) school) []
-  return $ if (not $ null adrights)
-    then Authorized
-    else Unauthorized "No admin access" -- TODO internationalize
-
-lecturerAccess :: Maybe SchoolId
-               -> YesodDB UniWorX AuthResult
-lecturerAccess school = do
-  authId <- lift requireAuthId
-  lecrights <- selectList ((UserLecturerUser ==. authId) : maybe [] (\s -> [UserLecturerSchool ==. s]) school) []
-  return $ if (not $ null lecrights)
-    then Authorized
-    else Unauthorized "No lecturer access" -- TODO internationalize
-
-lecturerAccess' :: SchoolId -> YesodDB UniWorX AuthResult
-lecturerAccess' = authorizedFor UniqueSchoolLecturer MsgUnauthorizedSchoolLecturer
-
-courseLecturerAccess :: CourseId -> YesodDB UniWorX AuthResult
-courseLecturerAccess    = authorizedFor UniqueLecturer    MsgUnauthorizedLecturer
-
-courseCorrectorAccess :: CourseId -> YesodDB UniWorX AuthResult
-courseCorrectorAccess   = authorizedFor UniqueCorrector   MsgUnauthorizedCorrector
-
-courseParticipantAccess :: CourseId -> YesodDB UniWorX AuthResult
-courseParticipantAccess = authorizedFor UniqueParticipant MsgUnauthorizedParticipant
-
-authorizedFor ::  ( PersistEntityBackend record ~ BaseBackend backend
-                  , PersistEntity record, PersistUniqueRead backend
-                  , YesodAuth master, RenderMessage master msg
-                  )
-  => (AuthId master -> t -> Unique record) -> msg -> t -> ReaderT backend (HandlerT master IO) AuthResult
-authorizedFor authType msg courseId = do
-  authId <- lift requireAuthId
-  access <- getBy $ authType authId courseId
-  case access of
-    (Just _) -> return Authorized
-    Nothing  -> unauthorizedI msg
-
-isAuthorizedDB' :: Route UniWorX -> Bool -> YesodDB UniWorX Bool
-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
   breadcrumb TermShowR = return ("Semester", Just HomeR)
@@ -329,25 +536,89 @@ 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 (CourseR term course CourseShowR) = return (course, Just $ CourseListTermR term)
+  breadcrumb (TermCourseListR term)    = return (toPathPiece term, Just TermShowR)
+  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 (SheetR SheetNewR ))       = return ("Neu",    Just $ CourseR tid csh $ SheetR SheetListR)
-  breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn,      Just $ CourseR tid csh $ SheetR SheetListR)
-  breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit",   Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
-  breadcrumb (CourseR tid csh (SheetR (SheetDelR  shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
+  breadcrumb (CourseR tid csh SheetListR) = return ("Übungen",Just $ CourseR tid csh CShowR)
+  breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu",    Just $ CourseR tid csh SheetListR)
+  breadcrumb (CSheetR tid csh shn SShowR) = return (shn,      Just $ CourseR tid csh SheetListR)
+  breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit",   Just $ CSheetR tid csh shn SShowR)
+  breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR)
+  breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
 
   breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
-  breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR)
 
-  breadcrumb HomeR = return ("UniworkY", Nothing)
+
+  breadcrumb HomeR = return ("Uniworky", Nothing)
   breadcrumb (AuthR _) = return ("Login", Just HomeR)
   breadcrumb ProfileR = return ("Profile", Just HomeR)
   breadcrumb  _ = return ("home", Nothing)
 
+pageActions :: Route UniWorX -> [MenuTypes]
+pageActions (CourseR tid csh CShowR) =
+  [ PageActionPrime $ MenuItem
+      { menuItemLabel = "Übungsblätter"
+      , menuItemIcon  = Nothing
+      , menuItemRoute = CourseR tid csh SheetListR
+      , menuItemAccessCallback' = return True
+      }
+  , PageActionPrime $ MenuItem
+      { menuItemLabel = "Kurs Editieren"
+      , menuItemIcon  = Nothing
+      , menuItemRoute = CourseR tid csh CEditR
+      , menuItemAccessCallback' = return True
+      }
+  ]
+pageActions (CourseR tid csh SheetListR) =
+  [ PageActionPrime $ MenuItem
+      { menuItemLabel = "Neues Übungsblatt"
+      , menuItemIcon  = Nothing
+      , menuItemRoute = CourseR tid csh SheetNewR
+      , menuItemAccessCallback' = return True
+      }
+  ]
+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 shn SubmissionOwnR
+      , menuItemAccessCallback' = return True -- TODO: check that a submission already exists
+      }
+  ]
+pageActions TermShowR =
+  [ PageActionPrime $ MenuItem
+      { menuItemLabel = "Neues Semester"
+      , menuItemIcon  = Nothing
+      , menuItemRoute = TermEditR
+      , menuItemAccessCallback' = return True
+      }
+  ]
+pageActions (TermCourseListR _) =
+  [ PageActionPrime $ MenuItem
+      { menuItemLabel = "Neuer Kurs"
+      , menuItemIcon  = Just "book"
+      , menuItemRoute = CourseNewR
+      , menuItemAccessCallback' = return True
+      }
+  ]
+
+pageActions _ = []
+
+pageHeading :: Route UniWorX -> Maybe Widget
+pageHeading HomeR
+  = Just [whamlet|_{MsgHomeHeading}|]
+pageHeading TermShowR
+  = Just [whamlet|_{MsgTermsHeading}|]
+pageHeading _
+  = Nothing
 
 defaultLinks :: [MenuTypes]
 defaultLinks = -- Define the menu items of the header.
@@ -355,114 +626,46 @@ defaultLinks = -- Define the menu items of the header.
       { menuItemLabel = "Home"
       , menuItemIcon = Just "home"
       , menuItemRoute = HomeR
-      , menuItemAccessCallback = return True
+      , menuItemAccessCallback' = return True
       }
   , NavbarRight $ MenuItem
       { menuItemLabel = "Profile"
       , menuItemIcon = Just "profile"
       , menuItemRoute = ProfileR
-      , menuItemAccessCallback = isJust <$> maybeAuthPair
+      , menuItemAccessCallback' = isJust <$> maybeAuthPair
       }
   , NavbarSecondary $ MenuItem
       { menuItemLabel = "Login"
       , menuItemIcon = Just "login"
       , menuItemRoute = AuthR LoginR
-      , menuItemAccessCallback = isNothing <$> maybeAuthPair
+      , menuItemAccessCallback' = isNothing <$> maybeAuthPair
       }
   , NavbarSecondary $ MenuItem
       { menuItemLabel = "Logout"
       , menuItemIcon = Just "logout"
       , menuItemRoute = AuthR LogoutR
-      , menuItemAccessCallback = isJust <$> maybeAuthPair
-      }
-  , NavbarAside $ MenuItem
-      { menuItemLabel = "Aktuelle Veranstaltungen"
-      , menuItemIcon = Just "book"
-      , menuItemRoute = CourseListR -- should be CourseListActiveR or similar in the future
-      , menuItemAccessCallback = return True
-      }
-  , NavbarAside $ MenuItem
-      { menuItemLabel = "Alte Veranstaltungen"
-      , menuItemIcon = Just "book"
-      , menuItemRoute = CourseListR -- should be CourseListInactiveR or similar in the future
-      , menuItemAccessCallback = return True
+      , menuItemAccessCallback' = isJust <$> maybeAuthPair
       }
   , NavbarAside $ MenuItem
       { menuItemLabel = "Veranstaltungen"
       , menuItemIcon = Just "book"
-      , menuItemRoute = CourseListR
-      , menuItemAccessCallback = return True
+      , menuItemRoute = CourseListR -- should be CourseListActiveR or similar in the future
+      , menuItemAccessCallback' = return True
+      }
+  , NavbarAside $ MenuItem
+      { menuItemLabel = "Semester"
+      , menuItemIcon = Nothing
+      , menuItemRoute = CourseListR -- should be TermListR ,,,
+      , menuItemAccessCallback' = return True
       }
   , NavbarAside $ MenuItem
       { menuItemLabel = "Benutzer"
       , menuItemIcon = Just "user"
       , menuItemRoute = UsersR
-      , menuItemAccessCallback = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False
+      , menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False
       }
   ]
 
-defaultLinkLayout :: [MenuTypes] -> Widget -> Handler Html
-defaultLinkLayout = defaultMenuLayout . (defaultLinks ++)
-
-defaultMenuLayout :: [MenuTypes] -> Widget -> Handler Html
-defaultMenuLayout menu widget = do
-    master <- getYesod
-    mmsgs  <- getMessages
-
-    mcurrentRoute <- getCurrentRoute
-
-    -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
-    (title, parents) <- breadcrumbs
-
-    menuTypes <- filterM (menuItemAccessCallback . menuItem) menu
-
-    -- Lookup Favourites if possible
-    favourites <- do
-      muid <- maybeAuthId
-      case muid of
-        Nothing    -> return []
-        (Just uid) -> runDB . E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do
-          E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse)
-          E.where_ (courseFavourite E.^. CourseFavouriteUser E.==. E.val uid)
-          E.orderBy [ E.asc $ course E.^. CourseShorthand ]
-          return course
-
-    -- We break up the default layout into two components:
-    -- default-layout is the contents of the body tag, and
-    -- default-layout-wrapper is the entire page. Since the final
-    -- value passed to hamletToRepHtml cannot be a widget, this allows
-    -- you to use normal widget features in default-layout.
-
-    let
-        navbar :: Widget
-        navbar = $(widgetFile "widgets/navbar")
-        asidenav :: Widget
-        asidenav = $(widgetFile "widgets/asidenav")
-        breadcrumbs :: Widget
-        breadcrumbs = $(widgetFile "widgets/breadcrumbs")
-        pageactionprime :: Widget
-        pageactionprime = $(widgetFile "widgets/pageactionprime")
-        -- functions to determine if there are page-actions
-        isPageActionPrime :: MenuTypes -> Bool
-        isPageActionPrime (PageActionPrime _) = True
-        isPageActionPrime _ = False
-        hasPageActions :: Bool
-        hasPageActions = any isPageActionPrime menuTypes
-
-    pc <- widgetToPageContent $ do
-        addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900"
-        addScript $ StaticR js_featureChecker_js
-        addScript $ StaticR js_flatpickr_js
-        addStylesheet $ StaticR css_fonts_css
-        addStylesheet $ StaticR css_icons_css
-        addStylesheet $ StaticR css_flatpickr_css
-        $(widgetFile "default-layout")
-        $(widgetFile "standalone/modal")
-        $(widgetFile "standalone/showHide")
-        $(widgetFile "standalone/sortable")
-        $(widgetFile "standalone/inputs")
-    withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
-
 -- How to run database actions.
 instance YesodPersist UniWorX where
     type YesodPersistBackend UniWorX = SqlBackend

src/Handler/Course.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -26,11 +27,18 @@ import qualified Data.UUID.Cryptographic as UUID
 getCourseListR :: Handler TypedContent
 getCourseListR = redirect TermShowR
 
-getCourseListTermR :: TermId -> Handler Html
-getCourseListTermR tidini = do
+getTermCurrentR :: Handler Html
+getTermCurrentR = do
+  termIds  <- runDB $ selectKeysList [TermActive ==. True] [] -- [Desc TermName] does not work, since database representation has wrong ordering
+  case fromNullable termIds of
+    Nothing -> notFound
+    (Just (maximum -> tid)) -> getTermCourseListR tid
+
+getTermCourseListR :: TermId -> Handler Html
+getTermCourseListR tidini = do
   (term,courses) <- runDB $ (,)
       <$> get tidini
-      <*> selectList [CourseTermId ==. tidini] [Asc CourseShorthand]
+      <*> selectList [CourseTerm ==. tidini] [Asc CourseShorthand]
   when (isNothing term) $ do
     addMessage "warning" [shamlet| Semester #{toPathPiece tidini} nicht gefunden. |]
     redirect TermShowR
@@ -39,51 +47,43 @@ getCourseListTermR tidini = do
         [ headed "Kürzel" $ (\ckv ->
             let c   = entityVal ckv
                 shd = courseShorthand c
-                tid = courseTermId c
-            in [whamlet| <a href=@{CourseR tid shd CourseShowR}>#{shd} |] )
+                tid = courseTerm c
+            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
         , headed "Teilnehmer" $ (\ckv -> do
               let cid = entityKey ckv
-              partiNum <- handlerToWidget $ runDB $ count [CourseParticipantCourseId ==. cid]
+              partiNum <- handlerToWidget $ runDB $ count [CourseParticipantCourse ==. cid]
               [whamlet| #{show partiNum} |]
             )
         , headed " " $ (\ckv ->
             let c   = entityVal ckv
                 shd = courseShorthand c
-                tid = courseTermId c
+                tid = courseTerm c
             in do
-              adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CourseEditR) False
-              -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else ""
+              adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CEditR) False
+              -- 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
               |]
           )
         ]
-  let pageLinks =
-        [ PageActionPrime $ MenuItem
-          { menuItemLabel = "Neuer Kurs"
-          , menuItemIcon  = Just "book"
-          , menuItemRoute = CourseNewR
-          , menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseNewR False
-          }
-        ]
   let coursesTable = encodeWidgetTable tableSortable colonnadeTerms courses
-  defaultLinkLayout pageLinks $ do
+  defaultLayout $ do
     setTitle "Semesterkurse"
     $(widgetFile "courses")
 
-getCourseShowR :: TermId -> Text -> Handler Html
-getCourseShowR tid csh = do
+getCShowR :: TermId -> Text -> Handler Html
+getCShowR tid csh = do
   mbAid <- maybeAuthId
   (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
       courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh
       dependent <- (,,)
-          <$> get (courseSchoolId course)               -- join
-          <*> count [CourseParticipantCourseId ==. cid] -- join
+          <$> get (courseSchool course)               -- join
+          <*> count [CourseParticipantCourse ==. cid] -- join
           <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
                 Nothing -> return False
                 (Just aid) -> do
@@ -92,15 +92,7 @@ getCourseShowR tid csh = do
       return $ (courseEnt,dependent)
   let course = entityVal courseEnt
   (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered
-  let pageActions =
-        [ PageActionPrime $ MenuItem
-          { menuItemLabel = "Übungsblätter"
-          , menuItemIcon  = Nothing
-          , menuItemRoute = CSheetR tid csh SheetListR
-          , menuItemAccessCallback = (== Authorized) <$> isAuthorized (CSheetR tid csh SheetListR) False
-          }
-        ]
-  defaultLinkLayout pageActions $ do
+  defaultLayout $ do
     setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
     $(widgetFile "course")
 
@@ -111,8 +103,8 @@ registerButton registered = renderAForm FormStandard $
     msg    = if registered then "Abmelden" else "Anmelden"
     regMsg = msg :: BootstrapSubmit Text
 
-postCourseShowR :: TermId -> Text -> Handler Html
-postCourseShowR tid csh = do
+postCShowR :: TermId -> Text -> Handler Html
+postCShowR tid csh = do
   aid <- requireAuthId
   (cid, registered) <- runDB $ do
       (Entity cid _) <- getBy404 $ CourseTermShort tid csh
@@ -130,7 +122,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
@@ -140,13 +132,13 @@ getCourseNewR = do
 postCourseNewR :: Handler Html
 postCourseNewR = courseEditHandler Nothing
 
-getCourseEditR :: TermId -> Text -> Handler Html
-getCourseEditR tid csh = do
+getCEditR :: TermId -> Text -> Handler Html
+getCEditR tid csh = do
   course <- runDB $ getBy $ CourseTermShort tid csh
   courseEditHandler course
 
-postCourseEditR :: TermId -> Text -> Handler Html
-postCourseEditR = getCourseEditR
+postCEditR :: TermId -> Text -> Handler Html
+postCEditR = getCEditR
 
 getCourseEditIDR :: CryptoUUIDCourse -> Handler Html
 getCourseEditIDR cID = do
@@ -163,7 +155,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,8 +175,8 @@ courseEditHandler course = do
             , courseDescription     = cfDesc     res
             , courseLinkExternal    = cfLink     res
             , courseShorthand       = cfShort    res
-            , courseTermId          = cfTerm     res
-            , courseSchoolId        = cfSchool   res
+            , courseTerm            = cfTerm     res
+            , courseSchool          = cfSchool   res
             , courseCapacity        = cfCapacity res
             , courseHasRegistration = cfHasReg   res
             , courseRegisterFrom    = cfRegFrom  res
@@ -199,7 +191,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
 
@@ -226,8 +218,8 @@ courseEditHandler course = do
 --                   , CourseDescription  =. cfDesc     res
 --                   , CourseLinkExternal =. cfLink     res
 --                   , CourseShorthand    =. cfShort    res -- TODO: change here should generate a warning, or only allowed for Admins?!
---                   , CourseTermId       =. tid            -- TODO: change here should generate a warning, or only allowed for Admins?!
---                   , CourseSchoolId     =. cfSchool   res
+--                   , CourseTerm       =. tid            -- TODO: change here should generate a warning, or only allowed for Admins?!
+--                   , CourseSchool     =. cfSchool   res
 --                   , CourseCapacity     =. cfCapacity res
 --                   , CourseRegisterFrom =. cfRegFrom  res
 --                   , CourseRegisterTo   =. cfRegTo    res
@@ -239,8 +231,8 @@ courseEditHandler course = do
                             ,  courseDescription     = cfDesc     res
                             ,  courseLinkExternal    = cfLink     res
                             ,  courseShorthand       = cfShort    res
-                            ,  courseTermId          = cfTerm     res
-                            ,  courseSchoolId        = cfSchool   res
+                            ,  courseTerm            = cfTerm     res
+                            ,  courseSchool          = cfSchool   res
                             ,  courseCapacity        = cfCapacity res
                             ,  courseHasRegistration = cfHasReg   res
                             ,  courseRegisterFrom    = cfRegFrom  res
@@ -254,7 +246,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
@@ -291,8 +283,8 @@ courseToForm cEntity = CourseForm
         , cfDesc     = courseDescription        course
         , cfLink     = courseLinkExternal       course
         , cfShort    = courseShorthand          course
-        , cfTerm     = courseTermId             course
-        , cfSchool   = courseSchoolId           course
+        , cfTerm     = courseTerm               course
+        , cfSchool   = courseSchool             course
         , cfCapacity = courseCapacity           course
         , cfHasReg   = courseHasRegistration    course
         , cfRegFrom  = courseRegisterFrom       course

src/Handler/CryptoIDDispatch.hs

@@ -20,6 +20,8 @@ import Import hiding (Proxy)
 
 import Data.Proxy
 
+import Handler.Utils
+
 import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
 import qualified Control.Monad.Catch as E (Handler(..))
@@ -30,9 +32,13 @@ class CryptoRoute ciphertext plaintext where
 
 instance CryptoRoute UUID SubmissionId where
   cryptoIDRoute _ (CryptoID -> cID) = do
-    (_ :: SubmissionId) <- decrypt cID
-    
-    return $ SubmissionR cID
+    (smid :: SubmissionId) <- decrypt cID
+    (tid,csh,shn) <- runDB $ do
+      shid <- submissionSheet <$> get404 smid
+      Sheet{..}  <- get404 shid
+      Course{..} <- get404 sheetCourse
+      return (courseTerm, courseShorthand, sheetName)
+    return $ CSheetR tid csh shn $ SubmissionR cID
 
 
 class Dispatch ciphertext (x :: [*]) where

src/Handler/Home.hs

@@ -43,7 +43,7 @@ getHomeR :: Handler Html
 getHomeR = do
   (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton)
   defaultLayout $ do
-    setTitle "Willkommen zum UniworkY Test!"
+    setTitle "Willkommen zum Uniworky Test!"
     $(widgetFile "home")
 
 

src/Handler/Sheet.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -7,6 +8,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Handler.Sheet where
 
@@ -61,6 +63,7 @@ data SheetForm = SheetForm
       , sfSolutionFrom :: Maybe UTCTime
       , sfSolutionF    :: Maybe FileInfo
       -- Keine SheetId im Formular!
+      , sfCorrectors   :: [(UserId,Load)]
       }
 
 
@@ -68,8 +71,8 @@ makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
 makeSheetForm msId template = identForm FIDsheet $ \html -> do
     let oldFileIds fType
           | Just sId <- msId = fmap setFromList . fmap (map E.unValue) . runDB . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
-              E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
-              E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val sId
+              E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
+              E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
                    E.&&. sheetFile E.^. SheetFileType    E.==. E.val fType
               return (file E.^. FileId)
           | otherwise = return Set.empty
@@ -88,7 +91,8 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
       <*> fileAFormOpt        (fsb "Hinweis")
       <*> aopt utcTimeField   (fsb "Lösung ab")   (sfSolutionFrom <$> template)
       <*> fileAFormOpt        (fsb "Lösung")
-      <*  submitButton
+      <*> formToAForm (correctorForm msId (maybe [] sfCorrectors template))
+      -- <*  submitButton
     return $ case result of
       FormSuccess sheetResult
         | errorMsgs <- validateSheet sheetResult
@@ -117,36 +121,15 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
         -- TODO: continue validation here!!!
       ] ]
 
+correctorForm :: Maybe SheetId -> [(UserId,Load)] -> MForm Handler (FormResult [(UserId,Load)], [FieldView UniWorX])
+correctorForm _msid templates = return mempty -- TODO deprecated
+  -- Datenbank UserId -> UserName
+  -- Eingabelist für Colonnade
+     -- enthält die benötigten Felder
+  -- FormResult konstruieren
+  -- Eingabebox für Korrektor hinzufügen
+  -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
 
-fetchSheetAux ::  ( BaseBackend backend ~ SqlBackend
-                  , E.SqlSelect b a
-                  , Typeable a, MonadHandler m, IsPersistBackend backend
-                  , PersistQueryRead backend, PersistUniqueRead backend
-                  )
-  =>  (E.SqlExpr (Entity Sheet) -> b)
-      -> Key Term -> Text -> Text -> ReaderT backend m a
-fetchSheetAux prj tid csh shn =
-    let cachId = encodeUtf8 $ tshow (tid,csh,shn)
-    in  cachedBy cachId $ do
-    -- Mit Yesod:
-    -- cid <- getKeyBy404 $ CourseTermShort tid csh
-    -- getBy404 $ CourseSheet cid shn
-    -- Mit Esqueleto:
-        sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
-            E.on     $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
-            E.where_ $ course E.^. CourseTermId    E.==. E.val tid
-                E.&&. course E.^. CourseShorthand E.==. E.val csh
-                E.&&. sheet  E.^. SheetName       E.==. E.val shn
-            return $ prj sheet
-        case sheetList of
-          [sheet] -> return sheet
-          _other  -> notFound
-
-fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
-fetchSheet = fetchSheetAux id
-
-fetchSheetId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet)
-fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn
 
 -- List Sheets
 getSheetListCID :: CourseId -> Handler Html
@@ -163,16 +146,16 @@ getSheetList courseEnt = do
   let cid    = entityKey courseEnt
   let course = entityVal courseEnt
   let csh    = courseShorthand course
-  let tid    = courseTermId course
+  let tid    = courseTerm course
   sheets <- runDB $ do
-    rawSheets <- selectList [SheetCourseId ==. cid] [Desc SheetActiveFrom]
+    rawSheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
     forM rawSheets $ \(Entity sid sheet) -> do
-        let sheetsub = [SubmissionSheetId ==. sid]
+        let sheetsub = [SubmissionSheet ==. sid]
         submissions <- count sheetsub
         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,_) -> simpleLink (toWgt $ sheetName sheet) $ 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
@@ -180,69 +163,93 @@ 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 "Delete" BCLink $ CourseR tid csh $ SheetR $ SheetDelR  $ sheetName $ snd3 s
+        , headed ""            $ \s -> simpleLink "Edit"   $ CSheetR tid csh (sheetName $ snd3 s) SEditR
+        , headed ""            $ \s -> simpleLink "Delete" $ 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
         else colBase
-  let pageActions =
-        [ PageActionPrime $ MenuItem
-          { menuItemLabel = "Neues Übungsblatt"
-          , menuItemIcon  = Nothing
-          , menuItemRoute = CSheetR tid csh SheetNewR
-          , menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseNewR False
-          }
-        ]
-  defaultLinkLayout pageActions $ do
+  defaultLayout $ do
     setTitle $ toHtml $ T.append "Übungsblätter " csh
     if null sheets
       then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
       else encodeWidgetTable tableDefault colSheets sheets
 
+
 -- Show single sheet
-getSheetShowR :: TermId -> Text -> Text -> Handler Html
-getSheetShowR tid csh shn = do
+getSShowR :: TermId -> Text -> Text -> Handler Html
+getSShowR tid csh shn = do
   entSheet <- runDB $ fetchSheet tid csh shn
   let sheet = entityVal entSheet
       sid   = entityKey entSheet
-  --
-  fileNameTypes <- runDB $ E.select $ E.from $
-    \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-      -- Restrict to consistent rows that correspond to each other
-      E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFileId)
-      E.on (sheetFile E.^. SheetFileSheetId E.==. sheet     E.^. SheetId)
-      -- filter to requested file
-      E.where_ (sheet     E.^. SheetId      E.==. E.val sid )
-      -- return desired columns
-      return $ (file E.^. FileTitle, sheetFile E.^. SheetFileType)
-  let fileLinks = map (\(E.Value fName, E.Value fType) -> CSheetR tid csh (SheetFileR shn fType fName)) fileNameTypes
+  -- without Colonnade
+--   fileNameTypes <- runDB $ E.select $ E.from $
+--     \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
+--       -- Restrict to consistent rows that correspond to each other
+--       E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFile)
+--       E.on (sheetFile E.^. SheetFileSheet E.==. sheet     E.^. SheetId)
+--       -- filter to requested file
+--       E.where_ (sheet     E.^. SheetId      E.==. E.val sid )
+--       -- return desired columns
+--       return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
+--   let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid csh (SheetFileR shn fType fName),modified)) fileNameTypes
+  -- with Colonnade
 
+  let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do
+        -- Restrict to consistent rows that correspond to each other
+        E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFile)
+        E.on (sheetFile E.^. SheetFileSheet E.==. sheet     E.^. SheetId)
+        -- filter to requested file
+        E.where_ $  sheet     E.^. SheetId      E.==. E.val sid
+              E.&&. E.not_ (E.isNothing $ file E.^. FileContent)
+        -- return desired columns
+        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 shn (SFileR fType fName))
+                                                          (\(E.Value fName,_,_) -> str2widget fName)
+        , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime)
+        ]
+  fileTable <- dbTable def $ DBTable
+    { dbtSQLQuery = fileData
+    , dbtColonnade = colonnadeFiles
+    , dbtAttrs = tableDefault
+    , dbtIdent = "files" :: Text
+    , dbtSorting = [ ( "type"
+                     , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> sheetFile E.^. SheetFileType
+                     )
+                   , ( "path"
+                     , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
+                     )
+                   , ( "time"
+                     , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileModified
+                     )
+                   ]
+    }
   defaultLayout $ do
     setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
     $(widgetFile "sheetShow")
     [whamlet| Under Construction !!! |] -- TODO
 
-
-getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
-getSheetFileR tid csh shn typ title = do
+getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
+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
-      E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFileId)
-      E.on (sheetFile E.^. SheetFileSheetId E.==. sheet     E.^. SheetId)
-      E.on (sheet     E.^. SheetCourseId    E.==. course    E.^. CourseId)
+      E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFile)
+      E.on (sheetFile E.^. SheetFileSheet E.==. sheet     E.^. SheetId)
+      E.on (sheet     E.^. SheetCourse    E.==. course    E.^. CourseId)
       -- filter to requested file
       E.where_ ((file      E.^. FileTitle       E.==. E.val title)
         E.&&.   (sheetFile E.^. SheetFileType   E.==. E.val typ  )
         E.&&.   (sheet     E.^. SheetName       E.==. E.val shn  )
         E.&&.   (course    E.^. CourseShorthand E.==. E.val csh  )
-        E.&&.   (course    E.^. CourseTermId    E.==. E.val tid  )
+        E.&&.   (course    E.^. CourseTerm    E.==. E.val tid  )
         )
       -- return desired columns
       return $ file E.^. FileContent
@@ -266,13 +273,13 @@ postSheetNewR :: TermId -> Text -> Handler Html
 postSheetNewR = getSheetNewR
 
 
-getSheetEditR :: TermId -> Text -> Text -> Handler Html
-getSheetEditR tid csh shn = do
+getSEditR :: TermId -> Text -> Text -> Handler Html
+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
-      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
-      E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val (entityKey ent)
+      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
+      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val (entityKey ent)
            E.&&. sheetFile E.^. SheetFileType    E.==. E.val SheetExercise
       return (file E.^. FileId)
     return (ent, fIds)
@@ -292,6 +299,7 @@ getSheetEditR tid csh shn = do
         , sfHintF        = Nothing -- TODO
         , sfSolutionFrom = sheetSolutionFrom
         , sfSolutionF    = Nothing -- TODO
+        , sfCorrectors   = [] -- TODO read correctors from list
         }
   let action newSheet = do
         replaceRes <- myReplaceUnique sid $ newSheet
@@ -300,8 +308,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
-postSheetEditR = getSheetEditR
+postSEditR :: TermId -> Text -> Text -> Handler Html
+postSEditR = getSEditR
 
 handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
 handleSheetEdit tid csh msId template dbAction = do
@@ -315,7 +323,7 @@ handleSheetEdit tid csh msId template dbAction = do
         actTime <- liftIO getCurrentTime
         cid <- getKeyBy404 $ CourseTermShort tid csh
         let newSheet = Sheet
-              { sheetCourseId     = cid
+              { sheetCourse     = cid
               , sheetName         = sfName
               , sheetDescription  = sfDescription
               , sheetType         = sfType
@@ -337,44 +345,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
-getSheetDelR tid csh shn = do
+getSDelR :: TermId -> Text -> Text -> Handler Html
+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!!!
-      setMessageI $ MsgSheetDelOk tident csh shn
-      redirect $ CSheetR tid csh SheetListR
+      addMessageI "info" $ MsgSheetDelOk tident csh shn
+      redirect $ CourseR tid csh SheetListR
     _other -> do
       submissionno <- runDB $ do
           sid <- fetchSheetId tid csh shn
-          count [SubmissionSheetId ==. sid]
+          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
-postSheetDelR = getSheetDelR
+postSDelR :: TermId -> Text -> Text -> Handler Html
+postSDelR = getSDelR
 
 
 
@@ -389,8 +397,8 @@ insertSheetFile sid ftype finfo = do
 insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX ()
 insertSheetFile' sid ftype fs = do
     oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
-      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
-      E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val sid
+      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
+      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
            E.&&. sheetFile E.^. SheetFileType    E.==. E.val ftype
       return (file E.^. FileId)
     keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert

src/Handler/Submission.hs

@@ -1,6 +1,8 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ParallelListComp #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -9,6 +11,8 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TypeOperators #-}
 
 module Handler.Submission where
 
@@ -24,8 +28,11 @@ import Control.Monad.Trans.Maybe
 import Control.Monad.State.Class
 import Control.Monad.Trans.State.Strict (StateT)
 
+import qualified Data.Maybe
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
+
+import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
 import qualified Database.Esqueleto as E
@@ -33,20 +40,310 @@ import qualified Database.Esqueleto as E
 import qualified Data.Conduit.List as Conduit
 import Data.Conduit.ResumableSink
 
+import Data.Set (Set)
+import qualified Data.Set as Set
 import Data.Map (Map)
 import qualified Data.Map as Map
+import Data.Bifunctor
 
 import System.FilePath
 
-import Colonnade
+import Colonnade hiding (bool)
 import Yesod.Colonnade
 import qualified Text.Blaze.Html5.Attributes as HA
 
+
+numberOfSubmissionEditDates :: Int64
+numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
+
+
+makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [Text] -> Form (Maybe (Source Handler File), [Text])
+makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do
+    flip (renderAForm FormStandard) html $ (,)
+      <$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
+      <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies textField (fsm $ MsgSubmissionMember g) buddy
+                                    | g <- [1..(max groupNr $ length buddies)]             -- groupNr might have decreased meanwhile
+                                    | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
+                                    ])
+      <*  submitButton
+  where
+    (groupNr, editableBuddies)
+      | Arbitrary{..} <- grouping = (pred maxParticipants, True) -- pred to account for the person submitting
+      | otherwise = (0, False)
+
+    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 -> CryptoUUIDSubmission -> Handler Html
+getSubmissionR = postSubmissionR
+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
+    sheet@(Entity shid Sheet{..})  <- fetchSheet tid csh shn
+    case msmid of
+      Nothing     -> do
+        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 uid
+               E.&&. submission     E.^. SubmissionSheet    E.==. E.val shid
+          return $ submission E.^. SubmissionId
+        -- $logDebugS "Submission.DUPLICATENEW" (tshow submissions)
+        case submissions of
+          []    -> do
+            -- fetch buddies from previous submission in this course
+            buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+              E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
+              let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser `E.InnerJoin` submissionEdit) -> do
+                    E.on (submissionEdit E.^. SubmissionEditSubmission   E.==. submission E.^. SubmissionId)
+                    E.on (submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
+                    E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet)
+                    E.where_ $  submissionUser E.^. SubmissionUserUser E.==. E.val uid
+                          E.&&. sheet          E.^.        SheetCourse E.==. E.val sheetCourse
+                    E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
+                    E.limit 1
+                    return $ submission E.^. SubmissionId
+              E.where_ $  submissionUser E.^. SubmissionUserSubmission `E.in_` oldids
+                    E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
+              E.orderBy  [E.asc $ user E.^. UserEmail]
+              return $ user E.^. UserEmail
+            return (sheet,buddies,[])
+          (E.Value smid:_) -> do
+            cID <- encrypt smid
+            addMessageI "info" $ MsgSubmissionAlreadyExists
+            redirect $ CSheetR tid csh shn $ SubmissionR cID
+      (Just smid) -> do
+        shid' <- submissionSheet <$> get404 smid
+        when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet]
+        -- fetch buddies from current submission
+        buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+          E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
+          E.where_ $  submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
+                E.&&. submissionUser E.^. SubmissionUserUser       E.!=. E.val uid
+          E.orderBy  [E.asc $ user E.^. UserEmail]
+          return $ user E.^. UserEmail
+        -- mLastEdit <- selectFirst [SubmissionEditSubmission ==. smid] [Desc SubmissionEditTime]
+        lastEditValues <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
+            E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser)
+            E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid
+            E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
+            E.limit numberOfSubmissionEditDates
+            return $ (user E.^. UserDisplayName, submissionEdit E.^. SubmissionEditTime)
+        let lastEdits = map (bimap E.unValue E.unValue) lastEditValues
+        return (sheet,buddies,lastEdits)
+  let unpackZips = True -- undefined -- TODO
+  ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping $ map E.unValue buddies
+  mCID <- runDB $ do
+    res' <- case res of
+      (FormMissing )           -> return $ FormMissing
+      (FormFailure failmsgs)   -> return $ FormFailure failmsgs
+      (FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change
+      (FormSuccess (mFiles, (map CI.mk -> gEMails@(_:_)))) -- Validate AdHoc Group Members
+        | (Arbitrary {..}) <- sheetGrouping
+        , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
+          let gemails = map CI.foldedCase gEMails
+              prep :: [(E.Value Text, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))
+              prep ps = Map.fromList $ map (, Nothing) gEMails ++ [(CI.mk m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
+          participants <- fmap prep . E.select . E.from $ \user -> do
+            E.where_ $ (E.lower_ $ user E.^. UserEmail) `E.in_` E.valList gemails
+            let
+              isParticipant = E.sub_select . E.from $ \courseParticipant -> do
+                E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
+                     E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse
+                return $ E.countRows E.>. E.val (0 :: Int64)
+              hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
+                E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+                E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
+                     E.&&. submission E.^. SubmissionSheet E.==. E.val shid
+                return $ E.countRows E.>. E.val (0 :: Int64)
+            return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))
+          $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants
+          mr <- getMessageRender
+
+          let failmsgs = flip Map.foldMapWithKey participants $ \email -> \case
+                  Nothing            -> [mr $ MsgEMailUnknown $ CI.original email]
+                  (Just (_,False,_)) -> [mr $ MsgNotAParticipant (CI.original email) (unTermKey tid) csh]
+                  (Just (_,_, True)) -> [mr $ MsgSubmissionAlreadyExistsFor (CI.original email)]
+                  _other             -> mempty
+          return $ if null failmsgs
+            then FormSuccess (mFiles, foldMap (\(Just (i,_,_)) -> [i]) participants)
+            else FormFailure failmsgs
+
+        | otherwise -> return $ FormFailure ["Mismatching number of group participants"]
+
+
+    case res' of
+      (FormSuccess (mFiles,(setFromList -> adhocIds))) -> do
+        now <- liftIO $ getCurrentTime
+        smid <- do
+          smid <- case (mFiles, msmid) of
+            (Nothing, Just smid)   -- no new files, existing submission partners updated
+              -> return smid
+            (Just files, _)  -- new files
+              -> runConduit $ transPipe lift files .| extractRatings .| sinkSubmission shid uid ((,False) <$> msmid)
+            _ -> error "Impossible, because of definition of `makeSubmissionForm`"
+          -- Determine members of pre-registered group
+          groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
+            E.on $ submissionGroup E.^. SubmissionGroupId  E.==. submissionGroupUser' E.^. SubmissionGroupUserSubmissionGroup
+            E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+            E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
+                E.&&.  submissionGroup     E.^. SubmissionGroupCourse   E.==. E.val sheetCourse
+            return $ submissionGroupUser' E.^. SubmissionGroupUserUser
+          -- SubmissionUser for all group members (pre-registered & ad-hoc)
+          let subUsers = Set.insert uid $ groupUids `Set.union` adhocIds
+          -- remove obsolete old entries
+          deleteWhere [SubmissionUserSubmission ==. smid, SubmissionUserUser /<-. setToList subUsers]
+          -- maybe add current users
+          forM_ subUsers $ \uid' -> void . insertUnique $ SubmissionUser uid' smid
+          return smid
+        cID <- encrypt smid
+        return $ Just cID
+      (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage "warning" . toHtml)
+      _other -> return Nothing
+  
+  case mCID of
+    Just cID -> redirect $ CSheetR tid csh shn $ SubmissionR cID
+    Nothing  -> return ()
+
+  mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid
+
+  let pageTitle = MsgSubmissionTitle (unTermKey tid) csh shn
+  let formTitle = pageTitle
+  let formText  = Nothing :: Maybe UniWorXMessage
+  actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
+  -- Maybe construct a table to display uploaded archive files
+  let colonnadeFiles cid = mconcat
+        -- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
+        [ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> SubmissionDownloadSingleR cid fileTitle)
+                                                          (\(Entity _ File{..}) -> str2widget fileTitle)
+        , sortable (Just "time") "Modifikation" $ \(Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified
+        ]
+      smid2ArchiveTable (smid,cid) = DBTable
+        { dbtSQLQuery = submissionFileQuery smid
+        , dbtColonnade = colonnadeFiles cid
+        , dbtAttrs = tableDefault
+        , dbtIdent = "files" :: Text
+        , dbtSorting =  [ ( "path"
+                          , SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileTitle
+                          )
+                        , ( "time"
+                          , SortColumn $ \(sf `E.InnerJoin` f) -> f E.^. FileModified
+                          )
+                        ]
+        , dbtFilter = []
+        }
+  mFileTable <- traverse (dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
+
+  defaultLayout $ do
+    setTitleI pageTitle
+    $(widgetFile "formPageI18n")
+    [whamlet|
+      $maybe arCid <- mArCid
+        <hr>
+        <h2>
+          <a href=@{SubmissionDownloadArchiveR arCid}>Archiv
+        $forall (name,time) <- lastEdits
+          <div>last edited by #{name} at #{formatTimeGerDTlong time}
+        $maybe fileTable <- mFileTable
+          <h3>Enthaltene Dateien:
+          ^{fileTable}
+    |]
+
+
+
+
+
+submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
+submissionFileSource = E.selectSource . E.from . submissionFileQuery
+
+submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
+                        -> E.SqlQuery (E.SqlExpr (Entity File))
+submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
+  E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
+  E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
+  E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor
+  E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]  -- E.desc returns corrector updated data first
+  return f
+
+getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent
+getSubmissionDownloadSingleR cID path = do
+  submissionID <- decrypt cID
+  cID' <- encrypt submissionID
+
+  runDB $ do
+    isRating <- maybe False (== submissionID) <$> isRatingFile path
+    case isRating of
+      True  -> do
+        file <- runMaybeT $ lift . ratingFile cID' =<< MaybeT (getRating submissionID)
+        maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
+      False -> do
+        results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
+          E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
+          E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionID)
+          E.where_ (f E.^. FileTitle E.==. E.val path)
+          E.where_ . E.not_ . E.isNothing $ f E.^. FileContent
+          E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion
+          E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
+          return f
+
+        let fileName = Text.pack $ takeFileName path
+        case results of
+          [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c)
+          _ -> notFound
+
+getSubmissionDownloadArchiveR :: ZIPArchiveName SubmissionId -> Handler TypedContent
+getSubmissionDownloadArchiveR (ZIPArchiveName cID) = do
+  submissionID <- decrypt cID
+  cUUID <- encrypt submissionID
+  respondSourceDB "application/zip" $ do
+    rating <- lift $ getRating submissionID
+    case rating of
+      Nothing -> lift notFound
+      Just rating' -> do
+        let fileEntitySource' :: Source (YesodDB UniWorX) File
+            fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating')
+            info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) }
+        fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder
+
+
+
+
+
+
+
+-----------------------------------------------------------------------------------------------
+------------------------- DEMO BELOW
+
+
 submissionTable :: MForm Handler (FormResult [SubmissionId], Widget)
 submissionTable = do
   subs <- lift . runDB $ E.select . E.from $ \(sub `E.InnerJoin` sheet `E.InnerJoin` course) -> do
-    E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
-    E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheetId
+    E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+    E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheet
 
     return (sub, sheet, course)
 
@@ -54,9 +351,9 @@ submissionTable = do
     (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
 
   let
-    anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTermId courseShorthand CourseShowR
+    anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CShowR
     courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
-    anchorSubmission (_, cUUID, _) = SubmissionR cUUID
+    anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID
     submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
     colonnade = mconcat
       [ headed "Abgabe-ID" $ anchorCell anchorSubmission submissionText
@@ -91,7 +388,7 @@ postSubmissionListR = do
                 Just sink -> return sink
                 Nothing -> do
                   Submission{..} <- lift $ get404 sId
-                  return . newResumableSink $ sinkSubmission submissionSheetId userId (Just (sId, isUpdate))
+                  return . newResumableSink $ sinkSubmission submissionSheet userId (Just (sId, isUpdate))
               sink' <- lift $ yield val ++$$ sink
               case sink' of
                 Left _ -> error "sinkSubmission returned prematurely"
@@ -115,39 +412,7 @@ postSubmissionListR = do
 
   defaultLayout $(widgetFile "submission-list")
 
-getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent
-getSubmissionDownloadSingleR cID path = do
-  submissionID <- decrypt cID
-  cID' <- encrypt submissionID
 
-  runDB $ do
-    isRating <- maybe False (== submissionID) <$> isRatingFile path
-    case isRating of
-      True  -> do
-        file <- runMaybeT $ lift . ratingFile cID' =<< MaybeT (getRating submissionID)
-        maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
-      False -> do
-        results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
-          E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
-          E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID)
-          E.where_ (f E.^. FileTitle E.==. E.val path)
-          E.where_ . E.not_ . E.isNothing $ f E.^. FileContent
-          E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion
-          E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
-          return f
-
-        let fileName = Text.pack $ takeFileName path
-        case results of
-          [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c)
-          _ -> notFound
-
-submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
-submissionFileSource submissionID = E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
-  E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
-  E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID
-  E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion
-  E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
-  return f
 
 postSubmissionDownloadMultiArchiveR :: Handler TypedContent
 postSubmissionDownloadMultiArchiveR = do
@@ -193,27 +458,12 @@ postSubmissionDownloadMultiArchiveR = do
         mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
 
 
-getSubmissionDownloadArchiveR :: FilePath -> Handler TypedContent
-getSubmissionDownloadArchiveR path = do
-  let (baseName, ext) = splitExtension path
-      cID :: CryptoFileNameSubmission
-      cID = CryptoID $ CI.mk baseName
-  unless (ext == ".zip") notFound
-  submissionID <- decrypt cID
-  cUUID <- encrypt submissionID
-  respondSourceDB "application/zip" $ do
-    rating <- lift $ getRating submissionID
-    case rating of
-      Nothing -> lift notFound
-      Just rating' -> do
-        let fileEntitySource' :: Source (YesodDB UniWorX) File
-            fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating')
-            info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) }
-        fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder
 
-getSubmissionR, postSubmissionR :: CryptoUUIDSubmission -> Handler Html
-getSubmissionR = postSubmissionR
-postSubmissionR cID = do
+
+
+getSubmissionDemoR, postSubmissionDemoR :: CryptoUUIDSubmission -> Handler Html
+getSubmissionDemoR = postSubmissionDemoR
+postSubmissionDemoR cID = do
   submissionId <- decrypt cID
   
   ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
@@ -238,12 +488,12 @@ postSubmissionR cID = do
                   yieldM $ do
                     fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
                     return File{..}
-          submissionId' <- runConduit $ source =$= extractRatings =$= sinkSubmission submissionSheetId userId (Just (submissionId, isUpdate))
+          submissionId' <- runConduit $ source =$= extractRatings =$= sinkSubmission submissionSheet userId (Just (submissionId, isUpdate))
           get404 submissionId'
   
     files <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
-      E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
-      E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId)
+      E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
+      E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionId)
       E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
       return (f, sf)
     return (submission, files)

src/Handler/Term.hs

@@ -1,11 +1,13 @@
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE NoImplicitPrelude
+           , OverloadedStrings
+           , OverloadedLists
+           , RecordWildCards
+           , TemplateHaskell
+           , QuasiQuotes
+           , MultiParamTypeClasses
+           , TypeFamilies
+           , FlexibleContexts
+  #-}
 
 module Handler.Term where
 
@@ -29,18 +31,18 @@ getTermShowR = do
 --              return term
 --
   let
-    termData = E.from $ \term -> do
+    termData :: E.SqlExpr (Entity Term) -> E.SqlQuery (E.SqlExpr (Entity Term), E.SqlExpr (E.Value Int64))
+    termData term = do
       -- E.orderBy [E.desc $ term E.^. TermStart ]
-      let courseCount :: E.SqlExpr (E.Value Int)
-          courseCount = E.sub_select . E.from $ \course -> do
-            E.where_ $ term E.^. TermId E.==. course E.^. CourseTermId
+      let courseCount = E.sub_select . E.from $ \course -> do
+            E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
             return E.countRows
       return (term, courseCount)
   selectRep $ do
-    provideRep $ toJSON . map fst <$> runDB (E.select termData)
+    provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
     provideRep $ do
       let colonnadeTerms = mconcat
-            [ headed "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do
+            [ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do
                 -- Scrap this if to slow, create term edit page instead
                 adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
                 [whamlet|
@@ -50,40 +52,46 @@ getTermShowR = do
                   $else
                       #{termToText termName}
                 |]
-            , headed "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
+            , sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
                 stringCell $ formatTimeGerWD termLectureStart
-            , headed "Ende Vorlesungen"   $ \(Entity _ Term{..},_) ->
+            , sortable (Just "lecture-end") "Ende Vorlesungen"   $ \(Entity _ Term{..},_) ->
                 stringCell $ formatTimeGerWD termLectureEnd
-            , headed "Aktiv" $ \(Entity _ Term{..},_) ->
+            , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
                 textCell $ bool "" tickmark termActive
-            , headed "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) ->
-                cell [whamlet|
-                  <a href=@{CourseListTermR tid}>
-                    #{show numCourses} Kurse
-                |]
-            , headed "Semesteranfang" $ \(Entity _ Term{..},_) ->
+            , sortable Nothing "Kursliste" $ anchorCell
+                (\(Entity tid _, _) -> TermCourseListR tid)
+                (\(_, E.Value numCourses) -> [whamlet|_{MsgNumCourses numCourses}|])
+            , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
               stringCell $ formatTimeGerWD termStart
-            , headed "Semesterende"   $ \(Entity _ Term{..},_) ->
+            , sortable (Just "end") "Semesterende"   $ \(Entity _ Term{..},_) ->
               stringCell $ formatTimeGerWD termEnd
-            , headed "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
+            , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
               stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays
             ]
       table <- dbTable def $ DBTable
         { dbtSQLQuery = termData
         , dbtColonnade = colonnadeTerms
-        , dbtSorting = mempty
+        , dbtSorting = [ ( "start"
+                         , SortColumn $ \term -> term E.^. TermStart
+                         )
+                       , ( "end"
+                         , SortColumn $ \term -> term E.^. TermEnd
+                         )
+                       , ( "lecture-start"
+                         , SortColumn $ \term -> term E.^. TermLectureStart
+                         )
+                       , ( "lecture-end"
+                         , SortColumn $ \term -> term E.^. TermLectureEnd
+                         )
+                       ]
+        , dbtFilter = [ ( "active"
+                        , FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool))
+                        )
+                      ]
         , dbtAttrs = tableDefault
         , dbtIdent = "terms" :: Text
         }
-      let pageActions =
-            [ PageActionPrime $ MenuItem
-              { menuItemLabel = "Neues Semester"
-              , menuItemIcon  = Nothing
-              , menuItemRoute = TermEditR
-              , menuItemAccessCallback = (== Authorized) <$> isAuthorized TermEditR True
-              }
-            ]
-      defaultLinkLayout pageActions $ do
+      defaultLayout $ do
         setTitle "Freigeschaltete Semester"
         $(widgetFile "terms")
 

src/Handler/Utils.hs

@@ -16,7 +16,8 @@ import Handler.Utils.Form as Handler.Utils
 import Handler.Utils.Table as Handler.Utils
 import Handler.Utils.Table.Pagination as Handler.Utils
 
-import Handler.Utils.Zip as Handler.Utils
-import Handler.Utils.Rating as Handler.Utils
+import Handler.Utils.Zip        as Handler.Utils
+import Handler.Utils.Rating     as Handler.Utils
 import Handler.Utils.Submission as Handler.Utils
-import Handler.Utils.Templates as Handler.Utils
+import Handler.Utils.Sheet      as Handler.Utils
+import Handler.Utils.Templates  as Handler.Utils

src/Handler/Utils/Form.hs

@@ -15,9 +15,11 @@ module Handler.Utils.Form where
 
 import Handler.Utils.Form.Types
 
+
+import Handler.Utils.DateTime
+
 import Import
 import qualified Data.Char as Char
-import Handler.Utils.DateTime
 import Data.String (IsString(..))
 
 import qualified Data.Foldable as Foldable
@@ -40,11 +42,13 @@ import qualified Database.Esqueleto.Internal.Sql as E
 
 import qualified Data.Set as Set
 
+import Control.Monad.Writer.Class
+
 ------------------------------------------------
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
 
-data FormIdentifier = FIDcourse | FIDsheet
+data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
 
@@ -131,6 +135,8 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
 --   |]
   --  <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
 
+simpleLink :: Widget -> Route UniWorX -> Widget
+simpleLink lbl url = [whamlet| <a href=@{url}>^{lbl} |]
 
 buttonField :: Button a => a -> Field Handler a
 buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
@@ -232,7 +238,6 @@ posIntField d = checkBool (>= 1) (T.append  d " muss eine positive Zahl sein.")
 minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
 minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField
 
-
 --termField: see Utils.Term
 
 schoolField :: Field Handler SchoolId
@@ -327,6 +332,25 @@ sheetGroupAFormReq d _other = -- TODO
   -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
   Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1)
 
+{-
+dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime
+dayTimeField fs mutc = do
+    let (mbDay,mbTime) = case mutcs of
+          Nothing    -> return (Nothing,Nothing)
+          (Just utc) ->
+
+    (dayResult, dayView) <- mreq dayField fs
+
+    (result, view) <- (,) <$> dayField <*> timeField
+  where
+    (mbDay,mbTime)
+      | (Just utc) <- mutc =
+          let lt = utcToLocalTime ??? utcs
+          in  (Just $ localDay lt, Just $ localTimeOfDay lt)
+      | otherwise = (Nothing,Nothing)
+-}
+
+
 utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UTCTime
 -- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
 -- TODO: Verify whether this is UTC or local time from Browser
@@ -355,7 +379,7 @@ utcTimeField = Field
 
 
 fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX
-fsm = bfs
+fsm = bfs -- TODO: get rid of Bootstrap
 
 fsb :: Text -> FieldSettings site
 fsb = bfs -- Just to avoid annoying Ambiguous Type Errors
@@ -426,3 +450,26 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
                  , optionInternalValue = key
                  , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
                  }) cPairs
+
+mforced :: (site ~ HandlerSite m, MonadHandler m)
+        => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
+mforced Field{..} FieldSettings{..} val = do
+  tell fieldEnctype
+  name <- maybe newFormIdent return fsName
+  theId <- lift $ maybe newIdent return fsId
+  mr <- getMessageRender
+  let fsAttrs' = fsAttrs <> [("disabled", "")]
+  return ( FormSuccess val
+         , FieldView
+           { fvLabel = toHtml $ mr fsLabel
+           , fvTooltip = toHtml <$> fmap mr fsTooltip
+           , fvId = theId
+           , fvInput = fieldView theId name fsAttrs' (Right val) False
+           , fvErrors = Nothing
+           , fvRequired = False
+           }
+         )
+
+aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+        => Field m a -> FieldSettings site -> a -> AForm m a
+aforced field settings val = formToAForm $ second pure <$> mforced field settings val

src/Handler/Utils/Rating.hs

@@ -90,8 +90,8 @@ instance Exception RatingException
 getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)
 getRating submissionId = runMaybeT $ do
   let query = E.select . E.from $ \(submission `E.InnerJoin` sheet `E.InnerJoin` course) -> do
-        E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
-        E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheetId
+        E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+        E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
 
         E.where_ $ submission E.^. SubmissionId E.==. E.val submissionId
 

src/Handler/Utils/Sheet.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+module Handler.Utils.Sheet where
+
+import Import
+
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Internal.Sql as E
+
+
+
+
+fetchSheetAux ::  ( BaseBackend backend ~ SqlBackend
+                  , E.SqlSelect b a
+                  , Typeable a, MonadHandler m, IsPersistBackend backend
+                  , PersistQueryRead backend, PersistUniqueRead backend
+                  )
+  =>  (E.SqlExpr (Entity Sheet) -> b)
+      -> TermId -> Text -> Text -> ReaderT backend m a
+fetchSheetAux prj tid csh shn =
+    let cachId = encodeUtf8 $ tshow (tid,csh,shn)
+    in  cachedBy cachId $ do
+    -- Mit Yesod:
+    -- cid <- getKeyBy404 $ CourseTermShort tid csh
+    -- getBy404 $ CourseSheet cid shn
+    -- Mit Esqueleto:
+        sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+            E.on     $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+            E.where_ $ course E.^. CourseTerm    E.==. E.val tid
+                E.&&. course E.^. CourseShorthand E.==. E.val csh
+                E.&&. sheet  E.^. SheetName       E.==. E.val shn
+            return $ prj sheet
+        case sheetList of
+          [sheet] -> return sheet
+          _other  -> notFound
+
+fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
+fetchSheet = fetchSheetAux id
+
+fetchSheetId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet)
+fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn
+
+fetchSheetIdCourseId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet, Key Course)
+fetchSheetIdCourseId tid cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid cid shn

src/Handler/Utils/Submission.hs

@@ -15,13 +15,24 @@ module Handler.Utils.Submission
   , sinkSubmission
   ) where
 
-import Import
+import Import hiding ((.=))
+
+import Control.Lens
+import Control.Lens.Extras (is)
+import Utils.Lens
 
 import Control.Monad.State hiding (forM_)
+import qualified Control.Monad.Random as Rand
 
+import Data.Maybe
+
+import qualified Data.List as List
 import Data.Set (Set)
 import qualified Data.Set as Set
-  
+import Data.Map (Map, (!?))
+import qualified Data.Map as Map
+
+
 import Data.Monoid (Monoid, Any(..))
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
@@ -32,6 +43,70 @@ import qualified Database.Esqueleto as E
 import qualified Data.Conduit.List as Conduit
 
 
+data AssignSubmissionException = NoCorrectorsByProportion
+  deriving (Typeable, Show)
+
+instance Exception AssignSubmissionException
+
+-- | Assigns all submissions according to sheet corrector loads
+assignSubmissions ::
+    SheetId -- ^ Sheet do distribute to correction
+    -> YesodDB UniWorX (Set SubmissionId -- ^ assigned submissions
+                       ,Set SubmissionId -- ^ unassigend submissions (no tutors by load)
+                       )
+assignSubmissions sid = do
+    correctors <- selectList [SheetCorrectorSheet ==. sid] []
+    let corrsGroup = filter hasTutorialLoad correctors -- needed as List within Esqueleto
+    let corrsProp  = filter hasPositiveLoad correctors
+    let countsToLoad' :: UserId -> Bool
+        countsToLoad' uid = -- refactor by simply using Map.(!)
+          fromMaybe (error "Called `countsToLoad'` on entity not element of `corrsGroup`") $
+          Map.lookup uid loadMap
+        loadMap :: Map UserId Bool
+        loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsGroup]
+
+    subs <- E.select . E.from $ \(submission `E.LeftOuterJoin` user) -> do
+        let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do
+              -- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group
+              -- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do
+                E.on (tutorial       E.^. TutorialId         E.==. tutorialUser E.^. TutorialUserTutorial)
+                E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser)
+                E.where_ (tutorial   E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsGroup))
+                return $ tutorial E.^. TutorialTutor
+        E.on $ user E.?. UserId `E.in_` E.justList tutors
+        E.where_ $  submission E.^. SubmissionSheet E.==. E.val sid
+        E.orderBy [E.rand] -- randomize for fair tutor distribution
+        return (submission E.^. SubmissionId, user) -- , listToMaybe tutors)
+
+    queue <- liftIO . Rand.evalRandIO . sequence . repeat $ Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp]
+
+    let subTutor' :: Map SubmissionId (Maybe UserId)
+        subTutor' = Map.fromListWith (<|>) $ map (over (_2.traverse) entityKey . over _1 E.unValue) subs
+
+    subTutor <- fmap fst . flip execStateT (Map.empty, queue) . forM_ (Map.toList subTutor') $ \case
+      (smid, Just tutid) -> do
+        _1 %= Map.insert smid tutid
+        when (any ((== tutid) . sheetCorrectorUser . entityVal) corrsProp && countsToLoad' tutid) $
+          _2 %= List.delete (Just tutid)
+      (smid, Nothing) -> do
+        (q:qs) <- use _2
+        _2 .= qs
+        case q of
+          Just q  -> _1 %= Map.insert smid q
+          Nothing -> return () -- NOTE: throwM NoCorrectorsByProportion
+
+    forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [SubmissionRatingBy =. Just tutid]
+        
+    let assignedSubmissions   = Map.keysSet subTutor
+        unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions
+    return (assignedSubmissions, unassigendSubmissions)
+    where
+      hasPositiveLoad = (> 0)  . byProportion . sheetCorrectorLoad . entityVal
+      hasTutorialLoad = isJust . byTutorial   . sheetCorrectorLoad . entityVal
+
+
+
+
 data SubmissionSinkState = SubmissionSinkState
   { sinkSeenRating :: Any
   , sinkSubmissionTouched :: Any
@@ -65,7 +140,7 @@ sinkSubmission :: SheetId
 sinkSubmission sheetId userId mExists = do
   now <- liftIO getCurrentTime
   let
-    submissionSheetId       = sheetId
+    submissionSheet       = sheetId
     submissionRatingPoints  = Nothing
     submissionRatingComment = Nothing
     submissionRatingBy      = Nothing
@@ -90,8 +165,8 @@ sinkSubmission sheetId userId mExists = do
         tell $ mempty{ sinkFilenames = Set.singleton fileTitle  }
 
         otherVersions <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do
-          E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId
-          E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId
+          E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
+          E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
           -- E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
           E.where_ $ f E.^. FileTitle E.==. E.val fileTitle -- 'Zip.hs' normalises filenames already, so this should work
           return (f, sf)
@@ -121,8 +196,8 @@ sinkSubmission sheetId userId mExists = do
             _   -> do
               fileId <- insert file
               insert_ $ SubmissionFile
-                { submissionFileSubmissionId = submissionId
-                , submissionFileFileId = fileId
+                { submissionFileSubmission = submissionId
+                , submissionFileFile = fileId
                 , submissionFileIsUpdate = isUpdate
                 , submissionFileIsDeletion = False
                 }
@@ -189,8 +264,8 @@ sinkSubmission sheetId userId mExists = do
         finalize :: SubmissionSinkState -> YesodDB UniWorX ()
         finalize SubmissionSinkState{..} = do
           missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
-            E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId
-            E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId
+            E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
+            E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
             when (not isUpdate) $
               E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
             E.where_ $ f E.^. FileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
@@ -202,8 +277,8 @@ sinkSubmission sheetId userId mExists = do
             False -> deleteCascadeWhere [ FileId <-. [ fileId | (Entity fileId _, _) <- missingFiles ] ]
             True  -> forM_ missingFiles $ \(Entity fileId File{..}, Entity sfId SubmissionFile{..}) -> do
               shadowing <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
-                E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId
-                E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId
+                E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
+                E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
                 E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val (not isUpdate)
                 E.where_ $ f E.^. FileTitle E.==. E.val fileTitle
                 return $ f E.^. FileId
@@ -212,13 +287,13 @@ sinkSubmission sheetId userId mExists = do
                 ([], _) -> deleteCascade fileId
                 (E.Value f:_, False) -> do
                   insert_ $ SubmissionFile
-                    { submissionFileSubmissionId = submissionId
-                    , submissionFileFileId = f
+                    { submissionFileSubmission = submissionId
+                    , submissionFileFile = f
                     , submissionFileIsUpdate = True
                     , submissionFileIsDeletion = True
                     }
                 (E.Value f:_, True) -> do
-                  update sfId [ SubmissionFileFileId =. f, SubmissionFileIsDeletion =. True ]
+                  update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ]
                   deleteCascade fileId
 
           when (isUpdate && not (getAny sinkSeenRating)) $

src/Handler/Utils/Table/Pagination.hs

@@ -6,30 +6,50 @@
            , QuasiQuotes
            , LambdaCase
            , ViewPatterns
+           , FlexibleContexts
+           , FlexibleInstances
+           , MultiParamTypeClasses
+           , TypeFamilies
   #-}
 
 module Handler.Utils.Table.Pagination
   ( SortColumn(..), SortDirection(..)
+  , FilterColumn(..), IsFilterColumn
+  , DBRow(..), DBOutput
   , DBTable(..)
   , PaginationSettings(..)
   , PSValidator(..)
+  , Sortable(..), sortable
   , dbTable
   ) where
 
+import Handler.Utils.Table.Pagination.Types
+
 import Import
 import qualified Database.Esqueleto as E
-import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
+import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
+import qualified Database.Esqueleto.Internal.Language as E (From)
 import Text.Blaze (Attribute)
 import qualified Text.Blaze.Html5.Attributes as Html5
+import qualified Text.Blaze.Html5 as Html5
+import Yesod.Core.Types (Body(..),GWData(..),WidgetT(..))
+
+import qualified Data.Binary.Builder as Builder
+
+import qualified Network.Wai as Wai
 
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
-import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_)
+import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_)
 
 import Data.Map (Map, (!))
+import qualified Data.Map as Map
 
-import Colonnade hiding (bool, fromMaybe)
+import Data.Profunctor (lmap)
+
+import Colonnade hiding (bool, fromMaybe, singleton)
+import Colonnade.Encode
 import Yesod.Colonnade
 
 import Text.Hamlet (hamletFile)
@@ -37,7 +57,7 @@ import Text.Hamlet (hamletFile)
 import Data.Ratio ((%))
 
 
-data SortColumn = forall a. PersistField a => SortColumn { getSortColumn :: E.SqlExpr (E.Value a) }
+data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
 
 data SortDirection = SortAsc | SortDesc
   deriving (Eq, Ord, Enum, Show, Read)
@@ -49,24 +69,68 @@ instance PathPiece SortDirection where
     | t == "desc" = Just SortDesc
     | otherwise   = Nothing
 
-sqlSortDirection :: (SortColumn, SortDirection) -> E.SqlExpr E.OrderBy
-sqlSortDirection (SortColumn e, SortAsc ) = E.asc  e
-sqlSortDirection (SortColumn e, SortDesc) = E.desc e
-  
-data DBTable = forall a r h i.
-  ( Headedness h
-  , E.SqlSelect a r
+sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy
+sqlSortDirection t (SortColumn e, SortAsc ) = E.asc  $ e t
+sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
+
+
+data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a
+
+filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool)
+filterColumn (FilterColumn f) = filterColumn' f
+
+class IsFilterColumn t a where
+  filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool)
+
+instance IsFilterColumn t (E.SqlExpr (E.Value Bool)) where
+  filterColumn' fin _ _ = fin
+
+instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
+  filterColumn' cont is t = filterColumn' (cont t) is t
+
+instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
+  filterColumn' cont is t = filterColumn' (cont input) is' t
+    where
+      (input, ($ []) -> is') = go (mempty, id) is
+      go acc [] = acc
+      go (acc, is') (i:is)
+        | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is
+        | otherwise = go (acc, is' . (i:)) is
+
+
+data DBRow r = DBRow
+  { dbrIndex, dbrCount :: Int64
+  , dbrOutput :: r
+  }
+
+class DBOutput r r' where
+  dbProj :: r -> r'
+
+instance DBOutput r r where
+  dbProj = id
+instance DBOutput (DBRow r) r where
+  dbProj = dbrOutput
+instance DBOutput (DBRow r) (Int64, r) where
+  dbProj = (,) <$> dbrIndex <*> dbrOutput
+
+ 
+data DBTable = forall a r r' h i t.
+  ( ToSortable h, Functor h
+  , E.SqlSelect a r, DBOutput (DBRow r) r'
   , PathPiece i
+  , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
   ) => DBTable
-  { dbtSQLQuery :: E.SqlQuery a
-  , dbtColonnade :: Colonnade h r (Cell UniWorX)
-  , dbtSorting :: Map Text SortColumn
+  { dbtSQLQuery :: t -> E.SqlQuery a
+  , dbtColonnade :: Colonnade h r' (Cell UniWorX)
+  , dbtSorting :: Map Text (SortColumn t)
+  , dbtFilter :: Map Text (FilterColumn t)
   , dbtAttrs :: Attribute
   , dbtIdent :: i
   }
 
 data PaginationSettings = PaginationSettings
   { psSorting      :: [(Text, SortDirection)]
+  , psFilter       :: Map Text [Text]
   , psLimit        :: Int64
   , psPage         :: Int64
   , psShortcircuit :: Bool
@@ -75,15 +139,16 @@ data PaginationSettings = PaginationSettings
 instance Default PaginationSettings where
   def = PaginationSettings
     { psSorting      = []
+    , psFilter       = Map.empty
     , psLimit        = 50
     , psPage         = 0
     , psShortcircuit = False
     }
 
-newtype PSValidator = PSValidator { runPSValidator :: Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
+newtype PSValidator = PSValidator { runPSValidator :: DBTable -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
 
 instance Default PSValidator where
-  def = PSValidator $ \case
+  def = PSValidator $ \DBTable{..} -> \case
     Nothing -> def
     Just ps -> swap . (\act -> execRWS act () ps) $ do
       l <- gets psLimit
@@ -91,8 +156,9 @@ instance Default PSValidator where
         modify $ \ps -> ps { psLimit = psLimit def }
         tell . pure $ SomeMessage MsgPSLimitNonPositive
 
+
 dbTable :: PSValidator -> DBTable -> Handler Widget
-dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
+dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), .. }) = do
   let
     sortingOptions = mkOptionList
       [ Option t' (t, d) t'
@@ -100,46 +166,96 @@ dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
       , d <- [SortAsc, SortDesc]
       , let t' = t <> "-" <> toPathPiece d
       ]
-    (_, defPS) = runPSValidator Nothing
+    (_, defPS) = runPSValidator dbtable Nothing
     wIdent n
       | not $ null dbtIdent = dbtIdent <> "-" <> n
       | otherwise           = n
     dbtAttrs'
       | not $ null dbtIdent = Html5.id (fromString $ unpack dbtIdent) <> dbtAttrs
       | otherwise           = dbtAttrs
+    multiTextField = Field
+      { fieldParse = \ts _ -> return . Right $ Just ts
+      , fieldView = undefined
+      , fieldEnctype = UrlEncoded
+      }
     
   psResult <- runInputGetResult $ PaginationSettings
-    <$> ireq (multiSelectField $ return sortingOptions) (wIdent "sorting")
+    <$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting"))
+    <*> (Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField $ wIdent k) dbtFilter)
     <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize"))
     <*> (fromMaybe (psPage  defPS) <$> iopt intField (wIdent "page"))
     <*> ireq checkBoxField (wIdent "table-only")
 
-  $(logDebug) . tshow $ (,,,) <$> (length . psSorting <$> psResult)
-                              <*> (psLimit <$> psResult)
-                              <*> (psPage <$> psResult)
-                              <*> (psShortcircuit <$> psResult)
+  $(logDebug) . tshow $ (,,,,) <$> (length . psSorting <$> psResult)
+                               <*> (Map.keys . psFilter <$> psResult)
+                               <*> (psLimit <$> psResult)
+                               <*> (psPage <$> psResult)
+                               <*> (psShortcircuit <$> psResult)
 
   let
     (errs, PaginationSettings{..}) = case psResult of
-      FormSuccess ps   -> runPSValidator $ Just ps
-      FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing
-      FormMissing      -> runPSValidator Nothing
+      FormSuccess ps   -> runPSValidator dbtable $ Just ps
+      FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing
+      FormMissing      -> runPSValidator dbtable Nothing
     psSorting' = map (first (dbtSorting !)) psSorting
-    sqlQuery' = dbtSQLQuery
-      <* E.orderBy (map sqlSortDirection psSorting')
+    sqlQuery' = E.from $ \t -> dbtSQLQuery t
+      <* E.orderBy (map (sqlSortDirection t) psSorting')
       <* E.limit psLimit
       <* E.offset (psPage * psLimit)
+      <* Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
 
   mapM_ (addMessageI "warning") errs
 
-  (rows, [E.Value rowCount]) <- runDB $ (,) <$> E.select sqlQuery' <*> E.select (E.countRows <$ dbtSQLQuery :: E.SqlQuery (E.SqlExpr (E.Value Int64)))
+  rows' <- runDB . E.select $ (,) <$> pure (E.unsafeSqlValue "row_number() OVER ()" :: E.SqlExpr (E.Value Int64), E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'
+
+  let
+    rowCount
+      | ((_, E.Value n), _):_ <- rows' = n
+      | otherwise = 0
+    rows = map (\((E.Value i, E.Value n), r) -> DBRow i n r) rows'
 
   bool return (sendResponse <=< tblLayout) psShortcircuit $ do
-    let table = encodeCellTable dbtAttrs' dbtColonnade rows
+    getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+    let table = $(widgetFile "table/colonnade")
         pageCount = max 1 . ceiling $ rowCount % psLimit
-    $(widgetFile "table-layout")
+        pageNumbers = [0..pred pageCount]
+        tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
+
+        withSortLinks Sortable{ sortableContent = Cell{..}, .. } = Cell
+          { cellContents = $(widgetFile "table/sortable-header")
+          , cellAttrs = maybe mempty (const sortableAttr) sortableKey <> cellAttrs
+          }
+          where
+            directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
+            sortableAttr = Html5.class_ . fromString . unwords $ "sortable" : foldMap toAttr directions
+            toAttr SortAsc = ["sorted-asc"]
+            toAttr SortDesc = ["sorted-desc"]
+    $(widgetFile "table/layout")
   where
     tblLayout :: Widget -> Handler Html
     tblLayout tbl' = do
       tbl <- widgetToPageContent tbl'
-      withUrlRenderer $(hamletFile "templates/table-layout-wrapper.hamlet")
+      withUrlRenderer $(hamletFile "templates/table/layout-wrapper.hamlet")
+
+    setParam :: Text -> Maybe Text -> QueryText -> QueryText
+    setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
+
+widgetFromCell ::
+  (Attribute -> WidgetT site IO () -> WidgetT site IO ())
+  -> Cell site
+  -> WidgetT site IO ()
+widgetFromCell f (Cell attrs contents) =
+  f attrs contents
+td,th ::
+  Attribute -> WidgetT site IO () -> WidgetT site IO ()
+
+td = liftParent Html5.td
+th = liftParent Html5.th
+
+liftParent :: (Html -> Html) -> Attribute -> WidgetT site IO a -> WidgetT site IO a
+liftParent el attrs (WidgetT f) = WidgetT $ \hdata -> do
+  (a,gwd) <- f hdata
+  let Body bodyFunc = gwdBody gwd
+      newBodyFunc render =
+        el Html5.! attrs $ (bodyFunc render)
+  return (a,gwd { gwdBody = Body newBodyFunc })

src/Handler/Utils/Table/Pagination/Types.hs

@@ -0,0 +1,43 @@
+{-# LANGUAGE NoImplicitPrelude
+           , ExistentialQuantification
+           , RankNTypes
+           , RecordWildCards
+  #-}
+
+module Handler.Utils.Table.Pagination.Types where
+
+import Import hiding (singleton)
+
+import Colonnade
+import Colonnade.Encode
+
+data Sortable a = Sortable
+  { sortableKey :: Maybe Text
+  , sortableContent :: a
+  }
+
+sortable :: Maybe Text -> c -> (a -> c) -> Colonnade Sortable a c
+sortable k h = singleton (Sortable k h)
+
+instance Headedness Sortable where
+  headednessPure = Sortable Nothing
+  headednessExtract = Just $ \(Sortable _ x) -> x
+  headednessExtractForall = Just $ ExtractForall (\(Sortable _ x) -> x)
+
+instance Functor Sortable where
+  fmap f Sortable{..} = Sortable { sortableContent = f sortableContent, .. }
+                                                 
+newtype SortableP s = SortableP { toSortable :: forall a. s a -> Sortable a}
+
+class Headedness s => ToSortable s where
+  pSortable :: Maybe (SortableP s)
+
+instance ToSortable Sortable where
+  pSortable = Just $ SortableP id
+
+instance ToSortable Headed where
+  pSortable = Just $ SortableP (\(Headed x) -> Sortable Nothing x)
+
+instance ToSortable Headless where
+  pSortable = Nothing
+ 

src/Model/Types.hs

@@ -54,7 +54,7 @@ deriveJSON defaultOptions ''SheetType
 derivePersistFieldJSON "SheetType"
 
 data SheetGroup
-  = Arbitrary { maxParticipants :: Int } -- Distinguish Limited/Arbitrary
+  = Arbitrary { maxParticipants :: Int }
   | RegisteredGroups
   | NoGroups
   deriving (Show, Read, Eq)
@@ -77,10 +77,33 @@ data ExamStatus = Attended | NoShow | Voided
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 derivePersistField "ExamStatus"
 
-data Load = ByTutorial | ByProportion Rational
+-- | Specify a corrector's workload
+data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational }
+    = Load { byTutorial :: Maybe Bool  -- ^ Just all from Tutorial, True if counting towards overall workload
+           , byProportion :: Rational  -- ^ workload proportion of all submission not assigned to tutorial leaders
+           }
   deriving (Show, Read, Eq)
 derivePersistField "Load"
 
+instance Semigroup Load where
+  (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
+    where
+      byTut''
+        | Nothing <- byTut  = byTut'
+        | Nothing <- byTut' = byTut
+        | Just a <- byTut
+        , Just b <- byTut'  = Just $ a || b
+
+instance Monoid Load where
+  mempty = Load Nothing 0
+  mappend = (<>)
+
+{- Use (is _ByTutorial) instead of this unneeded definition:
+  isByTutorial :: Load -> Bool
+  isByTutorial (ByTutorial {}) = True
+  isByTutorial _               = False
+-}
+
 data Season = Summer | Winter
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
 
@@ -158,3 +181,6 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
 data StudyFieldType = FieldPrimary | FieldSecondary
   deriving (Eq, Ord, Enum, Show, Read, Bounded)
 derivePersistField "StudyFieldType"
+
+
+

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 qualified Data.Map as Map
-import qualified Data.List as List
+-- import Data.Map (Map)
+-- import qualified Data.Map as Map
+-- 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,6 +64,16 @@ 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)
 
+
+------------
+-- Tuples --
+------------
+
+----------
+-- Maps --
+----------
+
+
 -----------
 -- Maybe --
 -----------
@@ -49,8 +81,48 @@ 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)
 
 
-----------
--- Maps --
-----------
+------------
+-- 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" 
         
+

src/Utils/Lens.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+module Utils.Lens where
+
+import Import.NoFoundation
+import Control.Lens
+
+makeClassy_ ''Entity
+
+makeClassy_ ''SheetCorrector
+
+-- makeClassy_ ''Load

static/css/icons.css

@@ -32,3 +32,6 @@
 .glyphicon--logout::before {
   content: '\e163';
 }
+.glyphicon--none::before {
+  content: '';
+}

static/css/tabber.css

@@ -0,0 +1,39 @@
+.tab-group {
+  border-top: 2px solid #dcdcdc;
+  padding-top: 30px;
+}
+
+.tab-group-openers {
+  display: flex;
+  justify-content: stretch;
+  line-height: 40px;
+  font-size: 14px;
+  margin-bottom: 40px;
+}
+
+.tab-opener {
+  display: inline-block;
+  flex: 1;
+  text-align: center;
+  padding: 0 13px;
+  margin: 0 2px;
+  background-color: #b3b7c1;
+  color: white;
+  font-size: 16px;
+  text-transform: uppercase;
+  font-weight: 600;
+  transition: all .1s ease;
+  border-bottom: 5px solid rgba(100, 100, 100, 0.2);
+}
+.tab-opener:not(.tab-visible):hover {
+  cursor: pointer;
+  background-color: transparent;
+  color: rgb(52, 48, 58);
+  border-bottom-color: grey;
+}
+
+.tab-opener.tab-visible {
+  background-color: transparent;
+  color: rgb(52, 48, 58);
+  border-bottom-color: #5F98C2;
+}

static/js/featureChecker.js

@@ -1,7 +1,4 @@
 window.addEventListener('touchstart', function onFirstTouch() {
-  // we could use a class
   document.body.classList.add('touch-supported');
-
-  // we only need to know once that a human touched the screen, so we can stop listening now
   window.removeEventListener('touchstart', onFirstTouch, false);
 }, false);

static/js/fetchPolyfill.js

@@ -0,0 +1,466 @@
+(function(self) {
+  'use strict';
+
+  if (self.fetch) {
+    return
+  }
+
+  var support = {
+    searchParams: 'URLSearchParams' in self,
+    iterable: 'Symbol' in self && 'iterator' in Symbol,
+    blob: 'FileReader' in self && 'Blob' in self && (function() {
+      try {
+        new Blob()
+        return true
+      } catch(e) {
+        return false
+      }
+    })(),
+    formData: 'FormData' in self,
+    arrayBuffer: 'ArrayBuffer' in self
+  }
+
+  if (support.arrayBuffer) {
+    var viewClasses = [
+      '[object Int8Array]',
+      '[object Uint8Array]',
+      '[object Uint8ClampedArray]',
+      '[object Int16Array]',
+      '[object Uint16Array]',
+      '[object Int32Array]',
+      '[object Uint32Array]',
+      '[object Float32Array]',
+      '[object Float64Array]'
+    ]
+
+    var isDataView = function(obj) {
+      return obj && DataView.prototype.isPrototypeOf(obj)
+    }
+
+    var isArrayBufferView = ArrayBuffer.isView || function(obj) {
+      return obj && viewClasses.indexOf(Object.prototype.toString.call(obj)) > -1
+    }
+  }
+
+  function normalizeName(name) {
+    if (typeof name !== 'string') {
+      name = String(name)
+    }
+    if (/[^a-z0-9\-#$%&'*+.\^_`|~]/i.test(name)) {
+      throw new TypeError('Invalid character in header field name')
+    }
+    return name.toLowerCase()
+  }
+
+  function normalizeValue(value) {
+    if (typeof value !== 'string') {
+      value = String(value)
+    }
+    return value
+  }
+
+  // Build a destructive iterator for the value list
+  function iteratorFor(items) {
+    var iterator = {
+      next: function() {
+        var value = items.shift()
+        return {done: value === undefined, value: value}
+      }
+    }
+
+    if (support.iterable) {
+      iterator[Symbol.iterator] = function() {
+        return iterator
+      }
+    }
+
+    return iterator
+  }
+
+  function Headers(headers) {
+    this.map = {}
+
+    if (headers instanceof Headers) {
+      headers.forEach(function(value, name) {
+        this.append(name, value)
+      }, this)
+    } else if (Array.isArray(headers)) {
+      headers.forEach(function(header) {
+        this.append(header[0], header[1])
+      }, this)
+    } else if (headers) {
+      Object.getOwnPropertyNames(headers).forEach(function(name) {
+        this.append(name, headers[name])
+      }, this)
+    }
+  }
+
+  Headers.prototype.append = function(name, value) {
+    name = normalizeName(name)
+    value = normalizeValue(value)
+    var oldValue = this.map[name]
+    this.map[name] = oldValue ? oldValue+','+value : value
+  }
+
+  Headers.prototype['delete'] = function(name) {
+    delete this.map[normalizeName(name)]
+  }
+
+  Headers.prototype.get = function(name) {
+    name = normalizeName(name)
+    return this.has(name) ? this.map[name] : null
+  }
+
+  Headers.prototype.has = function(name) {
+    return this.map.hasOwnProperty(normalizeName(name))
+  }
+
+  Headers.prototype.set = function(name, value) {
+    this.map[normalizeName(name)] = normalizeValue(value)
+  }
+
+  Headers.prototype.forEach = function(callback, thisArg) {
+    for (var name in this.map) {
+      if (this.map.hasOwnProperty(name)) {
+        callback.call(thisArg, this.map[name], name, this)
+      }
+    }
+  }
+
+  Headers.prototype.keys = function() {
+    var items = []
+    this.forEach(function(value, name) { items.push(name) })
+    return iteratorFor(items)
+  }
+
+  Headers.prototype.values = function() {
+    var items = []
+    this.forEach(function(value) { items.push(value) })
+    return iteratorFor(items)
+  }
+
+  Headers.prototype.entries = function() {
+    var items = []
+    this.forEach(function(value, name) { items.push([name, value]) })
+    return iteratorFor(items)
+  }
+
+  if (support.iterable) {
+    Headers.prototype[Symbol.iterator] = Headers.prototype.entries
+  }
+
+  function consumed(body) {
+    if (body.bodyUsed) {
+      return Promise.reject(new TypeError('Already read'))
+    }
+    body.bodyUsed = true
+  }
+
+  function fileReaderReady(reader) {
+    return new Promise(function(resolve, reject) {
+      reader.onload = function() {
+        resolve(reader.result)
+      }
+      reader.onerror = function() {
+        reject(reader.error)
+      }
+    })
+  }
+
+  function readBlobAsArrayBuffer(blob) {
+    var reader = new FileReader()
+    var promise = fileReaderReady(reader)
+    reader.readAsArrayBuffer(blob)
+    return promise
+  }
+
+  function readBlobAsText(blob) {
+    var reader = new FileReader()
+    var promise = fileReaderReady(reader)
+    reader.readAsText(blob)
+    return promise
+  }
+
+  function readArrayBufferAsText(buf) {
+    var view = new Uint8Array(buf)
+    var chars = new Array(view.length)
+
+    for (var i = 0; i < view.length; i++) {
+      chars[i] = String.fromCharCode(view[i])
+    }
+    return chars.join('')
+  }
+
+  function bufferClone(buf) {
+    if (buf.slice) {
+      return buf.slice(0)
+    } else {
+      var view = new Uint8Array(buf.byteLength)
+      view.set(new Uint8Array(buf))
+      return view.buffer
+    }
+  }
+
+  function Body() {
+    this.bodyUsed = false
+
+    this._initBody = function(body) {
+      this._bodyInit = body
+      if (!body) {
+        this._bodyText = ''
+      } else if (typeof body === 'string') {
+        this._bodyText = body
+      } else if (support.blob && Blob.prototype.isPrototypeOf(body)) {
+        this._bodyBlob = body
+      } else if (support.formData && FormData.prototype.isPrototypeOf(body)) {
+        this._bodyFormData = body
+      } else if (support.searchParams && URLSearchParams.prototype.isPrototypeOf(body)) {
+        this._bodyText = body.toString()
+      } else if (support.arrayBuffer && support.blob && isDataView(body)) {
+        this._bodyArrayBuffer = bufferClone(body.buffer)
+        // IE 10-11 can't handle a DataView body.
+        this._bodyInit = new Blob([this._bodyArrayBuffer])
+      } else if (support.arrayBuffer && (ArrayBuffer.prototype.isPrototypeOf(body) || isArrayBufferView(body))) {
+        this._bodyArrayBuffer = bufferClone(body)
+      } else {
+        throw new Error('unsupported BodyInit type')
+      }
+
+      if (!this.headers.get('content-type')) {
+        if (typeof body === 'string') {
+          this.headers.set('content-type', 'text/plain;charset=UTF-8')
+        } else if (this._bodyBlob && this._bodyBlob.type) {
+          this.headers.set('content-type', this._bodyBlob.type)
+        } else if (support.searchParams && URLSearchParams.prototype.isPrototypeOf(body)) {
+          this.headers.set('content-type', 'application/x-www-form-urlencoded;charset=UTF-8')
+        }
+      }
+    }
+
+    if (support.blob) {
+      this.blob = function() {
+        var rejected = consumed(this)
+        if (rejected) {
+          return rejected
+        }
+
+        if (this._bodyBlob) {
+          return Promise.resolve(this._bodyBlob)
+        } else if (this._bodyArrayBuffer) {
+          return Promise.resolve(new Blob([this._bodyArrayBuffer]))
+        } else if (this._bodyFormData) {
+          throw new Error('could not read FormData body as blob')
+        } else {
+          return Promise.resolve(new Blob([this._bodyText]))
+        }
+      }
+
+      this.arrayBuffer = function() {
+        if (this._bodyArrayBuffer) {
+          return consumed(this) || Promise.resolve(this._bodyArrayBuffer)
+        } else {
+          return this.blob().then(readBlobAsArrayBuffer)
+        }
+      }
+    }
+
+    this.text = function() {
+      var rejected = consumed(this)
+      if (rejected) {
+        return rejected
+      }
+
+      if (this._bodyBlob) {
+        return readBlobAsText(this._bodyBlob)
+      } else if (this._bodyArrayBuffer) {
+        return Promise.resolve(readArrayBufferAsText(this._bodyArrayBuffer))
+      } else if (this._bodyFormData) {
+        throw new Error('could not read FormData body as text')
+      } else {
+        return Promise.resolve(this._bodyText)
+      }
+    }
+
+    if (support.formData) {
+      this.formData = function() {
+        return this.text().then(decode)
+      }
+    }
+
+    this.json = function() {
+      return this.text().then(JSON.parse)
+    }
+
+    return this
+  }
+
+  // HTTP methods whose capitalization should be normalized
+  var methods = ['DELETE', 'GET', 'HEAD', 'OPTIONS', 'POST', 'PUT']
+
+  function normalizeMethod(method) {
+    var upcased = method.toUpperCase()
+    return (methods.indexOf(upcased) > -1) ? upcased : method
+  }
+
+  function Request(input, options) {
+    options = options || {}
+    var body = options.body
+
+    if (input instanceof Request) {
+      if (input.bodyUsed) {
+        throw new TypeError('Already read')
+      }
+      this.url = input.url
+      this.credentials = input.credentials
+      if (!options.headers) {
+        this.headers = new Headers(input.headers)
+      }
+      this.method = input.method
+      this.mode = input.mode
+      if (!body && input._bodyInit != null) {
+        body = input._bodyInit
+        input.bodyUsed = true
+      }
+    } else {
+      this.url = String(input)
+    }
+
+    this.credentials = options.credentials || this.credentials || 'omit'
+    if (options.headers || !this.headers) {
+      this.headers = new Headers(options.headers)
+    }
+    this.method = normalizeMethod(options.method || this.method || 'GET')
+    this.mode = options.mode || this.mode || null
+    this.referrer = null
+
+    if ((this.method === 'GET' || this.method === 'HEAD') && body) {
+      throw new TypeError('Body not allowed for GET or HEAD requests')
+    }
+    this._initBody(body)
+  }
+
+  Request.prototype.clone = function() {
+    return new Request(this, { body: this._bodyInit })
+  }
+
+  function decode(body) {
+    var form = new FormData()
+    body.trim().split('&').forEach(function(bytes) {
+      if (bytes) {
+        var split = bytes.split('=')
+        var name = split.shift().replace(/\+/g, ' ')
+        var value = split.join('=').replace(/\+/g, ' ')
+        form.append(decodeURIComponent(name), decodeURIComponent(value))
+      }
+    })
+    return form
+  }
+
+  function parseHeaders(rawHeaders) {
+    var headers = new Headers()
+    // Replace instances of \r\n and \n followed by at least one space or horizontal tab with a space
+    // https://tools.ietf.org/html/rfc7230#section-3.2
+    var preProcessedHeaders = rawHeaders.replace(/\r?\n[\t ]+/g, ' ')
+    preProcessedHeaders.split(/\r?\n/).forEach(function(line) {
+      var parts = line.split(':')
+      var key = parts.shift().trim()
+      if (key) {
+        var value = parts.join(':').trim()
+        headers.append(key, value)
+      }
+    })
+    return headers
+  }
+
+  Body.call(Request.prototype)
+
+  function Response(bodyInit, options) {
+    if (!options) {
+      options = {}
+    }
+
+    this.type = 'default'
+    this.status = options.status === undefined ? 200 : options.status
+    this.ok = this.status >= 200 && this.status < 300
+    this.statusText = 'statusText' in options ? options.statusText : 'OK'
+    this.headers = new Headers(options.headers)
+    this.url = options.url || ''
+    this._initBody(bodyInit)
+  }
+
+  Body.call(Response.prototype)
+
+  Response.prototype.clone = function() {
+    return new Response(this._bodyInit, {
+      status: this.status,
+      statusText: this.statusText,
+      headers: new Headers(this.headers),
+      url: this.url
+    })
+  }
+
+  Response.error = function() {
+    var response = new Response(null, {status: 0, statusText: ''})
+    response.type = 'error'
+    return response
+  }
+
+  var redirectStatuses = [301, 302, 303, 307, 308]
+
+  Response.redirect = function(url, status) {
+    if (redirectStatuses.indexOf(status) === -1) {
+      throw new RangeError('Invalid status code')
+    }
+
+    return new Response(null, {status: status, headers: {location: url}})
+  }
+
+  self.Headers = Headers
+  self.Request = Request
+  self.Response = Response
+
+  self.fetch = function(input, init) {
+    return new Promise(function(resolve, reject) {
+      var request = new Request(input, init)
+      var xhr = new XMLHttpRequest()
+
+      xhr.onload = function() {
+        var options = {
+          status: xhr.status,
+          statusText: xhr.statusText,
+          headers: parseHeaders(xhr.getAllResponseHeaders() || '')
+        }
+        options.url = 'responseURL' in xhr ? xhr.responseURL : options.headers.get('X-Request-URL')
+        var body = 'response' in xhr ? xhr.response : xhr.responseText
+        resolve(new Response(body, options))
+      }
+
+      xhr.onerror = function() {
+        reject(new TypeError('Network request failed'))
+      }
+
+      xhr.ontimeout = function() {
+        reject(new TypeError('Network request failed'))
+      }
+
+      xhr.open(request.method, request.url, true)
+
+      if (request.credentials === 'include') {
+        xhr.withCredentials = true
+      } else if (request.credentials === 'omit') {
+        xhr.withCredentials = false
+      }
+
+      if ('responseType' in xhr && support.blob) {
+        xhr.responseType = 'blob'
+      }
+
+      request.headers.forEach(function(value, name) {
+        xhr.setRequestHeader(name, value)
+      })
+
+      xhr.send(typeof request._bodyInit === 'undefined' ? null : request._bodyInit)
+    })
+  }
+  self.fetch.polyfill = true
+})(typeof self !== 'undefined' ? self : this);

static/js/tabber.js

@@ -0,0 +1,88 @@
+(function($) {
+
+  document.addEventListener('DOMContentLoaded', function() {
+    'use strict';
+
+    // define plugin
+    $.fn.tabgroup = function() {
+
+      var $this = $(this);
+      var $openers = $('<div class="tab-group-openers"></div>');
+      $this.prepend($openers);
+
+      var openedByDefault = $this.data('tab-open') || 0;
+      var tabs = [];
+      var currentTab = {};
+
+      $this.find('.tab').each(function(i, t) {
+        var tab = $(t);
+        tab.data('tab-index', i);
+        var tabName = tab.data('tab-name') || 'Tab '+i;
+        var tabFile = tab.data('tab-file') || false;
+        var $opener = makeOpener(tabName, i);
+        $openers.append($opener);
+        if (tab.find('.tab-title')) {
+          tab.find('.tab-title').remove();
+        }
+        tab.hide();
+        var loaded = false;
+        tabs.push({index: i, name: tabName, file: tabFile, dom: tab, opener: $opener, loaded: false});
+      });
+
+      $this.on('click', 'a[href^="#"]', function(event) {
+        var $target = $(event.currentTarget);
+        var tab = getTabByName($target.attr('href').replace('#', ''));
+        if ( tab ) {
+          showTab(tab.index);
+        }
+        event.preventDefault();
+      });
+
+      function getTabByName(name) {
+        var it = -1;
+        $.each(tabs, function(i, t) {
+          if ( t.name.toLowerCase() === name.toLowerCase() ) {
+            it = i;
+          }
+        });
+        if ( it >= 0 ) {
+          return tabs[it];
+        } else {
+          return false;
+        }
+      }
+
+      function makeOpener(tabName, i) {
+        return $('<span class="tab-opener">'+tabName+'</span>').
+                on('click', function() {
+                  showTab(i);
+                });
+      }
+
+      function showTab(i) {
+        tabs.forEach(function(t) {
+          t.dom.hide();
+          t.opener.removeClass('tab-visible');
+        });
+        currentTab = tabs[i];
+        if ( !currentTab.loaded && currentTab.file ){
+          $.get(currentTab.file, function(res) {
+            currentTab.dom.html(res);
+            currentTab.loaded = true;
+          });
+        }
+        currentTab.opener.addClass('tab-visible');
+        currentTab.dom.show();
+      }
+
+      showTab(openedByDefault);
+      currentTab = tabs[openedByDefault];
+
+    };
+
+    // apply plugin to all available tab-groups
+    $('.tab-group').each(function(i, t) {
+      $(t).tabgroup();
+    })
+  });
+})($);

static/js/urlPolyfill.js

@@ -0,0 +1,348 @@
+(function(global) {
+  /**
+   * Polyfill URLSearchParams
+   *
+   * Inspired from : https://github.com/WebReflection/url-search-params/blob/master/src/url-search-params.js
+   */
+
+  var checkIfIteratorIsSupported = function() {
+    try {
+      return !!Symbol.iterator;
+    } catch(error) {
+      return false;
+    }
+  };
+
+
+  var iteratorSupported = checkIfIteratorIsSupported();
+
+  var createIterator = function(items) {
+    var iterator = {
+      next: function() {
+        var value = items.shift();
+        return { done: value === void 0, value: value };
+      }
+    };
+
+    if(iteratorSupported) {
+      iterator[Symbol.iterator] = function() {
+        return iterator;
+      };
+    }
+
+    return iterator;
+  };
+
+  /**
+   * Search param name and values should be encoded according to https://url.spec.whatwg.org/#urlencoded-serializing
+   * encodeURIComponent() produces the same result except encoding spaces as `%20` instead of `+`.
+   */
+  var serializeParam = function(value) {
+    return encodeURIComponent(value).replace(/%20/g, '+');
+  };
+
+  var deserializeParam = function(value) {
+    return decodeURIComponent(value).replace(/\+/g, ' ');
+  };
+
+  var polyfillURLSearchParams= function() {
+
+    var URLSearchParams = function(searchString) {
+      Object.defineProperty(this, '_entries', { value: {} });
+
+      if(typeof searchString === 'string') {
+        if(searchString !== '') {
+          searchString = searchString.replace(/^\?/, '');
+          var attributes = searchString.split('&');
+          var attribute;
+          for(var i = 0; i < attributes.length; i++) {
+            attribute = attributes[i].split('=');
+            this.append(
+              deserializeParam(attribute[0]),
+              (attribute.length > 1) ? deserializeParam(attribute[1]) : ''
+            );
+          }
+        }
+      } else if(searchString instanceof URLSearchParams) {
+        var _this = this;
+        searchString.forEach(function(value, name) {
+          _this.append(value, name);
+        });
+      }
+    };
+
+    var proto = URLSearchParams.prototype;
+
+    proto.append = function(name, value) {
+      if(name in this._entries) {
+        this._entries[name].push(value.toString());
+      } else {
+        this._entries[name] = [value.toString()];
+      }
+    };
+
+    proto.delete = function(name) {
+      delete this._entries[name];
+    };
+
+    proto.get = function(name) {
+      return (name in this._entries) ? this._entries[name][0] : null;
+    };
+
+    proto.getAll = function(name) {
+      return (name in this._entries) ? this._entries[name].slice(0) : [];
+    };
+
+    proto.has = function(name) {
+      return (name in this._entries);
+    };
+
+    proto.set = function(name, value) {
+      this._entries[name] = [value.toString()];
+    };
+
+    proto.forEach = function(callback, thisArg) {
+      var entries;
+      for(var name in this._entries) {
+        if(this._entries.hasOwnProperty(name)) {
+          entries = this._entries[name];
+          for(var i = 0; i < entries.length; i++) {
+            callback.call(thisArg, entries[i], name, this);
+          }
+        }
+      }
+    };
+
+    proto.keys = function() {
+      var items = [];
+      this.forEach(function(value, name) { items.push(name); });
+      return createIterator(items);
+    };
+
+    proto.values = function() {
+      var items = [];
+      this.forEach(function(value) { items.push(value); });
+      return createIterator(items);
+    };
+
+    proto.entries = function() {
+      var items = [];
+      this.forEach(function(value, name) { items.push([name, value]); });
+      return createIterator(items);
+    };
+
+    if(iteratorSupported) {
+      proto[Symbol.iterator] = proto.entries;
+    }
+
+    proto.toString = function() {
+      var searchString = '';
+      this.forEach(function(value, name) {
+        if(searchString.length > 0) searchString+= '&';
+        searchString += serializeParam(name) + '=' + serializeParam(value);
+      });
+      return searchString;
+    };
+
+    global.URLSearchParams = URLSearchParams;
+  };
+
+  if(!('URLSearchParams' in global) || (new URLSearchParams('?a=1').toString() !== 'a=1')) {
+    polyfillURLSearchParams();
+  }
+
+  // HTMLAnchorElement
+
+})(
+  (typeof global !== 'undefined') ? global
+    : ((typeof window !== 'undefined') ? window
+    : ((typeof self !== 'undefined') ? self : this))
+);
+
+(function(global) {
+  /**
+   * Polyfill URL
+   *
+   * Inspired from : https://github.com/arv/DOM-URL-Polyfill/blob/master/src/url.js
+   */
+
+  var checkIfURLIsSupported = function() {
+    try {
+      var u = new URL('b', 'http://a');
+      u.pathname = 'c%20d';
+      return (u.href === 'http://a/c%20d') && u.searchParams;
+    } catch(e) {
+      return false;
+    }
+  };
+
+
+  var polyfillURL = function() {
+    var _URL = global.URL;
+
+    var URL = function(url, base) {
+      if(typeof url !== 'string') url = String(url);
+
+      var doc = document.implementation.createHTMLDocument('');
+      window.doc = doc;
+      if(base) {
+        var baseElement = doc.createElement('base');
+        baseElement.href = base;
+        doc.head.appendChild(baseElement);
+      }
+
+      var anchorElement = doc.createElement('a');
+      anchorElement.href = url;
+      doc.body.appendChild(anchorElement);
+      anchorElement.href = anchorElement.href; // force href to refresh
+
+      if(anchorElement.protocol === ':' || !/:/.test(anchorElement.href)) {
+        throw new TypeError('Invalid URL');
+      }
+
+      Object.defineProperty(this, '_anchorElement', {
+        value: anchorElement
+      });
+    };
+
+    var proto = URL.prototype;
+
+    var linkURLWithAnchorAttribute = function(attributeName) {
+      Object.defineProperty(proto, attributeName, {
+        get: function() {
+          return this._anchorElement[attributeName];
+        },
+        set: function(value) {
+          this._anchorElement[attributeName] = value;
+        },
+        enumerable: true
+      });
+    };
+
+    ['hash', 'host', 'hostname', 'port', 'protocol', 'search']
+    .forEach(function(attributeName) {
+      linkURLWithAnchorAttribute(attributeName);
+    });
+
+    Object.defineProperties(proto, {
+
+      'toString': {
+        get: function() {
+          var _this = this;
+          return function() {
+            return _this.href;
+          };
+        }
+      },
+
+      'href' : {
+        get: function() {
+          return this._anchorElement.href.replace(/\?$/,'');
+        },
+        set: function(value) {
+          this._anchorElement.href = value;
+        },
+        enumerable: true
+      },
+
+      'pathname' : {
+        get: function() {
+          return this._anchorElement.pathname.replace(/(^\/?)/,'/');
+        },
+        set: function(value) {
+          this._anchorElement.pathname = value;
+        },
+        enumerable: true
+      },
+
+      'origin': {
+        get: function() {
+          // get expected port from protocol
+          var expectedPort = {'http:': 80, 'https:': 443, 'ftp:': 21}[this._anchorElement.protocol];
+          // add port to origin if, expected port is different than actual port
+          // and it is not empty f.e http://foo:8080
+          // 8080 != 80 && 8080 != ''
+          var addPortToOrigin = this._anchorElement.port != expectedPort &&
+            this._anchorElement.port !== ''
+
+          return this._anchorElement.protocol +
+            '//' +
+            this._anchorElement.hostname +
+            (addPortToOrigin ? (':' + this._anchorElement.port) : '');
+        },
+        enumerable: true
+      },
+
+      'password': { // TODO
+        get: function() {
+          return '';
+        },
+        set: function(value) {
+        },
+        enumerable: true
+      },
+
+      'username': { // TODO
+        get: function() {
+          return '';
+        },
+        set: function(value) {
+        },
+        enumerable: true
+      },
+
+      'searchParams': {
+        get: function() {
+          var searchParams = new URLSearchParams(this.search);
+          var _this = this;
+          ['append', 'delete', 'set'].forEach(function(methodName) {
+            var method = searchParams[methodName];
+            searchParams[methodName] = function() {
+              method.apply(searchParams, arguments);
+              _this.search = searchParams.toString();
+            };
+          });
+          return searchParams;
+        },
+        enumerable: true
+      }
+    });
+
+    URL.createObjectURL = function(blob) {
+      return _URL.createObjectURL.apply(_URL, arguments);
+    };
+
+    URL.revokeObjectURL = function(url) {
+      return _URL.revokeObjectURL.apply(_URL, arguments);
+    };
+
+    global.URL = URL;
+
+  };
+
+  if(!checkIfURLIsSupported()) {
+    polyfillURL();
+  }
+
+  if((global.location !== void 0) && !('origin' in global.location)) {
+    var getOrigin = function() {
+      return global.location.protocol + '//' + global.location.hostname + (global.location.port ? (':' + global.location.port) : '');
+    };
+
+    try {
+      Object.defineProperty(global.location, 'origin', {
+        get: getOrigin,
+        enumerable: true
+      });
+    } catch(e) {
+      setInterval(function() {
+        global.location.origin = getOrigin();
+      }, 100);
+    }
+  }
+
+})(
+  (typeof global !== 'undefined') ? global
+    : ((typeof window !== 'undefined') ? window
+    : ((typeof self !== 'undefined') ? self : this))
+);

templates/course.hamlet

@@ -1,34 +1,100 @@
-<div .course-header>
-  <div .course-header__info>
-    <table>
-      <tr>
-        <th>Teilnehmer
-        <td>
-          #{participants}
-          $maybe capacity <- courseCapacity course
-            \ von #{capacity}
-      <tr>
-        <th>Anmeldezeitraum
-        <td>
-          $maybe regFrom <- courseRegisterFrom course
-            #{formatTimeGerWD regFrom}
-          $maybe regTo   <- courseRegisterTo   course
-            \ bis #{formatTimeGerWD regTo}
-
-    <div>
-      <form method=post action=@{CourseR tid csh CourseShowR} enctype=#{regEnctype}>
-        ^{regWidget}
-
-  <div .course-header__title>
-    <h1>#{courseName course}
+<div .container>
+  <h2>#{courseName course}
+  <table>
     $maybe school <- schoolMB
-      <h4>#{schoolName school}
+      <tr>
+        <th #school>Fakultät/Institut
+        <td>
+          #{schoolName school}
+    $maybe descr <- courseDescription course
+      <tr>
+        <th #description>Beschreibung
+        <td>
+          <p>#{descr}
+    $maybe link <- courseLinkExternal course
+      <tr>
+        <th #website>Website
+        <td>
+          <a href=#{link}>#{link}
+    <tr>
+      <th #participants>Teilnehmer
+      <td>
+        #{participants}
+        $maybe capacity <- courseCapacity course
+          \ von #{capacity}
+    <tr>
+      <th #registration>Anmeldezeitraum
+      <td>
+        $maybe regFrom <- courseRegisterFrom course
+          #{formatTimeGerWD regFrom}
+        $maybe regTo   <- courseRegisterTo   course
+          \ bis #{formatTimeGerWD regTo}
 
+    <tr>
+      <th>
+      <td>
+        $# if allowed to register
+        <div .course__registration.container>
+          <button class="btn btn-primary">
+            <a href="#">Anmelden
+
+  $# <form method=post action=@{CourseR tid csh CShow} enctype=#{regEnctype}>
+  $#   ^{regWidget}
 
 <div .container>
-  $maybe descr <- courseDescription course
-    <h2 #description>Beschreibung
-    <p> #{descr}
-  $maybe link <- courseLinkExternal course
-    <h4 #linl>Homepage
-    <a href=#{link}>#{link}
+  <div .tab-group>
+    <div .tab data-tab-name="Übungsblätter">
+      ^{modal "#modal-toggler__new-sheet" Nothing}
+      <h3 .tab-title>Übungsblätter
+      <table .table.table-striped.table-hover>
+        <thead>
+          <tr>
+            <th>Blatt
+            <th>Abgabe ab
+            <th>Abgabe bis
+            <th>Bewertung</th>
+        <tbody>
+          <tr>
+            <td>
+              <a href="http://localhost:3000/course/S2018/ffp/ex/Blatt%201/show" role="button">Blatt 1
+            <td>Do 08.04.18
+            <td>Do 11.04.18
+            <td>NotGraded
+          <tr>
+            <td>
+              <a href="http://localhost:3000/course/S2018/ffp/ex/Blatt%201/show" role="button">Blatt 2
+            <td>Do 15.04.18
+            <td>Do 18.04.18
+            <td>NotGraded
+          <tr .no-hover.no-stripe>
+            <td colspan="4">
+              <a href="/course/S2018/ffp/ex/new" #modal-toggler__new-sheet>Neues Übungsblatt anlegen
+    <div .tab data-tab-name="Übungsgruppen">
+      <h3 .tab-title>Übungsgruppen
+      <table .table.table-striped.table-hover>
+        <thead>
+          <tr>
+            <th>Name
+            <th>Termin
+            <th>Raum
+            <th>Studenten
+            <th>Tutor
+            <th>Anmeldung bis
+        <tbody>
+          <tr>
+            <td>Gruppe 1
+            <td>Montag 10:00 - 12:00
+            <td>N/A
+            <td>2/10
+            <td>Tutor1 Tutoren
+            <td>Do 21.02.2019, 19:00
+          <tr>
+            <td>Gruppe 2
+            <td>Montag 12:00 - 14:00
+            <td>N/A
+            <td>0/10
+            <td>Assistant1 Assistant
+            <td>Di 21.02.2017, 19:00
+    <div .tab data-tab-name="Klausuren">
+      <h3 .tab-title>Klausuren
+      <div>...

templates/course.lucius

@@ -1,19 +1,3 @@
-.course-header {
-  /*display: flex;
-  flex-direction: row;
-  justify-content: space-between;*/
-}
-
-.course-header__title {
-  align-self: baseline;
-}
-.course-header__info {
-  border: 1px solid var(--greybase);
-  padding: 13px;
-  align-self: center;
-  float: right;
-}
-
-.course-header__info table {
-  margin: 0;
+.course__registration {
+  margin-top: 20px;
 }

templates/default-layout.hamlet

@@ -13,8 +13,17 @@
       $with status2 <- bool status "info" (status == "")
         <div class="alert alert-#{status2}">#{msg}
 
+    <!-- breadcrumbs -->
+    $if not $ Just HomeR == mcurrentRoute
+      ^{breadcrumbs}
+
+    $maybe headline <- contentHeadline
+      <h1>
+        ^{headline}
+
     <!-- prime page actions -->
     ^{pageactionprime}
 
     <!-- actual content -->
+
     ^{widget}

templates/default-layout.lucius

@@ -1,46 +1,18 @@
 :root {
-  /* THEME 1 */
-  --base00: #72a85b;
-  --base-bg-color: #1d1c1d;
-  --base-font-color: #fff;
-  --sec-font-color: #fff;
-  --box-bg-color: #3c3c3c;
-  /* THEME 2 */
-  --base00: #38428a;
-  --base-bg-color: #ffffff;
-  --base-font-color: rgb(53, 53, 53);
-  --sec-font-color: #eaf2ff;
-  --box-bg-color: #dddddd;
-  /* THEME 3 */
-  --darkbase: #364B60;
-  --lightbase: #2490E8;
-  --lighterbase: #60C2FF;
-  --whitebase: #FCFFFA;
-  --greybase: #B1B5C0;
-  --fontbase: #34303a;
-  --fontsec: #5b5861;
-  /* THEME 4 */
-  --darkbase: #263C4C;
-  --lightbase: #598EB5;
-  --lighterbase: #5F98C2;
-  --whitebase: #FCFFFA;
-  --greybase: #B1B5C0;
-  --lightgreybase: #D9DEDB;
-  --blackbase: #1A2A36;
-  --fontbase: #34303a;
-  --fontsec: #5b5861;
-  --primarybase: #4C7A9C;
-
-
   /* THEME INDEPENDENT COLORS */
-  --errorbase: red;
-  --warningbase: #fe7700;
-  --validbase: #2dcc35;
-  --infobase: var(--darkbase);
+  --color-error: red;
+  --color-warning: #fe7700;
+  --color-success: #2dcc35;
+  --color-info: #c4c4c4;
+  --color-lightblack: #1A2A36;
+  --color-lightwhite: #FCFFFA;
+  --color-grey: #B1B5C0;
+  --color-font: #34303a;
+  --color-fontsec: #5b5861;
 
 
   /* FONTS */
-  --fontfamilybase: "Source Sans Pro", Helvetica, sans-serif;
+  --font-base: "Source Sans Pro", Helvetica, sans-serif;
 
   /* DIMENSIONS */
   --header-height: 80px;
@@ -55,13 +27,64 @@
 
 body {
   background-color: white;
-  color: var(--fontbase);
-  font-family: var(--fontfamilybase);
+  color: var(--color-font);
+  font-family: var(--font-base);
   font-weight: 400;
   font-size: 16px;
   overflow-y: scroll;
 }
 
+/* THEMES */
+
+body {
+  /* DEFAULT THEME */
+  --color-primary: #4C7A9C;
+  --color-light: #598EB5;
+  --color-lighter: #5F98C2;
+  --color-dark: #425d79;
+  --color-darker: #274a65;
+  --color-link: var(--color-dark);
+  --color-link-hover: var(--color-darker);
+
+
+  &.theme--neutral-blue {
+    --color-primary: #3E606F;
+    --color-light: rgb(189, 201, 219);
+    --color-lighter: rgb(145, 159, 170);
+    --color-dark: #3E606F;
+    --color-darker: #193441;
+  }
+
+  &.theme--aberdeen-reds {
+    --color-primary: #820333;
+    --color-light: #C9283E;
+    --color-lighter: #F0433A;
+    --color-dark: #540032;
+    --color-darker: #2E112D;
+  }
+
+  &.theme--mint-green {
+    --color-primary: #5C996B;
+    --color-light: #7ACC8F;
+    --color-lighter: #99FFB2;
+    --color-dark: #3D6647;
+    --color-darker: #1F3324;
+  }
+
+  &.theme--sky-love {
+    --color-primary: #87ABE5;
+    --color-light: #A0C6F2;
+    --color-lighter: #BAE2FF;
+    --color-dark: #7A95DE;
+    --color-darker: #6B7BC9;
+    --color-link: var(--color-lightblack);
+    --color-link-hover: var(--color-darker);
+  }
+
+}
+
+/* END THEMES */
+
 a,
 a:visited {
   text-decoration: none;
@@ -69,6 +92,15 @@ a:visited {
   transition: color .2s ease, background-color .2s ease;
 }
 
+a {
+  color: var(--color-link);
+}
+
+a:hover {
+  color: var(--color-link-hover);
+}
+
+
 ul {
   list-style-type: none;
 }
@@ -105,18 +137,35 @@ table {
   overflow: auto;
 }
 
+.table-striped {
+
+  tbody {
+    tr:not(.no-stripe):nth-child(even) {
+      background-color: #e8e8e8;
+    }
+  }
+}
+
+.table-hover {
+
+  tbody {
+    tr:not(.no-hover):hover {
+      background-color: #d8d8d8;
+    }
+  }
+}
+
 th, td {
   text-align: left;
-  padding: 0 13px 0 7px;
+  padding: 7px;
   vertical-align: baseline;
 }
 th:first-child,
 td:first-child {
-  padding-left: 0;
   border-left: 0;
 }
 th {
-  border-left: 2px solid var(--greybase);
+  border-left: 2px solid var(--color-grey);
 }
 /* LAYOUT */
 .main {
@@ -140,18 +189,10 @@ th {
   p {
     margin: 10px 0;
   }
-
-  a {
-    color: var(--darkbase);
-  }
-
-  a:hover {
-    color: var(--lightbase);
-  }
 }
 
 .pseudo-focus {
-  outline: 5px auto var(--lightbase);
+  outline: 5px auto var(--color-light);
   outline: 5px auto -webkit-focus-ring-color;
 }
 
@@ -163,28 +204,22 @@ button,
   outline: 0;
   border: 0;
   box-shadow: 0;
-  background-color: var(--lightbase);
+  background-color: var(--color-dark);
   color: white;
   padding: 10px 17px;
   min-width: 100px;
   transition: all .1s;
   font-size: 16px;
   cursor: pointer;
-  border-radius: 4px;
   display: inline-block;
-}
-input.btn-primary,
-button.btn-primary,
-a.btn.btn-primary,
-.btn.btn-primary {
-  background-color: var(--primarybase);
-}
 
-input.btn-info,
-button.btn-info,
-a.btn.btn-info,
-.btn.btn-info {
-  background-color: var(--infobase)
+  a {
+    color: white;
+  }
+
+  a:hover {
+    color: white;
+  }
 }
 
 input[type="submit"][disabled],
@@ -193,7 +228,7 @@ button[disabled],
 a.btn[disabled],
 .btn[disabled] {
   opacity: 0.3;
-  background-color: var(--greybase);
+  background-color: var(--color-grey);
   cursor: default;
 }
 
@@ -202,20 +237,33 @@ input[type="button"]:not([disabled]):hover,
 button:not([disabled]):hover,
 a.btn:not([disabled]):hover,
 .btn:not([disabled]):hover {
-  background-color: var(--lighterbase);
+  background-color: var(--color-light);
   text-decoration: underline;
   color: white;
 }
 
+input.btn-primary,
+button.btn-primary,
+a.btn.btn-primary,
+.btn.btn-primary {
+  background-color: var(--color-primary);
+}
+
+input.btn-info,
+button.btn-info,
+a.btn.btn-info,
+.btn.btn-info {
+  background-color: var(--color-info)
+}
+
 input[type="submit"].btn-info:hover,
 input[type="button"].btn-info:hover,
 button.btn-info:hover,
 a.btn.btn-info:hover,
 .btn.btn-info:hover {
-  background-color: var(--greybase)
+  background-color: var(--color-grey)
 }
 
 .alert-debug {
   background-color: rgb(240, 30, 240);
 }
-

templates/home.hamlet

@@ -1,5 +1,5 @@
 <div .container>
-  <h1>UniworkY - Demo
+  <h1>Uniworky - Demo
   <h3>
     Testumgebung für die Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
   <p>
@@ -49,24 +49,6 @@
       ^{modal ".toggler1" Nothing}
       <a href="/" .btn.toggler1>Klick mich für Ajax-Test
         <noscript>(Für Modals bitte JS aktivieren)</noscript>
-      ^{modal ".toggler2" (Just "Test wegen Modal")}
+      ^{modal ".toggler2" (Just "Test Inhalt für Modal")}
       <div .btn.toggler2>Klick mich für Content-Test
         <noscript>(Für Modals bitte JS aktivieren)</noscript>
-
-    <li><br>
-      Multi-File-Input für bereits hochgeladene Dateien:
-      <form>
-        <div .form-group>
-          <label .form-group__label>Datei(en)
-          $# file 1
-          <div .file-checkbox__container>
-            <label .file-checkbox__label.reactive-label.btn for="f2-1">Datenschutz.txt
-            <div .checkbox>
-              <input .file-checkbox id="f2-1" name="f2" value="Datenschutz.txt" type="checkbox">
-              <label for="f2-1">
-          $# file 2
-          <div .file-checkbox__container>
-            <label .file-checkbox__label.reactive-label.btn for="f2-2">fill-db.hs
-            <div .checkbox>
-              <input .file-checkbox id="f2-2" name="f2" value="fill-db.hs" type="checkbox">
-              <label for="f2-2">

templates/multiFileField.hamlet

@@ -6,13 +6,6 @@ $forall FileUploadInfo{..} <- fileInfos
       <input .file-checkbox.js-file-checkbox id=#{fuiHtmlId} name=#{fieldName} :fuiChecked:checked value=#{toPathPiece fuiId} type="checkbox">
       <label for=#{fuiHtmlId}>
 
-
-<div .file-checkbox__container.file-checkbox__container--checked>
-  <label .file-checkbox__label.reactive-label.btn for=fi1>file1.txt
-  <div .checkbox>
-    <input .file-checkbox.js-file-checkbox id=fi1 name=file checked value="file1.txt" type="checkbox">
-    <label for=fi1>
-
 $# new files
 <input type="file" name=#{fieldName} multiple>
 

templates/sheetShow.hamlet

@@ -25,15 +25,6 @@
         <div .row>
             <div .col-lg-12>     
                 <h2>Dateien
-                <ul>
-                  $forall fileLink <- fileLinks
-                    <li>
-                      $case fileLink
-                        $of CourseR _ _ (SheetR (SheetFileR _ typ name))
-                          #{toPathPiece typ}
-                          <a href=@{fileLink}>#{name}
-                        $of other
-                          <a href=@{fileLink}>@{fileLink}
-
+                ^{fileTable}
     <hr>
 

templates/standalone/inputs.julius

@@ -63,7 +63,6 @@
         if (formGroup.classList.contains('form-group')) {
           formGroup.classList.add('form-group--valid')
         }
-        submitBtn.removeAttribute('disabled');
         if (isMulti) {
           addNextInput();
         }
@@ -71,7 +70,6 @@
         if (formGroup.classList.contains('form-group')) {
           formGroup.classList.remove('form-group--valid')
         }
-        submitBtn.setAttribute('disabled', 'disabled');
       }
     }
     // addseventlistener destInput

templates/standalone/inputs.lucius

@@ -13,21 +13,9 @@ form {
   grid-gap: 5px;
   justify-content: flex-start;
   align-items: center;
-  margin: 10px 0;
+  margin: 17px 0;
   padding-left: 10px;
-  border-left: 8px solid transparent;
-}
-
-.form-group--required {
-  border-left: 8px solid var(--lighterbase);
-}
-
-.form-group--valid {
-  border-left: 8px solid var(--validbase);
-}
-
-.form-group--has-error {
-  border-left: 8px solid var(--errorbase) !important;
+  border-left: 2px solid transparent;
 }
 
 .form-group__label {
@@ -56,16 +44,54 @@ input[type="password"],
 input[type="url"],
 input[type="number"],
 input[type="email"] {
-  background-color: rgba(0, 0, 0, 0.05);
-  padding: 7px 3px 7px;
-  outline: 0;
-  border: 0;
-  border-bottom: 2px solid var(--darkbase);
-  box-shadow: 0 2px 13px rgba(0, 0, 0, 0.05);
-  color: var(--fontbase);
-  transition: all .1s;
-  font-size: 16px;
+  /* from bulma.css */
+  background-color: #fff;
+  border-color: #dbdbdb;
+  color: #363636;
+  box-shadow: inset 0 2px 3px 1px rgba(50,50,50,.1);
   min-width: 400px;
+  -webkit-appearance: none;
+  align-items: center;
+  border: 1px solid transparent;
+  border-radius: 4px;
+  display: inline-flex;
+  font-size: 1rem;
+  height: 2.25em;
+  justify-content: flex-start;
+  line-height: 1.5;
+  padding-bottom: calc(.375em - 1px);
+  padding-left: calc(.625em - 1px);
+  padding-right: calc(.625em - 1px);
+  padding-top: calc(.375em - 1px);
+  position: relative;
+  vertical-align: top;
+}
+
+.form-group--required {
+
+  .form-group__label::before {
+    content: '*';
+    position: absolute;
+    left: -14px;
+  }
+
+  input, textarea {
+    border-bottom-color: var(--color-lighter);
+  }
+}
+
+.form-group--valid {
+
+  input, textarea {
+    border-bottom-color: var(--color-success);
+  }
+}
+
+.form-group--has-error {
+
+  input, textarea {
+    border-bottom-color: var(--color-error);
+  }
 }
 
 input[type="text"]:focus,
@@ -73,30 +99,42 @@ input[type="password"]:focus,
 input[type="url"]:focus,
 input[type="number"]:focus,
 input[type="email"]:focus {
-  border-bottom-color: var(--lightbase);
+  /* border-bottom-color: var(--color-light);
   background-color: transparent;
+  box-shadow: 0 0 13px var(--color-lighter); */
+  border-color: #3273dc;
+  box-shadow: 0 0 0 0.125em rgba(50,115,220,.25);
+  outline: 0;
 }
 
 /* BUTTON STYLE SEE default-layout.lucius */
 
 /* TEXTAREAS */
 textarea {
-  outline: 0;
-  border: 0;
-  padding: 7px 4px;
-  min-width: 400px;
-  min-height: 100px;
-  font-family: var(--fontfamilybase);
-  font-size: 16px;
-  color: var(--fontbase);
-  background-color: rgba(0, 0, 0, 0.05);
-  box-shadow: 0 2px 13px rgba(0, 0, 0, 0.05);
-  border-bottom: 2px solid var(--darkbase);
+  -webkit-appearance: none;
+  border: 1px solid transparent;
+  border-radius: 2px;
+  display: inline-flex;
+  font-size: 1rem;
+  height: 170px;
+  width: 400px;
+  line-height: 1.5;
+  padding-bottom: calc(.375em - 1px);
+  padding-left: calc(.625em - 1px);
+  padding-right: calc(.625em - 1px);
+  padding-top: calc(.375em - 1px);
+  position: relative;
+  vertical-align: top;
+  background-color: #fff;
+  border-color: #dbdbdb;
+  color: #363636;
+  box-shadow: inset 0 1px 2px rgba(10,10,10,.1);
 }
 
 textarea:focus {
-  background-color: transparent;
-  border-bottom-color: var(--lightbase);
+  border-color: #3273dc;
+  box-shadow: 0 0 0 0.125em rgba(50,115,220,.25);
+  outline: 0;
 }
 
 /* CUSTOM LEGACY CHECKBOX AND RADIO BOXES */
@@ -112,14 +150,14 @@ input[type="checkbox"]::before {
   position: absolute;
   width: 20px;
   height: 20px;
-  background-color: var(--lighterbase);
+  background-color: var(--color-lighter);
   display: flex;
   align-items: center;
   justify-content: center;
   border-radius: 2px;
 }
 input[type="checkbox"]:checked::before {
-  background-color: var(--lightbase);
+  background-color: var(--color-light);
 }
 input[type="checkbox"]:checked::after {
   content: '✓';
@@ -148,7 +186,7 @@ input[type="checkbox"]:checked::after {
     display: block;
     height: 30px;
     width: 30px;
-    background-color: var(--greybase);
+    background-color: var(--color-grey);
     border-radius: 4px;
     color: white;
     cursor: pointer;
@@ -180,12 +218,12 @@ input[type="checkbox"]:checked::after {
   }
 
   > :checked + label {
-    background-color: var(--lightbase);
+    background-color: var(--color-light);
     text-decoration: underline;
   }
 
   &:hover > label {
-    background-color: var(--lighterbase);
+    background-color: var(--color-lighter);
   }
 
   &:hover > label::before {
@@ -231,13 +269,13 @@ input[type="checkbox"]:checked::after {
 /* REACTIVE LABELS */
 .reactive-label {
   cursor: text;
-  color: var(--fontsec);
+  color: var(--color-fontsec);
   transform: translate(0, 0);
   transition: all .1s;
 }
 .reactive-label--small {
   cursor: default;
-  color: var(--fontbase);
+  color: var(--color-font);
 }
 @media (max-width: 999px) {
   .reactive-label {
@@ -246,7 +284,7 @@ input[type="checkbox"]:checked::after {
   }
   .reactive-label--small {
     transform: translate(2px, 0px);
-    color: var(--fontsec);
+    color: var(--color-fontsec);
     /*font-size: 14px;*/
   }
 }
@@ -281,7 +319,7 @@ input[type="file"].js-file-input {
   display: block;
   border-radius: 2px;
   padding: 5px 13px;
-  color: var(--whitebase);
+  color: var(--color-lightwhite);
   cursor: pointer;
 }
 .file-input__label,
@@ -291,7 +329,7 @@ input[type="file"].js-file-input {
   height: 30px;
 }
 .file-checkbox__label {
-  background-color: var(--greybase);
+  background-color: var(--color-grey);
   text-decoration: line-through;
 }
 .file-input__label.btn,
@@ -325,7 +363,7 @@ input[type="file"].js-file-input {
   width: 40px;
   height: 30px;
   text-align: center;
-  background-color: var(--warningbase);
+  background-color: var(--color-warning);
   position: relative;
   margin-left: 10px;
 }
@@ -339,14 +377,14 @@ input[type="file"].js-file-input {
   background-color: white;
 }
 .file-input__container--valid > .file-input__label {
-  background-color: var(--lightbase);
+  background-color: var(--color-light);
 }
 .file-checkbox__container--checked > .file-checkbox__label {
   text-decoration: none;
-  background-color: var(--lighterbase);
+  background-color: var(--color-lighter);
 
   &.btn:hover {
-    background-color: var(--lighterbase);
+    background-color: var(--color-lighter);
     text-decoration: line-through;
   }
 }

templates/standalone/modal.julius

@@ -10,6 +10,8 @@
     var origParent = modal.parentNode;
 
     function open(event) {
+      // disable modals for narrow screens
+      if (window.innerWidth < 768) return true;
       if (event) {
         event.preventDefault();
       }
@@ -64,7 +66,9 @@
         replaceMe.classList.remove('replace-me');
         replaceMe.innerText = '...loading';
         if (replaceWith.length > 0) {
-          fetch(replaceWith).then(function(response) {
+          fetch(replaceWith, {
+            credentials: 'same-origin'
+          }).then(function(response) {
             return response.text();
           }).then(function(body) {
             var modalContent = document.createElement('div');

templates/standalone/modal.lucius

@@ -10,7 +10,7 @@
   max-height: calc(100vh - 30px);
   border-radius: 7px;
   z-index: -1;
-  color: var(--fontbase);
+  color: var(--color-font);
   padding: 20px;
   overflow: auto;
   opacity: 0;
@@ -70,7 +70,7 @@
   justify-content: center;
   width: 30px;
   height: 30px;
-  background-color: var(--darkbase);
+  background-color: var(--color-darker);
   border-radius: 2px;
   cursor: pointer;
   z-index: 20;

templates/standalone/showHide.lucius

@@ -24,12 +24,12 @@
   left: -28px;
   top: 10px;
   border-left: 8px solid transparent;
-  border-top: 8px solid var(--lightbase);
+  border-top: 8px solid var(--color-light);
 }
 
 .js-show-hide__toggle:hover::before,
 .js-show-hide--collapsed .js-show-hide__toggle::before {
-  border-left: 8px solid var(--lightbase);
+  border-left: 8px solid var(--color-light);
   border-top: 8px solid transparent;
   top: 5px;
   left: -22px;

templates/standalone/sortable.hamlet

@@ -1 +0,0 @@
-<!-- only here to be able to include sortable using `toWidget` -->

templates/standalone/sortable.julius

@@ -1,107 +0,0 @@
-/**
- * delcare a table as sortable by adding class 'js-sortable'
- */
- (function() {
-   'use strict';
-
-   window.utils = window.utils || {};
-
-   window.utils.sortable = function(table) {
-     var ASC = 1;
-     var DESC = -1;
-
-     var trs, ths, sortBy, sortDir, trContents;
-
-     function setup() {
-         trs = table.querySelectorAll('tr');
-         ths = table.querySelectorAll('th');
-         sortBy = 0;
-         sortDir = ASC;
-         trContents = [];
-
-         Array.from(trs).forEach(function(tr, rowIndex) {
-             if (rowIndex === 0) {
-                 // register table headers as sort-listener
-                 Array.from(tr.querySelectorAll('th')).forEach(function(th, thIndex) {
-                     th.addEventListener('click', function(el) {
-                         sortTableBy(thIndex);
-                     });
-                 });
-             } else {
-                 // register table rows
-                 trContents.push(Array.from(tr.querySelectorAll('td')).map(function(td) {
-                     return td.innerHTML;
-                 }));
-             }
-         });
-     }
-     setup();
-
-     function updateThs(thIndex, sortOrder) {
-         Array.from(ths).forEach(function (th) {
-             th.classList.remove('sorted-asc', 'sorted-desc');
-         });
-         var suffix = sortOrder > 0 ? 'asc' : 'desc';
-         ths[thIndex].classList.add('sorted-' + suffix);
-     }
-
-     function sortTableBy(thIndex) {
-         var sortKey = thIndex;
-         var sortOrder = ASC;
-         if (sortBy === sortKey) {
-             sortOrder = sortDir === ASC ? DESC : ASC;
-         }
-
-         trContents.sort(dynamicSortByType(sortKey, sortOrder));
-         trContents.sort(dynamicSortByKey(sortKey, sortOrder));
-         sortBy = thIndex;
-         sortDir = sortOrder;
-         updateThs(thIndex, sortOrder);
-
-         Array.from(trs).forEach(function(tr, trIndex) {
-             if (trIndex > 0) {
-                 Array.from(tr.querySelectorAll('td')).forEach(function (td, tdIndex) {
-                     td.innerHTML = trContents[trIndex - 1][tdIndex];
-                 });
-             }
-         });
-     }
-
-     function dynamicSortByKey(key, order) {
-         return function (a,b) {
-             var aVal = parseInt(a[key]);
-             var bVal = parseInt(b[key]);
-             if ((isNaN(aVal) && !isNaN(bVal)) || (!isNaN(aVal) && isNaN(bVal))) {
-               return 1;
-             }
-             aVal = isNaN(aVal) ? a[key] : aVal;
-             bVal = isNaN(bVal) ? b[key] : bVal;
-             var result = (aVal < bVal) ? -1 : (aVal > bVal) ? 1 : 0;
-             return result * order;
-         }
-     }
-
-     function dynamicSortByType(key, order) {
-         return function (a,b) {
-             var aVal = parseInt(a[key]);
-             var bVal = parseInt(b[key]);
-             aVal = isNaN(aVal) ? a[key] : aVal;
-             bVal = isNaN(bVal) ? b[key] : bVal;
-             var res = (aVal < bVal ? -1 : aVal > bVal ? 1 : 0);
-             if (isNaN(aVal) && !isNaN(bVal)) {
-               res = -1;
-             }
-             if (!isNaN(aVal) && isNaN(bVal)) {
-               res = 1;
-             }
-             return res * order;
-         }
-     }
-   };
- })();
-
-document.addEventListener('DOMContentLoaded', function() {
-    Array.from(document.querySelectorAll('.js-sortable')).forEach(function(table) {
-        utils.sortable(table);
-    });
-});

templates/standalone/sortable.lucius

@@ -1,31 +0,0 @@
-table.js-sortable th {
-  cursor: pointer;
-  position: relative;
-  padding-right: 20px;
-}
-
-table.js-sortable th.sorted-asc,
-table.js-sortable th.sorted-desc {
-  color: var(--darkbase);
-}
-
-table.js-sortable th.sorted-asc::after,
-table.js-sortable th.sorted-desc::after {
-  content: '';
-  position: absolute;
-  right: 0;
-  top: 15px;
-  width: 0;
-  height: 0;
-  transform: translateY(-100%);
-  border-left: 8px solid transparent;
-  border-right: 8px solid transparent;
-}
-
-table.js-sortable th.sorted-asc::after {
-  border-top: 8px solid var(--lightbase);
-}
-
-table.js-sortable th.sorted-desc::after {
-  border-bottom: 8px solid var(--lightbase);
-}

templates/standalone/tabber.hamlet

@@ -0,0 +1 @@
+<!-- only here to be able to include tabber using `toWidget` -->

templates/standalone/tabber.lucius

@@ -0,0 +1,7 @@
+.tab-opener {
+  background-color: var(--color-dark);
+
+  &.tab-visible {
+    border-bottom-color: var(--color-primary);
+  }
+}

templates/submission.hamlet

@@ -27,13 +27,13 @@
         <div .panel-heading>
           Abgabe herunterladen
         <div .panel-body .text-center>
-          <a href=@{SubmissionDownloadArchiveR archiveName} download .btn .btn-lg .btn-default>
+          $#<a href=@{SubmissionDownloadArchiveR archiveName} download .btn .btn-lg .btn-default>
             <span .glyphicon .glyphicon-cloud-download aria-hidden="true"> ZIP-Archive
     <div .col-md-6>
       <div .panel .panel-default>
         <div .panel-heading>
           Abgabe ersetzen
-        <form role=form method=post action=@{SubmissionR cID} enctype=#{uploadEnctype} .panel-body>
+        <form role=form method=post action=@{SubmissionDemoR cID} enctype=#{uploadEnctype} .panel-body>
           ^{uploadWidget}
 
 <div .panel .panel-default>

templates/table-layout.hamlet

@@ -1,4 +0,0 @@
-<div .table>
-  ^{table}
-  <p style="text-align:center">
-    _{MsgPage (succ psPage) pageCount}

templates/table/colonnade.hamlet

@@ -0,0 +1,12 @@
+<table id="#{dbtIdent}">
+  $maybe sortableP <- pSortable
+    $with toSortable <- toSortable sortableP
+      <thead>
+        $forall OneColonnade{..} <- getColonnade dbtColonnade
+          ^{widgetFromCell th $ withSortLinks $ toSortable oneColonnadeHead}
+  $nothing
+  <tbody>
+    $forall row <- rows
+      <tr>
+        $forall OneColonnade{..} <- getColonnade dbtColonnade
+          ^{widgetFromCell td $ oneColonnadeEncode row}

templates/table/colonnade.lucius

@@ -0,0 +1,45 @@
+table th {
+  position: relative;
+  padding-right: 20px;
+
+  &.sortable {
+    cursor: pointer;
+  }
+
+  a {
+    font-weight: 800;
+  }
+}
+
+table th.sorted-asc,
+table th.sorted-desc {
+  color: var(--color-light);
+}
+
+table th.sortable::after,
+table th.sortable::before {
+  content: '';
+  position: absolute;
+  right: 0;
+  width: 0;
+  height: 0;
+  transform: translateY(-100%);
+  border-left: 8px solid transparent;
+  border-right: 8px solid transparent;
+}
+
+table th.sortable::before {
+  top: 21px;
+  border-top: 8px solid rgba(0, 0, 0, 0.1);
+}
+table th.sortable::after {
+  top: 9px;
+  border-bottom: 8px solid rgba(0, 0, 0, 0.1);
+}
+table th.sorted-asc::before {
+  border-top: 8px solid var(--color-light);
+}
+
+table th.sorted-desc::after {
+  border-bottom: 8px solid var(--color-light);
+}

templates/table/layout.hamlet

@@ -0,0 +1,10 @@
+$newline never
+<div ##{dbtIdent}-table-wrapper>
+  <div .scrolltable>
+    ^{table}
+  $if pageCount > 1
+    <ul ##{dbtIdent}-pagination .pagination>
+      $forall p <- pageNumbers
+        <li .pagination-link :p == psPage:.current>
+          <a href=#{tblLink $ setParam (wIdent "page") (Just $ tshow p)}>
+            _{MsgPage (succ p)}

templates/table/layout.julius

@@ -0,0 +1,70 @@
+(function collonadeClosure() {
+  'use strict';
+
+  document.addEventListener('DOMContentLoaded', function DOMContentLoaded() {
+
+    var ASC = 'asc';
+    var DESC = 'desc';
+
+    function setupAsync(wrapper) {
+
+      var table = wrapper.querySelector('#' + #{String $ dbtIdent});
+      var ths = Array.from(table.querySelectorAll('th.sortable'));
+      if (ths) {
+        // attach click handler to each sortable column if any
+        ths.forEach(function(th) {
+          th.addEventListener('click', clickHandler);
+        });
+      }
+
+      var pagination = wrapper.querySelector('#' + #{String $ dbtIdent} + '-pagination');
+      if (pagination) {
+        var paginationLinks = Array.from(pagination.querySelectorAll('.pagination-link'));
+        // attach click handler to pagination links if any
+        paginationLinks.forEach(function(p) {
+          p.addEventListener('click', clickHandler);
+        });
+      }
+
+      function clickHandler(event) {
+        event.preventDefault();
+        var url = new URL(window.location.origin + window.location.pathname + getClickDestination(this));
+        url.searchParams.set(#{String $ wIdent "table-only"}, 'yes');
+        updateTableFrom(url);
+      }
+
+      function getClickDestination(el) {
+        var link = el.querySelector('a');
+        if (!link) { return false; }
+        return link.getAttribute('href');
+      }
+
+      // fetches new sorted table from url with params and replaces contents of current table
+      function updateTableFrom(url) {
+        fetch(url, {
+          credentials: 'same-origin',
+          headers: {
+            'Accept': 'text/html'
+          }
+        }).then(function(response) {
+          var contentType = response.headers.get("content-type");
+          if (!response.ok) {
+            throw ('Looks like there was a problem fetching ' + url.toString() + '. Status Code: ' + response.status);
+          }
+          return response.text();
+        }).then(function(data) {
+          // replace contents of table body
+          wrapper.innerHTML = data;
+          // set up async functionality again
+          setupAsync(wrapper);
+          table.querySelector('tbody').innerHTML = data;
+        }).catch(function(err) {
+          console.error(err);
+        });
+      }
+    }
+
+    var selector = '#' + #{String $ dbtIdent} + '-table-wrapper';
+    setupAsync(document.querySelector(selector));
+  });
+})();

templates/table/layout.lucius

@@ -0,0 +1,38 @@
+.pagination {
+  margin-top: 20px;
+  text-align: center;
+
+  .pagination-link {
+    margin: 0 7px;
+    display: inline-block;
+    background-color: var(--color-grey);
+
+    a {
+      color: var(--color-lightwhite);
+      padding: 7px 13px;
+      display: inline-block;
+    }
+
+    &:not(.current):hover {
+      background-color: var(--color-lighter);
+
+      a {
+        color: var(--color-lightwhite);
+      }
+    }
+
+    &.current {
+      pointer-events: none;
+      background-color: var(--color-light);
+
+      a {
+        text-decoration: underline;
+        pointer-events: none;
+      }
+    }
+
+    &:last-child {
+      margin-right: 0;
+    }
+  }
+}

templates/table/sortable-header.hamlet

@@ -0,0 +1,10 @@
+$maybe flag <- sortableKey
+  $case directions
+    $of [SortAsc]
+      <a href=#{tblLink $ setParam (wIdent "sorting") (Just $ flag <> "-desc")}>
+        ^{cellContents}
+    $of _
+      <a href=#{tblLink $ setParam (wIdent "sorting") (Just $ flag <> "-asc")}>
+        ^{cellContents}
+$nothing
+  ^{cellContents}

templates/terms.hamlet

@@ -1,5 +1,2 @@
 <div .container>
-  <h1>Semesterübersicht
-
-  <div .scrolltable>
-    ^{table}
+  ^{table}

templates/widgets/asidenav.hamlet

@@ -8,8 +8,7 @@ $newline never
             $of NavbarAside (MenuItem label mIcon route _)
               <li .asidenav__list-item :Just route == mcurrentRoute:.asidenav__list-item--active>
                 <a .asidenav__link-wrapper href=@{route}>
-                  $if isJust mIcon
-                    <div .glyphicon.glyphicon--#{fromMaybe "" mIcon}>
+                  <div .glyphicon.glyphicon--#{fromMaybe "none" mIcon}>
                   <div .asidenav__link-label>#{label}
             $of _
 
@@ -17,22 +16,28 @@ $newline never
       <h3 .asidenav__box-title>
         WiSe 17/18
       <ul .asidenav__list>
-        $forall (Entity _ Course{..}) <- favourites
+        $forall (Course{..}, courseRoute, pageActions) <- favourites
           <li .asidenav__list-item>
-            <a .asidenav__link-wrapper href=@{CourseR courseTermId courseShorthand CourseShowR}>
+            <a .asidenav__link-wrapper href=@{courseRoute}>
               <div .asidenav__link-shorthand>#{courseShorthand}
               <div .asidenav__link-label>#{courseName}
+            <ul .asidenav__nested-list>
+              $forall action <- pageActions
+                $case action
+                  $of PageActionPrime (MenuItem{..})
+                    <li .asidenav__nested-list-item>
+                      <a .asidenav__link-wrapper href=@{menuItemRoute}>#{menuItemLabel}
+                  $of _
+
+    <div .asidenav__box>
+      <h3 .asidenav__box-title>
+        Themes (dev)
+      <select #theme-selector>
+        <option value="default">Default Blue
+        <option value="neutral-blue">Neutral Blue
+        <option value="aberdeen-reds">Aberdeen Reds
+        <option value="mint-green">Mint Green
+        <option value="sky-love">Sky Love
 
-        <li .asidenav__list-item>
-          <a .asidenav__link-wrapper href="/course/S2018/ixd/show">
-            <div .asidenav__link-shorthand>EXAMPLE
-            <div .asidenav__link-label>Beispiel-Kurs
-          <ul .asidenav__nested-list>
-            <li .asidenav__list-item>
-              <a .asidenav__link-wrapper href="/course/S2018/ixd/ex">Übungsblätter
-            <li .asidenav__list-item>
-              <a .asidenav__link-wrapper href="/course/S2018/ixd/show">Klausuren
-            <li .asidenav__list-item>
-              <a .asidenav__link-wrapper href="/course/S2018/ixd/show">Übungsgruppen
 
   <div .asidenav__toggler>

templates/widgets/asidenav.julius

@@ -4,7 +4,7 @@
   window.utils = window.utils || {};
 
   // Defines a function to turn an element into an interactive aside-navigation.
-  // If the small is smaller than 999px the navigation is automatically
+  // If the screen is smaller than 999px the navigation is automatically
   // collapsed - even when dynamically resized (e.g. switching from portatit
   // to landscape).
   // The can user may also manually collapse and expand the navigation by
@@ -16,7 +16,7 @@
     // (potentially happening) initial collapse of the asidenav
     // goes unnoticed by the user.
     var animClass = 'main__aside--transitioning';
-    var aboveCollapsedNav = false;
+    var hoveringAboveCollapsedNav = false;
 
     init();
     function init() {
@@ -62,17 +62,21 @@
         if (!hasCollapsedClass()) {
           return false;
         }
-        aboveCollapsedNav = true;
+        hoveringAboveCollapsedNav = true;
         window.setTimeout(function() {
-          if (aboveCollapsedNav && !document.body.classList.contains('touch-supported')) {
+          if (hoveringAboveCollapsedNav && !document.body.classList.contains('touch-supported')) {
             asideEl.classList.add('pseudo-hover');
           }
-        }, 800);
+        }, 200);
       }, false);
 
       asideEl.addEventListener('mouseleave', function(event) {
-        aboveCollapsedNav = false;
-        asideEl.classList.remove('pseudo-hover');
+        hoveringAboveCollapsedNav = false;
+        window.setTimeout(function() {
+          if (!hoveringAboveCollapsedNav) {
+            asideEl.classList.remove('pseudo-hover');
+          }
+        }, 200);
       }, false);
     }
   };
@@ -82,4 +86,36 @@ document.addEventListener('DOMContentLoaded', function() {
 
     utils.aside(document.querySelector('.main__aside'));
 
+    // remove me before flight:
+    // EXPERIMENTAL
+    var selector = document.querySelector('#theme-selector');
+    var options = Array.from(selector.querySelectorAll('option'))
+      .reduce(function(acc, optEl) {
+          if (!acc.includes(optEl.value)) {
+            acc.push(optEl.value);
+          }
+          return acc;
+        },
+        []);
+
+    selector.addEventListener('change', function(event) {
+      setTheme(event.target.value);
+    });
+
+    function setTheme(theme) {
+      document.body.className = 'theme--' + theme;
+    }
+
+    // random theme on loading and again every 20 seconds
+    // setInterval(function() {
+    //   setTheme(randomOption());
+    // }, 20000);
+
+    // function randomOption() {
+    //   return options[Math.floor(Math.random() * options.length)];
+    // }
+
+    // // initial theme
+    // setTheme(randomOption());
+
 });

templates/widgets/asidenav.lucius

@@ -1,6 +1,6 @@
 .main__aside {
   position: relative;
-  background-color: var(--darkbase);
+  background-color: var(--color-dark);
   box-shadow: 0 0 10px rgba(0, 0, 0, 0.3);
   z-index: 1;
   flex: 0 0 300px;
@@ -12,48 +12,8 @@
   transition: opacity .2s ease;
 }
 
-.main__aside--collapsed.pseudo-hover {
-  overflow: visible;
-}
-.main__aside--collapsed {
-  width: 50px;
-  flex-basis: 50px;
-  overflow: hidden;
-
-  .asidenav__box-title {
-    width: 50px;
-    padding: 0;
-  }
-
-  .asidenav__link-wrapper {
-    .asidenav__link-shorthand {
-      display: flex;
-      position: static;
-      background-color: var(--darkbase);
-      color: var(--whitebase);
-      height: 50px;
-      width: 50px;
-      text-align: center;
-      opacity: 1;
-      font-size: 16px;
-      line-height: 1em;
-      margin-right: 13px;
-      flex-shrink: 0;
-      outline: 1px solid white;
-      text-transform: uppercase;
-      word-break: break-all;
-      align-items: center;
-      justify-content: center;
-    }
-    .asidenav__link-label {
-      padding-left: 0;
-    }
-  }
-}
-
 .asidenav {
   width: 300px;
-  margin-top: 20px;
   color: white;
 
   .js-show-hide__target {
@@ -78,82 +38,50 @@
 
 .asidenav__box-title {
   padding: 7px 13px;
-
-  a {
-    color: white;
-  }
-}
-
-/* hover sub-menus */
-.asidenav__nested-list {
-  position: absolute;
-  top: 0;
-  right: 0;
-  color: var(--fontbase);
-  transform: translateX(0);
-  opacity: 0;
-  transition: all .2s ease-out;
-  width: 0;
-  overflow: hidden;
-  z-index: -1;
-
-  .asidenav__list-item {
-    background-color: var(--darkbase);
-    color: white;
-
-    &:first-child {
-      margin-top: 0;
-    }
-  }
-
-  .asidenav__link-wrapper {
-    padding-left: 13px;
-    padding-right: 13px;
-    border-left: 20px solid white;
-    transition: all .2s ease;
-
-    &:hover {
-      background-color: white;
-      color: var(--darkbase) !important;
-      border-left: 20px solid var(--darkbase);
-    }
-  }
+  margin-top: 13px;
+  background-color: transparent;
+  transition: all .2s ease;
 }
 
 .asidenav__list-item {
   position: relative;
-  background-color: white;
-  color: var(--darkbase);
+  color: var(--color-lightwhite);
   margin: 4px 0;
 
-  &:not(.asidenav__list-item--active):hover {
-    color: white;
-    background-color: var(--darkbase);
+  &:hover {
+    color: var(--color-link);
+    background-color: var(--color-lightwhite);
+
+    .asidenav__link-shorthand {
+      transform: scale(1.05, 1.0);
+      transform-origin: right;
+      text-shadow: none;
+    }
+
+    > .asidenav__link-wrapper {
+      color: var(--color-link);
+    }
 
     .asidenav__nested-list {
       transform: translateX(100%);
       opacity: 1;
       width: 200px;
     }
-
-    .asidenav__link-wrapper,
-    .asidenav__link-label {
-      color: white;
-    }
-
-    .asidenav__link-shorthand {
-      transform: scale(1.05, 1.0);
-      transform-origin: right;
-    }
   }
 }
+
 .asidenav__list-item--active {
-  background-color: var(--darkbase);
-  color: white;
+  background-color: var(--color-lightwhite);
 
   .asidenav__link-wrapper {
     pointer-events: none;
-    color: white;
+    color: var(--color-link);
+  }
+
+  .asidenav__link-shorthand {
+    transform: scale(1.05, 1.0);
+    transform-origin: right;
+    text-shadow: none;
   }
 }
 
@@ -163,35 +91,81 @@
   height: 50px;
   align-items: center;
   justify-content: flex-start;
-  color: var(--darkbase);
+  color: var(--color-lightwhite);
   z-index: 1;
 
   .glyphicon {
     width: 50px;
   }
 
-  .asidenav__link-shorthand {
-    display: block;
-    position: absolute;
-    color: var(--greybase);
-    line-height: 50px;
-    opacity: 0.3;
-    right: 10px;
-    top: 0;
-    font-size: 40px;
-    text-transform: uppercase;
-    transition: transform .2s ease;
-  }
-
-  .asidenav__link-label {
-    padding-left: 13px;
-  }
 
   .glyphicon + .asidenav__link-label {
     padding-left: 0;
   }
 }
 
+.asidenav__link-shorthand {
+  display: block;
+  position: absolute;
+  color: var(--color-grey);
+  line-height: 50px;
+  opacity: 0.2;
+  right: 10px;
+  top: 0;
+  font-size: 40px;
+  text-transform: uppercase;
+  transition: transform .2s ease;
+  text-shadow: 1px 1px 4px rgba(30, 30, 30, 0.8);
+}
+
+.asidenav__link-label {
+  padding-left: 13px;
+}
+
+/* hover sub-menus */
+.asidenav__nested-list {
+  position: absolute;
+  top: 0;
+  right: 0;
+  color: var(--color-font);
+  transform: translateX(0);
+  opacity: 0;
+  transition: all .2s ease-out;
+  width: 0;
+  overflow: hidden;
+  z-index: -1;
+}
+
+.asidenav__nested-list-item {
+  position: relative;
+  color: var(--color-lightwhite);
+  background-color: var(--color-dark);
+
+  &:hover {
+    color: var(--color-link);
+    background-color: var(--color-lightwhite);
+
+    .asidenav__link-wrapper {
+      background-color: white;
+      color: var(--color-link);
+    }
+
+    .asidenav__nested-list {
+      transform: translateX(100%);
+      opacity: 1;
+      width: 200px;
+    }
+  }
+
+  .asidenav__link-wrapper {
+    padding-left: 13px;
+    padding-right: 13px;
+    border-left: 20px solid white;
+    transition: all .2s ease;
+    color: var(--color-lightwhite);
+  }
+}
+
 .asidenav__toggler {
   position: absolute;
   bottom: 20px;
@@ -201,22 +175,78 @@
   align-items: center;
   justify-content: center;
   transition: background-color .2s ease;
-  border-top: 1px solid var(--whitebase);
-  border-bottom: 1px solid var(--whitebase);
+  border-top: 1px solid var(--color-lightwhite);
+  border-bottom: 1px solid var(--color-lightwhite);
   cursor: pointer;
 
   &::before {
     content: '\e079';
     display: block;
     font-family: 'Glyphicons Halflings';
-    color: var(--whitebase);
+    color: var(--color-lightwhite);
   }
 
   &:hover {
-    background-color: var(--lightbase);
+    background-color: var(--color-light);
   }
 }
 
-.main__aside--collapsed .asidenav__toggler::before {
-  content: '\e080';
+.main__aside--collapsed {
+  width: 50px;
+  flex-basis: 50px;
+  overflow: hidden;
+
+  &.pseudo-hover {
+    overflow: visible;
+  }
+
+  .asidenav__toggler::before {
+    content: '\e080';
+  }
+
+  .asidenav__box-title {
+    width: 50px;
+    padding: 1px;
+    font-size: 18px;
+    text-align: center;
+    margin-bottom: 0;
+  }
+
+  .asidenav__link-shorthand {
+    display: flex;
+    position: static;
+    background-color: var(--color-dark);
+    color: var(--color-lightwhite);
+    height: 50px;
+    width: 50px;
+    text-align: center;
+    opacity: 1;
+    font-size: 15px;
+    line-height: 1em;
+    margin-right: 13px;
+    flex-shrink: 0;
+    padding: 1px;
+    outline: 1px solid white;
+    text-transform: uppercase;
+    word-break: break-all;
+    align-items: center;
+    justify-content: center;
+  }
+
+  .asidenav__list-item:hover {
+
+    > .asidenav__link-wrapper {
+      color: var(--color-dark);
+      background-color: var(--color-lightwhite);
+    }
+  }
+
+  .asidenav__link-wrapper {
+    color: var(--color-lightwhite);
+    background-color: var(--color-dark);
+  }
+
+  .asidenav__link-label {
+    padding-left: 0;
+  }
 }

templates/widgets/breadcrumbs.hamlet

@@ -1,7 +1,7 @@
+$newline never
 <div .breadcrumbs__container>
   <ul .breadcrumbs__list.list--inline>
     $forall bc <- parents
       <li .breadcrumbs__item>
         <a .breadcrumbs__link href="@{fst bc}">#{snd bc}
-        &gt;
-    <li .breadcrumbs__item--active>#{title}
+    <li .breadcrumbs__item.breadcrumbs__item--active>#{title}

templates/widgets/breadcrumbs.lucius

@@ -3,12 +3,82 @@
   color: white;
   z-index: 10;
   align-self: flex-end;
-  margin-bottom: 20px;
+  margin-bottom: 10px;
   transition: margin-bottom .2s ease;
+  margin-left: -40px;
+  margin-right: -40px;
+  background-color: var(--color-dark);
 }
 .breadcrumbs__container--animated {
   transition: left .2s ease;
 }
-.breadcrumbs__container .breadcrumbs__link {
-  color: white;
+.breadcrumbs__link {
+  color: var(--color-lightwhite);
+  z-index: 2;
+}
+
+.breadcrumbs__item {
+  padding-left: 10px;
+  padding-right: 4px;
+  position: relative;
+  line-height: 28px;
+
+  &:nth-child(even) {
+    background-color: var(--color-light);
+  }
+
+  &:first-child {
+    padding-left: 20px;
+  }
+
+  &:nth-child(even) {
+    background-color: var(--color-light);
+
+    &::before {
+      border-left-color: var(--color-primary) !important;
+    }
+
+    &::after {
+      border-left-color: var(--color-light) !important;
+    }
+  }
+
+  &:nth-child(odd) {
+    background-color: var(--color-primary);
+
+    &::before {
+      border-left-color: var(--color-light) !important;
+    }
+
+    &::after {
+      border-left-color: var(--color-primary) !important;
+    }
+  }
+
+  &:not(:first-child) {
+    padding-left: 25px;
+
+    &::before {
+      content: '';
+      position: absolute;
+      top: 0;
+      left: 0;
+      border-top: 14px solid transparent;
+      border-bottom: 14px solid transparent;
+      border-left: 14px solid var(--color-light);
+    }
+  }
+
+  &:last-child {
+
+    &::after {
+      content: '';
+      position: absolute;
+      top: 0;
+      right: -14px;
+      border-top: 14px solid transparent;
+      border-bottom: 14px solid transparent;
+      border-left: 14px solid var(--color-light);
+    }
+  }
 }

templates/widgets/form.julius

@@ -4,8 +4,8 @@
   window.utils = window.utils || {};
 
   // registers input-listener for each element in <elements> (array) and
-  // enables <button> if <fn> for these elements returns true
-  window.utils.reactiveButton = function(elements, button, fn) {
+  // enables <button> if <validation> for these elements returns true
+  window.utils.reactiveButton = function(elements, button, validation) {
     if (elements.length == 0) {
       return false;
     }
@@ -19,7 +19,7 @@
     });
 
     function updateButtonState() {
-      if (fn.call(null, elements)) {
+      if (validation.call(null, elements) === true) {
         button.removeAttribute('disabled');
       } else {
         button.setAttribute('disabled', 'true');
@@ -36,7 +36,7 @@ document.addEventListener('DOMContentLoaded', function() {
     var requireds = form.querySelectorAll('[required]');
     var submitBtn = form.querySelector('[type=submit]');
     if (submitBtn && requireds) {
-      window.utils.reactiveButton(Array.from(requireds), submitBtn, function(inputs) {
+      window.utils.reactiveButton(Array.from(requireds), submitBtn, function validateForm(inputs) {
         var done = true;
         inputs.forEach(function(inp) {
           var len = inp.value.trim().length;

templates/widgets/modal.hamlet

@@ -1,18 +1,8 @@
 <div .modal.js-modal #modal-#{modalId} data-trigger=#{modalTrigger} data-closeable=true>
+  $# primitive way of checking if this is supposed to be add a placeholder for async data.
+  $# modalContent is 'placeholder' if there should be a placeholder only.
+  $# 'placeholder' has length 11.
   $if 11 == length modalContent
     <div .replace-me>
   $else
-    <h2>Neue Veranstaltung
     #{modalContent}
-    <form>
-      <div .form-group>
-        <label .reactive-label for="inp1">Name
-        <input type="text" id="inp1">
-      <div .form-group>
-        <label .reactive-label for="inp2">Kürzel
-        <input type="text" id="inp2">
-      <div .form-group>
-        <label .reactive-label for="inp3">Semester
-        <input type="text" id="inp3">
-      <div .form-group>
-        <input type="submit" value="Submit">

templates/widgets/navbar.hamlet

@@ -2,10 +2,6 @@ $newline never
 <div .navbar-container>
   <nav .navbar.js-sticky-navbar>
 
-    <!-- breadcrumbs -->
-    $if not $ Just HomeR == mcurrentRoute
-      ^{breadcrumbs}
-
     <ul .navbar__list.list--inline>
       $forall menuType <- menuTypes
         $case menuType

templates/widgets/navbar.lucius

@@ -7,18 +7,17 @@
   width: 100%;
   height: var(--header-height);
   padding-right: 5vw;
-  padding-left: 340px;
-  background: var(--darkbase); /* Old browsers */
-  background: -moz-linear-gradient(bottom, var(--darkbase) 0%, #425d79 100%); /* FF3.6-15 */
-  background: -webkit-linear-gradient(bottom, var(--darkbase) 0%,#425d79 100%); /* Chrome10-25,Safari5.1-6 */
-  background: linear-gradient(to top, var(--darkbase) 0%,#425d79 100%); /* W3C, IE10+, FF16+, Chrome26+, Opera12+, Safari7+ */
+  background: var(--color-darker); /* Old browsers */
+  background: -moz-linear-gradient(bottom, var(--color-dark) 0%, var(--color-darker) 100%); /* FF3.6-15 */
+  background: -webkit-linear-gradient(bottom, var(--color-dark) 0%,var(--color-darker) 100%); /* Chrome10-25,Safari5.1-6 */
+  background: linear-gradient(to top, var(--color-dark) 0%,var(--color-darker) 100%); /* W3C, IE10+, FF16+, Chrome26+, Opera12+, Safari7+ */
   color: white;
-  box-shadow: 0 1px 10px rgba(0, 0, 0, 0.1);
   z-index: 10;
   top: 0;
   left: 0;
   overflow: hidden;
   transition: height 0.2s ease;
+  box-shadow: 0 0 4px rgba(0, 0, 0, 0.2);
 }
 
 .navbar__list {
@@ -50,7 +49,7 @@
   justify-content: center;
   align-items: center;
   height: 80px;
-  color: var(--whitebase);
+  color: var(--color-lightwhite);
   transition: height .2s ease;
 }
 
@@ -63,7 +62,7 @@
 
 .navbar__list-item--secondary {
   margin-left: 20px;
-  color: var(--greybase);
+  color: var(--color-grey);
 }
 .navbar__list-item--secondary + .navbar__list-item--secondary {
   margin-left: 0;
@@ -72,32 +71,31 @@
 
 .navbar__list-item--active {
   background-color: white;
-  color: var(--darkbase);
+  color: var(--color-dark);
 
   .navbar__link-wrapper {
-    color: var(--darkbase);
+    color: var(--color-dark);
   }
 }
 .navbar__list-item--active .navbar__link-wrapper {
   pointer-events: none;
 }
 .navbar__list-item--active .navbar__link-label {
-  color: var(--darkbase);
+  color: var(--color-dark);
 }
 
 .navbar .navbar__list-item:not(.navbar__list-item--active):hover {
-  background-color: var(--darkbase);
-  color: var(--whitebase);
+  background-color: var(--color-darker);
 }
 .navbar .navbar__list-item:not(.navbar__list-item--active):hover .navbar__link-wrapper {
-  color: var(--whitebase);
+  color: var(--color-lightwhite);
 }
 .navbar .navbar__list-item:not(.navbar__list-item--active):hover .navbar__link-label {
-  color: var(--whitebase);
+  color: var(--color-lightwhite);
 }
 .navbar__list-item--secondary .navbar__link-wrapper,
 .navbar__list-item--secondary .navbar__link-label {
-  color: var(--greybase);
+  color: var(--color-grey);
 }
 
 .navbar--sticky {

templates/widgets/pageactionprime.hamlet

@@ -1,7 +1,6 @@
 $newline never
 $if hasPageActions
   <div .page-nav-prime>
-    <h3>Aktionen:
     <ul .pagenav__list>
       $forall menuType <- menuTypes
         $case menuType

templates/widgets/pageactionprime.lucius

@@ -1,21 +1,13 @@
 .page-nav-prime {
-  background-color: var(--lightgreybase);
-  box-shadow: -20px -20px 0 20px var(--lightgreybase),
-              20px -20px 0 20px var(--lightgreybase);
-  padding: 13px 0;
+  background-color: rgba(200, 200, 200, 0.2);
+  padding: 13px;
+  margin-top: 30px;
 }
 
 .page-nav-prime .pagenav__list {
-  margin: 7px 0 0;
   display: block;
 }
 .page-nav-prime .pagenav__list-item {
   display: inline-block;
-  border-bottom: 2px solid var(--lightbase);
   margin-right: 7px;
-  transition: border-bottom-color .2s ease;
-
-  &:hover {
-    border-bottom-color: var(--lighterbase);
-  }
 }