Merge branch 'master' into 'live'

Fancier Breadcrumbs, Sheet-UploadMode, Overhauled Authentication

Closes #190, #189, #188, #150, #148, #147, #86, #186, #183, and #181

See merge request !77

ChangeLog.md

@@ -10,6 +10,8 @@
 
     Intelligente Verteilung von Abgaben auf Korrektoren (z.B. bei Krankheit)
     
+    Übungsblätter können Abgabe von Dateien verbieten und angeben ob ZIP-Archive entpackt werden sollen
+
   * Version 06.08.2018
   
     Einführung einer Option, ob Dateien automatisch heruntergeladen werden sollen

config/settings.yml

@@ -13,9 +13,12 @@ detailed-logging:  "_env:DETAILED_LOGGING:false"
 should-log-all:    "_env:LOG_ALL:false"
 minimum-log-level: "_env:LOGLEVEL:warn"
 auth-dummy-login:  "_env:DUMMY_LOGIN:false"
-auth-pwfile:       "_env:PWFILE:"
 allow-deprecated:  "_env:ALLOW_DEPRECATED:false"
 
+auth-pw-hash:
+  algorithm: "pbkdf2"
+  strength: 14
+
 # Optional values with the following production defaults.
 # In development, they default to true.
 # reload-templates: false
@@ -42,7 +45,7 @@ ldap:
   timeout: "_env:LDAPTIMEOUT:5"
 
 user-defaults:
-  favourites:       12
+  max-favourites:   12
   theme:            Default
   date-time-format: "%a %d %b %Y %R"
   date-format:      "%d.%m.%Y"

db.hs

@@ -66,8 +66,8 @@ fillDb = do
     winter2017 = TermIdentifier 2017 Winter
     summer2018 = TermIdentifier 2018 Summer
   gkleen <- insert User
-    { userPlugin = "LDAP"
+    { userIdent  = "G.Kleen@campus.lmu.de"
-    , userIdent  = "G.Kleen@campus.lmu.de"
+    , userAuthentication = AuthLDAP
     , userMatrikelnummer = Nothing
     , userEmail  = "G.Kleen@campus.lmu.de"
     , userDisplayName = "Gregor Kleen"
@@ -80,8 +80,8 @@ fillDb = do
     , userDownloadFiles = userDefaultDownloadFiles
     }
   fhamann <- insert User
-    { userPlugin = "LDAP"
+    { userIdent  = "felix.hamann@campus.lmu.de"
-    , userIdent  = "felix.hamann@campus.lmu.de"
+    , userAuthentication = AuthLDAP
     , userMatrikelnummer = Nothing
     , userEmail  = "felix.hamann@campus.lmu.de"
     , userDisplayName = "Felix Hamann"
@@ -94,8 +94,8 @@ fillDb = do
     , userDownloadFiles = userDefaultDownloadFiles
     }
   jost <- insert User
-    { userPlugin = "LDAP"
+    { userIdent  = "jost@tcs.ifi.lmu.de"
-    , userIdent  = "jost@tcs.ifi.lmu.de"
+    , userAuthentication = AuthLDAP
     , userMatrikelnummer = Nothing
     , userEmail  = "jost@tcs.ifi.lmu.de"
     , userDisplayName = "Steffen Jost"
@@ -108,8 +108,8 @@ fillDb = do
     , userDownloadFiles = userDefaultDownloadFiles
     }
   void . insert $ User
-    { userPlugin = "LDAP"
+    { userIdent  = "max@campus.lmu.de"
-    , userIdent  = "max@campus.lmu.de"
+    , userAuthentication = AuthLDAP
     , userMatrikelnummer = Nothing
     , userEmail  = "max@campus.lmu.de"
     , userDisplayName = "Max Musterstudent"
@@ -122,8 +122,8 @@ fillDb = do
     , userDownloadFiles = userDefaultDownloadFiles
     }
   void . insert $ User
-    { userPlugin = "LDAP"
+    { userIdent  = "tester@campus.lmu.de"
-    , userIdent  = "tester@campus.lmu.de"
+    , userAuthentication = AuthLDAP
     , userMatrikelnummer = Just "999"
     , userEmail  = "tester@campus.lmu.de"
     , userDisplayName = "Tina Tester"
@@ -196,11 +196,11 @@ fillDb = do
   void . insert $ DegreeCourse ffp sdMst sdInf
   void . insert $ Lecturer jost   ffp
   void . insert $ Lecturer gkleen ffp
-  sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing
+  sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True)
   insert_ $ SheetEdit gkleen now sheetkey
-  sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing
+  sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True)
   insert_ $ SheetEdit gkleen now sheetkey
-  sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing
+  sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True)
   insert_ $ SheetEdit gkleen now sheetkey
   -- EIP
   eip <- insert Course
@@ -284,6 +284,7 @@ fillDb = do
     , sheetVisibleFrom = Just now
     , sheetActiveFrom = now
     , sheetActiveTo = (14 * nominalDay) `addUTCTime` now 
+    , sheetUploadMode = Upload True
     , sheetHintFrom = Nothing
     , sheetSolutionFrom = Nothing
     }

messages/dummy/de.msg

@@ -0,0 +1 @@
+DummyIdent: Nutzer-Kennung

messages/pw-hash/de.msg

@@ -0,0 +1,2 @@
+PWHashIdent: Identifikation
+PWHashPassword: Passwort

messages/uniworx/de.msg

@@ -5,6 +5,7 @@ BtnRegister: Anmelden
 BtnDeregister: Abmelden
 BtnHijack: Sitzung übernehmen
 
+Aborted: Abgebrochen
 Registered: Angemeldet
 RegisterFrom: Anmeldungen von
 RegisterTo: Anmeldungen bis
@@ -41,10 +42,10 @@ CourseRegisterOk: Sie wurden angemeldet
 CourseDeregisterOk: Sie wurden abgemeldet
 CourseSecretWrong: Falsches Kennwort
 CourseSecret: Zugangspasswort
-CourseNewOk        tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich erstellt.
+CourseNewOk        tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt.
-CourseEditOk       tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich geändert.
+CourseEditOk       tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich geändert.
-CourseNewDupShort  tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
+CourseNewDupShort  tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester.
-CourseEditDupShort tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
+CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester.
 FFSheetName: Name
 TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
 TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{display school}
@@ -52,7 +53,7 @@ CourseListTitle: Alle Kurse
 TermCourseListTitle   tid@TermId: Kurse #{display tid}
 TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{display school}
 CourseNewHeading: Neuen Kurs anlegen
-CourseEditHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} editieren
+CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren
 CourseEditTitle: Kurs editieren/anlegen
 CourseMembers: Teilnehmer
 CourseMembersCount num@Int64: #{display num}
@@ -71,20 +72,25 @@ CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich
 CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein
 CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
 
+NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
+NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
+NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{display csh} bekannt.
+NoSuchCourse: Keinen passenden Kurs gefunden.
 
 Sheet: Blatt
-SheetList          tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Übersicht Übungsblätter
+SheetList          tid@TermId ssh@SchoolId csh@CourseShorthand: #{display tid}-#{display ssh}-#{csh} Übersicht Übungsblätter
-SheetNewHeading    tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Neues Übungsblatt anlegen
+SheetNewHeading    tid@TermId ssh@SchoolId csh@CourseShorthand: #{display tid}-#{display ssh}-#{csh} Neues Übungsblatt anlegen
-SheetNewOk         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wurde als neues Übungsblatt im Kurs #{display tid}-#{display ssh}-#{courseShortHand} erfolgreich erstellt.
+SheetNewOk         tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wurde als neues Übungsblatt im Kurs #{display tid}-#{display ssh}-#{csh} erfolgreich erstellt.
-SheetTitle         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
+SheetTitle         tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}
-SheetTitleNew      tid@TermId ssh@SchoolId courseShortHand@CourseShorthand                    : #{display tid}-#{display ssh}-#{courseShortHand}: Neues Übungsblatt
+SheetTitleNew      tid@TermId ssh@SchoolId csh@CourseShorthand                    : #{display tid}-#{display ssh}-#{csh}: Neues Übungsblatt
-SheetEditHead      tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} editieren
+SheetEditHead      tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren
-SheetEditOk        tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde gespeichert.
+SheetEditOk        tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{csh} wurde gespeichert.
-SheetNameDup       tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{courseShortHand}.
+SheetNameDup       tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}.
-SheetDelHead       tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} herauslöschen?
+SheetDelHead       tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{csh} herauslöschen?
 SheetDelText       submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
-SheetDelOk         tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: #{sheetName} gelöscht.
+SheetDelOk         tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
 
+SheetUploadMode: Abgabe von Dateien
 SheetExercise: Aufgabenstellung
 SheetHint: Hinweis
 SheetHintFrom: Hinweis ab
@@ -116,12 +122,12 @@ Deadline: Abgabe
 Done: Eingereicht
 
 Submission: Abgabenummer
-SubmissionsCourse tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{display ssh}-#{courseShortHand}
+SubmissionsCourse tid@TermId ssh@SchoolId csh@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{display ssh}-#{csh}
 SubmissionsSheet sheetName@SheetName: Abgaben für #{sheetName}
 SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
 SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
-SubmissionEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
+SubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen
-CorrectionHead     tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Korrektur
+CorrectionHead     tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Korrektur
 SubmissionMember g@Int: Mitabgebende(r) ##{display g}
 SubmissionArchive: Zip-Archiv der Abgabedatei(en)
 SubmissionFile: Datei zur Abgabe
@@ -163,7 +169,7 @@ TooManyParticipants: Es wurden zu viele Mitabgebende angegeben
 
 AddCorrector: Zusätzlicher Korrektor
 CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
-SheetCorrectorsTitle tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
+SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
 CountTutProp: Tutorien zählen gegen Proportion
 Corrector: Korrektor
 Correctors: Korrektoren
@@ -184,7 +190,7 @@ Users: Benutzer
 HomeHeading: Aktuelle Termine
 LoginHeading: Authentifizierung
 LoginTitle: Authentifizierung
-ProfileHeading: Benutzerprofil und Einstellungen
+ProfileHeading: Benutzereinstellungen
 ProfileDataHeading: Gespeicherte Benutzerdaten
 ImpressumHeading: Impressum
 
@@ -196,7 +202,7 @@ MatrikelNr: Matrikelnummer
 Theme: Oberflächen Design
 Favoriten: Anzahl gespeicherter Favoriten
 Plugin: Plugin
-Ident: Identifizierung
+Ident: Identifikation
 Settings: Individuelle Benutzereinstellungen
 SettingsUpdate: Einstellungen wurden gespeichert.
 
@@ -218,11 +224,14 @@ NoCorrector: Kein Korrektor
 RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt.
 UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den Korrektoren aufgeteilt.
 CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden:
+SelfCorrectors num@Int64: #{display num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt!
+
 
 CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
 NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden.
 
 RatingBy: Korrigiert von
+AssignedTime: Zuteilung
 AchievedBonusPoints: Erreichte Bonuspunkte
 AchievedNormalPoints: Erreichte Punkte
 AchievedPassPoints: Erreichte Punkte
@@ -280,8 +289,23 @@ SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
 SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}.
 
 LDAPLoginTitle: Campus-Login
+PWHashLoginTitle: Uni2Work-Login
+PWHashLoginNote: Dieses Formular ist zu verwenden, wenn Sie vom Uni2Work-Team spezielle Logindaten erhalten haben. Normale Nutzer melden sich bitte via Campus-Login an!
 DummyLoginTitle: Development-Login
 
 CorrectorNormal: Normal
 CorrectorMissing: Abwesend
 CorrectorExcused: Entschuldigt
+
+DayIsAHoliday     tid@TermId date@Text: #{date} ist ein Feiertag
+DayIsOutOfLecture tid@TermId date@Text: #{date} ist außerhalb der Vorlesungszeit des #{display tid}
+DayIsOutOfTerm    tid@TermId date@Text: #{date} liegt nicht im #{display tid}
+
+UploadModeNone: Kein Upload
+UploadModeUnpack: Upload, einzelne Datei
+UploadModeNoUnpack: Upload, ZIP-Archive entpacken
+
+SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
+
+FieldPrimary: Hauptfach
+FieldSecondary: Nebenfach

models

@@ -1,6 +1,6 @@
 User json
-    plugin         Text
+    ident          (CI Text)
-    ident          Text
+    authentication AuthenticationMode
     matrikelnummer Text Maybe
     email          (CI Text)
     displayName    Text
@@ -11,7 +11,7 @@ User json
     dateFormat     DateTimeFormat "default='%d.%m.%Y'"
     timeFormat     DateTimeFormat "default='%R'"
     downloadFiles  Bool default=false
-    UniqueAuthentication plugin ident
+    UniqueAuthentication ident
     UniqueEmail email
     deriving Show
 UserAdmin
@@ -41,7 +41,7 @@ StudyTerms
     Primary key
 Term json
     name          TermIdentifier -- unTermKey :: TermId -> TermIdentifier
-    start         Day            -- TermKey   :: TermIdentifier -< TermId
+    start         Day            -- TermKey   :: TermIdentifier -> TermId
     end           Day
     holidays      [Day]
     lectureStart  Day 
@@ -54,7 +54,7 @@ School json
     shorthand     (CI Text)
     UniqueSchool name
     UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
-    Primary shorthand  -- newtype Key School = School { unSchoolKey :: SchoolShorthand }
+    Primary shorthand  -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
     deriving Eq    
 DegreeCourse json
     course       CourseId
@@ -108,6 +108,7 @@ Sheet
     activeTo        UTCTime
     hintFrom        UTCTime Maybe
     solutionFrom    UTCTime Maybe
+    uploadMode      UploadMode
     CourseSheet course name
 SheetEdit
     user            UserId
@@ -132,10 +133,11 @@ File
     deriving Show Eq
 Submission
     sheet           SheetId
-    ratingPoints    Points  Maybe
+    ratingPoints    Points  Maybe -- "Just" does not mean done
-    ratingComment   Text    Maybe 
+    ratingComment   Text    Maybe -- "Just" does not mean done
-    ratingBy        UserId  Maybe
+    ratingBy        UserId  Maybe -- assigned corrector
-    ratingTime      UTCTime Maybe   
+    ratingAssigned  UTCTime Maybe -- time assigned corrector
+    ratingTime      UTCTime Maybe -- "Just" here indicates done!
     deriving Show
 SubmissionEdit
     user            UserId

routes

@@ -39,7 +39,7 @@
 /info                       VersionR          GET             !free
 
 /profile                    ProfileR          GET POST        !free                             !free
-/profile/data               ProfileDataR      GET             !free                             !free
+/profile/data               ProfileDataR      GET POST        !free                             !free
 
 /term                      TermShowR         GET             !free
 /term/current              TermCurrentR      GET             !free
@@ -55,10 +55,15 @@
 -- For Pattern Synonyms see Foundation
 /course/                    CourseListR       GET             !free
 !/course/new                CourseNewR        GET POST        !lecturer
+!/course/new/#{Maybe TermId}/#{Maybe SchoolId}/#{Maybe CourseShorthand}   CourseNewTemplateR GET   !lecturer
 /course/#TermId/#SchoolId/#CourseShorthand CourseR          !lecturer:
   /                           CShowR          GET             !free
   /register                   CRegisterR          POST        !timeANDcapacity
   /edit                       CEditR          GET POST
+  /delete                     CDeleteR        GET POST        !lecturerANDempty
+  /users                      CUsersR         GET
+  /user/#CryptoUUIDUser       CUserR          GET
+  /correctors                 CHiWisR         GET
   /subs                       CCorrectionsR   GET POST
   /ex                         SheetListR      GET             !registered !materials
   !/ex/new                    SheetNewR       GET POST
@@ -77,10 +82,6 @@
     /correctors                 SCorrR        GET POST
     !/#SheetFileType/*FilePath  SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
 
--- /user/#CryptoUUIDUser
--- /users
--- /correctors
-
 
 /corrections  CorrectionsR GET POST !corrector !lecturer
 /corrections/upload CorrectionsUploadR GET POST !corrector !lecturer

src/Application.hs

@@ -206,13 +206,10 @@ handler h = getAppDevSettings >>= makeFoundation >>= flip unsafeHandler h
 db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a
 db = handler . runDB
 
-addPWEntry :: FilePath {-^ Password file -}
+addPWEntry :: User
-           -> User
            -> Text {-^ Password -}
            -> IO ()
-addPWEntry pwFile User{..} (Text.encodeUtf8 -> pw) = do
+addPWEntry User{..} (Text.encodeUtf8 -> pw) = db $ do
-  (Text.decodeUtf8 -> pwHash) <- makePassword pw 14
+  PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings
-  let pwEntry = PWEntry{ pwUser = User{ userPlugin = "PWFile", .. }, .. }
+  (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
-      newUser = userIdent
+  void $ insert User{..}
-  c <- either (const []) id <$> Yaml.decodeFileEither pwFile
-  Yaml.encodeFile pwFile $ pwEntry : [ c' | c'@(PWEntry{pwUser=User{..}}) <- c, userIdent /= newUser ]

src/Auth/Dummy.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , TemplateHaskell
+           , FlexibleContexts
+           , TypeFamilies
+           , OverloadedStrings
+  #-}
+
+module Auth.Dummy
+  ( dummyLogin
+  , DummyMessage(..)
+  ) where
+
+import Import.NoFoundation
+import Database.Persist.Sql (SqlBackendCanRead)
+
+import Utils.Form
+  
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+
+data DummyMessage = MsgDummyIdent
+
+
+dummyForm :: ( RenderMessage site FormMessage
+             , RenderMessage site DummyMessage
+             , YesodPersist site
+             , SqlBackendCanRead (YesodPersistBackend site)
+             , Button site SubmitButton
+             , Show (ButtonCssClass site)
+             ) => AForm (HandlerT site IO) (CI Text)
+dummyForm = areq (selectField userList) (fslI MsgDummyIdent) Nothing
+         <* submitButton
+  where
+    userList = fmap mkOptionList . runDB $ map toOption <$> selectList [] [Asc UserIdent]
+    toOption (Entity _ User{..}) = Option (CI.original userIdent) userIdent (CI.original userIdent)
+
+dummyLogin :: ( YesodAuth site
+              , YesodPersist site
+              , SqlBackendCanRead (YesodPersistBackend site)
+              , RenderMessage site FormMessage
+              , RenderMessage site DummyMessage
+              , Button site SubmitButton
+              , Show (ButtonCssClass site)
+              ) => AuthPlugin site
+dummyLogin = AuthPlugin{..}
+  where
+    apName = "dummy"
+    -- apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
+    apDispatch "POST" [] = do
+      ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard dummyForm
+      case loginRes of
+        FormFailure errs -> do
+          lift . forM_ errs $ addMessage Error . toHtml
+          redirect LoginR
+        FormMissing -> redirect LoginR
+        FormSuccess ident ->
+          lift . setCredsRedirect $ Creds "dummy" (CI.original ident) []
+    apDispatch _ _ = notFound
+    apLogin toMaster = do
+      (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard dummyForm
+      $(widgetFile "widgets/dummy-login-form")

src/Auth/LDAP.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE RecordWildCards
            , OverloadedStrings
            , TemplateHaskell
+           , ViewPatterns
            , TypeFamilies
            , FlexibleContexts
            , FlexibleInstances
@@ -20,6 +21,9 @@ import Import.NoFoundation
 import Control.Lens
 import Network.Connection
 
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
 import qualified Control.Monad.Catch as Exc
 
 import Utils.Form
@@ -31,7 +35,10 @@ import qualified Data.Text.Encoding as Text
 import qualified Yesod.Auth.Message as Msg
 
 
-data CampusLogin = CampusLogin { campusIdent, campusPassword :: Text }
+data CampusLogin = CampusLogin
+  { campusIdent :: CI Text
+  , campusPassword :: Text
+  }
 
 data CampusMessage = MsgCampusIdentNote
                    | MsgCampusIdent
@@ -60,7 +67,7 @@ campusForm :: ( RenderMessage site FormMessage
               , Show (ButtonCssClass site)
               ) => AForm (HandlerT site IO) CampusLogin
 campusForm = CampusLogin
-  <$> areq textField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing
+  <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing
   <*> areq passwordField (fslI MsgCampusPassword) Nothing
   <*  submitButton
 
@@ -79,10 +86,10 @@ campusLogin conf@LdapConf{..} = AuthPlugin{..}
       ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm
       case loginRes of
         FormFailure errs -> do
-          forM_ errs $ addMessage "error" . toHtml
+          forM_ errs $ addMessage Error . toHtml
           redirect LoginR
         FormMissing -> redirect LoginR
-        FormSuccess CampusLogin{..} -> do
+        FormSuccess CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> do
           ldapResult <- liftIO . Ldap.with ldapHost ldapPort $ \ldap -> do
             Ldap.bind ldap (Ldap.Dn campusIdent) (Ldap.Password $ Text.encodeUtf8 campusPassword)
             Ldap.bind ldap ldapDn ldapPassword

src/Auth/PWFile.hs

@@ -1,60 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude
-           , QuasiQuotes
-           , TemplateHaskell
-           , ViewPatterns
-           , RecordWildCards
-           , OverloadedStrings
-           , FlexibleContexts
-           , TypeFamilies
-  #-}
-
-module Auth.PWFile
-  ( maintenanceLogin
-  ) where
-
-import Import.NoFoundation
-import Database.Persist.Sql (IsSqlBackend)
-
-import qualified Data.Yaml as Yaml
-
-import qualified Data.Text.Encoding as Text
-
-import Yesod.Auth.Util.PasswordStore (verifyPassword)
-
-  
-maintenanceLogin :: ( YesodAuth site
-                    , YesodPersist site
-                    , IsSqlBackend (YesodPersistBackend site)
-                    , PersistUniqueWrite (YesodPersistBackend site)
-                    ) => FilePath -> AuthPlugin site
-maintenanceLogin fp = AuthPlugin{..}
-  where
-    apName = "PWFile"
-    apLogin = mempty
-    apDispatch "GET" [] = do
-      authData <- lookupBasicAuth
-      pwdata <- liftIO $ Yaml.decodeFileEither fp
-
-      addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|]
-
-      case pwdata of
-        Left err -> $logDebugS "Auth" $ tshow err
-        Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries"
-
-      case (authData, pwdata) of
-        (Nothing, _) -> do
-          notAuthenticated
-        (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata')
-          | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ]
-              <- [ pwe | pwe@PWEntry{..} <- pwdata'
-                       , let User{..} = pwUser
-                       , userIdent  == usr
-                       , userPlugin == apName
-                 ]
-          , verifyPassword pw pwHash
-            -> lift $ do
-              runDB . void $ insertUnique pwUser
-              setCredsRedirect $ Creds apName userIdent []
-        _ -> permissionDenied "Invalid auth"
-    apDispatch _ _ = notFound
-

src/Auth/PWHash.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE NoImplicitPrelude
+           , QuasiQuotes
+           , TemplateHaskell
+           , ViewPatterns
+           , RecordWildCards
+           , OverloadedStrings
+           , FlexibleContexts
+           , TypeFamilies
+  #-}
+
+module Auth.PWHash
+  ( hashLogin
+  , PWHashMessage(..)
+  ) where
+
+import Import.NoFoundation
+import Database.Persist.Sql (SqlBackendCanRead)
+
+import Utils.Form
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Yesod.Auth.Util.PasswordStore (verifyPasswordWith)
+
+import qualified Yesod.Auth.Message as Msg
+
+
+data HashLogin = HashLogin
+  { hashIdent :: CI Text
+  , hashPassword :: Text
+  }
+
+data PWHashMessage = MsgPWHashIdent
+                   | MsgPWHashPassword
+
+
+hashForm :: ( RenderMessage site FormMessage
+            , RenderMessage site PWHashMessage
+            , Button site SubmitButton
+            , Show (ButtonCssClass site)
+            ) => AForm (HandlerT site IO) HashLogin
+hashForm = HashLogin
+  <$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing
+  <*> areq passwordField (fslpI MsgPWHashPassword "Passwort") Nothing
+  <*  submitButton
+
+  
+hashLogin :: ( YesodAuth site
+             , YesodPersist site
+             , SqlBackendCanRead (YesodPersistBackend site)
+             , RenderMessage site FormMessage
+             , RenderMessage site PWHashMessage
+             , Button site SubmitButton
+             , Show (ButtonCssClass site)
+             ) => PWHashAlgorithm -> AuthPlugin site
+hashLogin pwHashAlgo = AuthPlugin{..}
+  where
+    apName = "PWHash"
+    apDispatch "POST" [] = do
+      ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard hashForm
+      case loginRes of
+        FormFailure errs -> do
+          forM_ errs $ addMessage Error . toHtml
+          redirect LoginR
+        FormMissing -> redirect LoginR
+        FormSuccess HashLogin{..} -> do
+          user <- lift . runDB . getBy $ UniqueAuthentication hashIdent
+          case user of
+            Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent })
+              | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> -- (2^) is magic.
+                  lift . setCredsRedirect $ Creds apName userIdent []
+            other -> do
+              $logDebugS "PWHash" $ tshow other
+              loginErrorMessageI LoginR Msg.InvalidLogin
+    -- apDispatch "GET" [] = do
+    --   authData <- lookupBasicAuth
+    --   pwdata <- liftIO $ Yaml.decodeFileEither fp
+
+    --   addHeader "WWW-Authenticate" [st|Basic realm="uni2work maintenance auth" charset="UTF-8"|]
+
+    --   case pwdata of
+    --     Left err -> $logDebugS "Auth" $ tshow err
+    --     Right pws -> $logDebugS "Auth" $ tshow (length pws) <> " pw entries"
+
+    --   case (authData, pwdata) of
+    --     (Nothing, _) -> do
+    --       notAuthenticated
+    --     (Just (usr, (Text.encodeUtf8 -> pw)), Right pwdata')
+    --       | [ PWEntry{ pwUser = pwUser@(User{..}), pwHash = (Text.encodeUtf8 -> pwHash) } ]
+    --           <- [ pwe | pwe@PWEntry{..} <- pwdata'
+    --                    , let User{..} = pwUser
+    --                    , userIdent  == usr
+    --                    , userPlugin == apName
+    --              ]
+    --       , verifyPassword pw pwHash
+    --         -> lift $ do
+    --           runDB . void $ insertUnique pwUser
+    --           setCredsRedirect $ Creds apName userIdent []
+    --     _ -> permissionDenied "Invalid auth"
+    apDispatch _ _ = notFound
+    apLogin toMaster = do
+      (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard hashForm
+      $(widgetFile "widgets/hash-login-form")
+

src/Foundation.hs

@@ -24,7 +24,8 @@ import Text.Jasmine         (minifym)
 import Yesod.Auth.Message
 import Yesod.Auth.Dummy
 import Auth.LDAP
-import Auth.PWFile
+import Auth.PWHash
+import Auth.Dummy
 
 import qualified Network.Wai as W (requestMethod, pathInfo)
 
@@ -81,7 +82,7 @@ import Utils
 import Utils.Form
 import Utils.Lens
 
-import Data.Aeson
+import Data.Aeson hiding (Error)
 import Data.Aeson.TH
 import qualified Data.Yaml as Yaml
 
@@ -166,6 +167,8 @@ data MenuTypes                                 -- Semantische Rolle:
 -- Messages
 mkMessage "UniWorX" "messages/uniworx" "de"
 mkMessageVariant "UniWorX" "Campus" "messages/campus" "de"
+mkMessageVariant "UniWorX" "Dummy" "messages/dummy" "de"
+mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
 
 -- This instance is required to use forms. You can modify renderMessage to
 -- achieve customized and internationalized form validation messages.
@@ -178,6 +181,12 @@ instance RenderMessage UniWorX TermIdentifier where
     Winter -> renderMessage' $ MsgWinterTerm year
     where renderMessage' = renderMessage foundation ls
 
+instance RenderMessage UniWorX StudyFieldType where
+  renderMessage foundation ls = \case
+    FieldPrimary -> renderMessage' MsgFieldPrimary
+    FieldSecondary -> renderMessage' MsgFieldSecondary
+    where renderMessage' = renderMessage foundation ls
+
 newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
   deriving (Eq, Ord, Read, Show)
 
@@ -302,7 +311,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
   [("free", trueAP)
   ,("deprecated", APHandler $ \r _ -> do
       $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
-      addMessageI "error" MsgDeprecatedRoute
+      addMessageI Error MsgDeprecatedRoute
       allow <- appAllowDeprecated . appSettings <$> getYesod
       return $ bool (Unauthorized "Deprecated Route") Authorized allow
     )
@@ -677,7 +686,7 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb TermCurrentR           = return ("Aktuell"   , Just TermShowR)
   breadcrumb TermEditR              = return ("Neu"       , Just TermCurrentR)
   breadcrumb (TermEditExistR tid)   = return ("Editieren" , Just $ TermCourseListR tid)
-  breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR)
+  breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Nothing)
 
   breadcrumb (TermSchoolCourseListR tid ssh)  = return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid)
 
@@ -737,7 +746,7 @@ defaultLinks = -- Define the menu items of the header.
       , menuItemAccessCallback' = return True
       }
   , NavbarRight $ MenuItem
-      { menuItemLabel = "Profile"
+      { menuItemLabel = "Profil"
       , menuItemIcon = Just "cogs"
       , menuItemRoute = ProfileR
       , menuItemAccessCallback' = isJust <$> maybeAuthPair
@@ -844,12 +853,6 @@ pageActions (CourseListR) =
   ]
 pageActions (CourseR tid ssh csh CShowR) =
   [ PageActionPrime $ MenuItem
-      { menuItemLabel = "Kurs Editieren"
-      , menuItemIcon  = Nothing
-      , menuItemRoute = CourseR tid ssh csh CEditR
-      , menuItemAccessCallback' = return True
-      }
-  , PageActionPrime $ MenuItem
       { menuItemLabel = "Übungsblätter"
       , menuItemIcon  = Nothing
       , menuItemRoute = CourseR tid ssh csh SheetListR
@@ -871,12 +874,24 @@ pageActions (CourseR tid ssh csh CShowR) =
       , menuItemRoute = CourseR tid ssh csh CCorrectionsR
       , menuItemAccessCallback' = return True
       }
-  , PageActionSecondary $ MenuItem
+  , PageActionPrime $ MenuItem
       { menuItemLabel = "Neues Übungsblatt anlegen"
       , menuItemIcon  = Nothing
       , menuItemRoute = CourseR tid ssh csh SheetNewR
       , menuItemAccessCallback' = return True
       }
+  , PageActionSecondary $ MenuItem
+      { menuItemLabel = "Kurs editieren"
+      , menuItemIcon  = Nothing
+      , menuItemRoute = CourseR tid ssh csh CEditR
+      , menuItemAccessCallback' = return True
+      }
+  , PageActionSecondary $ MenuItem
+      { menuItemLabel = "Neuen Kurs klonen"
+      , menuItemIcon  = Nothing
+      , menuItemRoute = CourseNewTemplateR (Just tid) (Just ssh) (Just csh)
+      , menuItemAccessCallback' = return True
+      }
   ]
 pageActions (CourseR tid ssh csh SheetListR) =
   [ PageActionPrime $ MenuItem
@@ -1133,20 +1148,16 @@ instance YesodAuth UniWorX where
 
     authenticate Creds{..} = runDB $ do
       let
-        (userPlugin, userIdent)
+        userIdent = CI.mk credsIdent
-          | isDummy
+        uAuth = UniqueAuthentication userIdent
-          , [dummyPlugin, dummyIdent] <- Text.splitOn ":" credsIdent
+
-          = (dummyPlugin, dummyIdent)
-          | otherwise
-          = (credsPlugin, credsIdent)
         isDummy = credsPlugin == "dummy"
-        isPWFile = credsPlugin == "PWFile"
+        isPWHash = credsPlugin == "PWHash"
-        uAuth = UniqueAuthentication userPlugin userIdent
 
         excHandlers
-          | isDummy || isPWFile
+          | isDummy || isPWHash
           = [ C.Handler $ \err -> do
-                addMessage "error" (toHtml $ tshow (err :: CampusUserException))
+                addMessage Error (toHtml $ tshow (err :: CampusUserException))
                 $logErrorS "LDAP" $ tshow err
                 acceptExisting
             ]
@@ -1170,7 +1181,7 @@ instance YesodAuth UniWorX where
 
       flip catches excHandlers $ case appLdapConf of
         Just ldapConf -> fmap (either id id) . runExceptT $ do
-          ldapData <- campusUser ldapConf $ Creds userPlugin userIdent credsExtra
+          ldapData <- campusUser ldapConf $ Creds credsPlugin (CI.original userIdent) credsExtra
           $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
 
           let
@@ -1179,6 +1190,10 @@ instance YesodAuth UniWorX where
             userDisplayName' = lookup (Attr "displayName") ldapData
             userSurname' = lookup (Attr "sn") ldapData
           
+            userAuthentication
+              | isPWHash  = error "PWHash should only work for users that are already known"
+              | otherwise = AuthLDAP
+
           userEmail <- if
             | Just [bs] <- userEmail'
             , Right userEmail <- Text.decodeUtf8' bs
@@ -1250,8 +1265,8 @@ instance YesodAuth UniWorX where
 
     authPlugins (appSettings -> AppSettings{..}) = catMaybes
       [ campusLogin <$> appLdapConf
-      , maintenanceLogin <$> appAuthPWFile
+      , Just . hashLogin $ pwHashAlgorithm appAuthPWHash
-      , authDummy <$ guard appAuthDummyLogin
+      , dummyLogin <$ guard appAuthDummyLogin
       ]
 
     authHttpManager = getHttpManager

src/Handler/Admin.hs

@@ -53,9 +53,9 @@ postAdminTestR :: Handler Html
 postAdminTestR = do
   ((btnResult,_), _) <- runFormPost $ buttonForm
   case btnResult of
-    (FormSuccess CreateInf)  -> setMessage "Informatik-Knopf gedrückt"
+    (FormSuccess CreateInf)  -> addMessage Info "Informatik-Knopf gedrückt"
-    (FormSuccess CreateMath) -> addMessage "warning" "Knopf Mathematik erkannt"
+    (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
-    _other -> return ()
+    _other -> addMessage Warning "KEIN Knopf erkannt"
   getAdminTestR
 
 
@@ -66,6 +66,6 @@ getAdminUserR uuid = do
   defaultLayout $
     [whamlet|
       <h1>TODO
-      <h2>Admin Page for User #{display userDisplayName}
+      <h2>Admin Page for User ^{nameWidget userDisplayName userSurname}
     |]
 

src/Handler/Corrections.hs

@@ -123,8 +123,13 @@ colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult
 colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
 
 colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
-colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
+colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
-  cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (toWidget userDisplayName)
+  csh = course ^. _2
+  tid = course ^. _3
+  ssh = course ^. _4
+  link cid = CourseR tid ssh csh $ CUserR cid
+  cell = listCell (Map.toList users) $ \(userId, User{..}) -> do
+    anchorCellM (link <$> encrypt userId) (nameWidget userDisplayName userSurname)
   in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
 
 colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
@@ -143,6 +148,16 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $  \DBRow{ dbrOutput=(
         return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
   in anchorCellM mkRoute $(widgetFile "widgets/rating")
 
+colAssigned :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
+  maybe mempty timeCell submissionRatingAssigned
+
+colRated :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
+  maybe mempty timeCell submissionRatingTime
+
+
+
 type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
             
 makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
@@ -243,7 +258,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
 
   Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
   case actionRes of
-    FormFailure errs -> mapM_ (addMessage "danger" . toHtml) errs
+    FormFailure errs -> mapM_ (addMessage Warning . toHtml) errs
     FormMissing      -> return ()
     FormSuccess (CorrDownloadData, subs) -> do
       ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
@@ -251,26 +266,38 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
       sendResponse =<< submissionMultiArchive ids
     FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do
       subs <- mapM decrypt $ Set.toList subs'
+      now <- liftIO getCurrentTime
       runDB $ do
         alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
         when (not $ null alreadyAssigned) $ do
           mr <- (toHtml . ) <$> getMessageRender
           alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) 
-          addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
+          addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
         let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
         when (not $ null unassigned) $ do
-          num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] [SubmissionRatingBy =. Just uid]
+          num <- updateWhereCount [SubmissionId <-. Set.toList unassigned]
-          addMessageI "success" $ MsgUpdatedAssignedCorrectorSingle num
+                    [ SubmissionRatingBy       =. Just uid
+                    , SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned
+                    ]
+          addMessageI Success $ MsgUpdatedAssignedCorrectorSingle num
+        (E.Value selfCorrectors:_) <- E.select . E.from $ \(submission `E.InnerJoin` subuser) -> do
+            E.on $ submission E.^. SubmissionId E.==. subuser E.^. SubmissionUserSubmission
+            E.where_ $ submission E.^. SubmissionId `E.in_` E.valList subs
+                E.&&.  submission E.^. SubmissionRatingBy E.==. E.just (subuser E.^. SubmissionUserUser)
+            return (E.countRows :: E.SqlExpr (E.Value Int64))
+        when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors
       redirect currentRoute
     FormSuccess (CorrSetCorrectorData Nothing, subs') -> do
       subs <- mapM decrypt $ Set.toList subs'
       runDB $ do
-        num <- updateWhereCount [SubmissionId <-. subs] [ SubmissionRatingPoints =. Nothing
+        num <- updateWhereCount [SubmissionId <-. subs]
-                                                        , SubmissionRatingComment =. Nothing
+                  [ SubmissionRatingPoints   =. Nothing
-                                                        , SubmissionRatingBy =. Nothing
+                  , SubmissionRatingComment  =. Nothing
-                                                        , SubmissionRatingTime =. Nothing
+                  , SubmissionRatingBy       =. Nothing
-                                                        ]
+                  , SubmissionRatingAssigned =. Nothing
-        addMessageI "success" $ MsgRemovedCorrections num
+                  , SubmissionRatingTime     =. Nothing
+                  ]
+        addMessageI Success $ MsgRemovedCorrections num
       redirect currentRoute
     FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do
       subs <- mapM decrypt $ Set.toList subs'
@@ -279,16 +306,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
         when (not $ null alreadyAssigned) $ do
           mr <- (toHtml . ) <$> getMessageRender
           alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) 
-          addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
+          addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
         let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
         when (not $ null unassigned) $ do
           (assigned, unassigned) <- assignSubmissions shid (Just unassigned)
           when (not $ null assigned) $
-            addMessageI "success" $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
+            addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
           when (not $ null unassigned) $ do
             mr <- (toHtml . ) <$> getMessageRender
             unassigned' <- forM (Set.toList unassigned) $ \sid -> (encrypt sid :: DB CryptoFileNameSubmission) 
-            addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
+            addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
       redirect currentRoute
 
   fmap toTypedContent . defaultLayout $ do
@@ -341,7 +368,9 @@ postCorrectionsR = do
         , colCourse
         , colSheet
         , colSubmissionLink
+        , colAssigned
         , colRating
+        , colRated
         ] -- Continue here
       psValidator = def
         & restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
@@ -355,15 +384,17 @@ getCCorrectionsR = postCCorrectionsR
 postCCorrectionsR tid ssh csh = do
   Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
   let whereClause = courseIs cid
-      colonnade = mconcat
+      colonnade = mconcat -- should match getSSubsR for consistent UX
         [ colSelect
         , dbRow
         , colSheet
-        , colCorrector
         , colSMatrikel
         , colSubmittors
         , colSubmissionLink
         , colRating
+        , colRated
+        , colCorrector
+        , colAssigned
         ] -- Continue here
       psValidator = def
   correctionsR whereClause colonnade psValidator $ Map.fromList
@@ -376,13 +407,16 @@ getSSubsR = postSSubsR
 postSSubsR tid ssh csh shn = do
   shid <- runDB $ fetchSheetId tid ssh csh shn
   let whereClause = sheetIs shid
-      colonnade = mconcat
+      colonnade = mconcat -- should match getCCorrectionsR for consistent UX
         [ colSelect
         , dbRow
-        , colCorrector
+        , colSMatrikel
         , colSubmittors
         , colSubmissionLink
         , colRating
+        , colRated
+        , colCorrector
+        , colAssigned
         ]
       psValidator = def
   correctionsR whereClause colonnade psValidator $ Map.fromList
@@ -427,7 +461,7 @@ postCorrectionR tid ssh csh shn cid = do
 
       case corrResult of
         FormMissing -> return ()
-        FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
+        FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
         FormSuccess (ratingPoints, ratingComment) -> do
           runDB $ do
             uid <- liftHandlerT requireAuthId
@@ -436,23 +470,25 @@ postCorrectionR tid ssh csh shn cid = do
             let rated = isJust $ void ratingPoints <|> void ratingComment
           
             update sub [ SubmissionRatingBy      =. (uid <$ guard rated)
+-- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload
+--                        , SubmissionRatingAssigned +=. (Just now) -- TODO: Should submissionRatingAssigned change here if userId changes?
                        , SubmissionRatingTime    =. (now <$ guard rated)
                        , SubmissionRatingPoints  =. ratingPoints
                        , SubmissionRatingComment =. ratingComment
                        ]
 
-            addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated
+            addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
           redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
 
       case uploadResult of
         FormMissing -> return ()
-        FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
+        FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
         FormSuccess fileSource -> do
           uid <- requireAuthId
           
           runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
 
-          addMessageI "success" MsgRatingFilesUpdated
+          addMessageI Success MsgRatingFilesUpdated
           redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
 
       defaultLayout $ do
@@ -482,16 +518,16 @@ postCorrectionsUploadR = do
 
   case uploadRes of
     FormMissing -> return ()
-    FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
+    FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
     FormSuccess files -> do
       uid <- requireAuthId
       subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
       if
-        | null subs -> addMessageI "warning" MsgNoCorrectionsUploaded
+        | null subs -> addMessageI Warning MsgNoCorrectionsUploaded
         | otherwise -> do
             subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
             mr <- (toHtml .) <$> getMessageRender
-            addMessage "success" =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
+            addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
         
 
   defaultLayout $ do

src/Handler/Course.hs

@@ -20,6 +20,7 @@ import Import
 import Control.Lens
 import Utils.Lens
 import Utils.TH
+-- import Utils.DB
 import Handler.Utils
 import Handler.Utils.Table.Cells
 
@@ -28,6 +29,7 @@ import qualified Data.Text as T
 import Data.Function ((&))
 -- import Yesod.Form.Bootstrap3
 
+import Data.Maybe
 import qualified Data.Set as Set
 import qualified Data.Map as Map
 
@@ -57,7 +59,7 @@ colDescription = sortable Nothing (i18nCell MsgCourseDescription)
           $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
             case courseDescription of
               Nothing      -> mempty
-              (Just descr) -> cell $ modalStatic descr
+              (Just descr) -> cell $ modal "Beschreibung" (Right $ toWidget descr)
 
 colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
@@ -71,7 +73,11 @@ colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
             ( case courseDescription of
                 Nothing      -> mempty
                 (Just descr) -> cell
-                  [whamlet|<span style="float:right"> ^{modalStatic descr} |]
+                  [whamlet|
+                    $newline never
+                    <span style="float:right">
+                      ^{modal "Beschreibung" (Right $ toWidget descr)}
+                  |]
             )
 
 colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
@@ -302,50 +308,113 @@ postCRegisterR tid ssh csh = do
     (FormSuccess codeOk)
       | registered -> do
           runDB $ deleteBy $ UniqueParticipant aid cid
-          addMessageI "info" MsgCourseDeregisterOk
+          addMessageI Info MsgCourseDeregisterOk
       | codeOk -> do
           actTime <- liftIO $ getCurrentTime
           regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
-          when (isJust regOk) $ addMessageI "success" MsgCourseRegisterOk
+          when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
-      | otherwise -> addMessageI "danger" MsgCourseSecretWrong
+      | otherwise -> addMessageI Warning MsgCourseSecretWrong
     (_other) -> return () -- TODO check this!
   redirect $ CourseR tid ssh csh CShowR
 
-getCourseNewR :: Handler Html
+getCourseNewR :: Handler Html -- call via toTextUrl
 getCourseNewR = do
-  -- TODO: Defaults für Semester hier ermitteln und übergeben
+  uid <- requireAuthId
-  courseEditHandler True Nothing
+  params <- runInputGetResult $ (,,)    --TODO: change to AForm, which is used in Course-Copy-Button
+            <$> iopt termNewField "tid"
+            <*> iopt ciField      "ssh"
+            <*> iopt ciField      "csh"
+  let noTemplateAction = courseEditHandler True Nothing
+  case params of
+    FormMissing      -> noTemplateAction
+    FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml)
+                        >> noTemplateAction
+    FormSuccess (mbTid,mbSsh,mbCsh) ->
+      getCourseNewTemplateR (TermKey <$> mbTid) (SchoolKey <$> mbSsh) mbCsh
+
+getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html
+getCourseNewTemplateR mbTid mbSsh mbCsh = do
+  uid <- requireAuthId
+  oldCourses <- runDB $ do
+    E.select $ E.from $ \course -> do
+      whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm       E.==. E.val tid
+      whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool     E.==. E.val ssh
+      whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand  E.==. E.val csh
+      let lecturersCourse =
+            E.exists $ E.from $ \lecturer -> do
+              E.where_ $ lecturer E.^. LecturerUser   E.==. E.val uid
+                  E.&&.  lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+      let lecturersSchool =
+            E.exists $ E.from $ \user -> do
+              E.where_ $ user E.^. UserLecturerUser   E.==. E.val uid
+                  E.&&.  user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
+      let courseCreated c =
+            E.sub_select . E.from $ \edit -> do      -- oldest edit must be creation
+              E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
+              return $ E.min_ $ edit E.^. CourseEditTime
+      E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
+                , E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
+                , E.desc $ courseCreated course]                                     -- most recent created course
+      E.limit 1
+      return course
+  template <- case listToMaybe oldCourses of
+    (Just oldTemplate) ->
+        let newTemplate = (courseToForm oldTemplate) in
+        return $ Just $ newTemplate
+            { cfCourseId   = Nothing
+            , cfTerm       = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
+            , cfRegFrom    = Nothing
+            , cfRegTo      = Nothing
+            , cfDeRegUntil = Nothing
+            }
+    Nothing -> do
+        (tidOk,sshOk,cshOk) <- runDB $ (,,)
+            <$> ifMaybeM mbTid True existsKey
+            <*> ifMaybeM mbSsh True existsKey
+            <*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
+        unless tidOk $ addMessageI Warning $ MsgNoSuchTerm   $ fromJust mbTid -- safe, since tidOk==True otherwise
+        unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
+        unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
+        when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
+        return Nothing
+  courseEditHandler True template
 
 postCourseNewR :: Handler Html
-postCourseNewR = courseEditHandler False Nothing
+postCourseNewR = courseEditHandler False Nothing -- Note: Nothing is safe here, since we will create a new course.
 
-getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-getCEditR tid ssh csh = do
+getCEditR  = pgCEditR True
+postCEditR = pgCEditR False
+
+pgCEditR :: Bool -> TermId -> SchoolId -> CourseShorthand -> Handler Html
+pgCEditR isGetReq tid ssh csh = do
   course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
-  courseEditHandler True course
+  -- IMPORTANT: both GET and POST Handler must use the same template,
-
+  --    since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
-postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+  courseEditHandler isGetReq $ courseToForm <$> course
-postCEditR tid ssh csh = do
-  course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
-  courseEditHandler False course
 
 
-courseDeleteHandler :: Handler Html -- not called anywhere yet
+getCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
-courseDeleteHandler = undefined
+getCDeleteR = error "TODO: implement getCDeleteR"
+postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+postCDeleteR = error "TODO: implement getCDeleteR"
 {- TODO
         | False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler
         , Just cid <- cfCourseId res -> do
             runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
             let cti = toPathPiece $ cfTerm res
-            addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
+            addMessage Info [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
             redirect $ TermCourseListR $ cfTerm res
 -}
 
-courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html
+
-courseEditHandler isGet course = do
+-- | Course Creation and Editing
-    -- $logDebug "€€€€€€ courseEditHandler started"
+-- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing),
+-- |            since an edit is identified via cfCourseId which is not contained in the received form data for security reasons!
+courseEditHandler :: Bool -> Maybe CourseForm -> Handler Html
+courseEditHandler isGet mbCourseForm = do
     aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
-    ((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm
+    ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm mbCourseForm
     case result of
       (FormSuccess res@(
         CourseForm  { cfCourseId = Nothing
@@ -373,10 +442,10 @@ courseEditHandler isGet course = do
               runDB $ do
                 insert_ $ CourseEdit aid now cid
                 insert_ $ Lecturer aid cid
-              addMessageI "info" $ MsgCourseNewOk tid ssh csh
+              addMessageI Info $ MsgCourseNewOk tid ssh csh
               redirect $ TermCourseListR tid
             Nothing ->
-              addMessageI "danger" $ MsgCourseNewDupShort tid ssh csh
+              addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
 
       (FormSuccess res@(
         CourseForm  { cfCourseId = Just cid
@@ -389,14 +458,14 @@ courseEditHandler isGet course = do
           success <- runDB $ do
             old <- get cid
             case old of
-              Nothing -> addMessageI "error" MsgInvalidInput $> False
+              Nothing -> addMessageI Error MsgInvalidInput $> False
               (Just oldCourse) -> do
                 updOkay <- myReplaceUnique cid (  -- replaceUnique requires Eq Course, which we cannot have
                     Course  {  courseName            = cfName       res
                             ,  courseDescription     = cfDesc       res
                             ,  courseLinkExternal    = cfLink       res
                             ,  courseShorthand       = cfShort      res
-                            ,  courseTerm            = cfTerm       res
+                            ,  courseTerm            = cfTerm       res -- dangerous
                             ,  courseSchool          = cfSchool     res
                             ,  courseCapacity        = cfCapacity   res
                             ,  courseRegisterSecret  = cfSecret     res
@@ -407,14 +476,14 @@ courseEditHandler isGet course = do
                     }
                   )
                 case updOkay of
-                  (Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid ssh csh) $> False
+                  (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
                   Nothing  -> do
                     insert_ $ CourseEdit aid now cid
-                    addMessageI "success" $ MsgCourseEditOk tid ssh csh
+                    addMessageI Success $ MsgCourseEditOk tid ssh csh
                     return True
           when success $ redirect $ CourseR tid ssh csh CShowR
 
-      (FormFailure _) -> addMessageI "warning" MsgInvalidInput
+      (FormFailure _) -> addMessageI Warning MsgInvalidInput
       (FormMissing) -> return ()
     actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
     defaultLayout $ do
@@ -438,9 +507,8 @@ data CourseForm = CourseForm
         , cfDeRegUntil :: Maybe UTCTime
         }
 
-courseToForm :: MonadCrypto m => Entity Course -> m CourseForm
+courseToForm :: Entity Course -> CourseForm
-courseToForm (Entity cid Course{..}) = do
+courseToForm (Entity cid Course{..}) = CourseForm
-  return $ CourseForm
     { cfCourseId   = Just cid
     , cfName       = courseName
     , cfDesc       = courseDescription
@@ -462,19 +530,30 @@ newCourseForm template = identForm FIDcourse $ \html -> do
       userId <- liftHandlerT requireAuthId
       (fmap concat . sequence)
         [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
-        , map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] []
+        , map (userAdminSchool    . entityVal) <$> selectList [UserAdminUser    ==. userId] []
         ]
+
+    termsField <- liftHandlerT $ case template of
+          -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
+          (Just cform)  | (Just cid) <- cfCourseId cform -> do -- edit existing course
+              _courseOld@Course{..} <- runDB $ get404 cid
+              mayEditTerm <- isAuthorized TermEditR True
+              mayDelete   <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
+              return $ if
+                | (mayEditTerm == Authorized) || (mayDelete == Authorized) -> termsAllowedField
+                | otherwise ->  termsSetField [cfTerm cform]
+          _allOtherCases -> return termsAllowedField
     (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
       <$> pure (cfCourseId =<< template)
-      <*> areq (ciField textField) (fslI MsgCourseName)          (cfName     <$> template)
+      <*> areq ciField (fslI MsgCourseName)          (cfName     <$> template)
       <*> aopt htmlField (fslI MsgCourseDescription
                          & setTooltip MsgCourseDescriptionTip)   (cfDesc     <$> template)
       <*> aopt urlField  (fslI MsgCourseHomepage)                (cfLink     <$> template)
-      <*> areq (ciField textField) (fslI MsgCourseShorthand
+      <*> areq ciField (fslI MsgCourseShorthand
             -- & addAttr "disabled" "disabled"
             & setTooltip MsgCourseShorthandUnique)
                                                 (cfShort  <$> template)
-      <*> areq termActiveField              (fslI MsgCourseSemester)    (cfTerm     <$> template)
+      <*> areq termsField                   (fslI MsgCourseSemester)    (cfTerm     <$> template)
       <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool)      (cfSchool   <$> template)
       <*> aopt (natField "Kapazität")       (fslI MsgCourseCapacity
             & setTooltip MsgCourseCapacityTip)                          (cfCapacity <$> template)
@@ -523,3 +602,22 @@ validateCourse (CourseForm{..}) =
 --       )
 --     ,
   ] ]
+
+
+
+getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCUsersR tid ssh csh = undefined -- TODO
+
+
+getCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
+getCUserR tid ssh csh uuid = do
+  uid <- decrypt uuid
+  User{..} <- runDB $ get404 uid
+  defaultLayout $
+    [whamlet|
+      <h1>TODO
+      <h2>Lecturer's Page for User ^{nameWidget userDisplayName userSurname}
+    |]
+
+getCHiWisR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCHiWisR tid ssh csh = undefined -- TODO

src/Handler/Home.hs

@@ -107,7 +107,7 @@ homeAnonymous = do
     , dbtIdent     = "upcomingdeadlines" :: Text
     }
   let features = $(widgetFile "featureList")
-  addMessage "danger" "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen!"
+  addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen!"
   defaultLayout $ do
     $(widgetFile "dsgvDisclaimer")
     $(widgetFile "home")
@@ -207,7 +207,7 @@ homeUser uid = do
     , dbtStyle     = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
     , dbtIdent     = "upcomingdeadlines" :: Text
     }
-  addMessage "danger" "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen."
+  addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen."
   defaultLayout $ do
     -- setTitle "Willkommen zum Uni2work Test!"
     $(widgetFile "homeUser")

src/Handler/Profile.hs

@@ -87,14 +87,14 @@ getProfileR = do
                                       , OffsetBy $ stgMaxFavourties
                                       ]
             mapM_ delete oldFavs
-        addMessageI "info" $ MsgSettingsUpdate
+        addMessageI Info $ MsgSettingsUpdate
         redirect ProfileR -- TODO: them change does not happen without redirect
 
-    (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
+    (FormFailure msgs) -> forM_ msgs $ (addMessage Warning) . toHtml
     _ -> return ()
 
 
-  (admin_rights,lecturer_rights,lecture_owner,lecture_corrector,participant,studies) <- runDB $ (,,,,,) <$>
+  (admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
             (E.select $ E.from $ \(adright `E.InnerJoin` school) -> do
                 E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
                 E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
@@ -107,12 +107,6 @@ getProfileR = do
                 return (school E.^. SchoolShorthand)
             )
             <*>
-            (E.select $ E.from $ \(lecturer `E.InnerJoin` course) -> do
-                E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
-                E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
-                return (course E.^. CourseTerm, course E.^.CourseSchool, course E.^. CourseShorthand)
-            )
-            <*>
             (E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
                 E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
                 E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
@@ -120,20 +114,18 @@ getProfileR = do
                 return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
             )
             <*>
-            (E.select $ E.from $ \(participant `E.InnerJoin` course) -> do
-                E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
-                E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
-                return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, participant E.^. CourseParticipantRegistration)
-            )
-            <*>
             (E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
                 E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
                 E.on $ studyfeat E.^. StudyFeaturesField  E.==. studyterms  E.^. StudyTermsId
                 E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
-                return  (studydegree E.^. StudyDegreeName
+                return  ( ( studydegree E.^. StudyDegreeName
-                        ,studyterms  E.^. StudyTermsName
+                          , studydegree E.^. StudyDegreeKey
-                        ,studyfeat   E.^. StudyFeaturesType
+                          )
-                        ,studyfeat   E.^. StudyFeaturesSemester)
+                        , ( studyterms  E.^. StudyTermsName
+                          , studyterms  E.^. StudyTermsKey
+                          )
+                        , studyfeat   E.^. StudyFeaturesType
+                        , studyfeat   E.^. StudyFeaturesSemester)
             )
   let formText  = Just MsgSettings
       actionUrl = ProfileR
@@ -148,27 +140,78 @@ postProfileR = do
   -- TODO
   getProfileR
 
+postProfileDataR  :: Handler Html
+postProfileDataR = do
+  ((btnResult,_), _) <- runFormPost $ buttonForm
+  case btnResult of
+    (FormSuccess BtnDelete) -> do
+      (uid, User{..}) <- requireAuthPair
+      addMessage Warning "Delete-Knopf gedrückt"
+      addMessage Error "Löschen der Daten wurde noch nicht implementiert."
+      -- first determine all submission that solely depend on this user:
+      -- SubmissionGroup / SubmissionGroupUser
+      -- Submission / SubmissionUser
+      -- runDB $ deleteCascade uid
+    (FormSuccess BtnAbort ) -> do
+      addMessageI Info MsgAborted
+      redirect ProfileDataR
+    _other -> return ()
+  getProfileDataR
+
 
 
 getProfileDataR  :: Handler Html
 getProfileDataR = do
   (uid, User{..}) <- requireAuthPair
   --   mr <- getMessageRender
-
   -- Tabelle mit eigenen Kursen
   (hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid
   -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
   enrolledCoursesTable <- mkEnrolledCoursesTable uid
   -- Tabelle mit allen Klausuren und Noten
-  examTable <- return [whamlet| TOOD: Klausuranmeldungen anzeigen |] -- TODO
+  examTable <- return [whamlet| Klausuren werden momentan leider noch nicht unterstützt.|]
   -- Tabelle mit allen Abgaben und Abgabe-Gruppen
   submissionTable <- mkSubmissionTable uid
   -- Tabelle mit allen Abgabegruppen
   submissionGroupTable <- mkSubmissionGroupTable uid
   -- Tabelle mit allen Korrektor-Aufgaben
   correctionsTable <- mkCorrectionsTable uid
+  -- Tabelle mit allen eigenen Tutorials
+  ownTutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
   -- Tabelle mit allen Tutorials
-  tutorialTable <- return [whamlet| TOOD: Tutorials anzeigen |] -- TODO
+  tutorialTable <- return [whamlet| Übungsgruppen werden momentan leider noch nicht unterstützt.|]
+  -- Delete Button
+  (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete)
+  -- TODO: move this into a Message and/or Widget-File
+  let delWdgt = [whamlet|
+        <form .form-inline method=post action=@{ProfileDataR} enctype=#{btnEnctype}>
+          <h2>
+            Sind Sie sich absolut sicher, alle Ihre in Uni2work gespeicherten Daten zu löschen?
+          <div .container>
+              Während der Testphase von Uni2work können Sie hiermit
+              Ihren Account bei Uni2work vollständig löschen.
+              Mit Ihrem Campus-Account können Sie sich aber danach
+              jederzeit erneut einloggen, wodurch wieder ein leerer Account erstellt wird.
+          <div .container>
+              Hochgeladene Hausaufgaben-Dateien werden unabhhängig vom Urherber nur dann gelöscht,
+              wenn die Dateien ausschließlich Ihnen zugeordnet sind.
+              Dateien aus Gruppenabgaben werden also erst dann gelöscht,
+              wenn alle Gruppenmitglieder Ihren Account gelöscht haben.
+          <div .container>
+              <em>Achtung:
+              Auch abgegebene Hausübungen werden gelöscht!
+              Falls ein Veranstalter Informationen darüber nicht anderweitig gespeichert hat,
+              kann dadurch ein etwaiger Hausaufgabenbonus verloren gehen.
+              (Verbuchte Noten sollten dadurch nicht betroffen sein, aber in einem etwaigen
+              Streitfall konnen die per Uni2work verwalteten Hausaufgaben dann
+              auch nicht mehr rekonstruiert/berücksichtigt werden.)
+          <div .container>
+            <em>Nach der Testphase von Uni2work wird das Löschen eines Accounts etwas
+            eingeschränkt werden, da z.B. Klausurnoten 5 Jahre bis nach Exmatrikulation
+            aufbewahrt werden müssen.
+          <div .container>
+            ^{btnWdgt}
+      |]
   defaultLayout $ do
     $(widgetFile "profileData")
     $(widgetFile "dsgvDisclaimer")
@@ -417,7 +460,7 @@ mkSubmissionGroupTable =
 
 
 mkCorrectionsTable :: UserId -> Handler Widget
--- Table listing all corrections made by the given user
+-- Table listing sum of corrections made by the given user per sheet
 mkCorrectionsTable =
   let dbtIdent = "corrections" :: Text
       dbtStyle = def
@@ -426,6 +469,17 @@ mkCorrectionsTable =
               ->  ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
       withType = id
 
+      corrsAssigned uid sheet = E.sub_select . E.from $ \submission -> do
+          E.where_ $ submission E.^. SubmissionSheet    E.==. sheet E.^. SheetId
+              E.&&.  submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
+          return $ E.countRows
+
+      corrsCorrected uid sheet = E.sub_select . E.from $ \submission -> do
+          E.where_ $ submission E.^. SubmissionSheet    E.==. sheet E.^. SheetId
+              E.&&.  submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
+              E.&&.  (E.not_ $ E.isNothing $ submission E.^. SubmissionRatingTime)
+          return $ E.countRows
+
       dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` corrector) -> do
         E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
         E.on $ sheet E.^. SheetCourse E.==. course    E.^. CourseId
@@ -434,7 +488,7 @@ mkCorrectionsTable =
                     , course E.^. CourseSchool
                     , course E.^. CourseShorthand
                     )
-        return (crse, sheet E.^. SheetName, corrector)
+        return (crse, sheet E.^. SheetName, corrector, (corrsAssigned uid sheet, corrsCorrected uid sheet))
 
       dbtProj = \x -> return $ x
         & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
@@ -454,6 +508,10 @@ mkCorrectionsTable =
             correctorStateCell <$> view (_dbrOutput . _3 . _entityVal)
         , sortable (toNothing "cload")  (i18nCell MsgCorProportion) $
             correctorLoadCell  <$> view (_dbrOutput . _3 . _entityVal)
+        , sortable (toNothing "assigned")  (i18nCell MsgCorProportion) $
+            int64Cell <$> view (_dbrOutput . _4 . _1 . _unValue)
+        , sortable (toNothing "corrected")  (i18nCell MsgCorProportion) $
+            int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue)
         ]
 
       validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc),("sheet",SortAsc)]
@@ -472,4 +530,3 @@ mkCorrectionsTable =
   in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
               in  dbTableWidget' validator $ DBTable {..}
 
-

src/Handler/Sheet.hs

@@ -22,6 +22,7 @@ import System.FilePath (takeFileName)
 
 import Handler.Utils
 -- import Handler.Utils.Zip
+import Handler.Utils.Table.Cells
 
 -- import Data.Time
 -- import qualified Data.Text as T
@@ -81,6 +82,7 @@ data SheetForm = SheetForm
       , sfVisibleFrom  :: Maybe UTCTime
       , sfActiveFrom   :: UTCTime
       , sfActiveTo     :: UTCTime
+      , sfUploadMode   :: UploadMode
       , sfSheetF       :: Maybe (Source Handler (Either FileId File))
       , sfHintFrom     :: Maybe UTCTime
       , sfHintF        :: Maybe (Source Handler (Either FileId File))
@@ -106,11 +108,11 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
     mr <- getMsgRenderer
     ctime <- liftIO $ getCurrentTime
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
-      <$> areq (ciField textField) (fslI MsgSheetName) (sfName <$> template)
+      <$> areq ciField        (fslI MsgSheetName)         (sfName        <$> template)
       <*> aopt htmlField      (fslI MsgSheetDescription)  (sfDescription <$> template)
-      <*> sheetTypeAFormReq   (fslI MsgSheetType)                (sfType <$> template)
+      <*> sheetTypeAFormReq   (fslI MsgSheetType)         (sfType        <$> template)
-      <*> sheetGroupAFormReq  (fslI MsgSheetGroup) (sfGrouping <$> template)
+      <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)
-      <*> aopt htmlField      (fslI MsgSheetMarking) (sfMarkingText <$> template)
+      <*> aopt htmlField      (fslI MsgSheetMarking)      (sfMarkingText <$> template)
       <*> aopt utcTimeField   (fslI MsgSheetVisibleFrom
             & setTooltip MsgSheetVisibleFromTip)
                                                               ((sfVisibleFrom  <$> template) <|> pure (Just ctime))
@@ -118,10 +120,10 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
             & setTooltip MsgSheetActiveFromTip)
                                                               (sfActiveFrom   <$> template)
       <*> areq utcTimeField   (fslI MsgSheetActiveTo)         (sfActiveTo     <$> template)
+      <*> areq uploadModeField (fslI MsgSheetUploadMode)      ((sfUploadMode   <$> template) <|> pure (Upload True))
       <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
-            & setTooltip MsgSheetHintFromTip)
+            & setTooltip MsgSheetHintFromTip)                 (sfHintFrom     <$> template)
-                                                              (sfHintFrom     <$> template)
       <*> aopt (multiFileField $ oldFileIds SheetHint)     (fslI MsgSheetHint)      (sfHintF <$> template)
       <*> aopt utcTimeField   (fslpI MsgSheetSolutionFrom  "Datum, sonst nur für Korrektoren"
             & setTooltip MsgSheetSolutionFromTip)
@@ -151,27 +153,25 @@ getSheetListR tid ssh csh = do
   muid <- maybeAuthId
   Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
   let
+    lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
+        E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
+        return . E.max_ $ sheetEdit E.^. SheetEditTime
     sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)),E.SqlExpr (Maybe (Entity Submission)))
     sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
       E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
       E.on $  (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
         E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
-      let sheetEdit = E.sub_select . E.from $ \sheetEdit' -> do
-            E.where_ $ sheetEdit' E.^. SheetEditSheet E.==. sheet E.^. SheetId
-            return . E.max_ $ sheetEdit' E.^. SheetEditTime
       E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
-      return (sheet, sheetEdit, submission)
+      return (sheet, lastSheetEdit sheet, submission)
     sheetCol = widgetColonnade . mconcat $
       [ sortable (Just "name") (i18nCell MsgSheet)
           $ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
       , sortable (Just "last-edit") (i18nCell MsgLastEdit)
-          $ \(_, E.Value mEditTime, _) -> case mEditTime of
+          $ \(_, E.Value mEditTime, _) -> maybe mempty timeCell mEditTime
-            Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget
-            Nothing -> mempty
       , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
-          $ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveFrom >>= toWidget
+          $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveFrom
       , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
-          $ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveTo   >>= toWidget
+          $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo
       , sortable Nothing (i18nCell MsgSheetType)
           $ \(Entity _ Sheet{..}, _, _) -> textCell $ display sheetType
       , sortable Nothing (i18nCell MsgSubmission)
@@ -217,8 +217,7 @@ getSheetListR tid ssh csh = do
         , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
         )
       , ( "last-edit"
-        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do
+        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
-            return $ sheetEdit E.?. SheetEditTime
         )
       , ( "submission-since"
         , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
@@ -306,7 +305,7 @@ getSShowR tid ssh csh shn = do
     return (hasHints, hasSolution)
   cTime <- Just <$> liftIO getCurrentTime
   visibleFrom <-    traverse (formatTime SelFormatDateTime) $ sheetVisibleFrom  sheet
-  when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $
+  when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI Warning $
     maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
   defaultLayout $ do
     setTitleI $ MsgSheetTitle tid ssh csh shn
@@ -367,6 +366,7 @@ getSheetNewR tid ssh csh = do
           , sfVisibleFrom  = addOneWeek <$> sheetVisibleFrom
           , sfActiveFrom   = addOneWeek     sheetActiveFrom
           , sfActiveTo     = addOneWeek     sheetActiveTo
+          , sfUploadMode   = sheetUploadMode
           , sfSheetF       = Nothing
           , sfHintFrom     = addOneWeek <$> sheetHintFrom
           , sfHintF        = Nothing
@@ -400,6 +400,7 @@ getSEditR tid ssh csh shn = do
         , sfVisibleFrom  = sheetVisibleFrom
         , sfActiveFrom   = sheetActiveFrom
         , sfActiveTo     = sheetActiveTo
+        , sfUploadMode   = sheetUploadMode
         , sfSheetF       = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
         , sfHintFrom     = sheetHintFrom
         , sfHintF        = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
@@ -428,7 +429,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
         actTime <- liftIO getCurrentTime
         cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
         let newSheet = Sheet
-              { sheetCourse     = cid
+              { sheetCourse       = cid
               , sheetName         = sfName
               , sheetDescription  = sfDescription
               , sheetType         = sfType
@@ -439,23 +440,28 @@ handleSheetEdit tid ssh csh msId template dbAction = do
               , sheetActiveTo     = sfActiveTo
               , sheetHintFrom     = sfHintFrom
               , sheetSolutionFrom = sfSolutionFrom
+              , sheetUploadMode   = sfUploadMode
               }
         mbsid <- dbAction newSheet
         case mbsid of
-          Nothing    -> False <$ addMessageI "danger" (MsgSheetNameDup tid ssh csh sfName)
+          Nothing    -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName)
           (Just sid) ->  do -- save files in DB:
             whenIsJust sfSheetF    $ insertSheetFile' sid SheetExercise
             whenIsJust sfHintF     $ insertSheetFile' sid SheetHint
             whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution
             whenIsJust sfMarkingF  $ insertSheetFile' sid SheetMarking
             insert_ $ SheetEdit aid actTime sid
-            addMessageI "info" $ MsgSheetEditOk tid ssh csh sfName
+            addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
+            -- Sanity checks generating warnings only, but not errors!
+            warnTermDays tid [sfVisibleFrom, Just sfActiveFrom, Just sfActiveTo, sfHintFrom, sfSolutionFrom]
             return True
       when saveOkay $ redirect $ case msId of
         Just _  -> CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
         Nothing -> CSheetR tid ssh csh sfName SCorrR
-    (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
+    (FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
-    _ -> return ()
+    _ -> runDB $ warnTermDays tid $ (join . (flip fmap template))
+          <$> [sfVisibleFrom, Just . sfActiveFrom, Just . sfActiveTo, sfHintFrom, sfSolutionFrom]
+
   let pageTitle = maybe (MsgSheetTitleNew tid ssh csh)
                         (MsgSheetTitle    tid ssh csh) mbshn
 --   let formTitle = pageTitle -- no longer used in template
@@ -475,7 +481,7 @@ getSDelR tid ssh csh shn = do
     (FormSuccess BtnDelete) -> do
       runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade
       -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
-      addMessageI "info" $ MsgSheetDelOk tid ssh csh shn
+      addMessageI Info $ MsgSheetDelOk tid ssh csh shn
       redirect $ CourseR tid ssh csh SheetListR
     _other -> do
       submissionno <- runDB $ do
@@ -566,7 +572,7 @@ correctorForm shid = do
   (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
   loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
     | Map.null currentLoads'
-    , null formCIDs          -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warning" MsgCorrectorsDefaulted)
+    , null formCIDs          -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted)
     | otherwise              -> return $ Map.fromList (map (, (CorrectorNormal, mempty)) formCIDs) `Map.union` currentLoads'
 
   deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')
@@ -602,11 +608,11 @@ correctorForm shid = do
     FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
       mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
       case mUid of
-        Nothing  -> loads'' <$ addMessageI "error" (MsgEMailUnknown email)
+        Nothing  -> loads'' <$ addMessageI Error (MsgEMailUnknown email)
         Just uid
           | not (Map.member uid loads') -> return $ Map.insert uid (CorrectorNormal, mempty) loads''
-          | otherwise                   -> loads'' <$ addMessageI "warning" (MsgCorrectorExists email)
+          | otherwise                   -> loads'' <$ addMessageI Warning (MsgCorrectorExists email)
-    FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs
+    FormFailure errs -> loads'' <$ mapM_ (addMessage Error . toHtml) errs
     _ -> return loads''
 
   let deletions' = deletions `Set.difference` Map.keysSet loads
@@ -697,11 +703,11 @@ getSCorrR tid ssh csh shn = do
   ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
 
   case res of
-    FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
+    FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
     FormSuccess res -> runDB $ do
       deleteWhere [SheetCorrectorSheet ==. shid]
       insertMany_ $ Set.toList res
-      addMessageI "success" MsgCorrectorsUpdated
+      addMessageI Success MsgCorrectorsUpdated
     FormMissing -> return ()
 
   let

src/Handler/Submission.hs

@@ -27,47 +27,51 @@ import Handler.Utils.Table.Cells
 
 import Network.Mime
 
-import Control.Monad.Trans.Maybe
+-- import Control.Monad.Trans.Maybe
-import Control.Monad.State.Class
+-- import Control.Monad.State.Class
-import Control.Monad.Trans.State.Strict (StateT)
+-- import Control.Monad.Trans.State.Strict (StateT)
 
 import Data.Monoid (Any(..))
 import Data.Maybe (fromJust)
-import qualified Data.Maybe
+-- 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 Data.CaseInsensitive as CI
 
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction)
 
 import qualified Data.Conduit.List as Conduit
-import Data.Conduit.ResumableSink
+-- import Data.Conduit.ResumableSink
 
-import Data.Set (Set)
+-- import Data.Set (Set)
 import qualified Data.Set as Set
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.Bifunctor
+-- import Data.Bifunctor
 
 import System.FilePath
 
-import Colonnade hiding (bool, fromMaybe)
+-- import Colonnade hiding (bool, fromMaybe)
-import qualified Yesod.Colonnade as Yesod
+-- import qualified Yesod.Colonnade as Yesod
-import qualified Text.Blaze.Html5.Attributes as HA
+-- import qualified Text.Blaze.Html5.Attributes as HA
 
 -- DEPRECATED: We always show all edits!
 -- numberOfSubmissionEditDates :: Int64
 -- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
 
 
-makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
+makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
-makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do
+makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $ \html -> do
+    let
+      fileUpload = case uploadMode of
+        NoUpload -> pure Nothing
+        (Upload unpackZips) -> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
     flip (renderAForm FormStandard) html $ (,)
-      <$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
+      <$> fileUpload
-      <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies (ciField textField) (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
+      <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
                                     | g <- [1..(max groupNr $ length buddies)]             -- groupNr might have decreased meanwhile
                                     | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
                                     ])
@@ -113,7 +117,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
   maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc.
 
   (Entity shid Sheet{..}, buddies, lastEdits)  <- runDB $ do
-    sheet@(Entity shid Sheet{..})  <- fetchSheet tid ssh csh shn
+    csheet@(Entity shid Sheet{..})  <- fetchSheet tid ssh csh shn
     case msmid of
       Nothing     -> do
         submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
@@ -127,12 +131,12 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = 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
+              let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` subUser `E.InnerJoin` submissionEdit) -> do
-                    E.on (submissionEdit E.^. SubmissionEditSubmission   E.==. submission E.^. SubmissionId)
+                    E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
-                    E.on (submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
+                    E.on (subUser        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.where_ $  subUser E.^. SubmissionUserUser E.==. E.val uid
-                          E.&&. sheet          E.^.        SheetCourse E.==. E.val sheetCourse
+                          E.&&. sheet   E.^.        SheetCourse E.==. E.val sheetCourse
                     E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
                     E.limit 1
                     return $ submission E.^. SubmissionId
@@ -140,10 +144,10 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
                     E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
               E.orderBy  [E.asc $ user E.^. UserEmail]
               return $ user E.^. UserEmail
-            return (sheet, map E.unValue buddies, [])
+            return (csheet, map E.unValue buddies, [])
           (E.Value smid:_) -> do
             cID <- encrypt smid
-            addMessageI "info" $ MsgSubmissionAlreadyExists
+            addMessageI Info $ MsgSubmissionAlreadyExists
             redirect $ CSubmissionR tid ssh csh shn cID SubShowR
       (Just smid) -> do
         void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
@@ -172,9 +176,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
                               else E.nothing
               return $ (userName, submissionEdit E.^. SubmissionEditTime)
             forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
-        return (sheet,buddies,lastEdits)
+        return (csheet,buddies,lastEdits)
-  let unpackZips = True -- undefined -- TODO
+  ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies
-  ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping buddies
   mCID <- runDB $ do
     res' <- case res of
       (FormMissing )           -> return $ FormMissing
@@ -231,7 +234,15 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
               -> return smid
             (Just files, _)  -- new files
               -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
-            _ -> error "Impossible, because of definition of `makeSubmissionForm`"
+            (Nothing, Nothing) -- new submission, no file upload requested
+              -> insert Submission
+                  { submissionSheet = shid
+                  , submissionRatingPoints   = Nothing
+                  , submissionRatingComment  = Nothing
+                  , submissionRatingBy       = Nothing
+                  , submissionRatingAssigned = Nothing
+                  , submissionRatingTime     = Nothing
+                  }
           -- 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
@@ -248,7 +259,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
           return smid
         cID <- encrypt smid
         return $ Just cID
-      (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage "warning" . toHtml)
+      (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage Warning . toHtml)
       _other -> return Nothing
   
   case mCID of

src/Handler/Term.hs

@@ -167,12 +167,12 @@ termEditHandler term = do
 -- VOR INTERNATIONALISIERUNG:
 --           let tid = termToText $ termName res
 --           let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."
---           addMessage "success" [shamlet| #{msg} |]
+--           addMessage Success [shamlet| #{msg} |]
 -- MIT INTERNATIONALISIERUNG:
-          addMessageI "success" $ MsgTermEdited tid
+          addMessageI Success $ MsgTermEdited tid
           redirect TermShowR
       (FormMissing  ) -> return ()
-      (FormFailure _) -> addMessageI "warning" MsgInvalidInput
+      (FormFailure _) -> addMessageI Warning MsgInvalidInput
     let actionUrl   = TermEditR
     defaultLayout $ do
       setTitleI MsgTermEditHeading
@@ -180,9 +180,9 @@ termEditHandler term = do
 
 newTermForm :: Maybe Term -> Form Term
 newTermForm template html = do
-    renderMessage <- getMessageRender
+    mr <- getMessageRender
     (result, widget) <- flip (renderAForm FormStandard) html $ Term
-      <$> areq termNewField (fslpI MsgTerm (renderMessage MsgTermPlaceholder)) (termName  <$> template)
+      <$> areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (termName  <$> template)
       <*> areq dayField  (fsl ("Erster Tag" :: Text)) (termStart <$> template)
       <*> areq dayField  (fsl ("Letzer Tag" :: Text)) (termEnd   <$> template)
       <*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined

src/Handler/Users.hs

@@ -14,6 +14,8 @@ import Handler.Utils
 
 import Utils.Lens
 
+import qualified Data.CaseInsensitive as CI
+
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 
@@ -116,7 +118,7 @@ postAdminHijackUserR cID = do
               permissionDenied "Cannot escalate admin status to additional schools"
 
             get404 uid
-          setCredsRedirect $ Creds "dummy" (userPlugin <> ":" <> userIdent) []
+          setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
       | otherwise -> error "This should be impossible by definition of `hijackUserForm`"
-    FormFailure errs -> toTypedContent <$> mapM_ (addMessage "error" . toHtml) errs
+    FormFailure errs -> toTypedContent <$> mapM_ (addMessage Error . toHtml) errs
     FormMissing -> return $ toTypedContent ()

src/Handler/Utils.hs

@@ -12,6 +12,8 @@ module Handler.Utils
 import Import
 
 import qualified Data.Text as T
+-- import qualified Data.Set (Set)
+import qualified Data.Set as Set
 
 import Handler.Utils.DateTime as Handler.Utils
 import Handler.Utils.Form as Handler.Utils
@@ -34,6 +36,11 @@ downloadFiles = do
       AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
       return userDefaultDownloadFiles
 
+tidFromText :: Text -> Maybe TermId
+tidFromText = (fmap TermKey) . maybeRight . termFromText
+
+simpleLink :: Widget -> Route UniWorX -> Widget
+simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
 
 nameWidget :: Text -> Text -> Widget
 nameWidget displayName surname
@@ -52,3 +59,17 @@ nameWidget displayName surname
             |]
       [] -> error "Data.Text.splitOn returned empty list in violation of specification."
 
+
+warnTermDays :: TermId -> [Maybe UTCTime] -> DB ()
+warnTermDays tid times = do
+  Term{..} <- get404 tid
+  let alldays       = Set.map utctDay $ Set.fromList $ catMaybes times
+      warnholidays  = Set.intersection alldays $ Set.fromList termHolidays
+      outoftermdays = Set.filter (\d -> d < termStart        || d > termEnd       ) alldays
+      outoflecture  = Set.filter (\d -> d < termLectureStart || d > termLectureEnd) alldays
+                        `Set.difference` outoftermdays -- out of term implies out of lecture-time
+      warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI Warning $ msg tid dt
+  forM_ warnholidays  $ warnI MsgDayIsAHoliday
+  forM_ outoflecture  $ warnI MsgDayIsOutOfLecture
+  forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
+

src/Handler/Utils/Form.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE LambdaCase #-}
@@ -111,7 +112,7 @@ instance Button UniWorX AdminHijackUserButton where
 -- instance PathPiece LinkButton where
 --     LinkButton route = ???
 
-linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget
+linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
 linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
 --   [whamlet|
 --     <form method=post action=@{url}>
@@ -120,10 +121,6 @@ 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} |]
-
-
     {-
 combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
 combinedButtonField btns inner csrf = do
@@ -157,7 +154,7 @@ combinedButtonField btns inner csrf = do
     -}
 
 -- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
-buttonForm :: (Button UniWorX a) => Form a
+buttonForm :: (Button UniWorX a, Show a) => Form a
 buttonForm csrf = do
     buttonIdent <- newFormIdent
     let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
@@ -168,12 +165,15 @@ buttonForm csrf = do
             $forall bView <- btnViews
               ^{fvInput bView}
           |]
+    $logDebugS "FormResult" $ tshow results
     return (accResult results,widget)
   where
     accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
     accResult = Foldable.foldr accResult' FormMissing
 
     accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
+    -- TODO: Does not work for Forms with more than 3 buttons, since all deliver FormFailure except for one!
+    -- TODO: Maybe change buttonField?
     accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
     accResult' (FormSuccess (Just x)) _ = FormSuccess x
     accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
@@ -187,8 +187,7 @@ buttonForm csrf = do
 -- Fields --
 ------------
 
-ciField :: (Functor m, CI.FoldCase a) => Field m a -> Field m (CI a)
+-- ciField moved to Utils.Form
-ciField = convertField CI.mk CI.original
 
 natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
 natFieldI msg = checkBool (>= 0) msg intField
@@ -219,26 +218,28 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
       return . fromRational $ round (sci * 100) % 100
 
 
-termActiveField :: Field Handler TermId
+termsActiveField :: Field Handler TermId
-termActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
+termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
 
-termActiveOld :: Field Handler TermIdentifier
+termsAllowedField :: Field Handler TermId
-termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
+termsAllowedField = selectField $ do
+  mayEditTerm <- isAuthorized TermEditR True
+  let termFilter | Authorized <- mayEditTerm = []
+                 | otherwise = [TermActive ==. True]
+  optionsPersistKey termFilter [Desc TermStart] termName
+
+termsSetField :: [TermId] -> Field Handler TermId
+termsSetField tids = selectField $ optionsPersistKey [TermName <-. (unTermKey <$> tids)] [Desc TermStart] termName
+-- termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ]
+
+termsActiveOrSetField :: [TermId] -> Field Handler TermId
+termsActiveOrSetField tids = selectField $ optionsPersistKey ([TermActive ==.True] ||. [TermName <-. terms]) [Desc TermStart] termName
+  where terms = map unTermKey tids
+-- termActiveOld :: Field Handler TermIdentifier
+-- termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
 
 termNewField :: Field Handler TermIdentifier
-termNewField = checkMMap checkTerm termToText textField
+termNewField = checkMMap (return.termFromText) termToText textField
-  where
-    errTextParse :: Text
-    errTextParse = "Semester: S oder W gefolgt von Jahreszahl"
-
-    errTextFreigabe :: TermIdentifier -> Text
-    errTextFreigabe ti = "Semester " `T.append` (termToText ti) `T.append` " wurde noch nicht freigegeben."
-
-    checkTerm :: Text -> HandlerT UniWorX IO (Either Text TermIdentifier)
-    checkTerm t = case termFromText t of
-      Left  _       -> return $ Left errTextParse
-      res@(Right _) -> return res
-
 
 schoolField :: Field Handler SchoolId
 schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName
@@ -249,6 +250,13 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
 schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
 schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
 
+uploadModeField :: Field Handler UploadMode
+uploadModeField = selectFieldList
+  [ (MsgUploadModeNone    , NoUpload      )
+  , (MsgUploadModeNoUnpack, Upload   False)
+  , (MsgUploadModeUnpack  , Upload   True )
+  ]
+
 zipFileField :: Bool -- ^ Unpack zips?
              -> Field Handler (Source Handler File)
 zipFileField doUnpack = Field{..}

src/Handler/Utils/Submission.hs

@@ -210,7 +210,10 @@ assignSubmissions sid restriction = do
               $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q <> " (tutorial)"
               assignSubmission (countsToLoad' q) smid q
 
-    forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [SubmissionRatingBy =. Just tutid]
+    now <- liftIO getCurrentTime
+    forM_ (Map.toList subTutor) $
+        \(smid, tutid) -> update smid [ SubmissionRatingBy       =. Just tutid
+                                      , SubmissionRatingAssigned =. Just now  ]
         
     let assignedSubmissions   = Map.keysSet subTutor
         unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions
@@ -325,7 +328,7 @@ extractRatingsMsg = do
       ignored = Right `Set.map` ignored'
   unless (null ignored) $ do
     mr <- (toHtml . ) <$> getMessageRender
-    addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
+    addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
 
 sinkSubmission :: UserId
                -> Either SheetId SubmissionId
@@ -343,11 +346,13 @@ sinkSubmission userId mExists isUpdate = do
   sId <- lift $ case mExists of
     Left sheetId -> do
       let
-        submissionSheet         = sheetId
+        submissionSheet          = sheetId
-        submissionRatingPoints  = Nothing
+        submissionRatingPoints   = Nothing
-        submissionRatingComment = Nothing
+        submissionRatingComment  = Nothing
-        submissionRatingBy      = Nothing
+        submissionRatingBy       = Nothing
-        submissionRatingTime    = Nothing
+        submissionRatingAssigned = Nothing
+        submissionRatingTime     = Nothing
+
       sId <- insert Submission{..}
       -- now <- liftIO getCurrentTime
       -- insert $ SubmissionEdit userId now sId -- This is done automatically during 'sinkSubmission'' iff the given submission is nonempty
@@ -466,6 +471,7 @@ sinkSubmission userId mExists isUpdate = do
             lift $ case isUpdate of
               False -> insert_ $ SubmissionEdit userId now submissionId
               True  -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
+                        -- TODO: Should submissionRatingAssigned change here if userId changes?
             tell $ mempty{ sinkSubmissionTouched = Any True }
 
         finalize :: SubmissionSinkState -> YesodDB UniWorX ()
@@ -586,7 +592,7 @@ sinkMultiSubmission userId isUpdate = do
             lift . feed sId $ Left f{ fileTitle = fileTitle' }
   when (not $ null ignored) $ do
     mr <- (toHtml .) <$> getMessageRender
-    addMessage "warning" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
+    addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
   fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do
     cID <- encrypt sId
     handle (throwM . SubmissionSinkException cID Nothing) $

src/Handler/Utils/Table/Cells.hs

@@ -35,6 +35,12 @@ userCell displayName surname = cell $ nameWidget displayName surname
 maybeTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a
 maybeTimeCell = maybe mempty timeCell
 
+numCell :: (IsDBTable m a, Num b, DisplayAble b) => b -> DBCell m a
+numCell = textCell . display
+
+int64Cell :: (IsDBTable m a) => Int64-> DBCell m a
+int64Cell = numCell
+
 termCell :: IsDBTable m a => TermId -> DBCell m a
 termCell tid = anchorCell link name
   where
@@ -70,7 +76,11 @@ courseCell (Course {..}) = anchorCell link name `mappend` desc
     name = citext2widget courseName
     desc = case courseDescription of
             Nothing      -> mempty
-            (Just descr) -> cell [whamlet| <span style="float:right"> ^{modalStatic descr} |]
+            (Just descr) -> cell [whamlet|
+              $newline never
+              <span style="float:right">
+                ^{modal "Beschreibung" (Right $ toWidget descr)}
+              |]
 
 sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a
 sheetCell crse shn =

src/Handler/Utils/Table/Pagination.hs

@@ -402,7 +402,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
       <* E.offset (psPage * psLimit)
       <* Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
 
-  mapM_ (addMessageI "warning") errs
+  mapM_ (addMessageI Warning) errs
 
   runDB $ do
     rows' <- E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'

src/Handler/Utils/Templates.hs

@@ -2,30 +2,19 @@
 
 module Handler.Utils.Templates where
 
+import Data.Either (isLeft)
+
 import Import.NoFoundation
 
 lipsum :: WidgetT site IO ()
 lipsum = $(widgetFile "widgets/lipsum")
 
-modalStatic :: Html -> WidgetT site IO ()
+modal :: WidgetT site IO () -> Either (Route site) (WidgetT site IO ()) -> WidgetT site IO ()
-modalStatic modalContent = do
+modal modalTrigger modalContent = do
-  uniqueId <- newIdent
+  let modalDynamic = isLeft modalContent
-  let modalTrigger = cons '#' uniqueId -- SJ: I am confused why this is needed here?
+  modalId <- newIdent
-      modalId :: Int32
+  triggerId <- newIdent
-      modalId = 13
-  $(widgetFile "widgets/modalStatic")
-  [whamlet|<div .tooltip__handle ##{uniqueId}>?|] -- SJ: confused why ## is needed here either?
-
-modal :: Text -> Maybe [Char] -> WidgetT site IO ()
-modal modalTrigger (Just modalContent) = do -- WARNING: ModalContent should not have length 11. SJ: This is possibly bad. See Template!
-  let
-    modalId :: Int32
-    modalId = 13
-  $(widgetFile "widgets/modal")
-modal modalTrigger Nothing = do
-  let
-    modalId :: Int32
-    modalId = 13
-    modalContent :: [Char]
-    modalContent = "placeholder"
   $(widgetFile "widgets/modal")
+  case modalContent of
+    Left route -> [whamlet|<a .btn ##{triggerId} href=@{route}>^{modalTrigger}|]
+    Right content -> [whamlet|<div .btn ##{triggerId}>^{modalTrigger}|]

src/Import/NoFoundation.hs

@@ -3,7 +3,7 @@ module Import.NoFoundation
     ( module Import
     ) where
 
-import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON)
+import ClassyPrelude.Yesod    as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI)
 import Model                  as Import
 import Model.Types.JSON       as Import
 import Model.Migration        as Import

src/Model/Migration.hs

@@ -168,12 +168,27 @@ customMigrations = Map.fromListWith (>>)
     , whenM (tableExists "user") $ do
         userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |]
         [executeQQ|
-          ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT ' ';
+          ALTER TABLE "user" ADD COLUMN "surname" text DEFAULT '';
         |]
         forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of
           Just name -> update uid [UserSurname =. name]
           _other    -> error $ "Empty userDisplayName found"
     )
+  , ( AppliedMigrationKey [migrationVersion|3.1.0|] [version|3.2.0|]
+    , whenM (tableExists "sheet") $ do
+        [executeQQ|
+          ALTER TABLE "sheet" ADD COLUMN "upload_mode" json DEFAULT '{ "tag": "Upload", "unpackZips": true }';
+        |]
+    )
+  , ( AppliedMigrationKey [migrationVersion|3.2.0|] [version|4.0.0|]
+    , whenM (tableExists "user") $ do
+        -- <> is standard sql for /=
+        [executeQQ|
+          DELETE FROM "user" WHERE "plugin" <> 'LDAP';
+          ALTER TABLE "user" DROP COLUMN "plugin";
+          ALTER TABLE "user" ADD COLUMN "authentication" json DEFAULT '"ldap"';
+        |]
+    )
   ]
 
 

src/Model/Types.hs

@@ -46,12 +46,14 @@ import Data.CaseInsensitive.Instances ()
 
 import Yesod.Core.Dispatch (PathPiece(..))
 import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
-import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..))
+import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
 
 import GHC.Generics (Generic)
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 import Data.Typeable (Typeable)
 
+import qualified Yesod.Auth.Util.PasswordStore as PWStore
+
 
 instance PathPiece UUID where
   fromPathPiece = Data.UUID.Types.fromString . unpack
@@ -193,6 +195,12 @@ instance DisplayAble DA where
 -}
 
 
+data UploadMode = NoUpload | Upload { unpackZips :: Bool }
+  deriving (Show, Read, Eq, Ord)
+
+deriveJSON defaultOptions ''UploadMode
+derivePersistFieldJSON ''UploadMode
+
 data ExamStatus = Attended | NoShow | Voided
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 derivePersistField "ExamStatus"
@@ -280,13 +288,14 @@ shortened = iso shorten expand
 termToText :: TermIdentifier -> Text
 termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)
 
+-- also see Hander.Utils.tidFromText
 termFromText :: Text -> Either Text TermIdentifier
 termFromText t
   | (s:ys) <- Text.unpack t
   , Just (review shortened -> year) <- readMaybe ys
   , Right season <- seasonFromChar s
   = Right TermIdentifier{..}
-  | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”"
+  | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number
 
 termToRational :: TermIdentifier -> Rational
 termToRational TermIdentifier{..} = fromInteger year + seasonOffset
@@ -329,9 +338,9 @@ instance FromJSON TermIdentifier where
   parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
 
 {- Must be defined in a later module:
-termField :: Field (HandlerT UniWorX IO) TermIdentifier
+    termField :: Field (HandlerT UniWorX IO) TermIdentifier
-termField = checkMMap (return . termFromText) termToText textField
+    termField = checkMMap (return . termFromText) termToText textField
-  -- TODO: this is too simple and inconvenient, use selector and year picker
+   See Handler.Utils.Form.termsField and termActiveField
 -}
 
 
@@ -361,11 +370,13 @@ deriveJSON defaultOptions
   { constructorTagModifier = fromJust . stripPrefix "Theme"
   } ''Theme
 
+$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
+
 instance Universe Theme where universe = universeDef
 instance Finite Theme
 
 instance PathPiece Theme where
-  toPathPiece = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
+  toPathPiece   = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
   fromPathPiece = finiteFromPathPiece
 
 $(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
@@ -381,7 +392,7 @@ instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
     toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName
 
 newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
-  deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql)
+  deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql, IsString)
 
 data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
   deriving (Eq, Ord, Read, Show, Enum, Bounded)
@@ -390,6 +401,8 @@ data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
 data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
   deriving (Eq, Ord, Read, Show, Enum, Bounded)
 
+$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
+
 deriveJSON defaultOptions
   { constructorTagModifier = fromJust . stripPrefix "Corrector"
   } ''CorrectorState
@@ -398,12 +411,25 @@ instance Universe CorrectorState where universe = universeDef
 instance Finite CorrectorState
 
 instance PathPiece CorrectorState where
-  toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
+  toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map toLower . unsafeTail . splitCamel])
   fromPathPiece = finiteFromPathPiece
 
 derivePersistField "CorrectorState"
 
 
+data AuthenticationMode = AuthLDAP
+                        | AuthPWHash { authPWHash :: Text }
+  deriving (Eq, Ord, Read, Show)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , sumEncoding = UntaggedValue
+  } ''AuthenticationMode
+
+derivePersistFieldJSON ''AuthenticationMode
+
+  
 -- Type synonyms
 
 type SchoolName      = CI Text
@@ -412,3 +438,5 @@ type CourseName      = CI Text
 type CourseShorthand = CI Text
 type SheetName       = CI Text
 type UserEmail       = CI Text
+
+type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString

src/Settings.hs

@@ -16,6 +16,7 @@ import           ClassyPrelude.Yesod
 import qualified Control.Exception           as Exception
 import           Data.Aeson                  (Result (..), fromJSON, withObject,
                                               (.!=), (.:?))
+import qualified Data.Aeson.Types as Aeson
 import           Data.Aeson.TH
 import           Data.FileEmbed              (embedFile)
 import           Data.Yaml                   (decodeEither')
@@ -26,12 +27,13 @@ import           Yesod.Default.Config2       (applyEnvValue, configSettingsYml)
 import           Yesod.Default.Util          (WidgetFileSettings,
                                               widgetFileNoReload,
                                               widgetFileReload)
+import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
 import qualified Data.Text.Encoding as Text
 
 import qualified Ldap.Client as Ldap
 
-import Utils
+import Utils hiding (MessageClass(..))
 import Control.Lens
 
 import Data.Maybe (fromJust)
@@ -74,11 +76,10 @@ data AppSettings = AppSettings
     -- ^ Indicate if auth dummy login should be enabled.
     , appAllowDeprecated        :: Bool
     -- ^ Indicate if deprecated routes are accessible for everyone
-    , appAuthPWFile             :: Maybe FilePath
-    -- ^ If set authenticate against a local password file
     , appMinimumLogLevel        :: LogLevel
 
     , appUserDefaults           :: UserDefaultConf
+    , appAuthPWHash             :: PWHashConf
 
     , appCryptoIDKeyFile        :: FilePath
     }
@@ -90,16 +91,21 @@ data UserDefaultConf = UserDefaultConf
   , userDefaultDownloadFiles :: Bool
   }
  
-instance FromJSON UserDefaultConf where
+data PWHashConf = PWHashConf
-  parseJSON = withObject "UserDefaultConf" $ \o -> do
+  { pwHashAlgorithm :: PWHashAlgorithm
-    userDefaultTheme          <- o .: "theme"
+  , pwHashStrength :: Int
-    userDefaultMaxFavourites  <- o .: "favourites"
+  }
-    userDefaultDateTimeFormat <- o .: "date-time-format"
-    userDefaultDateFormat     <- o .: "date-format"
-    userDefaultTimeFormat     <- o .: "time-format"
-    userDefaultDownloadFiles  <- o .: "download-files"
 
-    return UserDefaultConf{..}
+instance FromJSON PWHashConf where
+  parseJSON = withObject "PWHashConf" $ \o -> do
+    pwHashAlgorithm' <- (o .: "algorithm" :: Aeson.Parser Text)
+    pwHashAlgorithm <- if
+      | pwHashAlgorithm' == "pbkdf1" -> return PWStore.pbkdf1
+      | pwHashAlgorithm' == "pbkdf2" -> return PWStore.pbkdf2
+      | otherwise -> fail "Unsupported hash algorithm"
+    pwHashStrength <- o .: "strength"
+
+    return PWHashConf{..}
 
 data LdapConf = LdapConf
   { ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber
@@ -110,6 +116,9 @@ data LdapConf = LdapConf
   }
  
 deriveFromJSON defaultOptions ''Ldap.Scope
+deriveFromJSON defaultOptions
+  { fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel
+  } ''UserDefaultConf
 
 instance FromJSON LdapConf where
     parseJSON = withObject "LdapConf" $ \o -> do
@@ -164,9 +173,9 @@ instance FromJSON AppSettings where
         appSkipCombining          <- o .:? "skip-combining"   .!= defaultDev
         appAuthDummyLogin         <- o .:? "auth-dummy-login" .!= defaultDev
         appAllowDeprecated        <- o .:? "allow-deprecated" .!= defaultDev
-        appAuthPWFile             <- assertM (not . null) <$> o .:? "auth-pwfile"
 
         appUserDefaults           <- o .:  "user-defaults"
+        appAuthPWHash             <- o .:  "auth-pw-hash"
 
         appCryptoIDKeyFile        <- o .:  "cryptoid-keyfile"
 

src/Utils.hs

@@ -25,6 +25,8 @@ import Utils.DB as Utils
 import Utils.TH as Utils
 import Utils.DateTime as Utils
 import Utils.PathPiece as Utils
+import Utils.Message as Utils
+
 
 import Text.Blaze (Markup, ToMarkup)
 
@@ -130,7 +132,7 @@ withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >>
 
 
 -- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production)
-{-# DEPRECATED display "Create RenderMessage Instances instead!" #-}
+{- (not so sure we really want to get rid of display?!) DEPRECATED display "Create RenderMessage Instances instead!" -}
 class DisplayAble a where
   display :: a -> Text
   -- Default definitions for types belonging to Show (allows empty instance declarations)
@@ -300,6 +302,13 @@ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
 whenIsJust (Just x) f = f x
 whenIsJust Nothing  _ = return ()
 
+ifMaybeM :: Monad m => Maybe a -> b -> (a -> m b) -> m b -- more convenient argument order as compared to maybeM
+ifMaybeM Nothing dft _  = return dft
+ifMaybeM (Just x) _ act = act x
+
+maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
+maybeM dft act mb = mb >>= maybe dft act
+
 maybeT :: Monad m => m a -> MaybeT m a -> m a
 maybeT x m = runMaybeT m >>= maybe x return
 
@@ -323,6 +332,27 @@ instance Ord a => Ord (NTop (Maybe a)) where
 
 
 
+------------
+-- Either --
+------------
+
+maybeLeft  :: Either a b -> Maybe a
+maybeLeft  (Left a) = Just a
+maybeLeft  _ = Nothing
+
+maybeRight :: Either a b -> Maybe b
+maybeRight (Right b) = Just b
+maybeRight _ = Nothing
+
+whenIsLeft  :: Monad m => Either a b -> (a -> m ()) -> m ()
+whenIsLeft (Left   x) f = f x
+whenIsLeft (Right  _) _ = return ()
+
+whenIsRight :: Monad m => Either a b -> (b -> m ()) -> m ()
+whenIsRight (Right x) f = f x
+whenIsRight (Left  _) _ = return ()
+
+
 ---------------
 -- Exception --
 ---------------

src/Utils/DB.hs

@@ -37,8 +37,11 @@ getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does
 
 existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
   => Unique record -> ReaderT backend m Bool
-existsBy = fmap isJust . getBy
+existsBy = fmap isJust . getBy -- TODO optimize, so that DB does not deliver entire record
 
+existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistStoreRead backend, MonadIO m)
+  => Key record -> ReaderT backend m Bool
+existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
 
 myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq  record which is not needed anyway)
     :: (MonadIO m

src/Utils/Form.hs

@@ -20,6 +20,9 @@ import qualified Text.Blaze.Internal as Blaze (null)
 import qualified Data.Text as T
 import qualified Data.Char as Char
 
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
 import Web.PathPieces
 
 -------------------
@@ -118,6 +121,20 @@ setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass)
 setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
 setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }
 
+addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => Field m a -> WidgetT (HandlerSite m) IO vals -> Field m a
+addDatalist field mValues = field
+  { fieldView = \fId fName fAttrs fRes fReq -> do
+      listId <- newIdent
+      values <- map toPathPiece . otoList <$> mValues
+      fieldView field fId fName (("list", listId) : fAttrs) fRes fReq
+      [whamlet|
+        $newline never
+        <datalist ##{listId}>
+          $forall value <- values
+            <option value=#{value}>
+      |]
+  }
+
 ------------------------------------------------
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
@@ -178,7 +195,7 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
     fieldParse []    _ = return $ Right Nothing
     fieldParse [str] _
       | str == toPathPiece btn = return $ Right $ Just btn
-      | otherwise  = return $ Left "Wrong button value"
+      | otherwise  = return $ Left "Wrong button value" -- SJ: Right Nothing?!
     fieldParse _ _ = return $ Left "Multiple button values"
 
 combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
@@ -188,3 +205,14 @@ combinedButtonField btns = traverse b2f btns
 
 submitButton :: (Button site SubmitButton, Show (ButtonCssClass site)) => AForm (HandlerT site IO) ()
 submitButton = void $ combinedButtonField [BtnSubmit]
+
+-------------------
+-- Custom Fields --
+-------------------
+
+ciField :: ( Textual t
+           , CI.FoldCase t
+           , Monad m
+           , RenderMessage (HandlerSite m) FormMessage
+           ) => Field m (CI t)
+ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField

src/Utils/Message.hs

@@ -0,0 +1,35 @@
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+
+module Utils.Message
+  ( MessageClass(..)
+  , addMessage, addMessageI
+  ) where
+
+
+import Data.Text as Text (toLower)
+import Data.Universe
+import Utils.PathPiece (finiteFromPathPiece, nullaryToPathPiece)
+
+import qualified ClassyPrelude.Yesod (addMessage, addMessageI)
+import ClassyPrelude.Yesod (PathPiece(..),MonadHandler,HandlerSite,RenderMessage,Html)
+
+
+data MessageClass = Error | Warning | Info | Success
+  deriving (Eq,Ord,Enum,Bounded,Show,Read)
+
+instance Universe MessageClass
+instance Finite   MessageClass
+
+$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
+
+instance PathPiece MessageClass where
+  toPathPiece   = $(nullaryToPathPiece ''MessageClass [Text.toLower])
+  fromPathPiece = finiteFromPathPiece
+
+addMessage :: MonadHandler m => MessageClass-> Html -> m ()
+addMessage mc  = ClassyPrelude.Yesod.addMessage  (toPathPiece mc)
+
+addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m ()
+addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc)

src/Utils/PathPiece.hs

@@ -35,15 +35,17 @@ nullaryToPathPiece nullaryType manglers = do
   where
     mangle = appEndo (foldMap Endo manglers) . Text.pack
   
-splitCamel :: Text -> [Text]
+splitCamel :: Textual t => t -> [t]
-splitCamel = map Text.pack . reverse . helper (error "hasChange undefined at start of string") [] "" . Text.unpack
+splitCamel = map fromList . reverse . helper (error "hasChange undefined at start of string") [] "" . otoList
   where
     helper _hadChange items thisWord [] = reverse thisWord : items
     helper _hadChange items [] (c:cs) = helper True items [c] cs
     helper  hadChange items ws@(w:ws') (c:cs)
       | sameCategory w c
-      , null ws'         = helper False items (c:ws) cs
+      , null ws'         = helper (Char.isLower w) items (c:ws) cs
       | sameCategory w c = helper hadChange items (c:ws) cs
+      | Char.isLower w
+      , Char.isUpper c   = helper True (reverse ws :items) [c] cs
       | null ws'         = helper True items (c:ws) cs
       | not hadChange    = helper True (reverse ws':items) [c,w] cs
       | otherwise        = helper True (reverse ws :items) [c] cs

src/index.md

@@ -19,6 +19,9 @@ Utils.Form
 Utils.PathPiece
   : (Template-Haskell)-Hilfsfunktionen für Formulierung von PathPiece-Instanzen
     
+Utils.Message
+  : redefines addMessage, addMessageI, defines MessageClass
+
 Utils.Lens
   : Automatisch erzeugt Linsen für eigene und Yesod-Typen, `Control.Lens`-Export
   

templates/adminTest.hamlet

@@ -22,7 +22,6 @@
     <li .list-group-item>
       <a href=@{CourseNewR}>Kurse anlegen
 
-<hr>
 <div .container>
   <h2>Funktionen zum Testen
 
@@ -33,9 +32,5 @@
           ^{btnWdgt}
     <li><br>
       Modals:
-      ^{modal ".toggler1" Nothing}
+      ^{modal "Klick mich für Ajax-Test" (Left UsersR)}
-      <a href="/" .btn.toggler1>Klick mich für Ajax-Test
+      ^{modal "Klick mich für Content-Test" (Right "Test Inhalt für Modal")}
-        <noscript>(Für Modals bitte JS aktivieren)</noscript>
-      ^{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>

templates/default-layout-wrapper.hamlet

@@ -7,38 +7,11 @@ $newline never
 <html class="no-js" lang="en"> <!--<![endif]-->
   <head>
     <meta charset="UTF-8">
-
     <title>#{pageTitle pc}
-    <meta name="description" content="">
-    <meta name="author" content="">
-
     <meta name="viewport" content="width=device-width,initial-scale=1">
 
     ^{pageHead pc}
 
-    \<!--[if lt IE 9]>
-    \<script src="http://html5shiv.googlecode.com/svn/trunk/html5.js"></script>
-    \<![endif]-->
-    <script type="text/javascript" src="https://cdnjs.cloudflare.com/ajax/libs/js-cookie/2.0.3/js.cookie.min.js">
-    <script>
-      /* The `defaultCsrfMiddleware` Middleware added in Foundation.hs adds a CSRF token to the request cookies. */
-      /* AJAX requests should add that token to a header to be validated by the server. */
-      /* See the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package for details. */
-      var csrfHeaderName = "#{TE.decodeUtf8 $ CI.foldedCase defaultCsrfHeaderName}";
-
-      var csrfCookieName = "#{TE.decodeUtf8 defaultCsrfCookieName}";
-      var csrfToken = Cookies.get(csrfCookieName);
-
-
-      if (csrfToken) {
-      \  $.ajaxPrefilter(function( options, originalOptions, jqXHR ) {
-      \      if (!options.crossDomain) {
-      \          jqXHR.setRequestHeader(csrfHeaderName, csrfToken);
-      \      }
-      \  });
-      }
-
-
   <body .no-js .theme--#{toPathPiece currentTheme} :isAuth:.logged-in>
     <!-- removes no-js class from body if client supports javascript -->
     <script>

templates/default-layout.lucius

@@ -113,7 +113,7 @@ a:hover {
 
 
 ul {
-  list-style-type: none;
+  margin-left: 20px;
 }
 
 h1, h2, h3, h4, h5 {
@@ -424,8 +424,17 @@ input[type="button"].btn-info:hover,
 }
 
 /* LIST MODIFIERS */
-.list--inline li {
+.list--iconless {
-  display: inline-block;
+  list-style-type: none;
+  margin-left: 0;
+}
+
+.list--inline {
+  margin-left: 0;
+
+  li {
+    display: inline-block;
+  }
 }
 
 .list--comma-separated li {

templates/login.hamlet

@@ -3,6 +3,11 @@ $forall AuthPlugin{..} <- plugins
     <section>
       <h2>_{MsgLDAPLoginTitle}
       ^{apLogin toParent}
+  $elseif apName == "PWHash"
+    <section>
+      <h2>_{MsgPWHashLoginTitle}
+      <p>_{MsgPWHashLoginNote}
+      ^{apLogin toParent}
   $elseif apName == "dummy"
     <section>
       <h2>_{MsgDummyLoginTitle}

templates/multiFileField.hamlet

@@ -16,5 +16,5 @@ $# new files
   <label for=#{fieldId}_zip>ZIPs automatisch entpacken
   <input type=checkbox id=#{fieldId}_zip name=#{fieldName} value=#{unpackZips}>
   <div class="js-tooltip">
-    <div class="tooltip__handle">?
+    <div class="tooltip__handle">
     <div class="tooltip__content">Entpackt hochgeladene Zip-Dateien (*.zip) automatisch und fügt den Inhalt dem Stamm-Verzeichnis der Abgabe hinzu.

templates/profile.hamlet

@@ -3,33 +3,29 @@
   <dl .deflist.profile-dl>
       <dt .deflist__dt> _{MsgName}
       <dd .deflist__dd> ^{nameWidget userDisplayName userSurname}
-      <dt .deflist__dt> _{MsgMatrikelNr}
+      $maybe matnr <- userMatrikelnummer
-      <dd .deflist__dd> #{display userMatrikelnummer}
+        <dt .deflist__dt> _{MsgMatrikelNr}
+        <dd .deflist__dd> #{matnr}
       <dt .deflist__dt> _{MsgEMail}
       <dd .deflist__dd> #{display userEmail}
       <dt .deflist__dt> _{MsgIdent}
       <dd .deflist__dd> #{display userIdent}
-      <dt .deflist__dt> _{MsgPlugin}
-      <dd .deflist__dd> #{display userPlugin}
     $if not $ null admin_rights
       <dt .deflist__dt> Administrator
       <dd .deflist__dd>
         <ul .list-ul>
-          $forall institute <- admin_rights
+          $forall (E.Value institute) <- admin_rights
-            <li .list-ul__item>#{display institute}
+            <li .list-ul__item>
+              <a href=@{SchoolShowR $ SchoolKey institute}>
+                #{display institute}
     $if not $ null lecturer_rights
       <dt .deflist__dt> Lehrberechtigt
       <dd .deflist__dd>
         <ul .list-ul>
-          $forall institute <- lecturer_rights
+          $forall (E.Value institute) <- lecturer_rights
-            <li .list-ul__item>#{display institute}
-    $if not $ null lecture_owner
-      <dt .deflist__dt> Eigene Kurse
-      <dd .deflist__dd>
-        <ul .list-ul>
-          $forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_owner
             <li .list-ul__item>
-              <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
+              <a href=@{SchoolShowR $ SchoolKey institute}>
+                #{display institute}
     $if not $ null lecture_corrector
       <dt .deflist__dt> Korrektor
       <dd .deflist__dd>
@@ -48,21 +44,19 @@
               <th .table__th> Studienart
               <th .table__th> Semester
 
-            $forall (degree,field,fieldtype,semester) <- studies
+            $forall ((degree, degreeKey),(field, fieldKey),fieldtype,semester) <- studies
               <tr.table__row>
-                <td .table__td> #{display degree}
+                <td .table__td>
-                <td .table__td> #{display field}
+                  $maybe name <- E.unValue degree
-                <td .table__td> #{display fieldtype}
+                    #{display name}
-                <td .table__td> #{display semester}
+                  $nothing
-
+                    #{display degreeKey}
-    $if not $ null participant
+                <td .table__td>
-      <dt .deflist__dt> Teilnehmer
+                  $maybe name <- E.unValue field
-      <dd .deflist__dd>
+                    #{display name}
-        <dl .deflist>
+                  $nothing
-          $forall (E.Value tid, E.Value ssh, E.Value csh, E.Value regSince) <- participant
+                    #{display fieldKey}
-            <dt .deflist__dt>
+                <td .table__td>_{E.unValue fieldtype}
-                <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
+                <td .table__td>#{display semester}
-            <dd .deflist__dd>
-                seit ^{formatTimeW SelFormatDateTime regSince}
 
   ^{settingsForm}

templates/profileData.hamlet

@@ -1,13 +1,4 @@
 <div .container>
-  <div .alerts>
-    <div .alert .alert-danger>
-      <div .alert__content>
-        TODO: Alle Benutzerbezogenen Daten sollen hier angezeigt
-        und verlinkt werden
-        (alle Abgaben, Klausurnoten, etc.)
-
-  <em> TODO: Hier alle Daten in Tabellen anzeigen!
-
   $if hasRows
     <div .container>
       <h2> Eigene Kurse
@@ -24,6 +15,11 @@
     <div .container>
       ^{examTable}
 
+  <div .container>
+    <h2> Eigene Übungsgruppen
+    <div .container>
+      ^{ownTutorialTable}
+
   <div .container>
     <h2> Übungsgruppen
     <div .container>
@@ -47,9 +43,15 @@
     <div .container>
       ^{correctionsTable}
 
-  <h2>
+    <h4> Hinweis:
-        <em> TODO: Knopf zum Löschen aller Daten erstellen
+    Die oberhalb angezeigte Tabelle zeigt nur prinzipielle Einteilungen als Korrektor zu einem Übungsblatt;
+    auch ohne Einteilung können Korrekturen einzeln zugewiesen werden, welche hier nicht aufgeführt werden.
+    Hier finden Sie eine
+    <a href=@{CorrectionsR}>Auflistung aller tatsächlich zugewiesenen Korrekturen
+    .
 
+  <h2>
+        ^{modal "Alle Benutzerbezogenen Daten löschen" (Right delWdgt)}
   <p>
     <h4>Hinweise:
     <ul>

templates/standalone/alerts.julius

@@ -3,25 +3,75 @@
 
   window.utils = window.utils || {};
 
-  window.utils.alert = function(alertEl) {
+  var ALERT_INVISIBLE_CLASS = 'alert--invisible';
-    var closeEl = document.createElement('DIV');
+  var TOGGLER_INVISIBLE_CLASS = 'alerts__toggler--visible';
-    var dataDecay = alertEl.dataset.decay;
-    var autoDecay = 30;
-    if (dataDecay) {
-      autoDecay = parseInt(dataDecay, 10);
-    }
-    closeEl.classList.add('alert__close');
-    closeEl.addEventListener('click', function(event) {
-      alertEl.classList.add('alert--invisible');
-    });
-    alertEl.insertBefore(closeEl, alertEl.children[0]);
 
-    // auto-hide info and success-alerts after 3 seconds
+  window.utils.alerts = function(alertsEl) {
-    if (autoDecay > 0 && !alertEl.matches('.alert-danger, .alert-warning')) {
+
-      window.setTimeout(function() {
+    var alerts = Array.from(alertsEl.querySelectorAll('.alert'));
-        alertEl.classList.add('alert--invisible');
+    var toggler;
-      }, autoDecay * 1000);
+    var showingToggler = false;
+
+    function makeToggler() {
+      toggler = document.createElement('DIV');
+      toggler.classList.add('alerts__toggler');
+      toggler.addEventListener('click', function() {
+        alerts.forEach(function(alert) {
+          alert.classList.remove(ALERT_INVISIBLE_CLASS);
+          toggler.classList.remove(TOGGLER_INVISIBLE_CLASS);
+        });
+        checkToggler();
+      });
+      alertsEl.appendChild(toggler);
     }
+
+    function makeAlert(alertEl) {
+      var iconEl = document.createElement('DIV');
+      var closeEl = document.createElement('DIV');
+      var dataDecay = alertEl.dataset.decay;
+      var autoDecay = 30;
+      if (dataDecay) {
+        autoDecay = parseInt(dataDecay, 10);
+      }
+      iconEl.classList.add('alert__icon');
+      closeEl.classList.add('alert__close');
+      closeEl.addEventListener('click', function(event) {
+        closeAlert(alertEl);
+      });
+      alertEl.insertBefore(iconEl, alertEl.children[0]);
+      alertEl.insertBefore(closeEl, alertEl.children[0]);
+
+      // auto-hide info and success-alerts after 3 seconds
+      if (autoDecay > 0 && !alertEl.matches('.alert-warning, .alert-error')) {
+        window.setTimeout(function() {
+          closeAlert(alertEl);
+        }, autoDecay * 1000);
+      }
+    }
+
+    function closeAlert(alertEl) {
+      alertEl.classList.add(ALERT_INVISIBLE_CLASS);
+      checkToggler();
+    }
+
+    function checkToggler() {
+      var hidden = true;
+      alerts.forEach(function(alert) {
+        if (hidden && !alert.classList.contains(ALERT_INVISIBLE_CLASS)) {
+          hidden = false;
+        }
+      });
+      if (!showingToggler) {
+        showingToggler = true;
+        window.setTimeout(function() {
+          toggler.classList.toggle(TOGGLER_INVISIBLE_CLASS, hidden);
+          showingToggler = false;
+        }, 120);
+      }
+    }
+
+    makeToggler();
+    alerts.map(makeAlert);
   }
 
 })();
@@ -29,7 +79,5 @@
 document.addEventListener('DOMContentLoaded', function() {
 
   // setup alerts
-  Array.from(document.querySelectorAll('.alert')).forEach(function(alertEl) {
+  window.utils.alerts(document.querySelector('.alerts'));
-    window.utils.alert(alertEl);
-  });
 });

templates/standalone/alerts.lucius

@@ -3,100 +3,152 @@
   .alert
     Regular Info Alert
     Disappears automatically after 30 seconds
-    Disappears after x seconds if explicitly specified via data-decay='x' on html element
+    Disappears after x seconds if explicitly specified via data-decay='x'
     Can be told not to disappear with data-decay='0'
 
-  .alert-warning, .alert-error
+  .alert-success
-    Warning or Error alert
+    Disappears automatically after 30 seconds
-    These don't disappear, only difference is color
+
-    .alert-warning is orange regardless of user's selected theme
+  .alert-warning
-    .alert-error is red regardless of user's selected theme
+    Does not disappear
+    Orange regardless of user's selected theme
+
+  .alert-error
+    Does not disappear
+    Red regardless of user's selected theme
 
  */
 .alerts {
   position: fixed;
-  bottom: 5%;
+  bottom: 0;
-  right: 0;
+  right: 5%;
   z-index: 20;
   text-align: right;
   display: flex;
   flex-direction: column;
 }
 
+.alerts__toggler {
+  width: 40px;
+  height: 40px;
+  position: absolute;
+  top: 400px;
+  left: 50%;
+  transform: translateX(-50%);
+  cursor: pointer;
+
+  &::before {
+    content: '\f077';
+    position: absolute;
+    font-family: "Font Awesome 5 Free";
+    left: 50%;
+    top: 0;
+    height: 30px;
+    display: flex;
+    align-items: center;
+    justify-content: center;
+    width: 30px;
+    color: var(--color-lightblack);
+    font-size: 30px;
+    transform: translateX(-50%);
+  }
+}
+
+.alerts__toggler--visible {
+  top: -40px;
+  opacity: 1;
+  transition: top     .5s cubic-bezier(0.73, 1.25, 0.61, 1),
+              opacity .5s cubic-bezier(0.73, 1.25, 0.61, 1);
+}
+
+@media (max-width: 425px) {
+
+  .alerts {
+    left: 5%;
+  }
+}
+
 .alert {
   position: relative;
-  display: inline-block;
+  display: block;
-  background-color: var(--color-dark);
+  background-color: var(--color-lightblack);
   font-size: 1rem;
   color: var(--color-lightwhite);
   z-index: 0;
-  max-height: 200px;
+  padding: 0 50px;
-  transition: all .3s ease-in-out;
+  padding-right: 60px;
-  padding-left: 20px;
-  margin-left: 20px;
   animation: slide-in-alert .2s ease-out forwards;
-  margin-bottom: 20px;
+  margin-bottom: 10px;
-
+  transition: margin-bottom .2s ease-out;
-  &:hover {
-
-    .alert__content {
-
-      &::after {
-        opacity: 1;
-      }
-    }
-  }
 }
 
 @keyframes slide-in-alert {
   from {
-    left: 120%;
+    transform: translateY(120%);
   }
   to {
-    left: 0;
+    transform: translateY(0);
+  }
+}
+
+@keyframes slide-out-alert {
+  from {
+    transform: translateY(0);
+    max-height: 200px;
+  }
+  to {
+    transform: translateY(250%);
+    opacity: 0;
+    max-height: 0;
+    overflow: hidden;
   }
 }
 
 @media (min-width: 425px) {
 
   .alert {
-    margin-left: 80px;
+    max-width: 400px;
-    max-width: 420px;
   }
 }
 
-@media (min-width: 768px) {
+.alert--invisible {
-
+  animation: slide-out-alert .2s ease-out forwards;
-  .alert {
+  margin-bottom: 0;
-    padding-left: 30px;
-    margin-left: 40px;
-    min-width: 400px;
-  }
-}
-
-@media (min-width: 1024px) {
-
-  .alert {
-    min-width: 350px;
-  }
 }
 
 .alert__content {
-  padding: 8px 1.5em;
+  padding: 8px 0;
   min-height: 40px;
   position: relative;
   display: flex;
   font-weight: 600;
-  justify-content: flex-end;
   align-items: center;
   text-align: left;
 }
 
-@media (max-width: 768px) {
+.alert__icon {
+  text-align: right;
+  position: absolute;
+  left: 0px;
+  top: 0;
+  width: 50px;
+  height: 100%;
+  z-index: 40;
 
-  .alert__content {
+  &::before {
-    padding: 4px 7px;
+    content: '\f05a';
-    padding-left: 25px;
+    position: absolute;
+    font-family: "Font Awesome 5 Free";
+    font-size: 24px;
+    top: 50%;
+    left: 50%;
+    display: flex;
+    align-items: center;
+    justify-content: center;
+    transform: translate(-50%, -50%);
+    border-radius: 50%;
+    width: 30px;
+    height: 30px;
   }
 }
 
@@ -104,7 +156,7 @@
   cursor: pointer;
   text-align: right;
   position: absolute;
-  left: 0px;
+  right: 0px;
   top: 0;
   width: 60px;
   height: 100%;
@@ -145,18 +197,26 @@
   }
 }
 
+.alert-success {
+  background-color: var(--color-success);
+
+  .alert__icon::before {
+    content: '\f058';
+  }
+}
+
 .alert-warning {
   background-color: var(--color-warning);
+
+  .alert__icon::before {
+    content: '\f06a';
+  }
 }
 
-.alert-danger,
 .alert-error {
   background-color: var(--color-error);
-}
 
-.alert--invisible {
+  .alert__icon::before {
-  max-height: 0;
+    content: '\f071';
-  transform: translateX(120%);
+  }
-  margin-bottom: 0;
-  overflow: hidden;
 }

templates/standalone/inputs.lucius

@@ -30,6 +30,16 @@
   }
 }
 
+.form-group--submit .form-group__input {
+  grid-column: 2;
+}
+
+@media (max-width: 768px) {
+  .form-group--submit .form-group__input {
+    grid-column: 1;
+  }
+}
+
 .form-group--has-error {
   background-color: rgba(255, 0, 0, 0.1);
 
@@ -187,6 +197,7 @@ input[type="checkbox"]:checked::after {
 .checkbox,
 .radio {
   position: relative;
+  display: inline-block;
 
   [type="checkbox"],
   [type="radio"] {

templates/standalone/modal.julius

@@ -6,12 +6,11 @@
   window.utils.modal = function(modal) {
     var overlay = document.createElement('div');
     var closer = document.createElement('div');
-    var trigger = document.querySelector(modal.dataset.trigger);
+    var trigger = document.querySelector('#' + modal.dataset.trigger);
     var origParent = modal.parentNode;
 
     function open(event) {
       // disable modals for narrow screens
-      if (window.innerWidth < 768) return true;
       if (event) {
         event.preventDefault();
       }
@@ -20,7 +19,6 @@
       document.body.insertBefore(modal, null);
       document.body.insertBefore(overlay, modal);
       overlay.classList.add('modal__overlay--open');
-      toggleScroll(false);
 
       if (modal.dataset.closeable === 'true') {
         closer.classList.add('modal__closer');
@@ -30,8 +28,8 @@
       }
     }
 
-    // open this modal with an event:
+    // you can open this modal via event
-    // document.dispatchEvent(new CustomEvent('modal-open', { dateils: {for: 'modal-13'}}))
+    // example: document.dispatchEvent(new CustomEvent('modal-open', { details: { for: 'modal-[id]' }}))
     function openOnEvent(event) {
       if (event.detail.for === modal.getAttribute('id')) {
         open();
@@ -43,7 +41,6 @@
         overlay.remove();
         origParent.insertBefore(modal, null);
         modal.classList.remove('modal--open');
-        toggleScroll(true);
         closer.removeEventListener('click', close, false);
       }
     };
@@ -56,27 +53,20 @@
         trigger.classList.add('modal__trigger');
         trigger.addEventListener('click', open, false);
       }
-      // if there is no content specified for the modal we assume that
+
-      // the content is supposed to be the page the trigger links to.
+      if (modal.dataset.dynamic === 'True') {
-      // so we check if the trigger has a href-attribute, fetch that page
+        var dynamicContentURL = trigger.getAttribute('href');
-      // and replace the modal content with the response
+        if (dynamicContentURL.length > 0) {
-      var replaceMe = modal.querySelector('.replace-me');
+          fetch(dynamicContentURL, {
-      var replaceWith = trigger ? trigger.getAttribute('href') : '';
+            credentials: 'same-origin',
-      if (replaceMe) {
-        replaceMe.classList.remove('replace-me');
-        replaceMe.innerText = '...loading';
-        if (replaceWith.length > 0) {
-          fetch(replaceWith, {
-            credentials: 'same-origin'
           }).then(function(response) {
             return response.text();
           }).then(function(body) {
             var modalContent = document.createElement('div');
             modalContent.innerHTML = body;
-            var main = modalContent.querySelector('.main__content');
+            var main = modalContent.querySelector('.main__content-body');
             if (main) {
-              replaceMe.innerText = '';
+              modal.appendChild(main);
-              replaceMe.insertBefore(main, null);
             } else {
               replaceMe.innerHTML = body;
             }
@@ -88,11 +78,6 @@
     }
     setup();
   };
-
-  // make sure document doesn't scroll when modal is active
-  function toggleScroll(scrollable) {
-    document.body.classList.toggle('no-scroll', !scrollable);
-  }
 })();
 
 document.addEventListener('DOMContentLoaded', function() {

templates/standalone/modal.lucius

@@ -4,14 +4,15 @@
   top: 50%;
   transform: translate(-50%, -50%) scale(0.8, 0.8);
   display: block;
-  background-color: rgba(255, 255, 255, 0.9);
+  background-color: rgba(255, 255, 255, 0.99);
   min-width: 60vw;
   min-height: 100px;
   max-height: calc(100vh - 30px);
-  border-radius: 7px;
+  border-radius: 2px;
   z-index: -1;
   color: var(--color-font);
   padding: 20px;
+  padding-right: 65px;
   overflow: auto;
   opacity: 0;
   transition: all .15s ease;
@@ -81,7 +82,3 @@
     color: white;
   }
 }
-
-.no-scroll {
-  overflow: hidden;
-}

templates/standalone/tooltip.lucius

@@ -19,6 +19,23 @@
   text-align: center;
   margin: 0 10px;
   cursor: default;
+  position: relative;
+
+  &::before {
+    content: '\f128';
+    position: absolute;
+    top: 0;
+    left: 0;
+    font-family: "Font Awesome 5 Free";
+    top: 50%;
+    left: 50%;
+    transform: translate(-50%, -50%);
+    font-size: 15px;
+  }
+
+  &:hover {
+    background-color: var(--color-light);
+  }
 }
 
 .tooltip__content {

templates/submission.hamlet

@@ -1,12 +1,17 @@
 $maybe cID <- mcid
   <section>
-    <h2>
+    $case sheetUploadMode
-      <a href=@{urlArchive cID}>Archiv
+      $of Upload _
-      (<a href=@{urlOriginal cID}>Original</a>)
+        <h2>
+          <a href=@{urlArchive cID}>Archiv
+          (<a href=@{urlOriginal cID}>Original</a>)
 
-    $maybe fileTable <- mFileTable
+        $maybe fileTable <- mFileTable
-      <h3>_{MsgSubmissionFiles}
+          <h3>_{MsgSubmissionFiles}
-      ^{fileTable}
+          ^{fileTable}
+      $of _
+        <p>
+          _{MsgSubmissionNoUploadExpected}
 
     $if not (null lastEdits)
       <h3>_{MsgLastEdits}

templates/widgets/asidenav.hamlet

@@ -9,13 +9,13 @@ $newline never
               _{MsgWinterTermShort year}
             $of Summer
               _{MsgSummerTermShort year}
-        <ul .asidenav__list.js-show-hide__target>
+        <ul .asidenav__list.js-show-hide__target.list--iconless>
           $forall (Course{..}, courseRoute, pageActions) <- favouriteTerm tid
             <li .asidenav__list-item :highlight courseRoute:.asidenav__list-item--active>
               <a .asidenav__link-wrapper href=@{courseRoute}>
                 <div .asidenav__link-shorthand>#{courseShorthand}
                 <div .asidenav__link-label>#{courseName}
-              <ul .asidenav__nested-list>
+              <ul .asidenav__nested-list.list--iconless>
                 $forall action <- pageActions
                   $case action
                     $of PageActionPrime (MenuItem{..})

templates/widgets/dummy-login-form.hamlet

@@ -0,0 +1,2 @@
+<form method=POST action=@{toMaster $ PluginR "dummy" []} enctype=#{loginEnctype}>
+  ^{login}

templates/widgets/form.hamlet

@@ -3,6 +3,7 @@ $newline never
 $case formLayout
   $of FormStandard
     $forall view <- views
+      $# TODO: add class 'form-group--submit' if this is the submit-button view
       <div .form-group :fvRequired view:.form-group--required :not $ fvRequired view:.form-group--optional :isJust $ fvErrors view:.form-group--has-error>
         $if not (Blaze.null $ fvLabel view)
           <label .form-group__label for=#{fvId view}>#{fvLabel view}
@@ -10,5 +11,5 @@ $case formLayout
           ^{fvInput view}
           $maybe tooltip <- fvTooltip view
             <div .js-tooltip>
-              <div .tooltip__handle>?
+              <div .tooltip__handle>
               <div .tooltip__content>^{tooltip}

templates/widgets/hash-login-form.hamlet

@@ -0,0 +1,2 @@
+<form method=POST action=@{toMaster $ PluginR "PWHash" []} enctype=#{loginEnctype}>
+  ^{login}

templates/widgets/modal.hamlet

@@ -1,8 +1,5 @@
-<div .modal.js-modal #modal-#{modalId} data-trigger=#{modalTrigger} data-closeable=true>
+<div .modal.js-modal #modal-#{modalId} data-trigger=#{triggerId} data-closeable=true data-dynamic=#{modalDynamic}>
-  $# primitive way of checking if this is supposed to be add a placeholder for async data.
+  $case modalContent
-  $# modalContent is 'placeholder' if there should be a placeholder only.
+    $of Right content
-  $# 'placeholder' has length 11.
+      ^{content}
-  $if 11 == length modalContent
+    $of Left _
-    <div .replace-me>
-  $else
-    #{modalContent}

templates/widgets/modalStatic.hamlet

@@ -1,2 +0,0 @@
-<div .modal.js-modal #modal-#{modalId} data-trigger=#{modalTrigger} data-closeable=true>
-  #{modalContent}

templates/widgets/navbar.lucius

@@ -41,7 +41,7 @@
   background: linear-gradient(to top, var(--color-dark) 0%,var(--color-darker) 100%); /* W3C, IE10+, FF16+, Chrome26+, Opera12+, Safari7+ */
   color: white;
   margin-right: 40px;
-  z-index: 10;
+  z-index: 20;
   box-shadow: 0 0 4px rgba(0, 0, 0, 0.2);
   overflow: auto;
   transition: all .2s cubic-bezier(0.03, 0.43, 0.58, 1);

templates/widgets/pageactionprime.lucius

@@ -6,6 +6,7 @@
 
 .pagenav__list {
   display: block;
+  margin-left: 0;
 }
 
 .pagenav__list-item {