Merge branch 'master' into feat/jobs

.gitignore

@@ -30,3 +30,6 @@ src/Handler/Assist.bak
 src/Handler/Course.SnapCustom.hs
 *.orig
 /instance
+.stack-work-*
+.directory
+tags

ChangeLog.md

@@ -0,0 +1,42 @@
+  * Version 18.09.2018
+
+    Tooltips funktionieren auch ohne JavaScript
+
+    Kurskürzel müssen nur innerhalb eines Instituts eindeutig sein
+
+    User Data zeigt nun alle momentan gespeicherten Datensätze an
+
+    Unterstützung von Tabellenzusammenfassungen, z.B. Punktsummen
+
+    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
+
+  * Version 01.08.2018
+
+    Verbesserter Campus-Login
+    (Ersatz einer C-Bibliothek mit undokumentierter Abhängigkeit durch selbst entwickelten Haskell-Code erlaubt nun auch Umlaute.)
+
+  * Version 31.07.2018
+
+    Viele Verbesserung zur Anzeige von Korrekturen
+
+    Kursliste über alle Semester hinweg (Top-Level-Navigation "Kurse"), wird in Zukunft Filter/Suchfunktion erhalten
+
+  * Version 10.07.2018
+
+    Bugfixes, wählbares Format für Datum
+
+  * Version 04.07.2018
+
+    Hinweis eingefügt, dass alle Daten des Systems spätestens im Dezember 2018
+    gelöscht werden.
+
+  * Version 03.07.2018
+
+    Willkommen bei Uni2work aka "You-need-to-work!"
+

Dockerfile

@@ -1,6 +0,0 @@
-FROM fpco/stack-build:lts-9.3
-
-ENV DEBIAN_FRONTEND noninteractive
-
-RUN apt-get update
-RUN apt-get install libldap2-dev libsasl2-dev

FragenSJ.txt

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

README.md

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

config/keter.yml

@@ -1,42 +0,0 @@
-root: ..
-
-stanzas:
-  - type: webapp
-
-    # Name of your executable. You are unlikely to need to change this.
-    # Note that all file paths are relative to the keter.yml file.
-    #
-    # The path given is for Stack projects. If you're still using cabal, change
-    # to
-    # exec: ../dist/build/uniworx/uniworx
-    exec: ../dist/bin/uniworx
-
-    # Command line options passed to your application.
-    args: []
-
-    hosts:
-      - testworx.tcs.ifi.lmu.de
-
-    ssl: true
-
-    forward-env:
-      - LDAPURI
-      - LDAPDN
-      - LDAPPW
-      - LDAPBN
-      - DUMMY_LOGIN
-      - DETAILED_LOGGING
-      - LOG_ALL
-
-# Use the following to automatically copy your bundle upon creation via `yesod
-# keter`. Uses `scp` internally, so you can set it to a remote destination
-# copy-to: user@host:/opt/keter/incoming/
-copy-to: keter@testworx.tcs.ifi.lmu.de:/opt/keter/incoming/
-copy-to-args:
-  - "-P 30363"
-
-# If you would like to have Keter automatically create a PostgreSQL database
-# and set appropriate environment variables for it to be discovered, uncomment
-# the following line.
-plugins:
-  postgres: true

config/keter.yml

@@ -0,0 +1 @@
+keter_testworx.yml

config/keter_testworx.yml

@@ -0,0 +1,49 @@
+root: ..
+
+stanzas:
+  - type: webapp
+
+    # Name of your executable. You are unlikely to need to change this.
+    # Note that all file paths are relative to the keter.yml file.
+    #
+    # The path given is for Stack projects. If you're still using cabal, change
+    # to
+    # exec: ../dist/build/uniworx/uniworx
+    exec: ../dist/bin/uniworx
+
+    # Command line options passed to your application.
+    args: []
+
+    hosts:
+      - testworx.tcs.ifi.lmu.de
+
+    ssl: true
+
+    forward-env:
+      - LDAPHOST
+      - LDAPTLS
+      - LDAPPORT
+      - LDAPUSER
+      - LDAPPASS
+      - LDAPBASE
+      - LDAPSCOPE
+      - LDAPTIMEOUT
+      - DUMMY_LOGIN
+      - DETAILED_LOGGING
+      - LOG_ALL
+      - PWFILE
+      - CRYPTOID_KEYFILE
+      - IP_FROM_HEADER
+
+# Use the following to automatically copy your bundle upon creation via `yesod
+# keter`. Uses `scp` internally, so you can set it to a remote destination
+# copy-to: user@host:/opt/keter/incoming/
+copy-to: keter@testworx.tcs.ifi.lmu.de:/opt/keter/incoming/
+copy-to-args:
+  - "-P 30363"
+
+# If you would like to have Keter automatically create a PostgreSQL database
+# and set appropriate environment variables for it to be discovered, uncomment
+# the following line.
+plugins:
+  postgres: true

config/keter_uni2work.yml

@@ -0,0 +1,50 @@
+root: ..
+
+stanzas:
+  - type: webapp
+
+    # Name of your executable. You are unlikely to need to change this.
+    # Note that all file paths are relative to the keter.yml file.
+    #
+    # The path given is for Stack projects. If you're still using cabal, change
+    # to
+    # exec: ../dist/build/uniworx/uniworx
+    exec: ../dist/bin/uniworx
+
+    # Command line options passed to your application.
+    args: []
+
+    hosts:
+      - uni2work.ifi.lmu.de
+
+    ssl: true
+
+    forward-env:
+      - LDAPHOST
+      - LDAPTLS
+      - LDAPPORT
+      - LDAPUSER
+      - LDAPPASS
+      - LDAPBASE
+      - LDAPSCOPE
+      - LDAPTIMEOUT
+      - DETAILED_LOGGING
+      - LOG_ALL
+      - PWFILE
+      - CRYPTOID_KEYFILE
+      - IP_FROM_HEADER
+
+# Use the following to automatically copy your bundle upon creation via `yesod
+# keter`. Uses `scp` internally, so you can set it to a remote destination
+# copy-to: user@host:/opt/keter/incoming/
+copy-to: root@uni2work.ifi.lmu.de:/opt/keter/incoming/
+copy-to-args: []
+
+
+# If you would like to have Keter automatically create a PostgreSQL database
+# and set appropriate environment variables for it to be discovered, uncomment
+# the following line.
+plugins:
+  postgres:
+    - server: uniworxdb
+      port: 5432

config/settings.yml

@@ -1,27 +1,29 @@
 # Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable.
 # See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables
+# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'")
+# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings
 
 static-dir:     "_env:STATIC_DIR:static"
 host:           "_env:HOST:*4" # any IPv4 host
-port:           "_env:PORT:3000" # NB: The port `yesod devel` uses is distinct from this value. Set the `yesod devel` port from the command line.
+port:           "_env:PORT:3000"
 ip-from-header: "_env:IP_FROM_HEADER:false"
-
-# Default behavior: determine the application root from the request headers.
-# Uncomment to set an explicit approot
 approot:        "_env:APPROOT:http://localhost:3000"
 
+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"
+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 the inverse.
-#
-detailed-logging: "_env:DETAILED_LOGGING:false"
-should-log-all: "_env:LOG_ALL:false"
+# In development, they default to true.
 # reload-templates: false
 # mutable-static: false
 # skip-combining: false
-auth-dummy-login: "_env:DUMMY_LOGIN:false"
-
-# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'")
-# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings
 
 database:
   user:     "_env:PGUSER:uniworx"
@@ -33,15 +35,22 @@ database:
   poolsize: "_env:PGPOOLSIZE:10"
 
 ldap:
-  uri:      "_env:LDAPURI:ldap://localhost:389"
-  dn:       "_env:LDAPDN:uniworx"
-  password: "_env:LDAPPW:"
-  basename: "_env:LDAPBN:"
+  host:    "_env:LDAPHOST:"
+  tls:     "_env:LDAPTLS:"
+  port:    "_env:LDAPPORT:389"
+  user:    "_env:LDAPUSER:"
+  pass:    "_env:LDAPPASS:"
+  baseDN:  "_env:LDAPBASE:"
+  scope:   "_env:LDAPSCOPE:WholeSubtree"
+  timeout: "_env:LDAPTIMEOUT:5"
 
-userDefaultFavourites: 12
+user-defaults:
+  max-favourites:   12
+  theme:            Default
+  date-time-format: "%a %d %b %Y %R"
+  date-format:      "%d.%m.%Y"
+  time-format:      "%R"
+  download-files:   false
 
 cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf"
 instance-idfile: "_env:INSTANCEID_FILE:instance"
-
-copyright: ©Institute for Informatics, LMU Munich
-#analytics: UA-YOURCODE

config/submission-blacklist

@@ -0,0 +1,12 @@
+$# Syntax:
+$#   - Leere zeilen werden ignoriert
+$#   - Zeilen, die mit '$#' beginnen, werden ignoriert
+$#   - Verbleibende Zeilen werden jeweils als `Glob`-Pattern kompiliert
+
+$# Ignoriere rekursiv alle Ordner __MACOSX und ihren Inhalt
+**/__MACOSX
+**/__MACOSX/*
+**/__MACOSX/**/*
+
+$# Ignoriere rekursiv alle Dateien .DS_Store (Mac OS)
+**/.DS_Store

db.hs

@@ -0,0 +1,329 @@
+#!/usr/bin/env stack
+-- stack runghc --package uniworx
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PackageImports #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+
+import "uniworx" Import hiding (Option(..))
+import "uniworx" Application (db, getAppDevSettings)
+
+import Database.Persist.Postgresql
+import Database.Persist.Sql
+import Control.Monad.Logger
+
+import System.Console.GetOpt
+import System.Exit (exitWith, ExitCode(..))
+import System.IO (hPutStrLn, stderr)
+
+import qualified Data.ByteString as BS
+
+import Database.Persist.Sql (toSqlKey)
+
+import Data.Time
+
+
+data DBAction = DBClear
+              | DBMigrate
+              | DBFill
+
+argsDescr :: [OptDescr DBAction]
+argsDescr =
+  [ Option ['c'] ["clear"]   (NoArg DBClear)   "Delete everything accessable by the current database user"
+  , Option ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration"
+  , Option ['f'] ["fill"]    (NoArg DBFill)    "Fill database with example data"
+  ]
+
+  
+main :: IO ()
+main = do
+  args <- map unpack <$> getArgs
+  case getOpt Permute argsDescr args of
+    (acts@(_:_), [], []) -> forM_ acts $ \case
+      DBClear   -> runStderrLoggingT $ do -- We don't use `db` here, since we do /not/ want any migrations to run, yet
+        settings <- liftIO getAppDevSettings
+        withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do
+          rawExecute "drop owned by current_user;" []
+      DBMigrate -> db $ return ()
+      DBFill    -> db $ fillDb
+    (_, _, errs) -> do
+      forM_ errs $ hPutStrLn stderr
+      hPutStrLn stderr $ usageInfo "db.hs" argsDescr
+      exitWith $ ExitFailure 2
+
+insertFile :: FilePath -> DB FileId
+insertFile fileTitle = do
+  fileContent <- liftIO $ Just <$> BS.readFile ("testdata/" <> fileTitle)
+  fileModified <- liftIO getCurrentTime
+  insert File{..}
+
+fillDb :: DB ()
+fillDb = do
+  AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod appSettings
+  now <- liftIO getCurrentTime
+  let
+    insert' :: PersistRecordBackend r (YesodPersistBackend UniWorX) => r -> YesodDB UniWorX (Key r)
+    insert' = fmap (either entityKey id) . insertBy
+    summer2017 = TermIdentifier 2017 Summer
+    winter2017 = TermIdentifier 2017 Winter
+    summer2018 = TermIdentifier 2018 Summer
+  gkleen <- insert User
+    { userIdent  = "G.Kleen@campus.lmu.de"
+    , userAuthentication = AuthLDAP
+    , userMatrikelnummer = Nothing
+    , userEmail  = "G.Kleen@campus.lmu.de"
+    , userDisplayName = "Gregor Kleen"
+    , userSurname = "Kleen"
+    , userMaxFavourites = 6
+    , userTheme = ThemeDefault
+    , userDateTimeFormat = userDefaultDateTimeFormat
+    , userDateFormat = userDefaultDateFormat
+    , userTimeFormat = userDefaultTimeFormat
+    , userDownloadFiles = userDefaultDownloadFiles
+    }
+  fhamann <- insert User
+    { userIdent  = "felix.hamann@campus.lmu.de"
+    , userAuthentication = AuthLDAP
+    , userMatrikelnummer = Nothing
+    , userEmail  = "felix.hamann@campus.lmu.de"
+    , userDisplayName = "Felix Hamann"
+    , userSurname = "Hamann"
+    , userMaxFavourites = userDefaultMaxFavourites
+    , userTheme = ThemeDefault
+    , userDateTimeFormat = userDefaultDateTimeFormat
+    , userDateFormat = userDefaultDateFormat
+    , userTimeFormat = userDefaultTimeFormat
+    , userDownloadFiles = userDefaultDownloadFiles
+    }
+  jost <- insert User
+    { userIdent  = "jost@tcs.ifi.lmu.de"
+    , userAuthentication = AuthLDAP
+    , userMatrikelnummer = Nothing
+    , userEmail  = "jost@tcs.ifi.lmu.de"
+    , userDisplayName = "Steffen Jost"
+    , userSurname = "Jost"
+    , userMaxFavourites = 14
+    , userTheme = ThemeMossGreen
+    , userDateTimeFormat = userDefaultDateTimeFormat
+    , userDateFormat = userDefaultDateFormat
+    , userTimeFormat = userDefaultTimeFormat
+    , userDownloadFiles = userDefaultDownloadFiles
+    }
+  void . insert $ User
+    { userIdent  = "max@campus.lmu.de"
+    , userAuthentication = AuthLDAP
+    , userMatrikelnummer = Nothing
+    , userEmail  = "max@campus.lmu.de"
+    , userDisplayName = "Max Musterstudent"
+    , userSurname = "Musterstudent"
+    , userMaxFavourites = 7
+    , userTheme = ThemeAberdeenReds
+    , userDateTimeFormat = userDefaultDateTimeFormat
+    , userDateFormat = userDefaultDateFormat
+    , userTimeFormat = userDefaultTimeFormat
+    , userDownloadFiles = userDefaultDownloadFiles
+    }
+  void . insert $ User
+    { userIdent  = "tester@campus.lmu.de"
+    , userAuthentication = AuthLDAP
+    , userMatrikelnummer = Just "999"
+    , userEmail  = "tester@campus.lmu.de"
+    , userDisplayName = "Tina Tester"
+    , userSurname = "von Terror"
+    , userMaxFavourites = 5
+    , userTheme = ThemeAberdeenReds
+    , userDateTimeFormat = userDefaultDateTimeFormat
+    , userDateFormat = userDefaultDateFormat
+    , userTimeFormat = userDefaultTimeFormat
+    , userDownloadFiles = userDefaultDownloadFiles
+    }
+  void . repsert (TermKey summer2017) $ Term
+    { termName     = summer2017
+    , termStart    = fromGregorian 2017 04 09
+    , termEnd      = fromGregorian 2017 07 14
+    , termHolidays = []
+    , termLectureStart = fromGregorian 2017 04 09
+    , termLectureEnd   = fromGregorian 2018 07 14
+    , termActive       = False
+    }
+  void . repsert (TermKey winter2017) $ Term
+    { termName     = winter2017
+    , termStart    = fromGregorian 2017 10 16
+    , termEnd      = fromGregorian 2018 02 10
+    , termHolidays = [fromGregorian 2017 12 24..fromGregorian 2018 01 06]
+    , termLectureStart = fromGregorian 2017 10 16
+    , termLectureEnd   = fromGregorian 2018 02 10
+    , termActive       = True
+    }
+  void . repsert (TermKey summer2018) $ Term
+    { termName     = summer2018
+    , termStart    = fromGregorian 2018 04 09
+    , termEnd      = fromGregorian 2018 07 14
+    , termHolidays = []
+    , termLectureStart = fromGregorian 2018 04 09
+    , termLectureEnd   = fromGregorian 2018 07 14
+    , termActive       = True
+    }
+  ifi <- insert' $ School "Institut für Informatik" "IfI"
+  mi <- insert' $ School "Institut für Mathematik" "MI"
+  void . insert' $ UserAdmin gkleen ifi
+  void . insert' $ UserAdmin gkleen mi
+  void . insert' $ UserAdmin fhamann ifi
+  void . insert' $ UserAdmin jost ifi
+  void . insert' $ UserAdmin jost mi
+  void . insert' $ UserLecturer gkleen ifi
+  void . insert' $ UserLecturer fhamann ifi
+  void . insert' $ UserLecturer jost ifi
+  let
+    sdBsc = StudyDegreeKey' 82
+    sdMst = StudyDegreeKey' 88
+  repsert sdBsc  $ StudyDegree 82 (Just "BSc") (Just "Bachelor"  )
+  repsert sdMst  $ StudyDegree 88 (Just "MSc") (Just "Master"    )
+  let
+    sdInf  = StudyTermsKey' 79
+    sdMath = StudyTermsKey' 105
+  repsert sdInf  $ StudyTerms  79 (Just "Inf") (Just "Informatik")
+  repsert sdMath $ StudyTerms 105 (Just "M"  ) (Just "Mathematik")
+  -- FFP
+  ffp <- insert' Course
+    { courseName = "Fortgeschrittene Funktionale Programmierung"
+    , courseDescription = Nothing
+    , courseLinkExternal = Nothing
+    , courseShorthand = "FFP"
+    , courseTerm = TermKey summer2018
+    , courseSchool = ifi
+    , courseCapacity = Just 20
+    , courseRegisterFrom = Just now
+    , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
+    , courseDeregisterUntil = Nothing
+    , courseRegisterSecret  = Nothing
+    , courseMaterialFree    = True
+    }
+  insert_ $ CourseEdit jost now ffp
+  void . insert $ DegreeCourse ffp sdBsc sdInf
+  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 (Upload True)
+  insert_ $ SheetEdit gkleen now sheetkey
+  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 (Upload True)
+  insert_ $ SheetEdit gkleen now sheetkey
+  -- EIP
+  eip <- insert' Course
+    { courseName = "Einführung in die Programmierung"
+    , courseDescription = Nothing
+    , courseLinkExternal = Nothing
+    , courseShorthand = "EIP"
+    , courseTerm = TermKey summer2017
+    , courseSchool = ifi
+    , courseCapacity = Just 20
+    , courseRegisterFrom = Nothing
+    , courseRegisterTo = Nothing
+    , courseDeregisterUntil = Nothing
+    , courseRegisterSecret  = Nothing
+    , courseMaterialFree    = True
+    }
+  insert_ $ CourseEdit fhamann now eip
+  void . insert' $ DegreeCourse eip sdBsc sdInf
+  void . insert' $ Lecturer fhamann eip
+  -- interaction design
+  ixd <- insert' Course
+    { courseName = "Interaction Design (User Experience Design I & II)"
+    , courseDescription = Nothing
+    , courseLinkExternal = Nothing
+    , courseShorthand = "IXD"
+    , courseTerm = TermKey summer2018
+    , courseSchool = ifi
+    , courseCapacity = Just 20
+    , courseRegisterFrom = Just now
+    , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
+    , courseDeregisterUntil = Nothing
+    , courseRegisterSecret  = Nothing
+    , courseMaterialFree    = True
+    }
+  insert_ $ CourseEdit fhamann now ixd
+  void . insert' $ DegreeCourse ixd sdBsc sdInf
+  void . insert' $ Lecturer fhamann ixd
+  -- concept development
+  ux3 <- insert' Course
+    { courseName = "Concept Development (User Experience Design III)"
+    , courseDescription = Nothing
+    , courseLinkExternal = Nothing
+    , courseShorthand = "UX3"
+    , courseTerm = TermKey winter2017
+    , courseSchool = ifi
+    , courseCapacity = Just 30
+    , courseRegisterFrom = Nothing
+    , courseRegisterTo = Nothing
+    , courseDeregisterUntil = Nothing
+    , courseRegisterSecret  = Nothing
+    , courseMaterialFree    = True
+    }
+  insert_ $ CourseEdit fhamann now ux3
+  void . insert' $ DegreeCourse ux3 sdBsc sdInf
+  void . insert' $ Lecturer fhamann ux3
+  -- promo
+  pmo <- insert' Course
+    { courseName = "Programmierung und Modellierung"
+    , courseDescription = Nothing
+    , courseLinkExternal = Nothing
+    , courseShorthand = "ProMo"
+    , courseTerm = TermKey summer2018
+    , courseSchool = ifi
+    , courseCapacity = Just 50
+    , courseRegisterFrom = Just now
+    , courseRegisterTo = Nothing
+    , courseDeregisterUntil = Nothing
+    , courseRegisterSecret  = Nothing
+    , courseMaterialFree    = True
+    }
+  insert_ $ CourseEdit jost now pmo
+  void . insert $ DegreeCourse pmo sdBsc sdInf
+  void . insert $ Lecturer jost pmo
+  sh1 <- insert Sheet
+    { sheetCourse = pmo
+    , sheetName = "Blatt 1"
+    , sheetDescription = Nothing
+    , sheetType = Normal 6
+    , sheetGrouping = Arbitrary 3
+    , sheetMarkingText = Nothing
+    , sheetVisibleFrom = Just now
+    , sheetActiveFrom = now
+    , sheetActiveTo = (14 * nominalDay) `addUTCTime` now 
+    , sheetUploadMode = Upload True
+    , sheetHintFrom = Nothing
+    , sheetSolutionFrom = Nothing
+    }
+  void . insert $ SheetEdit jost now sh1
+  void . insert $ SheetCorrector jost sh1 (Load (Just True) 0) CorrectorNormal
+  void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1) CorrectorNormal
+  h102 <- insertFile "H10-2.hs"
+  h103 <- insertFile "H10-3.hs"
+  pdf10 <- insertFile "ProMo_Uebung10.pdf"
+  void . insert $ SheetFile sh1 h102 SheetHint
+  void . insert $ SheetFile sh1 h103 SheetSolution
+  void . insert $ SheetFile sh1 pdf10 SheetExercise
+  -- datenbanksysteme
+  dbs <- insert' Course
+    { courseName = "Datenbanksysteme"
+    , courseDescription = Nothing
+    , courseLinkExternal = Nothing
+    , courseShorthand = "DBS"
+    , courseTerm = TermKey summer2018
+    , courseSchool = ifi
+    , courseCapacity = Just 50
+    , courseRegisterFrom = Nothing
+    , courseRegisterTo = Nothing
+    , courseDeregisterUntil = Nothing
+    , courseRegisterSecret  = Nothing
+    , courseMaterialFree    = True
+    }
+  insert_ $ CourseEdit gkleen now dbs
+  void . insert' $ DegreeCourse dbs sdBsc sdInf
+  void . insert' $ DegreeCourse dbs sdBsc sdMath
+  void . insert' $ Lecturer gkleen dbs
+  void . insert' $ Lecturer jost   dbs

deploy.sh

@@ -0,0 +1,21 @@
+#!/usr/bin/env sh
+
+configFile=""
+
+case "$1" in
+    test)
+        ln -svf "keter_testworx.yml" config/keter.yml
+
+        yesod keter
+        ;;
+    production)
+        ln -svf "keter_uni2work.yml" config/keter.yml
+
+        yesod keter && git tag -f live && git push origin live
+        ;;
+    *)
+        echo "Usage: $0 (test|production)" >&2
+        exit 2
+        ;;
+esac
+

fill-db.hs

@@ -1,217 +0,0 @@
-#!/usr/bin/env stack
--- stack runghc --package uniworx
-
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE TypeFamilies #-}
-
-import "uniworx" Import
-import "uniworx" Application (db)
-
-import Database.Persist.Sql (toSqlKey)
-
-import Data.Time
-
-main :: IO ()
-main = db $ do
-  defaultFavourites <- getsYesod $ appDefaultFavourites . appSettings
-  now <- liftIO getCurrentTime
-  let
-    insert' :: PersistRecordBackend r (YesodPersistBackend UniWorX) => r -> YesodDB UniWorX (Key r)
-    insert' = fmap (either entityKey id) . insertBy
-    summer2017 = TermIdentifier 2017 Summer
-    winter2017 = TermIdentifier 2017 Winter
-    summer2018 = TermIdentifier 2018 Summer
-  gkleen <- insert' User
-    { userPlugin = "LDAP"
-    , userIdent  = "G.Kleen@campus.lmu.de"
-    , userMatrikelnummer = Nothing
-    , userEmail  = "G.Kleen@campus.lmu.de"
-    , userDisplayName = "Gregor Kleen"
-    , userMaxFavourites = 6
-    }
-  fhamann <- insert' User
-    { userPlugin = "LDAP"
-    , userIdent  = "felix.hamann@campus.lmu.de"
-    , userMatrikelnummer = Nothing
-    , userEmail  = "felix.hamann@campus.lmu.de"
-    , userDisplayName = "Felix Hamann"
-    , userMaxFavourites = defaultFavourites
-    }
-  jost <- insert' User
-    { userPlugin = "LDAP"
-    , userIdent  = "jost@tcs.ifi.lmu.de"
-    , userMatrikelnummer = Nothing
-    , userEmail  = "jost@tcs.ifi.lmu.de"
-    , userDisplayName = "Steffen Jost"
-    , userMaxFavourites = 14
-    }
-  void . repsert (TermKey summer2017) $ Term
-    { termName     = summer2017
-    , termStart    = fromGregorian 2017 04 09
-    , termEnd      = fromGregorian 2017 07 14
-    , termHolidays = []
-    , termLectureStart = fromGregorian 2017 04 09
-    , termLectureEnd   = fromGregorian 2018 07 14
-    , termActive       = False
-    }
-  void . repsert (TermKey winter2017) $ Term
-    { termName     = winter2017
-    , termStart    = fromGregorian 2017 10 16
-    , termEnd      = fromGregorian 2018 02 10
-    , termHolidays = [fromGregorian 2017 12 24..fromGregorian 2018 01 06]
-    , termLectureStart = fromGregorian 2017 10 16
-    , termLectureEnd   = fromGregorian 2018 02 10
-    , termActive       = True
-    }
-  void . repsert (TermKey summer2018) $ Term
-    { termName     = summer2018
-    , termStart    = fromGregorian 2018 04 09
-    , termEnd      = fromGregorian 2018 07 14
-    , termHolidays = []
-    , termLectureStart = fromGregorian 2018 04 09
-    , termLectureEnd   = fromGregorian 2018 07 14
-    , termActive       = True
-    }
-  ifi <- insert' $ School "Institut für Informatik" "IfI"
-  mi <- insert' $ School "Institut für Mathematik" "MI"
-  void . insert' $ UserAdmin gkleen ifi
-  void . insert' $ UserAdmin gkleen mi
-  void . insert' $ UserAdmin fhamann ifi
-  void . insert' $ UserAdmin jost ifi
-  void . insert' $ UserAdmin jost mi
-  void . insert' $ UserLecturer gkleen ifi
-  void . insert' $ UserLecturer fhamann ifi
-  void . insert' $ UserLecturer jost ifi
-  let
-    sdBsc = StudyDegreeKey' 82
-    sdMst = StudyDegreeKey' 88
-  repsert sdBsc  $ StudyDegree 82 (Just "BSc") (Just "Bachelor"  )
-  repsert sdMst  $ StudyDegree 88 (Just "MSc") (Just "Master"    )
-  let
-    sdInf  = StudyTermsKey' 79
-    sdMath = StudyTermsKey' 105
-  repsert sdInf  $ StudyTerms  79 (Just "Inf") (Just "Informatik")
-  repsert sdMath $ StudyTerms 105 (Just "M"  ) (Just "Mathematik")
-  -- FFP
-  ffp <- insert' Course
-    { courseName = "Fortgeschrittene Funktionale Programmierung"
-    , courseDescription = Nothing
-    , courseLinkExternal = Nothing
-    , courseShorthand = "ffp"
-    , courseTermId = TermKey summer2018
-    , courseSchoolId = ifi
-    , courseCapacity = Just 20
-    , courseHasRegistration = True
-    , courseRegisterFrom = Just now
-    , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
-    , courseDeregisterUntil = Nothing
-    , courseRegisterSecret  = Nothing
-    , courseMaterialFree    = True
-    }
-  insert_ $ CourseEdit jost now ffp
-  void . insert' $ DegreeCourse ffp sdBsc sdInf
-  void . insert' $ DegreeCourse ffp sdMst sdInf
-  void . insert' $ Lecturer jost   ffp
-  void . insert' $ Lecturer gkleen ffp
-  void . insert' $ Corrector gkleen ffp (ByProportion 1)
-  sheetkey <- insert' $ Sheet ffp "Blatt 1" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing
-  insert_ $ SheetEdit gkleen now sheetkey
-  -- EIP
-  eip <- insert' Course
-    { courseName = "Einführung in die Programmierung"
-    , courseDescription = Nothing
-    , courseLinkExternal = Nothing
-    , courseShorthand = "eip"
-    , courseTermId = TermKey summer2017
-    , courseSchoolId = ifi
-    , courseCapacity = Just 20
-    , courseHasRegistration = False
-    , courseRegisterFrom = Nothing
-    , courseRegisterTo = Nothing
-    , courseDeregisterUntil = Nothing
-    , courseRegisterSecret  = Nothing
-    , courseMaterialFree    = True
-    }
-  insert_ $ CourseEdit fhamann now eip
-  void . insert' $ DegreeCourse eip sdBsc sdInf
-  void . insert' $ Lecturer fhamann eip
-  -- interaction design
-  ixd <- insert' Course
-    { courseName = "Interaction Design (User Experience Design I & II)"
-    , courseDescription = Nothing
-    , courseLinkExternal = Nothing
-    , courseShorthand = "ixd"
-    , courseTermId = TermKey summer2018
-    , courseSchoolId = ifi
-    , courseCapacity = Just 20
-    , courseHasRegistration = True
-    , courseRegisterFrom = Just now
-    , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
-    , courseDeregisterUntil = Nothing
-    , courseRegisterSecret  = Nothing
-    , courseMaterialFree    = True
-    }
-  insert_ $ CourseEdit fhamann now ixd
-  void . insert' $ DegreeCourse ixd sdBsc sdInf
-  void . insert' $ Lecturer fhamann ixd
-  -- concept development
-  ux3 <- insert' Course
-    { courseName = "Concept Development (User Experience Design III)"
-    , courseDescription = Nothing
-    , courseLinkExternal = Nothing
-    , courseShorthand = "ux3"
-    , courseTermId = TermKey winter2017
-    , courseSchoolId = ifi
-    , courseCapacity = Just 30
-    , courseHasRegistration = False
-    , courseRegisterFrom = Nothing
-    , courseRegisterTo = Nothing
-    , courseDeregisterUntil = Nothing
-    , courseRegisterSecret  = Nothing
-    , courseMaterialFree    = True
-    }
-  insert_ $ CourseEdit fhamann now ux3
-  void . insert' $ DegreeCourse ux3 sdBsc sdInf
-  void . insert' $ Lecturer fhamann ux3
-  -- promo
-  pmo <- insert' Course
-    { courseName = "Programmierung und Modellierung"
-    , courseDescription = Nothing
-    , courseLinkExternal = Nothing
-    , courseShorthand = "pmo"
-    , courseTermId = TermKey summer2017
-    , courseSchoolId = ifi
-    , courseCapacity = Just 50
-    , courseHasRegistration = False
-    , courseRegisterFrom = Nothing
-    , courseRegisterTo = Nothing
-    , courseDeregisterUntil = Nothing
-    , courseRegisterSecret  = Nothing
-    , courseMaterialFree    = True
-    }
-  insert_ $ CourseEdit jost now pmo
-  void . insert' $ DegreeCourse pmo sdBsc sdInf
-  void . insert' $ Lecturer jost pmo
-  -- datenbanksysteme
-  dbs <- insert' Course
-    { courseName = "Datenbanksysteme"
-    , courseDescription = Nothing
-    , courseLinkExternal = Nothing
-    , courseShorthand = "dbs"
-    , courseTermId = TermKey summer2018
-    , courseSchoolId = ifi
-    , courseCapacity = Just 50
-    , courseHasRegistration = False
-    , courseRegisterFrom = Nothing
-    , courseRegisterTo = Nothing
-    , courseDeregisterUntil = Nothing
-    , courseRegisterSecret  = Nothing
-    , courseMaterialFree    = True
-    }
-  insert_ $ CourseEdit gkleen now dbs
-  void . insert' $ DegreeCourse dbs sdBsc sdInf
-  void . insert' $ DegreeCourse dbs sdBsc sdMath
-  void . insert' $ Lecturer gkleen dbs
-  void . insert' $ Lecturer jost   dbs

ghci.sh

@@ -5,4 +5,15 @@ export DETAILED_LOGGING=true
 export LOG_ALL=true
 export DUMMY_LOGIN=true
 
-exec -- stack ghci --flag uniworx:dev --flag uniworx:library-only uniworx
+move-back() {
+    mv -v .stack-work .stack-work-ghci
+    [[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work
+}
+
+if [[ -d .stack-work-ghci ]]; then
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-run
+    mv -v .stack-work-ghci .stack-work
+    trap move-back EXIT
+fi
+
+stack ghci --flag uniworx:dev --flag uniworx:library-only

messages/campus/de.msg

@@ -0,0 +1,5 @@
+CampusIdentNote: Campus-Kennung bitte inkl. Domain-Teil (@campus.lmu.de) angeben.
+CampusIdent: Campus-Kennung
+CampusPassword: Passwort
+CampusSubmit: Abschicken
+CampusInvalidCredentials: Ungültige Logindaten

messages/de.msg

@@ -1,26 +0,0 @@
-SummerTerm year@Integer: Sommersemester #{tshow year}
-WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year}
-PSLimitNonPositive: “pagesize” muss größer als null sein
-Page n@Int64: #{tshow n}
-TermEdited tid@TermIdentifier: Semester #{termToText tid} erfolgreich editiert.
-TermNewTitle: Semester editiere/anlegen.
-InvalidInput: Eingaben bitte korrigieren.
-CourseNewOk        tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich erstellt.
-CourseEditOk       tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich geändert.
-CourseNewDupShort  tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
-CourseEditDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
-FFSheetName: Name
-SheetNewOk         tid@TermIdentifier courseShortHand@Text sheetName@Text: Neues Übungsblatt #{sheetName} wurde im Kurs #{termToText tid}-#{courseShortHand} erfolgreich erstellt.
-SheetTitle         tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName}
-SheetTitleNew      tid@TermIdentifier courseShortHand@Text               : #{termToText tid}-#{courseShortHand}: Neues Übungsblatt
-SheetEditOk        tid@TermIdentifier courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} aus Kurs #{termToText tid}-#{courseShortHand} wurde gespeichert.
-SheetNameDup       tid@TermIdentifier courseShortHand@Text sheetName@Text: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{termToText tid}-#{courseShortHand}.
-SheetDelTitle      tid@TermIdentifier courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} wirklich aus Kurs #{termToText tid}-#{courseShortHand} herauslöschen?
-SheetDelText       submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{show submissionNo} Abgaben.
-SheetDelOk         tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht.
-UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
-UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
-UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
-UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen.
-UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
-OnlyUploadOneFile: Bitte nur eine Datei hochladen.

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

@@ -0,0 +1,310 @@
+BtnSubmit: Senden
+BtnAbort: Abbrechen
+BtnDelete: Löschen
+BtnRegister: Anmelden
+BtnDeregister: Abmelden
+BtnHijack: Sitzung übernehmen
+
+Registered: Angemeldet
+RegisterFrom: Anmeldungen von
+RegisterTo: Anmeldungen bis
+DeRegUntil: Abmeldungen bis
+
+SummerTerm year@Integer: Sommersemester #{display year}
+WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year}
+SummerTermShort year@Integer: SoSe #{display year}
+WinterTermShort year@Integer: WiSe #{display year}/#{display $ mod (succ year) 100}
+PSLimitNonPositive: “pagesize” muss größer als null sein
+Page n@Int64: #{display n}
+
+TermsHeading: Semesterübersicht
+TermCurrent: Aktuelles Semester
+TermEditHeading: Semester editieren/anlegen
+TermEditTid tid@TermId: Semester #{display tid} editieren
+TermEdited  tid@TermId: Semester #{display tid} erfolgreich editiert.
+TermNewTitle: Semester editieren/anlegen.
+InvalidInput: Eingaben bitte korrigieren.
+Term: Semester
+TermPlaceholder: W/S + vierstellige Jahreszahl
+
+SchoolListHeading: Übersicht über verwaltete Institute
+SchoolHeading school@SchoolName: Übersicht #{display school}
+
+LectureStart: Beginn Vorlesungen
+
+Course: Kurs
+CourseShort: Kürzel
+CourseCapacity: Kapazität
+CourseCapacityTip: Falls angegeben wird die Anzahl an Kursanmeldungen, die zugelassen werden, beschränkt
+CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
+CourseRegisterOk: Sie wurden angemeldet
+CourseDeregisterOk: Sie wurden abgemeldet
+CourseSecretWrong: Falsches Kennwort
+CourseSecret: Zugangspasswort
+CourseNewOk        tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt.
+CourseEditOk       tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich geändert.
+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 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}
+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 csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren
+CourseEditTitle: Kurs editieren/anlegen
+CourseMembers: Teilnehmer
+CourseMembersCount num@Int64: #{display num}
+CourseMembersCountLimited num@Int64 max@Int64: #{display num}/#{display max}
+CourseName: Name
+CourseDescription: Beschreibung
+CourseDescriptionTip: Beliebiges HTML-Markup ist gestattet
+CourseHomepage: Homepage
+CourseShorthand: Kürzel
+CourseShorthandUnique: Muss innerhalb des Semesters eindeutig sein
+CourseSemester: Semester
+CourseSchool: Institut
+CourseSchoolShort: Fach
+CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt
+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 csh@CourseShorthand: #{display tid}-#{display ssh}-#{csh} Übersicht Übungsblätter
+SheetNewHeading    tid@TermId ssh@SchoolId csh@CourseShorthand: #{display tid}-#{display ssh}-#{csh} Neues Übungsblatt anlegen
+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 csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}
+SheetTitleNew      tid@TermId ssh@SchoolId csh@CourseShorthand                    : #{display tid}-#{display ssh}-#{csh}: Neues Übungsblatt
+SheetEditHead      tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName} editieren
+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 csh@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{csh}.
+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 csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
+
+SheetUploadMode: Abgabe von Dateien
+SheetExercise: Aufgabenstellung
+SheetHint: Hinweis
+SheetHintFrom: Hinweis ab
+SheetSolution: Lösung
+SheetSolutionFrom: Lösung ab
+SheetMarking: Hinweise für Korrektoren
+SheetType: Wertung
+SheetInvisible: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar!
+SheetInvisibleUntil mFrom@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{mFrom}!
+SheetName: Name
+SheetDescription: Hinweise für Teilnehmer
+SheetGroup: Gruppenabgabe
+SheetVisibleFrom: Sichtbar ab
+SheetVisibleFromTip: Ohne Datum wird das Blatt nie sichtbar, z.B. weil es noch nicht fertig ist
+SheetActiveFrom: Aktiv ab
+SheetActiveFromTip: Abgabe und Download der Aufgabenstellung ist erst ab diesem Datum möglich
+SheetActiveTo: Abgabefrist
+SheetHintFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
+SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
+SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren
+
+SheetErrVisibility: Sichtbarkeit muss vor Beginn der Abgabefrist liegen
+SheetErrDeadlineEarly: Ende der Abgabefrist muss nach deren Beginn liegen
+SheetErrHintEarly: Hinweise dürfen erst nach Beginn der Abgabefrist herausgegeben werden
+SheetErrSolutionEarly: Die Lösung sollte erst nach Ende der Abgabefrist herausgegeben werden
+
+
+Deadline: Abgabe
+Done: Eingereicht
+
+Submission: Abgabenummer
+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 csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen
+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
+SubmissionFiles: Abgegebene Dateien
+SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt.
+
+SubmissionGroupName: Gruppenname
+
+CorrectionsTitle: Zugewiesene Korrekturen
+CourseCorrectionsTitle: Korrekturen für diesen Kurs
+CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
+
+Unauthorized: Sie haben hierfür keine explizite Berechtigung.
+UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
+UnauthorizedOr  l@Text r@Text: (#{l} ODER #{r})
+UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
+UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
+UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
+UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen.
+UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen.
+UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen.
+UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
+UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
+UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
+UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
+UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
+UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
+OnlyUploadOneFile: Bitte nur eine Datei hochladen.
+DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
+UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben.
+MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
+UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
+UnsupportedAuthPredicate tag@String shownRoute@String: "!#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
+
+EMail: E-Mail
+EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
+NotAParticipant email@UserEmail tid@TermId csh@CourseShorthand: #{email} ist nicht im Kurs #{display tid}-#{csh} angemeldet.
+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 csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName}
+CountTutProp: Tutorien zählen gegen Proportion
+Corrector: Korrektor
+Correctors: Korrektoren
+CorState: Status
+CorByTut: Nach Tutorium
+CorProportion: Anteil
+CorByProportionOnly proportion@Rational: #{display proportion} Anteile
+CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Anteile - Tutorium
+CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium
+
+DeleteRow: Zeile entfernen
+ProportionNegative: Anteile dürfen nicht negativ sein
+CorrectorsUpdated: Korrektoren erfolgreich aktualisiert
+CorrectorsPlaceholder: Korrektoren...
+CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert.
+
+Users: Benutzer
+HomeHeading: Aktuelle Termine
+LoginHeading: Authentifizierung
+LoginTitle: Authentifizierung
+ProfileHeading: Benutzereinstellungen
+ProfileDataHeading: Gespeicherte Benutzerdaten
+ImpressumHeading: Impressum
+
+NumCourses n@Int64: #{display n} Kurse
+CloseAlert: Schliessen
+
+Name: Name
+MatrikelNr: Matrikelnummer
+Theme: Oberflächen Design
+Favoriten: Anzahl gespeicherter Favoriten
+Plugin: Plugin
+Ident: Identifikation
+Settings: Individuelle Benutzereinstellungen
+SettingsUpdate: Einstellungen wurden gespeichert.
+
+MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen)
+
+NrColumn: Nr
+SelectColumn: Auswahl
+
+CorrDownload: Herunterladen
+CorrUploadField: Korrekturen
+CorrUpload: Korrekturen hochladen
+CorrSetCorrector: Korrektor zuweisen
+CorrAutoSetCorrector: Korrekturen verteilen
+NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!
+
+SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
+UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neuen Korrektor zugeteilt.
+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
+AchievedOf achieved@Points possible@Points: #{display achieved} von #{display possible}
+PassAchievedOf points@Points passingPoints@Points maxPoints@Points: #{display points} von #{display maxPoints} (Bestanden ab #{display passingPoints})
+PassedResult: Ergebnis
+Passed: Bestanden
+NotPassed: Nicht bestanden
+RatingTime: Korrigiert
+RatingComment: Kommentar
+SubmissionUsers: Studenten
+Rating: Korrektur
+RatingPoints: Punkte
+RatingPercent: Erreicht
+RatingFiles: Korrigierte Dateien
+PointsNotPositive: Punktzahl darf nicht negativ sein
+RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
+
+FileTitle: Dateiname
+FileModified: Letzte Änderung
+
+
+Corrected: Korrigiert
+FileCorrected: Korrigiert (Dateien)
+FileCorrectedDeleted: Korrigiert (gelöscht)
+RatingUpdated: Korrektur gespeichert
+RatingDeleted: Korrektur zurückgesetzt
+RatingFilesUpdated: Korrigierte Dateien überschrieben
+
+NoTableContent: Kein Tabelleninhalt
+NoUpcomingSheetDeadlines: Keine anstehenden Übungsblätter
+
+AdminFor: Administrator
+LecturerFor: Dozent
+LecturersFor: Dozenten
+UserListTitle: Komprehensive Benutzerliste
+
+DateTimeFormat: Datums- und Uhrzeitformat
+DateFormat: Datumsformat
+TimeFormat: Uhrzeitformat
+DownloadFiles: Dateien automatisch herunterladen
+DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden).
+
+InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet
+AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren
+IllDefinedUTCTime: Der angegebene Zeitpunkt lässt sich nicht zu UTC konvertieren
+
+LastEdits: Letzte Änderungen
+EditedBy name@Text time@Text: #{time} durch #{name}
+LastEdit: Letzte Änderung
+LastEditByUser: Ihre letzte Bearbeitung
+NoEditByUser: Nicht von Ihnen bearbeitet
+
+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,15 +1,23 @@
-User
-    plugin Text
-    ident Text
+User json
+    ident          (CI Text)
+    authentication AuthenticationMode
     matrikelnummer Text Maybe
-    email Text
-    displayName Text
-    maxFavourites Int default=12
-    UniqueAuthentication plugin ident
+    email          (CI Text)
+    displayName    Text
+    surname        Text            -- always use: nameWidget displayName surname
+    maxFavourites  Int default=12
+    theme          Theme default='Default'
+    dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'"
+    dateFormat     DateTimeFormat "default='%d.%m.%Y'"
+    timeFormat     DateTimeFormat "default='%R'"
+    downloadFiles  Bool default=false
+    UniqueAuthentication ident
+    UniqueEmail email
+    deriving Show
 UserAdmin
     user   UserId
     school SchoolId
-    UniqueUserAdmin school user
+    UniqueUserAdmin user school
 UserLecturer
     user   UserId
     school SchoolId
@@ -20,7 +28,7 @@ StudyFeatures
     field         StudyTermsId
     type          StudyFieldType
     semester      Int
-    UniqueUserSubject user degree field
+    -- UniqueUserSubject user degree field -- There exists a counterexample
 StudyDegree
     key           Int
     shorthand     Text Maybe
@@ -33,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 
@@ -42,30 +50,33 @@ Term json
     Primary name       -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
     deriving Show      -- type TermId = Key Term
 School json
-    name          Text 
-    shorthand     Text
+    name          (CI Text)
+    shorthand     (CI Text)
     UniqueSchool name
+    UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
+    Primary shorthand  -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
     deriving Eq    
 DegreeCourse json
     course       CourseId
     degree       StudyDegreeId
     terms        StudyTermsId
     UniqueDegreeCourse course degree terms
-Course 
-    name         Text
-    description  Html Maybe
-    linkExternal Text Maybe    
-    shorthand    Text
-    termId       TermId
-    schoolId     SchoolId    
-    capacity     Int Maybe    
-    hasRegistration  Bool -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
+Course
+    name             (CI Text)
+    description      Html Maybe
+    linkExternal     Text Maybe
+    shorthand        (CI Text)
+    term             TermId
+    school           SchoolId
+    capacity         Int64 Maybe
+    -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
     registerFrom     UTCTime Maybe
     registerTo       UTCTime Maybe
     deregisterUntil  UTCTime Maybe
     registerSecret   Text Maybe        -- Falls ein Passwort erforderlich ist
-    materialFree     Bool default=true
-    CourseTermShort  termId shorthand
+    materialFree     Bool
+    TermSchoolCourseShort  term school shorthand
+    TermSchoolCourseName   term school name
 CourseEdit
     user         UserId
     time         UTCTime
@@ -75,31 +86,19 @@ CourseFavourite
     time         UTCTime
     course       CourseId
     UniqueCourseFavourite user course
+    deriving Show
 Lecturer 
-    userId       UserId
-    courseId     CourseId
-    UniqueLecturer userId courseId 
-Corrector 
-    userId       UserId
-    courseId     CourseId
-    load         Load 
-    -- SELECT submissionID FROM Tutorial, TutorialUser, Submission, Sheet
-    -- WHERE ( tutorialTutor = correctorUserId
-    --      && tutorialCourse = correctorCourseId
-    --      && tutorialUserTutorial = tutorialId 
-    --      && submissionUser = tutorialUserUser
-    --      && sheetId = submissionSheetId
-    --      && sheetCourse = correctorCourseId
-    --      )
-    UniqueCorrector userId courseId
+    user         UserId
+    course       CourseId
+    UniqueLecturer user course
 CourseParticipant
-    courseId        CourseId
-    userId          UserId
+    course          CourseId
+    user            UserId
     registration    UTCTime
-    UniqueParticipant userId courseId
+    UniqueParticipant user course
 Sheet
-    courseId        CourseId
-    name            Text
+    course          CourseId
+    name            (CI Text)
     description     Html Maybe
     type            SheetType
     grouping        SheetGroup
@@ -109,64 +108,73 @@ Sheet
     activeTo        UTCTime
     hintFrom        UTCTime Maybe
     solutionFrom    UTCTime Maybe
-    CourseSheet courseId name
+    uploadMode      UploadMode
+    CourseSheet course name
 SheetEdit
     user            UserId
     time            UTCTime
     sheet           SheetId
+SheetCorrector
+    user            UserId
+    sheet           SheetId
+    load            Load
+    state           CorrectorState default='CorrectorNormal'
+    UniqueSheetCorrector user sheet
+    deriving Show Eq Ord
 SheetFile
-    sheetId         SheetId
-    fileId          FileId
+    sheet           SheetId
+    file            FileId
     type            SheetFileType
-    UniqueSheetFile fileId sheetId type
+    UniqueSheetFile file sheet type
 File        
     title           FilePath
     content         ByteString Maybe -- Nothing iff this is a directory
     modified        UTCTime
     deriving Show Eq
 Submission
-    sheetId         SheetId    
-    ratingPoints    Points  Maybe
-    ratingComment   Text    Maybe 
-    ratingBy        UserId  Maybe
-    ratingTime      UTCTime Maybe   
+    sheet           SheetId
+    ratingPoints    Points  Maybe -- "Just" does not mean done
+    ratingComment   Text    Maybe -- "Just" does not mean done
+    ratingBy        UserId  Maybe -- assigned corrector
+    ratingAssigned  UTCTime Maybe -- time assigned corrector
+    ratingTime      UTCTime Maybe -- "Just" here indicates done!
     deriving Show
 SubmissionEdit
     user            UserId
     time            UTCTime
     submission      SubmissionId
 SubmissionFile
-    submissionId    SubmissionId
-    fileId          FileId 
-    isUpdate        Bool
-    isDeletion      Bool
-    UniqueSubmissionFile fileId submissionId isUpdate
+    submission      SubmissionId
+    file            FileId
+    isUpdate        Bool         -- is this the file updated by a corrector (original will always be retained)
+    isDeletion      Bool         -- only set if isUpdate is also set, but file was deleted by corrector
+    UniqueSubmissionFile file submission isUpdate
     deriving Show
 SubmissionUser
-    userId          UserId
-    submissionId    SubmissionId
-    UniqueSubmissionUser userId submissionId
+    user            UserId
+    submission      SubmissionId
+    UniqueSubmissionUser user submission
 SubmissionGroup
-    courseId        CourseId
-    name            Text
+    course          CourseId
+    name            Text Maybe
 SubmissionGroupEdit
     user            UserId
     time            UTCTime
     submissionGroup SubmissionGroupId
 SubmissionGroupUser
-    submissionGroupId   SubmissionGroupId
-    userId              UserId   
-    UniqueSubmissionGroupUser submissionGroupId userId
+    submissionGroup     SubmissionGroupId
+    user                UserId
+    UniqueSubmissionGroupUser submissionGroup   user
 Tutorial json
     name        Text
-    tutor       UserId    
+    tutor       UserId
     course      CourseId
 TutorialUser
-    userId      UserId
-    tutorialId  TutorialId
-    UniqueTutorialUser userId tutorialId
+    user        UserId
+    tutorial    TutorialId
+    UniqueTutorialUser user   tutorial
 Booking
-    termId      TermId
+    term        TermId
     begin       UTCTime
     end         UTCTime
     weekly      Bool
@@ -183,17 +191,17 @@ Room
     building    Text Maybe
 -- BookingRoom
 --    subject     RoomForId
---    roomId      RoomId
---    bookingId   BookingId
---    UniqueRoomCourse subject roomId bookingId
+--    room        RoomId
+--    booking     BookingId
+--    UniqueRoomCourse subject room   booking
 +RoomFor
-    courseId    CourseId
-    tutorialId  TutorialId
-    examId      ExamId
--- data RoomFor = RoomForCourseIdSum CourseId | RoomForTutorialIdSum TutorialId ...
+    course      CourseId
+    tutorial    TutorialId
+    exam        ExamId
+-- data RoomFor = RoomForCourseSum CourseId | RoomForTutorialSum TutorialId ...
 -- EXAMS ARE TODO:
 Exam
-    courseId            CourseId
+    course              CourseId
     name                Text
     description         Text
     begin               UTCTime
@@ -208,13 +216,12 @@ Exam
 --    time                UTCTime
 --    exam                ExamId
 --ExamUser
---    userId              UserId
+--    user                UserId
 --    examId              ExamId
 --    -- CONTINUE HERE: Include rating in this table or separately?
---    UniqueExamUser userId examId
+--    UniqueExamUser user   examId
 -- By default this file is used in Model.hs (which is imported by Foundation.hs)
-QueuedNotification
-    recipient           UserId
+QueuedJob
     content             Value
     created             UTCTime
     lockInstance        UUID Maybe

package.yaml

@@ -20,7 +20,7 @@ dependencies:
 - classy-prelude-conduit >=0.10.2
 - bytestring >=0.9 && <0.11
 - text >=0.11 && <2.0
-- persistent >=2.0 && <2.8
+- persistent >=2.7.2 && <2.8
 - persistent-postgresql >=2.1.1 && <2.8
 - persistent-template >=2.0 && <2.8
 - template-haskell
@@ -74,12 +74,25 @@ dependencies:
 - generic-deriving
 - blaze-html
 - conduit-resumablesink >=0.2
-- yesod-auth-ldap
-- LDAP
 - parsec
 - uuid
 - exceptions
 - stm-conduit
+- lens
+- MonadRandom
+- email-validate
+- scientific
+- tz
+- system-locale
+- th-lift-instances
+- gitrev
+- Glob
+- ldap-client
+- connection
+- universe
+- universe-base
+- random-shuffle
+- th-abstraction
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.
@@ -92,6 +105,7 @@ library:
       - -Wall
       - -fwarn-tabs
       - -O0
+      - -ddump-splices
       cpp-options: -DDEVELOPMENT
     else:
       ghc-options:

routes

@@ -1,41 +1,91 @@
-/static StaticR Static appStatic
-/auth   AuthR   Auth   getAuth
+--
+--  Accesss granted via tags; default is no accesss.
+--  Permission must be explicitly granted.
+--
+--  Access permission is the disjunction of permit tags
+--  Tags are split on "AND" to encode conjunction.
+--
+--  Note that nested routes automatically inherit all tags from the parent.
+--
+--  Admins always have access to entities within their assigned schools.
+--
+--  Access Tags:
+--    !free       -- free for all
+--    !lecturer   -- lecturer    for this course (or the school, if route is not connected to a course)
+--    !corrector  -- corrector   for this sheet  (or the submission, if route is connected to a submission, or the course, if route is not connected to a sheet, or any course, if route is not connected to a course)
+--    !registered -- participant for this course (no effect outside of courses)
+--    !owner      -- part of the group of owners of this submission
+--    !capacity   -- course this route is associated with has at least one unit of participant capacity
+--
+--    !materials  -- only if course allows all materials to be free (no meaning outside of courses)
+--    !time       -- access depends on time somehow
+--    !isRead     -- only if it is read-only access (i.e. GET but not POST)
+--    !isWrite    -- only if it is write access     (i.e. POST only) why needed???
+--
+--    !deprecated -- like free, but logs and gives a warning; entirely disabled in production
+--
 
-/favicon.ico FaviconR GET
-/robots.txt RobotsR GET
+/static StaticR Static appStatic                              !free
+/auth   AuthR   Auth   getAuth                                !free
 
-/        HomeR    GET POST
-/profile ProfileR GET
-/users   UsersR   GET                                         !adminAny
+/favicon.ico FaviconR GET                                     !free
+/robots.txt RobotsR GET                                       !free
 
-/term                       TermShowR         GET
-/term/edit                  TermEditR         GET POST        !adminAny
-/term/#TermId/edit          TermEditExistR    GET             !adminAny
+/                           HomeR             GET             !free
+/users                      UsersR            GET             -- no tags, i.e. admins only
+/admin/test                 AdminTestR        GET POST
+/admin/user/#CryptoUUIDUser AdminUserR        GET
+/admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST
+/info                       VersionR          GET             !free
 
-/course/                    CourseListR       GET
-!/course/new                CourseNewR        GET POST        !lecturerAny
-!/course/#TermId            CourseListTermR   GET
-/course/#TermId/#Text CourseR !updateFavourite:
-  /show                       CourseShowR GET POST
-  /edit                       CourseEditR GET POST            !lecturer
+/profile                    ProfileR          GET POST        !free                             !free
+/profile/data               ProfileDataR      GET POST        !free                             !free
 
-  /ex SheetR                                                  !registered:
-    /                               SheetListR GET
-    /#Text/show                     SheetShowR GET            !time
-    /#Text/#SheetFileType/#FilePath SheetFileR GET            !time
-    /new                            SheetNewR  GET POST       !lecturer
-    /#Text/edit                     SheetEditR GET POST       !lecturer
-    /#Text/delete                   SheetDelR  GET POST       !lecturer
+/term                      TermShowR         GET             !free
+/term/current              TermCurrentR      GET             !free
+/term/edit                 TermEditR         GET POST
+/term/#TermId/edit         TermEditExistR    GET
+!/term/#TermId             TermCourseListR   GET             !free
+!/term/#TermId/#SchoolId   TermSchoolCourseListR  GET             !free
+
+/school                    SchoolListR       GET
+/school/#SchoolId          SchoolShowR       GET
 
 
--- TODO below
-/submission                 SubmissionListR GET POST
-/submission/#CryptoUUIDSubmission SubmissionR GET POST
-/submissions.zip SubmissionDownloadMultiArchiveR POST
-!/submission/archive/#FilePath SubmissionDownloadArchiveR GET
-!/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET
+-- 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
+  /ex/#SheetName SheetR:
+    /                           SShowR        GET             !timeANDregistered !timeANDmaterials !corrector
+    /edit                       SEditR        GET POST
+    /delete                     SDelR         GET POST
+    /subs                       SSubsR        GET POST        -- for lecturer only
+    /subs/new                   SubmissionNewR GET POST        !timeANDregistered
+    /subs/own                   SubmissionOwnR GET             !free -- just redirect
+    /sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead:
+      /                           SubShowR                   GET POST !ownerANDtime !ownerANDisRead
+      /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR                GET      !owner
+      /correction                 CorrectionR                GET POST !corrector !ownerANDisReadANDrated
+      !/#SubmissionFileType/*FilePath SubDownloadR           GET      !owner
+    /correctors                 SCorrR        GET POST
+    !/#SheetFileType/*FilePath  SFileR        GET             !timeANDregistered !timeANDmaterials !corrector
 
-!/#UUID CryptoUUIDDispatchR GET
 
--- For demonstration
-/course/#CryptoUUIDCourse/edit CourseEditIDR GET
+/corrections  CorrectionsR GET POST !corrector !lecturer
+/corrections/upload CorrectionsUploadR GET POST !corrector !lecturer
+
+
+!/#UUID CryptoUUIDDispatchR GET                               !free -- just redirect
+-- !/*{CI FilePath} CryptoFileNameDispatchR GET                  !free -- Disabled until preliminary check for valid cID exists

shell.nix

@@ -10,7 +10,7 @@ let
   drv = haskellPackages.callPackage ./uniworx.nix {};
 
   postgresSchema = pkgs.writeText "schema.sql" ''
-    CREATE USER uniworx;
+    CREATE USER uniworx WITH SUPERUSER;
     CREATE DATABASE uniworx_test;
     GRANT ALL ON DATABASE uniworx_test TO uniworx;
     CREATE DATABASE uniworx;
@@ -24,13 +24,12 @@ let
   override = oldAttrs: {
     nativeBuildInputs = oldAttrs.nativeBuildInputs ++ (with pkgs; [ postgresql cabal-install ]) ++ (with haskellPackages; [ stack yesod-bin ]);
     shellHook = ''
-      ${oldAttrs.shellHook}
       export PROMPT_INFO="${oldAttrs.name}"
 
       pgDir=$(mktemp -d)
       pgSockDir=$(mktemp -d)
       pgLogFile=$(mktemp)
-      pg_ctl init -D ''${pgDir}
+      initdb --no-locale -D ''${pgDir}
       pg_ctl start -D ''${pgDir} -l ''${pgLogFile} -w -o "-k ''${pgSockDir} -c listen_addresses=''' -c hba_file='${postgresHba}' -c unix_socket_permissions=0700"
       export PGHOST=''${pgSockDir} PGLOG=''${pgLogFile}
       psql -f ${postgresSchema} postgres
@@ -42,6 +41,8 @@ let
       }
 
       trap cleanup EXIT
+
+      ${oldAttrs.shellHook}
     '';
   };
 

src/Application.hs

@@ -7,7 +7,7 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module Application
-    ( getApplicationDev
+    ( getApplicationDev, getAppDevSettings
     , appMain
     , develMain
     , makeFoundation
@@ -19,6 +19,7 @@ module Application
     -- * for GHCI
     , handler
     , db
+    , addPWEntry
     ) where
 
 import Control.Monad.Logger                 (liftLoc, runLoggingT)
@@ -46,7 +47,12 @@ import qualified Data.UUID.V4 as UUID
 import System.Directory
 import System.FilePath
 
-import Notifications
+import Jobs
+
+import qualified Data.Text.Encoding as Text
+import Yesod.Auth.Util.PasswordStore
+
+import qualified Data.ByteString.Lazy as LBS
 
 -- Import all relevant handler modules here.
 -- (HPack takes care to add new modules to our cabal file nowadays.)
@@ -54,10 +60,13 @@ import Handler.Common
 import Handler.Home
 import Handler.Profile
 import Handler.Users
+import Handler.Admin
 import Handler.Term
+import Handler.School
 import Handler.Course
 import Handler.Sheet
 import Handler.Submission
+import Handler.Corrections
 import Handler.CryptoIDDispatch
 
 
@@ -83,7 +92,7 @@ makeFoundation appSettings@(AppSettings{..}) = do
     appCryptoIDKey <- readKeyFile appCryptoIDKeyFile
     appInstanceID <- maybe UUID.nextRandom readInstanceIDFile appInstanceIDFile
 
-    (appNotificationCtl, recvChan) <- atomically $ do
+    (appJobCtl, recvChan) <- atomically $ do
         chan <- newBroadcastTMChan
         recvChan <- dupTMChan chan
         return (chan, recvChan)
@@ -108,24 +117,24 @@ makeFoundation appSettings@(AppSettings{..}) = do
         (pgPoolSize appDatabaseConf)
     
     -- Perform database migration using our application's logging settings.
-    flip runLoggingT logFunc $ runSqlPool (runMigration migrateAll) pool
+    flip runLoggingT logFunc $ runSqlPool migrateAll pool
   
-    void . fork . handleNotifications $ (mkFoundation pool) { appNotificationCtl = recvChan }
+    void . fork . handleJobs $ (mkFoundation pool) { appJobCtl = recvChan }
 
     -- Return the foundation
     return $ mkFoundation pool
 
 readInstanceIDFile :: FilePath -> IO UUID
-readInstanceIDFile idFile = handle generateInstead $ readFileUtf8 idFile >>= parseText
+readInstanceIDFile idFile = handle generateInstead $ LBS.readFile idFile >>= parseBS
   where
-    parseText :: Text -> IO UUID
-    parseText = maybe (throwString "appInstanceIDFile does not contain an UUID") return . UUID.fromText
+    parseBS :: LBS.ByteString -> IO UUID
+    parseBS = maybe (throwString "appInstanceIDFile does not contain an UUID encoded in network byte order") return . UUID.fromByteString
     generateInstead :: IOException -> IO UUID
     generateInstead e
       | isDoesNotExistError e = do
           createDirectoryIfMissing True $ takeDirectory idFile
           instanceId <- UUID.nextRandom
-          writeFileUtf8 idFile $ UUID.toText instanceId
+          LBS.writeFile idFile $ UUID.toByteString instanceId
           return instanceId
       | otherwise = throw e
 
@@ -225,7 +234,7 @@ getApplicationRepl = do
 
 shutdownApp :: UniWorX -> IO ()
 shutdownApp UniWorX{..} = do
-  atomically $ closeTMChan appNotificationCtl
+  atomically $ closeTMChan appJobCtl
 
 
 ---------------------------------------------
@@ -239,3 +248,11 @@ handler h = getAppDevSettings >>= makeFoundation >>= flip unsafeHandler h
 -- | Run DB queries
 db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a
 db = handler . runDB
+
+addPWEntry :: User
+           -> Text {-^ Password -}
+           -> IO ()
+addPWEntry User{..} (Text.encodeUtf8 -> pw) = db $ do
+  PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings
+  (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
+  void $ insert User{..}

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

@@ -0,0 +1,171 @@
+{-# LANGUAGE RecordWildCards
+           , OverloadedStrings
+           , TemplateHaskell
+           , ViewPatterns
+           , TypeFamilies
+           , FlexibleContexts
+           , FlexibleInstances
+           , NoImplicitPrelude
+           , ScopedTypeVariables
+  #-}
+
+module Auth.LDAP
+  ( campusLogin
+  , CampusUserException(..)
+  , campusUser
+  , CampusMessage(..)
+  , Ldap.AttrList, Ldap.Attr(..), Ldap.AttrValue
+  ) where
+
+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
+
+import qualified Ldap.Client as Ldap
+
+import qualified Data.Text.Encoding as Text
+
+import qualified Yesod.Auth.Message as Msg
+
+
+data CampusLogin = CampusLogin
+  { campusIdent :: CI Text
+  , campusPassword :: Text
+  }
+
+data CampusMessage = MsgCampusIdentNote
+                   | MsgCampusIdent
+                   | MsgCampusPassword
+                   | MsgCampusSubmit
+                   | MsgCampusInvalidCredentials
+  
+
+findUser :: LdapConf -> Ldap.Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
+findUser LdapConf{..} ldap campusIdent = Ldap.search ldap ldapBase userSearchSettings userFilter
+  where
+    userFilter = userPrincipalName Ldap.:= Text.encodeUtf8 campusIdent
+    userSearchSettings = mconcat
+      [ Ldap.scope ldapScope
+      , Ldap.size 2
+      , Ldap.time ldapTimeout
+      , Ldap.derefAliases Ldap.DerefAlways
+      ]
+  
+userPrincipalName :: Ldap.Attr
+userPrincipalName = Ldap.Attr "userPrincipalName"
+
+campusForm :: ( RenderMessage site FormMessage
+              , RenderMessage site CampusMessage
+              , Button site SubmitButton
+              , Show (ButtonCssClass site)
+              ) => AForm (HandlerT site IO) CampusLogin
+campusForm = CampusLogin
+  <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing
+  <*> areq passwordField (fslI MsgCampusPassword) Nothing
+  <*  submitButton
+
+campusLogin :: forall site.
+               ( YesodAuth site
+               , RenderMessage site FormMessage
+               , RenderMessage site CampusMessage
+               , Button site SubmitButton
+               , Show (ButtonCssClass site)
+               ) => LdapConf -> AuthPlugin site
+campusLogin conf@LdapConf{..} = AuthPlugin{..}
+  where
+    apName = "LDAP"
+    apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
+    apDispatch "POST" [] = do
+      ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm
+      case loginRes of
+        FormFailure errs -> do
+          forM_ errs $ addMessage Error . toHtml
+          redirect LoginR
+        FormMissing -> redirect LoginR
+        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
+            findUser conf ldap campusIdent [userPrincipalName]
+          case ldapResult of
+            Left err
+              | Ldap.ResponseError (Ldap.ResponseErrorCode _ Ldap.InvalidCredentials _ _) <- err
+                -> do
+                  $logDebugS "LDAP" "Invalid credentials"
+                  loginErrorMessageI LoginR Msg.InvalidLogin
+              | otherwise -> do
+                  $logErrorS "LDAP" $ "Error during login: " <> tshow err
+                  loginErrorMessageI LoginR Msg.AuthError
+            Right searchResults
+              | [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] <- searchResults
+              , Just [principalName] <- lookup userPrincipalName userAttrs
+              , Right credsIdent <- Text.decodeUtf8' principalName
+                -> do
+                  $logDebugS "LDAP" $ tshow searchResults
+                  lift . setCredsRedirect $ Creds apName credsIdent [("DN", userDN)]
+              | otherwise -> do
+                  $logWarnS "LDAP" $ "Could not extract principal name: " <> tshow searchResults
+                  loginErrorMessageI LoginR Msg.AuthError
+    apDispatch _ _ = notFound
+    apLogin toMaster = do
+      (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm
+      $(widgetFile "widgets/campus-login-form")
+
+data CampusUserException = CampusUserLdapError Ldap.LdapError
+                         | CampusUserHostNotResolved String
+                         | CampusUserLineTooLong
+                         | CampusUserHostCannotConnect String [IOException]
+                         | CampusUserNoResult
+                         | CampusUserAmbiguous
+  deriving (Show, Eq, Typeable)
+
+instance Exception CampusUserException
+
+campusUser :: (MonadIO m, MonadThrow m) => LdapConf -> Creds site -> m (Ldap.AttrList [])
+campusUser conf@LdapConf{..} Creds{..} = liftIO . (`catches` errHandlers) $ either (throwM . CampusUserLdapError) return <=< Ldap.with ldapHost ldapPort $ \ldap -> do
+  Ldap.bind ldap ldapDn ldapPassword
+  results <- case lookup "DN" credsExtra of
+    Just userDN -> do
+      let userFilter = Ldap.Present userPrincipalName
+          userSearchSettings = mconcat
+            [ Ldap.scope Ldap.BaseObject
+            , Ldap.size 2
+            , Ldap.time ldapTimeout
+            , Ldap.derefAliases Ldap.DerefAlways
+            ]
+      Ldap.search ldap (Ldap.Dn userDN) userSearchSettings userFilter []
+    Nothing -> do
+      findUser conf ldap credsIdent []
+  case results of
+    [] -> throwM CampusUserNoResult
+    [Ldap.SearchEntry _ attrs] -> return attrs
+    _otherwise -> throwM CampusUserAmbiguous
+  where
+    errHandlers = [ Exc.Handler $ \LineTooLong -> throwM CampusUserLineTooLong
+                  , Exc.Handler $ \(HostNotResolved host) -> throwM $ CampusUserHostNotResolved host
+                  , Exc.Handler $ \(HostCannotConnect host excs) -> throwM $ CampusUserHostCannotConnect host excs
+                  ]
+
+-- ldapConfig :: UniWorX -> LDAPConfig
+-- ldapConfig _app@(appSettings -> settings) = LDAPConfig
+--   { usernameFilter = \u -> principalName <> "=" <> u
+--   , identifierModifier
+--   , ldapUri = appLDAPURI settings
+--   , initDN = appLDAPDN settings
+--   , initPass = appLDAPPw settings
+--   , baseDN = appLDAPBaseName settings
+--   , ldapScope = LdapScopeSubtree
+--   }
+--   where
+--     principalName :: IsString a => a
+--     principalName = "userPrincipalName"
+--     identifierModifier _ entry = case lookup principalName $ leattrs entry of
+--       Just [n] -> Text.pack n
+--       _        -> error "Could not determine user principal name"

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/CryptoID.hs

@@ -1,8 +1,11 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE RecordWildCards, ViewPatterns, PatternGuards #-}
+{-# LANGUAGE PatternSynonyms #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module CryptoID
@@ -17,23 +20,46 @@ import CryptoID.TH
 import ClassyPrelude hiding (fromString)
 import Model
 
+import qualified Data.CryptoID as E
 import Data.CryptoID.Poly.ImplicitNamespace
 import Data.UUID.Cryptographic.ImplicitNamespace
 import System.FilePath.Cryptographic.ImplicitNamespace
 
-import Data.UUID.Types
+import qualified Data.Text as Text
+
+-- import Data.UUID.Types
 import Web.PathPieces
 
-
-instance PathPiece UUID where
-  fromPathPiece = fromString . unpack
-  toPathPiece = pack . toString
+import           Data.CaseInsensitive   (CI)
+import qualified Data.CaseInsensitive as CI
 
 
--- Generates CryptoUUID... Datatypes
+-- Generates CryptoUUID... and CryptoFileName... Datatypes
 decCryptoIDs [ ''SubmissionId
-             , ''CourseId
-             , ''SheetId
              , ''FileId
+             , ''UserId
              ]
-{- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}
+
+instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where
+  fromPathPiece (Text.unpack -> piece) = do
+    piece' <- (stripPrefix `on` map CI.mk) "uwa" piece
+    return . CryptoID . CI.mk $ map CI.original piece'
+  toPathPiece = Text.pack . ("uwa" <>) . CI.foldedCase . ciphertext
+
+
+newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission)
+  deriving (Show, Read, Eq)
+
+pattern NewSubmission :: SubmissionMode
+pattern NewSubmission = SubmissionMode Nothing
+pattern ExistingSubmission :: CryptoFileNameSubmission -> SubmissionMode
+pattern ExistingSubmission cID = SubmissionMode (Just cID)
+
+instance PathPiece SubmissionMode where
+    fromPathPiece "new" = Just $ SubmissionMode Nothing
+    fromPathPiece s     = SubmissionMode . Just <$> fromPathPiece s
+
+    toPathPiece (SubmissionMode Nothing)  = "new"
+    toPathPiece (SubmissionMode (Just x)) = toPathPiece x
+
+

src/Data/CaseInsensitive/Instances.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Data.CaseInsensitive.Instances
+  () where
+
+import ClassyPrelude.Yesod
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Database.Persist.Sql
+
+import Text.Blaze (ToMarkup(..))
+
+import Data.Text (Text)
+import qualified Data.Text.Encoding as Text
+
+
+instance PersistField (CI Text) where
+  toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
+  fromPersistValue (PersistDbSpecific bs) = Right . CI.mk $ Text.decodeUtf8 bs
+  fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
+
+instance PersistField (CI String) where
+  toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 . pack $ CI.original ciText
+  fromPersistValue (PersistDbSpecific bs) = Right . CI.mk . unpack $ Text.decodeUtf8 bs
+  fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
+  
+instance PersistFieldSql (CI Text) where
+  sqlType _ = SqlOther "citext"
+
+instance PersistFieldSql (CI String) where
+  sqlType _ = SqlOther "citext"
+
+instance ToJSON a => ToJSON (CI a) where
+  toJSON = toJSON . CI.original
+
+instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where
+  parseJSON = fmap CI.mk . parseJSON
+
+instance ToMessage a => ToMessage (CI a) where
+  toMessage = toMessage . CI.original
+
+instance ToMarkup a => ToMarkup (CI a) where
+  toMarkup = toMarkup . CI.original
+  preEscapedToMarkup = preEscapedToMarkup . CI.original
+
+instance ToWidget site a => ToWidget site (CI a) where
+  toWidget = toWidget . CI.original
+
+instance RenderMessage site a => RenderMessage site (CI a) where
+  renderMessage f ls msg = renderMessage f ls $ CI.original msg

src/Handler/Admin.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Handler.Admin where
+
+import Import
+import Handler.Utils
+
+-- import Data.Time
+-- import qualified Data.Text as T
+-- import Data.Function ((&))
+-- import Yesod.Form.Bootstrap3
+
+import Web.PathPieces (showToPathPiece, readFromPathPiece)
+
+-- import Colonnade hiding (fromMaybe)
+-- import Yesod.Colonnade
+
+-- import qualified Data.UUID.Cryptographic as UUID
+
+-- BEGIN - Buttons needed only here
+data CreateButton = CreateMath | CreateInf  -- Dummy for Example
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance PathPiece CreateButton where    -- for displaying the button only, not really for paths
+  toPathPiece   = showToPathPiece
+  fromPathPiece = readFromPathPiece
+
+instance Button UniWorX CreateButton where
+  label CreateMath = [whamlet|Ma<i>thema</i>tik|]
+  label CreateInf  = "Informatik"
+
+  cssClass CreateMath = BCInfo
+  cssClass CreateInf  = BCPrimary
+-- END Button needed here
+
+
+getAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
+getAdminTestR = do
+  (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton)
+  defaultLayout $ do
+    -- setTitle "Uni2work Admin Testpage"
+    $(widgetFile "adminTest")
+
+postAdminTestR :: Handler Html
+postAdminTestR = do
+  ((btnResult,_), _) <- runFormPost $ buttonForm
+  case btnResult of
+    (FormSuccess CreateInf)  -> addMessage Info "Informatik-Knopf gedrückt"
+    (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
+    _other -> addMessage Warning "KEIN Knopf erkannt"
+  getAdminTestR
+
+
+getAdminUserR :: CryptoUUIDUser -> Handler Html
+getAdminUserR uuid = do
+  uid <- decrypt uuid
+  User{..} <- runDB $ get404 uid
+  defaultLayout $
+    [whamlet|
+      <h1>TODO
+      <h2>Admin Page for User ^{nameWidget userDisplayName userSurname}
+    |]
+

src/Handler/Corrections.hs

@@ -0,0 +1,534 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiWayIf, LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MultiWayIf #-}
+
+module Handler.Corrections where
+
+import Import
+-- import System.FilePath (takeFileName)
+
+import Handler.Utils
+import Handler.Utils.Submission
+import Handler.Utils.Table.Cells
+-- import Handler.Utils.Zip
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import qualified Data.Text as Text
+
+-- import Data.Time
+-- import qualified Data.Text as T
+-- import Data.Function ((&))
+--
+import Colonnade hiding (fromMaybe, singleton, bool)
+-- import Yesod.Colonnade
+--
+-- import qualified Data.UUID.Cryptographic as UUID
+-- import qualified Data.Conduit.List as C
+
+import qualified Database.Esqueleto as E
+-- import qualified Database.Esqueleto.Internal.Sql as E
+
+import Control.Lens
+-- import Control.Monad.Writer (MonadWriter(..), execWriterT)
+
+-- import Network.Mime
+
+import Web.PathPieces
+
+import Text.Hamlet (ihamletFile)
+import Text.Blaze.Html (preEscapedToHtml)
+
+import Database.Persist.Sql (updateWhereCount)
+
+import Data.List (genericLength)
+
+
+
+type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) =>
+            (expr (Entity Course), expr (Entity Sheet), expr (Entity Submission))
+            -> expr (E.Value Bool)
+
+ratedBy :: Key User -> CorrectionsWhere
+ratedBy uid (_course,_sheet,submission) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
+
+courseIs :: Key Course -> CorrectionsWhere
+courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
+
+sheetIs :: Key Sheet -> CorrectionsWhere
+sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid
+
+
+type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId User)
+
+colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colTerm = sortable (Just "term") (i18nCell MsgTerm)
+        $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
+          -- cell [whamlet| _{untermKey $ course ^. _3}|]   -- lange, internationale Semester
+          textCell $ termToText $ unTermKey $ course ^. _3 -- kurze Semsterkürzel
+
+colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colCourse = sortable (Just "course") (i18nCell MsgCourse)
+        $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
+          let tid = course ^. _3
+              ssh = course ^. _4
+              csh = course ^. _2
+          in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|]
+
+colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
+        $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } ->
+          let tid   = course ^. _3
+              ssh   = course ^. _4
+              csh   = course ^. _2
+              shn   = sheetName $ entityVal sheet
+          in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|]
+
+colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
+  DBRow{ dbrOutput = (_, _, _, Nothing  , _) } -> cell mempty
+  DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _) } -> userCell userDisplayName userSurname
+
+colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
+        $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } ->
+          let csh = course ^. _2
+              tid = course ^. _3
+              ssh = course ^. _4
+              shn = sheetName $ entityVal sheet
+              mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice
+              mkRoute = do
+                cid <- mkCid
+                return $ CSubmissionR tid ssh csh shn cid SubShowR
+          in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
+
+colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
+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=(_, _, course, _, users) } -> let
+  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)
+colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
+  cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
+  in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
+  
+colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
+colRating = sortable (Just "rating") (i18nCell MsgRating) $  \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } ->
+  let csh = course ^. _2
+      tid = course ^. _3
+      ssh = course ^. _4
+      -- shn = sheetName
+      mkRoute = do
+        cid <- encrypt subId
+        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 )
+                     => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
+makeCorrectionsTable whereClause colChoices psValidator = do
+  let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
+      dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
+        E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
+        E.on $ sheet  E.^. SheetId  E.==. submission E.^. SubmissionSheet
+        E.on $ course E.^. CourseId E.==. sheet      E.^. SheetCourse
+        E.where_ $ whereClause (course,sheet,submission)
+        let crse =  ( course E.^. CourseName      :: E.SqlExpr (E.Value CourseName)
+                    , course E.^. CourseShorthand
+                    , course E.^. CourseTerm
+                    , course E.^. CourseSchool    :: E.SqlExpr (E.Value SchoolId)
+                    )
+        return (submission, sheet, crse, corrector)
+      dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
+      dbtProj = traverse $ \(submission@(Entity sId _), sheet, (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
+        submittors <- lift . E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+          E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
+          E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
+          E.orderBy [E.asc $ user E.^. UserId]
+          return user
+        let
+          submittorMap = foldr (\(Entity userId user) -> Map.insert userId user) Map.empty submittors
+        return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
+  dbTable psValidator $ DBTable
+    { dbtSQLQuery
+    , dbtColonnade = colChoices
+    , dbtProj
+    , dbtSorting   = [ ( "term"
+                       , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
+                       )
+                     , ( "course"
+                       , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
+                       )
+                     , ( "sheet"
+                       , SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
+                       )
+                     , ( "corrector"
+                       , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname
+                       )
+                     , ( "rating"
+                       , SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
+                       )
+                     ]
+    , dbtFilter    = [ ( "term"
+                       , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if
+                           | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
+                           | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
+                       )
+                     , ( "course"
+                       , FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if
+                           | Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool)
+                           | otherwise     -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs)
+                       )
+                     , ( "sheet"
+                       , FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if
+                           | Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool)
+                           | otherwise     -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns)
+                       )
+                     , ( "corrector"
+                       , FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if
+                           | Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool)
+                           | otherwise       -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails)
+                                          E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
+                       )
+                     ]
+    , dbtStyle     = def
+    , dbtIdent     = "corrections" :: Text
+    }
+
+data ActionCorrections = CorrDownload
+                       | CorrSetCorrector
+                       | CorrAutoSetCorrector
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
+instance PathPiece ActionCorrections where
+  fromPathPiece = readFromPathPiece
+  toPathPiece = showToPathPiece
+
+instance RenderMessage UniWorX ActionCorrections where
+  renderMessage m ls CorrDownload = renderMessage m ls MsgCorrDownload
+  renderMessage m ls CorrSetCorrector = renderMessage m ls MsgCorrSetCorrector
+  renderMessage m ls CorrAutoSetCorrector = renderMessage m ls MsgCorrAutoSetCorrector
+
+data ActionCorrectionsData = CorrDownloadData
+                           | CorrSetCorrectorData (Maybe UserId)
+                           | CorrAutoSetCorrectorData SheetId
+
+correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) -> Handler TypedContent
+correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
+  tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
+  ((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
+    ((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
+    (actionRes, action) <- multiAction actions
+    return ((,) <$> actionRes <*> selectionRes, table <> action)
+
+  Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
+  case actionRes of
+    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
+      addHeader "Content-Disposition" [st|attachment; filename="corrections.zip"|]
+      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)
+        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
+                    , 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
+                  , SubmissionRatingComment  =. Nothing
+                  , SubmissionRatingBy       =. Nothing
+                  , SubmissionRatingAssigned =. Nothing
+                  , SubmissionRatingTime     =. Nothing
+                  ]
+        addMessageI Success $ MsgRemovedCorrections num
+      redirect currentRoute
+    FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do
+      subs <- mapM decrypt $ Set.toList subs'
+      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)
+        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)
+          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)
+      redirect currentRoute
+
+  fmap toTypedContent . defaultLayout $ do
+    setTitleI MsgCourseCorrectionsTitle
+    $(widgetFile "corrections")
+
+
+type ActionCorrections' = (ActionCorrections, MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget))
+  
+downloadAction :: ActionCorrections'
+downloadAction = ( CorrDownload
+                 , return (pure CorrDownloadData, Nothing)
+                 )
+
+assignAction :: Either CourseId SheetId -> ActionCorrections'
+assignAction selId = ( CorrSetCorrector
+                     , over (mapped._2) Just $ do
+                         correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
+                           E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
+                           E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+                           E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+
+                           E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId
+
+                           return user
+
+                         mr <- getMessageRender
+
+                         correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey
+
+                         ($ mempty) . renderAForm FormStandard . wFormToAForm $ do
+                            cId <- wreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing
+                            fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
+                     )
+
+autoAssignAction :: SheetId -> ActionCorrections'
+autoAssignAction shid = ( CorrAutoSetCorrector
+                        , return (pure $ CorrAutoSetCorrectorData shid, Nothing)
+                        )
+
+getCorrectionsR, postCorrectionsR :: Handler TypedContent
+getCorrectionsR = postCorrectionsR
+postCorrectionsR = do
+  uid <- requireAuthId
+  let whereClause = ratedBy uid
+      colonnade = mconcat
+        [ colSelect
+        , dbRow
+        , colTerm
+        , 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
+        & restrictSorting (\name _ -> name /= "corrector")
+  correctionsR whereClause colonnade psValidator $ Map.fromList
+    [ downloadAction
+    ]
+
+getCCorrectionsR, postCCorrectionsR ::  TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
+getCCorrectionsR = postCCorrectionsR
+postCCorrectionsR tid ssh csh = do
+  Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
+  let whereClause = courseIs cid
+      colonnade = mconcat -- should match getSSubsR for consistent UX
+        [ colSelect
+        , dbRow
+        , colSheet
+        , colSMatrikel
+        , colSubmittors
+        , colSubmissionLink
+        , colRating
+        , colRated
+        , colCorrector
+        , colAssigned
+        ] -- Continue here
+      psValidator = def
+  correctionsR whereClause colonnade psValidator $ Map.fromList
+    [ downloadAction
+    , assignAction (Left cid)
+    ]
+
+getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
+getSSubsR = postSSubsR
+postSSubsR tid ssh csh shn = do
+  shid <- runDB $ fetchSheetId tid ssh csh shn
+  let whereClause = sheetIs shid
+      colonnade = mconcat -- should match getCCorrectionsR for consistent UX
+        [ colSelect
+        , dbRow
+        , colSMatrikel
+        , colSubmittors
+        , colSubmissionLink
+        , colRating
+        , colRated
+        , colCorrector
+        , colAssigned
+        ]
+      psValidator = def
+  correctionsR whereClause colonnade psValidator $ Map.fromList
+    [ downloadAction
+    , assignAction (Right shid)
+    , autoAssignAction shid
+    ]
+
+correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
+correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
+  E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
+  E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
+  E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
+  E.where_ $ course E.^. CourseTerm       E.==. E.val tid
+       E.&&. course E.^. CourseSchool     E.==. E.val ssh
+       E.&&. course E.^. CourseShorthand  E.==. E.val csh
+       E.&&. sheet  E.^. SheetName        E.==. E.val shn
+       E.&&. submission E.^. SubmissionId E.==. E.val sub
+  return (course, sheet, submission, corrector)
+
+getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
+getCorrectionR tid ssh csh shn cid = do
+  mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True
+  bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid
+postCorrectionR tid ssh csh shn cid = do
+  sub <- decrypt cid
+
+  results <- runDB $ correctionData tid ssh csh shn sub
+
+  case results of
+    [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do
+      let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
+
+      ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,)
+        <$> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip MsgRatingPointsDone) (Just $ submissionRatingPoints)
+        <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
+        <* submitButton
+
+      ((uploadResult, uploadForm), uploadEncoding) <- runFormPost . identForm FIDcorrectionUpload . renderAForm FormStandard $
+            areq (zipFileField True) (fslI MsgRatingFiles) Nothing
+        <*  submitButton
+
+      case corrResult of
+        FormMissing -> return ()
+        FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
+        FormSuccess (ratingPoints, ratingComment) -> do
+          runDB $ do
+            uid <- liftHandlerT requireAuthId
+            now <- liftIO getCurrentTime
+
+            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
+          redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
+
+      case uploadResult of
+        FormMissing -> return ()
+        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
+          redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
+
+      defaultLayout $ do
+        let userCorrection = $(widgetFile "correction-user")
+        $(widgetFile "correction")
+    _ -> notFound
+getCorrectionUserR tid ssh csh shn cid = do
+  sub <- decrypt cid
+  
+  results <- runDB $ correctionData tid ssh csh shn sub
+
+  case results of
+    [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do
+      let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
+      
+      defaultLayout $ do
+        $(widgetFile "correction-user")
+    _ -> notFound
+
+  
+getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
+getCorrectionsUploadR = postCorrectionsUploadR
+postCorrectionsUploadR = do
+  ((uploadRes, upload), uploadEncoding) <- runFormPost . identForm FIDcorrectionsUpload . renderAForm FormStandard $
+       areq (zipFileField True) (fslI MsgCorrUploadField) Nothing
+    <* submitButton
+
+  case uploadRes of
+    FormMissing -> return ()
+    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
+        | otherwise -> do
+            subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
+            mr <- (toHtml .) <$> getMessageRender
+            addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
+        
+
+  defaultLayout $ do
+    $(widgetFile "corrections-upload")

src/Handler/Course.hs

@@ -1,313 +1,562 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE FlexibleContexts #-}
 
 module Handler.Course where
 
 import Import
+
+import Control.Lens
+import Utils.Lens
+import Utils.TH
+-- import Utils.DB
 import Handler.Utils
+import Handler.Utils.Table.Cells
 
 -- import Data.Time
 import qualified Data.Text as T
 import Data.Function ((&))
-import Yesod.Form.Bootstrap3
+-- import Yesod.Form.Bootstrap3
 
-import Colonnade hiding (fromMaybe)
-import Yesod.Colonnade
+import Data.Maybe
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+import Colonnade hiding (fromMaybe,bool)
+-- import Yesod.Colonnade
+
+import qualified Database.Esqueleto as E
 
 import qualified Data.UUID.Cryptographic as UUID
 
+-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
+type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School)
 
-getCourseListR :: Handler TypedContent
-getCourseListR = redirect TermShowR
+colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colCourse = sortable (Just "course") (i18nCell MsgCourse)
+          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+            anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
+              [whamlet|#{display courseName}|]
 
-getCourseListTermR :: TermId -> Handler Html
-getCourseListTermR tidini = do
-  (term,courses) <- runDB $ (,)
-      <$> get tidini
-      <*> selectList [CourseTermId ==. tidini] [Asc CourseShorthand]
-  when (isNothing term) $ do
-    addMessage "warning" [shamlet| Semester #{toPathPiece tidini} nicht gefunden. |]
-    redirect TermShowR
-  -- TODO: several runDBs per TableRow are probably too inefficient!
-  let colonnadeTerms = mconcat
-        [ headed "Kürzel" $ (\ckv ->
-            let c   = entityVal ckv
-                shd = courseShorthand c
-                tid = courseTermId c
-            in [whamlet| <a href=@{CourseR tid shd CourseShowR}>#{shd} |] )
---         , headed "Institut" $ [shamlet| #{course} |]
-        , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal
-        , headed "Ende Anmeldung"   $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal
-        , headed "Teilnehmer" $ (\ckv -> do
-              let cid = entityKey ckv
-              partiNum <- handlerToWidget $ runDB $ count [CourseParticipantCourseId ==. cid]
-              [whamlet| #{show partiNum} |]
+colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
+colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do
+    course <- view $ _dbrOutput . _1 . _entityVal
+    return $ courseCell course
+
+colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
+colDescription = sortable Nothing (i18nCell MsgCourseDescription)
+          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+            case courseDescription of
+              Nothing      -> mempty
+              (Just descr) -> cell $ modalStatic descr
+
+colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
+          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+            anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
+
+colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
+          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
+            ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
+            ( case courseDescription of
+                Nothing      -> mempty
+                (Just descr) -> cell
+                  [whamlet|<span style="float:right"> ^{modalStatic descr} |]
             )
-        , headed " " $ (\ckv ->
-            let c   = entityVal ckv
-                shd = courseShorthand c
-                tid = courseTermId c
-            in do
-              adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CourseEditR) False
-              -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else ""
-              [whamlet|
-                $if adminLink == Authorized
-                  <a href=@{CourseR tid shd CourseEditR}>
-                    editieren
-              |]
+
+colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colTerm = sortable (Just "term") (i18nCell MsgTerm)
+          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+            anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|]
+
+colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
+            anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|]
+
+colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
+          $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
+            anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|]
+
+colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
+          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+            maybe mempty timeCell courseRegisterFrom
+            -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
+
+colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
+          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
+            cell $ traverse (formatTime SelFormatDateTime) courseRegisterTo >>= maybe mempty toWidget
+
+colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colParticipants = sortable (Just "participants") (i18nCell MsgCourseMembers)
+          $ \DBRow{ dbrOutput=(Entity cid Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of
+              Nothing -> MsgCourseMembersCount currentParticipants
+              Just max -> MsgCourseMembersCountLimited currentParticipants max
+
+colRegistered :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
+          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, registered, _) } -> tickmarkCell registered
+
+type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
+
+course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int64)
+course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do
+    E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
+    return (E.countRows :: E.SqlExpr (E.Value Int64))
+
+course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
+course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant -> do
+    E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
+      E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
+
+makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h )
+                     => _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
+makeCourseTable whereClause colChoices psValidator = do
+  muid <- maybeAuthId
+  let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
+      dbtSQLQuery qin@(course `E.InnerJoin` school) = do
+        E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
+        let participants = course2Participants qin
+        let registered   = course2Registered muid qin
+        E.where_ $ whereClause (course, participants, registered)
+        return (course, participants, registered, school)
+      dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
+      dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
+  dbTable psValidator $ DBTable
+    { dbtSQLQuery
+    , dbtColonnade = colChoices
+    , dbtProj
+    , dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here
+        [ ( "course",        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseName)
+        , ( "cshort",        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseShorthand)
+        , ( "term"  ,        SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseTerm)
+        , ( "school",        SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolName)
+        , ( "schoolshort",   SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand)
+        , ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom)
+        , ( "register-to",   SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo)
+        , ( "participants",  SortColumn $ course2Participants   )
+        , ( "registered",    SortColumn $ course2Registered muid)
+        ]
+    , dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here
+        [ ( "course", FilterColumn $ \(course `E.InnerJoin` _school:: CourseTableExpr) criterias -> if
+                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+                | otherwise          -> course E.^. CourseName `E.in_` E.valList (Set.toList criterias)
+          )
+        , ( "cshort", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
+                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+                | otherwise          -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList criterias)
+          )
+        , ( "term"  , FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
+                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+                | otherwise          -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias)
+          )
+--         , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
+--                 | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+--                 | otherwise          -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias)
+--           )
+        , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) ->
+              emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?!
+          )
+        , ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
+                | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
+                | otherwise          -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias)
           )
         ]
-  let coursesTable = encodeWidgetTable tableSortable colonnadeTerms courses
+    , dbtStyle = def
+    , dbtIdent = "courses" :: Text
+    }
+
+getCourseListR :: Handler Html
+getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
+  muid <- maybeAuthId
+  let colonnade = widgetColonnade $ mconcat
+        [ colCourseDescr
+        , colCShort
+        , colTerm
+        , maybe mempty (const colRegistered) muid
+        , colSchool
+        ]
+      whereClause = const $ E.val True
+      validator = def
+        & defaultSorting [("course", SortAsc), ("term", SortDesc)]
+  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
   defaultLayout $ do
-    setTitle "Semesterkurse"
+    setTitleI MsgCourseListTitle
+    [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO
     $(widgetFile "courses")
 
-getCourseShowR :: TermId -> Text -> Handler Html
-getCourseShowR tid csh = do
+getTermCurrentR :: Handler Html
+getTermCurrentR = do
+  termIds  <- runDB $ selectKeysList [TermActive ==. True] [Desc TermName]
+  case fromNullable termIds of
+    Nothing -> notFound
+    (Just (maximum -> tid)) -> -- getTermCourseListR tid
+        redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc.
+
+getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html
+getTermSchoolCourseListR tid ssh = do
+  void . runDB $ get404 tid -- Just ensure the term exists
+  School{schoolName=school} <- runDB $ get404 ssh -- Just ensure the term exists
+  muid <- maybeAuthId
+  let colonnade = widgetColonnade $ mconcat
+        [ dbRow
+        , colCShortDescr
+        , colRegFrom
+        , colRegTo
+        , colParticipants
+        , maybe mempty (const colRegistered) muid
+        ]
+      whereClause = \(course, _, _) ->
+                course E.^. CourseTerm   E.==. E.val tid
+          E.&&. course E.^. CourseSchool E.==. E.val ssh
+      validator = def
+        & defaultSorting [("cshort", SortAsc)]
+  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
+  defaultLayout $ do
+    setTitleI $ MsgTermSchoolCourseListTitle tid school
+    $(widgetFile "courses")
+
+
+getTermCourseListR :: TermId -> Handler Html
+getTermCourseListR tid = do
+  void . runDB $ get404 tid -- Just ensure the term exists
+  muid <- maybeAuthId
+  let colonnade = widgetColonnade $ mconcat
+        [ dbRow
+        , colCShortDescr
+        , colSchoolShort
+        , colRegFrom
+        , colRegTo
+        , colParticipants
+        , maybe mempty (const colRegistered) muid
+        ]
+      whereClause = \(course, _, _) -> course E.^. CourseTerm E.==. E.val tid
+      validator = def
+        & defaultSorting [("cshort", SortAsc)]
+  ((), coursesTable) <- makeCourseTable whereClause colonnade validator
+  defaultLayout $ do
+    setTitleI . MsgTermCourseListTitle $ tid
+    $(widgetFile "courses")
+
+getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCShowR tid ssh csh = do
   mbAid <- maybeAuthId
-  (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
-      courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh
+  (courseEnt,(schoolMB,participants,registered),lecturers) <- runDB $ do
+      courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
       dependent <- (,,)
-          <$> get (courseSchoolId course)               -- join
-          <*> count [CourseParticipantCourseId ==. cid] -- join
+          <$> get (courseSchool course)               -- join -- just fetch full school name here
+          <*> count [CourseParticipantCourse ==. cid] -- join
           <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
                 Nothing -> return False
-                (Just aid) -> do
-                                regL <- getBy (UniqueParticipant aid cid)
-                                return $ isJust regL)
-      return $ (courseEnt,dependent)
+                (Just aid) -> do  regL <- getBy (UniqueParticipant aid cid)
+                                  return $ isJust regL)
+      lecturers <- E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
+          E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
+          E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
+          return $ user E.^. UserDisplayName
+      return $ (courseEnt,dependent,E.unValue <$> lecturers)
   let course = entityVal courseEnt
-  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered
+  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
+  registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
+  mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
+  mRegTo   <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
   defaultLayout $ do
     setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
     $(widgetFile "course")
 
-registerButton :: Bool -> Form ()
-registerButton registered = renderAForm FormStandard $
-      pure () <*  bootstrapSubmit regMsg
-  where
-    msg    = if registered then "Abmelden" else "Anmelden"
-    regMsg = msg :: BootstrapSubmit Text
 
-postCourseShowR :: TermId -> Text -> Handler Html
-postCourseShowR tid csh = do
+registerForm :: Bool -> Maybe Text -> Form Bool
+registerForm registered msecret extra = do
+  (msecretRes', msecretView) <- case msecret of
+    (Just _) | not registered -> bimap Just Just <$> (mreq textField (fslpI MsgCourseSecret "Code") Nothing)
+    _ -> return (Nothing,Nothing)
+  (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
+  let widget = $(widgetFile "widgets/registerForm")
+  let msecretRes | Just res <- msecretRes' = Just <$> res
+                 | otherwise               = FormSuccess Nothing
+  return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
+
+
+postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+postCRegisterR tid ssh csh = do
   aid <- requireAuthId
-  (cid, registered) <- runDB $ do
-      (Entity cid _) <- getBy404 $ CourseTermShort tid csh
+  (cid, course, registered) <- runDB $ do
+      (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
       registered <- isJust <$> (getBy $ UniqueParticipant aid cid)
-      return (cid, registered)
-  ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered
+      return (cid, course, registered)
+  ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
   case regResult of
-    (FormSuccess _)
+    (FormSuccess codeOk)
       | registered -> do
           runDB $ deleteBy $ UniqueParticipant aid cid
-          addMessage "info" "Sie wurden abgemeldet."
-      | otherwise  -> do
+          addMessageI Info MsgCourseDeregisterOk
+      | codeOk -> do
           actTime <- liftIO $ getCurrentTime
           regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
-          when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!"
+          when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
+      | otherwise -> addMessageI Warning MsgCourseSecretWrong
     (_other) -> return () -- TODO check this!
-  -- redirect or not?! I guess not, since we want GET now
-  getCourseShowR tid csh
+  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
-  courseEditHandler Nothing
+  uid <- requireAuthId
+  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 Nothing
+postCourseNewR = courseEditHandler False Nothing -- Note: Nothing is safe here, since we will create a new course.
 
-getCourseEditR :: TermId -> Text -> Handler Html
-getCourseEditR tid csh = do
-  course <- runDB $ getBy $ CourseTermShort tid csh
-  courseEditHandler course
+getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCEditR  = pgCEditR True
+postCEditR = pgCEditR False
 
-postCourseEditR :: TermId -> Text -> Handler Html
-postCourseEditR = getCourseEditR
-
-getCourseEditIDR :: CryptoUUIDCourse -> Handler Html
-getCourseEditIDR cID = do
-  cIDKey <- getsYesod appCryptoIDKey
-  courseID <- UUID.decrypt cIDKey cID
-  courseEditHandler =<< runDB (getEntity courseID)
+pgCEditR :: Bool -> TermId -> SchoolId -> CourseShorthand -> Handler Html
+pgCEditR isGetReq tid ssh csh = do
+  course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
+  -- 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.
+  courseEditHandler isGetReq $ courseToForm <$> course
 
 
-courseDeleteHandler :: Handler Html -- not called anywhere yet
-courseDeleteHandler = undefined
+getCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+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!|]
-            redirect $ CourseListTermR $ cfTerm res
+            addMessage Info [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
+            redirect $ TermCourseListR $ cfTerm res
 -}
 
-courseEditHandler :: Maybe (Entity Course) -> Handler Html
-courseEditHandler course = do
+
+-- | Course Creation and Editing
+-- | 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 $ courseToForm <$> course
+    ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm mbCourseForm
     case result of
       (FormSuccess res@(
         CourseForm  { cfCourseId = Nothing
                     , cfShort    = csh
+                    , cfSchool   = ssh
                     , cfTerm     = tid
                     })) ->  do -- create new course
-          let tident = unTermKey tid
           now <- liftIO getCurrentTime
           insertOkay <- runDB $ insertUnique $ Course
             { courseName            = cfName     res
             , courseDescription     = cfDesc     res
             , courseLinkExternal    = cfLink     res
             , courseShorthand       = cfShort    res
-            , courseTermId          = cfTerm     res
-            , courseSchoolId        = cfSchool   res
+            , courseTerm            = cfTerm     res
+            , courseSchool          = cfSchool   res
             , courseCapacity        = cfCapacity res
-            , courseHasRegistration = cfHasReg   res
+            , courseRegisterSecret  = cfSecret   res
+            , courseMaterialFree    = cfMatFree  res
             , courseRegisterFrom    = cfRegFrom  res
             , courseRegisterTo      = cfRegTo    res
-            , courseDeregisterUntil = Nothing -- TODO
-            , courseRegisterSecret  = Nothing -- TODO
-            , courseMaterialFree    = True    -- TODO
+            , courseDeregisterUntil = cfDeRegUntil res
             }
           case insertOkay of
             (Just cid) -> do
               runDB $ do
                 insert_ $ CourseEdit aid now cid
                 insert_ $ Lecturer aid cid
-              addMessageI "info" $ MsgCourseNewOk tident csh
-              redirect $ CourseListTermR tid
+              addMessageI Info $ MsgCourseNewOk tid ssh csh
+              redirect $ TermCourseListR tid
             Nothing ->
-              addMessageI "danger" $ MsgCourseNewDupShort tident csh
+              addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
 
       (FormSuccess res@(
         CourseForm  { cfCourseId = Just cid
                     , cfShort    = csh
+                    , cfSchool   = ssh
                     , cfTerm     = tid
                     })) -> do -- edit existing course
-          let tident = unTermKey tid
           now <- liftIO getCurrentTime
           -- addMessage "debug" [shamlet| #{show res}|]
-          runDB $ do
+          success <- runDB $ do
             old <- get cid
             case old of
-              Nothing -> addMessageI "error" $ MsgInvalidInput
+              Nothing -> addMessageI Error MsgInvalidInput $> False
               (Just oldCourse) -> do
-            -- existing <- getBy $ CourseTermShort tid csh
-            -- if ((entityKey <$> existing) /= Just cid)
-            --  then addMessageI "danger" $ MsgCourseEditDupShort tident csh
-            --   else do
-                -- addMessage "debug" $ fromMaybe [shamlet|No description given.|] $ cfDesc res
---                 update cid
---                   [ CourseName         =. cfName     res
---                   , CourseDescription  =. cfDesc     res
---                   , CourseLinkExternal =. cfLink     res
---                   , CourseShorthand    =. cfShort    res -- TODO: change here should generate a warning, or only allowed for Admins?!
---                   , CourseTermId       =. tid            -- TODO: change here should generate a warning, or only allowed for Admins?!
---                   , CourseSchoolId     =. cfSchool   res
---                   , CourseCapacity     =. cfCapacity res
---                   , CourseRegisterFrom =. cfRegFrom  res
---                   , CourseRegisterTo   =. cfRegTo    res
---                   , CourseChangedBy    =. aid
---                   , CourseChanged      =. now
---                   ]
-                _updOkay <- replace cid (  -- TODO replaceUnique requires Eq?!
-                    Course  {  courseName            = cfName     res
-                            ,  courseDescription     = cfDesc     res
-                            ,  courseLinkExternal    = cfLink     res
-                            ,  courseShorthand       = cfShort    res
-                            ,  courseTermId          = cfTerm     res
-                            ,  courseSchoolId        = cfSchool   res
-                            ,  courseCapacity        = cfCapacity res
-                            ,  courseHasRegistration = cfHasReg   res
-                            ,  courseRegisterFrom    = cfRegFrom  res
-                            ,  courseRegisterTo      = cfRegTo    res
-                            ,  courseDeregisterUntil = Nothing -- TODO
-                            ,  courseRegisterSecret  = Nothing -- TODO
-                            ,  courseMaterialFree    = True    -- TODO
+                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 -- dangerous
+                            ,  courseSchool          = cfSchool     res
+                            ,  courseCapacity        = cfCapacity   res
+                            ,  courseRegisterSecret  = cfSecret     res
+                            ,  courseMaterialFree    = cfMatFree    res
+                            ,  courseRegisterFrom    = cfRegFrom    res
+                            ,  courseRegisterTo      = cfRegTo      res
+                            ,  courseDeregisterUntil = cfDeRegUntil res
                     }
                   )
-                insert_ $ CourseEdit aid now cid
---                 if (isNothing updOkay)
---                   then do
-                addMessageI "info" $ MsgCourseEditOk tident csh
-                -- redirect $ CourseListTermR tid
---                   else addMessageI "danger" $ MsgCourseEditDupShort tident csh
+                case updOkay of
+                  (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
+                  Nothing  -> do
+                    insert_ $ CourseEdit aid now cid
+                    addMessageI Success $ MsgCourseEditOk tid ssh csh
+                    return True
+          when success $ redirect $ CourseR tid ssh csh CShowR
 
-      (FormFailure _) -> addMessageI "warning" MsgInvalidInput
-      other -> addMessage "error" $ [shamlet| Error: #{show other}|]
-    let formTitle   = "Kurs editieren/anlegen" :: Text
+      (FormFailure _) -> addMessageI Warning MsgInvalidInput
+      (FormMissing) -> return ()
     actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
     defaultLayout $ do
-      setTitle [shamlet| #{formTitle} |]
+      setTitleI MsgCourseEditTitle
       $(widgetFile "formPage")
 
 
 data CourseForm = CourseForm
-        { cfCourseId :: Maybe CourseId -- Maybe CryptoUUIDCourse
-        , cfName     :: Text
-        , cfDesc     :: Maybe Html
-        , cfLink     :: Maybe Text
-        , cfShort    :: Text
-        , cfTerm     :: TermId
-        , cfSchool   :: SchoolId
-        , cfCapacity :: Maybe Int
-        , cfHasReg   :: Bool
-        , cfRegFrom  :: Maybe UTCTime
-        , cfRegTo    :: Maybe UTCTime
+        { cfCourseId   :: Maybe CourseId
+        , cfName       :: CourseName
+        , cfDesc       :: Maybe Html
+        , cfLink       :: Maybe Text
+        , cfShort      :: CourseShorthand
+        , cfTerm       :: TermId
+        , cfSchool     :: SchoolId
+        , cfCapacity   :: Maybe Int64
+        , cfSecret     :: Maybe Text
+        , cfMatFree    :: Bool
+        , cfRegFrom    :: Maybe UTCTime
+        , cfRegTo      :: Maybe UTCTime
+        , cfDeRegUntil :: Maybe UTCTime
         }
 
-instance Show CourseForm where
-  show cf = T.unpack (cfShort cf) ++ ' ':(show $ cfCourseId cf)
-
-
 courseToForm :: Entity Course -> CourseForm
-courseToForm cEntity = CourseForm
-        { cfCourseId = Just $ entityKey cEntity
-        , cfName     = courseName               course
-        , cfDesc     = courseDescription        course
-        , cfLink     = courseLinkExternal       course
-        , cfShort    = courseShorthand          course
-        , cfTerm     = courseTermId             course
-        , cfSchool   = courseSchoolId           course
-        , cfCapacity = courseCapacity           course
-        , cfHasReg   = courseHasRegistration    course
-        , cfRegFrom  = courseRegisterFrom       course
-        , cfRegTo    = courseRegisterTo         course
-        }
-  where
-    course = entityVal cEntity
+courseToForm (Entity cid Course{..}) = CourseForm
+    { cfCourseId   = Just cid
+    , cfName       = courseName
+    , cfDesc       = courseDescription
+    , cfLink       = courseLinkExternal
+    , cfShort      = courseShorthand
+    , cfTerm       = courseTerm
+    , cfSchool     = courseSchool
+    , cfCapacity   = courseCapacity
+    , cfSecret     = courseRegisterSecret
+    , cfMatFree    = courseMaterialFree
+    , cfRegFrom    = courseRegisterFrom
+    , cfRegTo      = courseRegisterTo
+    , cfDeRegUntil = courseDeregisterUntil
+    }
 
 newCourseForm :: Maybe CourseForm -> Form CourseForm
 newCourseForm template = identForm FIDcourse $ \html -> do
-    -- mopt hiddenField
-    --     cidKey <- getsYesod appCryptoIDKey
-    --     courseId <- runMaybeT $ do
-    --         cid <- cfCourseId template
-    --         UUID.encrypt cidKey cid
+    userSchools <- liftHandlerT . runDB $ do
+      userId <- liftHandlerT requireAuthId
+      (fmap concat . sequence)
+        [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
+        , map (userAdminSchool    . entityVal) <$> selectList [UserAdminUser    ==. userId] []
+        ]
+    let termsField = case template of
+          --TODO: if Admin, then all
+          -- if allowed to delete course then allow current and all active term
+          -- otherwise only keep current term
+          (Just cform) | (Just _) <- cfCourseId cform -> termsSetField [cfTerm cform]
+          _allOtherCases -> termsActiveField
     (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
-      -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work?
-      <$> aopt hiddenField "KursId"             (cfCourseId <$> template)
-      <*> areq textField (fsb "Name")           (cfName     <$> template)
-      <*> aopt htmlField (fsb "Beschreibung")   (cfDesc     <$> template)
-      <*> aopt urlField  (fsb "Homepage")       (cfLink     <$> template)
-      <*> areq textField (fsb "Kürzel"
+      <$> pure (cfCourseId =<< template)
+      <*> areq ciField (fslI MsgCourseName)          (cfName     <$> template)
+      <*> aopt htmlField (fslI MsgCourseDescription
+                         & setTooltip MsgCourseDescriptionTip)   (cfDesc     <$> template)
+      <*> aopt urlField  (fslI MsgCourseHomepage)                (cfLink     <$> template)
+      <*> areq ciField (fslI MsgCourseShorthand
             -- & addAttr "disabled" "disabled"
-            & setTooltip "Muss innerhalb des Semesters eindeutig sein")
+            & setTooltip MsgCourseShorthandUnique)
                                                 (cfShort  <$> template)
-      <*> areq termActiveField        (fsb "Semester")       (cfTerm     <$> template)
-      <*> areq schoolField            (fsb "Institut")       (cfSchool   <$> template)
-      <*> aopt (natField "Kapazität") (fsb "Kapazität")      (cfCapacity <$> template)
-      <*> areq checkBoxField          (fsb "Anmeldung")      (cfHasReg   <$> template)
-      <*> aopt utcTimeField           (fsb "Anmeldung von:") (cfRegFrom  <$> template)
-      <*> aopt utcTimeField           (fsb "Anmeldung bis:") (cfRegTo    <$> template)
+      <*> areq termsField                   (fslI MsgCourseSemester)    (cfTerm     <$> template)
+      <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool)      (cfSchool   <$> template)
+      <*> aopt (natField "Kapazität")       (fslI MsgCourseCapacity
+            & setTooltip MsgCourseCapacityTip)                          (cfCapacity <$> template)
+      <*> aopt textField      (fslpI MsgCourseSecret "beliebige Zeichenkette"
+            & setTooltip MsgCourseSecretTip)                            (cfSecret   <$> template)
+      <*> areq checkBoxField  (fslI  MsgMaterialFree)                   (cfMatFree  <$> template)
+      <*> aopt utcTimeField   (fslpI MsgRegisterFrom "Datum"
+            & setTooltip MsgCourseRegisterFromTip)                      (cfRegFrom  <$> template)
+      <*> aopt utcTimeField   (fslpI MsgRegisterTo   "Datum"
+            & setTooltip MsgCourseRegisterToTip)                        (cfRegTo    <$> template)
+      <*> aopt utcTimeField   (fslpI MsgDeRegUntil   "Datum"
+            & setTooltip MsgCourseDeregisterUntilTip)                   (cfDeRegUntil <$> template)
       <*  submitButton
     return $ case result of
       FormSuccess courseResult
@@ -316,37 +565,52 @@ newCourseForm template = identForm FIDcourse $ \html -> do
           (FormFailure errorMsgs,
                 [whamlet|
                   <div class="alert alert-danger">
-                    <h4> Fehler:
-                    <ul>
-                      $forall errmsg <- errorMsgs
-                        <li> #{errmsg}
+                    <div class="alert__content">
+                      <h4> Fehler:
+                      <ul>
+                        $forall errmsg <- errorMsgs
+                          <li> #{errmsg}
                   ^{widget}
                 |]
               )
       _ -> (result, widget)
---  where
---     cid :: Maybe CourseId
---     cid = join $ cfCourseId <$> template
 
 
 validateCourse :: CourseForm -> [Text]
 validateCourse (CourseForm{..}) =
   [ msg | (False, msg) <-
     [
-      ( cfRegFrom <= cfRegTo
+      ( NTop cfRegFrom <= NTop cfRegTo
       , "Ende des Anmeldezeitraums muss nach dem Anfang liegen"
       )
     ,
+      ( NTop cfRegFrom <= NTop cfDeRegUntil
+      , "Ende des Abmeldezeitraums muss nach dem Anfang liegen"
+      )
 --    No starting date is okay: effective immediately
 --       ( cfHasReg <= (isNothing cfRegFrom)
 --       , "Beginn der Anmeldung angeben oder Anmeldungen deaktivieren"
 --       )
 --     ,
-      ( cfHasReg == (isJust cfRegTo)
-      , "Ende des Anmeldezeitraums angeben oder Anmeldungen deaktivieren"
-      )
-    ,
-      ( isJust cfRegFrom <= cfHasReg
-      , "Anmeldungen aktivieren oder Anmeldezeitraum löschen"
-      )
   ] ]
+
+
+
+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/CryptoIDDispatch.hs

@@ -14,26 +14,53 @@
 
 module Handler.CryptoIDDispatch
   ( getCryptoUUIDDispatchR
+  , getCryptoFileNameDispatchR
   ) where
 
 import Import hiding (Proxy)
 
 import Data.Proxy
 
+import qualified Data.Text as Text
+
 import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
 import qualified Control.Monad.Catch as E (Handler(..))
 
+import           Data.CaseInsensitive   (CI)
+import qualified Data.CaseInsensitive as CI
+
 
 class CryptoRoute ciphertext plaintext where
   cryptoIDRoute :: p plaintext -> ciphertext -> Handler (Route UniWorX)
 
 instance CryptoRoute UUID SubmissionId where
   cryptoIDRoute _ (CryptoID -> cID) = do
-    (_ :: SubmissionId) <- decrypt cID
-    
-    return $ SubmissionR cID
+    (smid :: SubmissionId) <- decrypt cID
+    cID' <- encrypt smid
+    (tid,ssh,csh,shn) <- runDB $ do
+      shid <- submissionSheet <$> get404 smid
+      Sheet{..}  <- get404 shid
+      Course{..} <- get404 sheetCourse
+      return (courseTerm, courseSchool, courseShorthand, sheetName)
+    return $ CSubmissionR tid ssh csh shn cID' SubShowR
 
+instance CryptoRoute (CI FilePath) SubmissionId where
+  cryptoIDRoute _ ciphertext
+    | Just cID <- fromPathPiece . Text.pack $ CI.original ciphertext = do
+        smid <- decrypt cID
+        (tid,ssh,csh,shn) <- runDB $ do
+          shid <- submissionSheet <$> get404 smid
+          Sheet{..}  <- get404 shid
+          Course{..} <- get404 sheetCourse
+          return (courseTerm, courseSchool, courseShorthand, sheetName)
+        return $ CSubmissionR tid ssh csh shn cID SubShowR
+    | otherwise = notFound
+
+instance CryptoRoute UUID UserId where
+  cryptoIDRoute _ (CryptoID -> cID) = do
+    (_ :: UserId) <- decrypt cID
+    return $ AdminUserR cID
 
 class Dispatch ciphertext (x :: [*]) where
   dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
@@ -58,5 +85,12 @@ getCryptoUUIDDispatchR :: UUID -> Handler ()
 getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302)
   where
     p :: Proxy '[ SubmissionId
+                , UserId
                 ]
     p = Proxy
+
+getCryptoFileNameDispatchR :: CI FilePath -> Handler ()
+getCryptoFileNameDispatchR path = dispatchID p path >>= maybe notFound (redirectWith found302)
+  where
+    p :: Proxy '[ SubmissionId ] 
+    p = Proxy

src/Handler/Home.hs

@@ -4,54 +4,223 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE IncoherentInstances #-} -- why is this needed? Instance for "display deadline" ought to be clear
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 
 module Handler.Home where
 
 import Import
 import Handler.Utils
 
--- import Data.Time
+import qualified Data.Map as Map
+
+import Data.Time hiding (formatTime)
 -- import qualified Data.Text as T
 -- import Yesod.Form.Bootstrap3
 
-import Web.PathPieces (showToPathPiece, readFromPathPiece)
+-- import Web.PathPieces (showToPathPiece, readFromPathPiece)
 
--- import Colonnade
+-- import Control.Lens
+-- import Colonnade hiding (fromMaybe, singleton)
 -- import Yesod.Colonnade
+import qualified Database.Esqueleto as E
+
+-- import Text.Shakespeare.Text
+
+import Development.GitRev
 
 -- import qualified Data.UUID.Cryptographic as UUID
 
--- BEGIN - Buttons needed only here
-data CreateButton = CreateMath | CreateInf  -- Dummy for Example
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
-instance PathPiece CreateButton where    -- for displaying the button only, not really for paths
-  toPathPiece   = showToPathPiece
-  fromPathPiece = readFromPathPiece
+-- CONSTANTS: TODO: make configurable elsewhere
+offSheetDeadlines :: NominalDiffTime
+offSheetDeadlines   = 15
+offCourseDeadlines :: NominalDiffTime
+offCourseDeadlines  = 15
+--offExamDeadlines :: NominalDiffTime
+--offExamDeadlines    = 15
 
-instance Button CreateButton where
-  label CreateMath = [whamlet|Ma<i>thema</i>tik|]
-  label CreateInf  = "Informatik"
 
-  cssClass CreateMath = BCInfo
-  cssClass CreateInf  = BCPrimary
--- END Button needed here
 
 getHomeR :: Handler Html
 getHomeR = do
-  (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton)
+  muid <- maybeAuthId
+  case muid of
+    Nothing   -> homeAnonymous
+    Just uid  -> homeUser uid
+
+
+homeAnonymous :: Handler Html
+homeAnonymous = do
+  cTime <- liftIO getCurrentTime
+  let tableData :: E.SqlExpr (Entity Course)
+                  -> E.SqlQuery (E.SqlExpr (Entity Course))
+      tableData course = do
+            E.where_ $ (E.not_ $ E.isNothing $ course E.^. CourseRegisterFrom) --   DO: do this with isAuthorized in dbtProj
+                E.&&.  (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime))
+                E.&&. ((E.isNothing $ course E.^. CourseRegisterTo)
+                        E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
+            return course
+
+      colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
+      colonnade = mconcat
+        [ -- dbRow
+          sortable (Just "term")   (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
+            textCell $ display $ courseTerm course
+        , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
+            textCell $ display $ courseSchool course
+        , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
+            let tid = courseTerm      course
+                ssh = courseSchool    course
+                csh = courseShorthand course
+            anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh)
+        , sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
+            cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
+        ]
+  ((), courseTable) <- dbTable def $ DBTable
+    { dbtSQLQuery  = tableData
+    , dbtColonnade = colonnade
+    , dbtProj      = return
+    , dbtSorting   = Map.fromList
+                      [ ( "term"
+                        , SortColumn $ \(course) -> course E.^. CourseTerm
+                        )
+                      , ( "school"
+                        , SortColumn $ \(course) -> course E.^. CourseSchool
+                        )
+                      , ( "course"
+                        , SortColumn $ \(course) -> course E.^. CourseShorthand
+                        )
+                      , ( "deadline"
+                        , SortColumn $ \(course) -> course E.^. CourseRegisterTo
+                        )
+                      ]
+    , dbtFilter    =  mempty {- [ ( "term"
+                        , FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if
+                            | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
+                            | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
+                        )
+                        ] -}
+    , dbtStyle     = def
+    , dbtIdent     = "upcomingdeadlines" :: Text
+    }
+  let features = $(widgetFile "featureList")
+  addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen!"
   defaultLayout $ do
-    setTitle "Willkommen zum UniworkY Test!"
+    $(widgetFile "dsgvDisclaimer")
     $(widgetFile "home")
 
+homeUser :: Key User -> Handler Html
+homeUser uid = do
+  cTime <- liftIO getCurrentTime
+  let fTime = addUTCTime (offSheetDeadlines * nominalDay) cTime
 
-postHomeR :: Handler Html
-postHomeR = do
-  ((btnResult,_), _) <- runFormPost $ buttonForm
-  case btnResult of
-    (FormSuccess CreateInf)  -> setMessage "Informatik-Knopf gedrückt"
-    (FormSuccess CreateMath) -> addMessage "warning" "Knopf Mathematik erkannt"
-    _other -> return ()
-  getHomeR
+      tableData :: -- E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant))
+                   --                         (E.SqlExpr (Entity Course           )))
+                   --                         (E.SqlExpr (Entity Sheet            ))
+                _ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
+                                , E.SqlExpr (E.Value SchoolId)
+                                , E.SqlExpr (E.Value CourseShorthand)
+                                , E.SqlExpr (E.Value SheetName)
+                                , E.SqlExpr (E.Value UTCTime)
+                                , E.SqlExpr (E.Value (Maybe SubmissionId)))
+      tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do
+        E.on $ submission E.?. SubmissionId    E.==. subuser      E.?. SubmissionUserSubmission
+            E.&&.       (E.just $ E.val uid)   E.==. subuser      E.?. SubmissionUserUser
+        E.on $ submission E.?. SubmissionSheet E.==. E.just(sheet E.^. SheetId)
+        E.on $ course     E.^. CourseId        E.==. sheet        E.^. SheetCourse
+        E.on $ course     E.^. CourseId        E.==. participant  E.^. CourseParticipantCourse
+        E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
+            E.&&. sheet E.^. SheetActiveTo E.>=. E.val cTime
+            E.&&. sheet E.^. SheetActiveTo E.<=. E.val fTime
+        -- E.limit nrSheetDeadlines -- arbitrary limits are not intuitive
+        return
+          ( course  E.^. CourseTerm
+          , course  E.^. CourseSchool
+          , course  E.^. CourseShorthand
+          , sheet   E.^. SheetName
+          , sheet   E.^. SheetActiveTo
+          , submission E.?. SubmissionId
+          )
+
+      colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term)
+                                             , E.Value SchoolId
+                                             , E.Value CourseShorthand
+                                             , E.Value SheetName
+                                             , E.Value UTCTime
+                                             , E.Value (Maybe SubmissionId)
+                                             ))
+                                      (DBCell (HandlerT UniWorX IO) ())
+      colonnade = mconcat
+        [ -- dbRow
+          -- TOOD: sortable (Just "term")   (textCell MsgTerm)   $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } ->
+          sortable (Just "term")   (i18nCell MsgTerm)   $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } ->
+            textCell $ display tid
+        , sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } ->
+            textCell $ display ssh
+        , sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } ->
+            anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh)
+        , sortable (Just "sheet")  (i18nCell MsgSheet)  $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } ->
+            anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget $ display shn)
+        , sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
+            cell $ formatTime SelFormatDateTime deadline >>= toWidget
+        , sortable (Just "done")   (i18nCell MsgDone)   $ \(DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) }) ->
+            case mbsid of
+              Nothing    -> mempty
+              (Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
+                                        tickmark
+        ]
+  let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
+  ((), sheetTable) <- dbTable validator $ DBTable
+    { dbtSQLQuery  = tableData
+    , dbtColonnade = colonnade
+    , dbtProj      = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
+                        -> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
+    , dbtSorting   = Map.fromList
+                      [ ( "term"
+                        , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm
+                        )
+                      , ( "school"
+                        , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseSchool
+                        )
+                      , ( "course"
+                        , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
+                        )
+                      , ( "sheet"
+                        , SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
+                        )
+                      , ( "deadline"
+                        , SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
+                        )
+                      , ( "done"
+                        , SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` _ `E.LeftOuterJoin` (subm `E.InnerJoin` _)) -> E.isNothing $ subm E.?. SubmissionId
+                        )
+                      ]
+    , dbtFilter    =  mempty {- [ ( "term"
+                        , FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if
+                            | Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
+                            | otherwise     -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
+                        )
+                        ] -}
+    , dbtStyle     = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
+    , dbtIdent     = "upcomingdeadlines" :: Text
+    }
+  addMessage Warning "Vorabversion! Die Implementierung von  Uni2work ist noch nicht abgeschlossen."
+  defaultLayout $ do
+    -- setTitle "Willkommen zum Uni2work Test!"
+    $(widgetFile "homeUser")
+    $(widgetFile "dsgvDisclaimer")
+
+
+getVersionR :: Handler TypedContent
+getVersionR = selectRep $ do
+    provideRep . defaultLayout $ do
+      let features = $(widgetFile "featureList")
+          gitInfo :: Text
+          gitInfo  = $gitDescribe <> " (" <> $gitCommitDate <> ")"
+      changeLog <- withUrlRenderer $(textFile "ChangeLog.md")
+      $(widgetFile "versionHistory")
+    provideRep $
+      return ($gitDescribe :: Text)

src/Handler/Profile.hs

@@ -1,30 +1,505 @@
 {-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE MultiWayIf, LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleInstances #-}
+
 module Handler.Profile where
 
 import Import
 
+import Handler.Utils
+import Handler.Utils.Table.Cells
+
+import Utils.Lens
+-- import Colonnade hiding (fromMaybe, singleton)
+-- import Yesod.Colonnade
+import Data.Monoid (Any(..))
+import qualified Data.Map as Map
+-- import qualified Data.Set as Set
 import qualified Database.Esqueleto as E
-import           Database.Esqueleto      ((^.))
+-- import           Database.Esqueleto      ((^.))
+
+
+
+data SettingsForm = SettingsForm
+      { stgMaxFavourties :: Int
+      , stgTheme         :: Theme
+      , stgDateTime      :: DateTimeFormat
+      , stgDate          :: DateTimeFormat
+      , stgTime          :: DateTimeFormat
+      , stgDownloadFiles :: Bool
+      }
+
+makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
+makeSettingForm template = identForm FIDsettings $ \html -> do
+    let themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
+    (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
+      <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
+            (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
+      <*> areq (selectField . return $ mkOptionList themeList)
+            (fslI  MsgTheme) { fsId = Just "theme-select" } (stgTheme         <$> template)
+      <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
+      <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
+      <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
+      <*> areq checkBoxField (fslI MsgDownloadFiles
+                               & setTooltip MsgDownloadFilesTip
+                             ) (stgDownloadFiles <$> template)
+      <*  submitButton
+    return (result, widget) -- no validation required here
+
+
 
 getProfileR :: Handler Html
 getProfileR = do
-    (uid, user) <- requireAuthPair
-    (admin_rights,lecturer_rights) <- runDB $ (,) <$>
+  (uid, User{..}) <- requireAuthPair
+  let settingsTemplate = Just $ SettingsForm
+        { stgMaxFavourties = userMaxFavourites
+        , stgTheme         = userTheme
+        , stgDateTime      = userDateTimeFormat
+        , stgDate          = userDateFormat
+        , stgTime          = userTimeFormat
+        , stgDownloadFiles = userDownloadFiles
+        }
+  ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate
+  case res of
+    (FormSuccess SettingsForm{..}) -> do
+        runDB $ do
+          update uid  [ UserMaxFavourites  =. stgMaxFavourties
+                      , UserTheme          =. stgTheme
+                      , UserDateTimeFormat =. stgDateTime
+                      , UserDateFormat     =. stgDate
+                      , UserTimeFormat     =. stgTime
+                      , UserDownloadFiles  =. stgDownloadFiles
+                      ]
+          when (stgMaxFavourties < userMaxFavourites) $ do
+            -- prune Favourites to user-defined size
+            oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid]
+                                      [ Desc CourseFavouriteTime
+                                      , OffsetBy $ stgMaxFavourties
+                                      ]
+            mapM_ delete oldFavs
+        addMessageI Info $ MsgSettingsUpdate
+        redirect ProfileR -- TODO: them change does not happen without redirect
+
+    (FormFailure msgs) -> forM_ msgs $ (addMessage Warning) . toHtml
+    _ -> return ()
+
+
+  (admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
             (E.select $ E.from $ \(adright `E.InnerJoin` school) -> do
-                E.where_ $ adright ^. UserAdminUser E.==. E.val uid
-                E.on $ adright ^. UserAdminSchool E.==. school ^. SchoolId
-                return (school ^. SchoolName)     
-            ) 
-            <*> 
+                E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
+                E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
+                return (school E.^. SchoolShorthand)
+            )
+            <*>
             (E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
-                E.where_ $ lecright ^. UserLecturerUser E.==. E.val uid
-                E.on $ lecright ^. UserLecturerSchool E.==. school ^. SchoolId
-                return (school ^. SchoolName)     
-            )        
-    defaultLayout $ do
-        setTitle . toHtml $ userIdent user <> "'s User page"
-        $(widgetFile "profile")
+                E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
+                E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
+                return (school E.^. SchoolShorthand)
+            )
+            <*>
+            (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
+                E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
+                return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
+            )
+            <*>
+            (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
+                          , studydegree E.^. StudyDegreeKey
+                          )
+                        , ( studyterms  E.^. StudyTermsName
+                          , studyterms  E.^. StudyTermsKey
+                          )
+                        , studyfeat   E.^. StudyFeaturesType
+                        , studyfeat   E.^. StudyFeaturesSemester)
+            )
+  let formText  = Just MsgSettings
+      actionUrl = ProfileR
+      settingsForm = $(widgetFile "formPageI18n")
+  defaultLayout $ do
+    setTitle . toHtml $ userIdent <> "'s User page"
+    $(widgetFile "profile")
+    $(widgetFile "dsgvDisclaimer")
+
+postProfileR :: Handler Html
+postProfileR = do
+  -- TODO
+  getProfileR
+
+postProfileDataR  :: Handler Html
+postProfileDataR = do
+  (uid, User{..}) <- requireAuthPair
+  ((btnResult,_), _) <- runFormPost $ buttonForm
+  case btnResult of
+    (FormSuccess BtnDelete) -> addMessage Warning "Delete-Knopf gedrückt"
+    (FormSuccess BtnAbort ) -> addMessage Warning "Knopf Abort erkannt"
+    _other -> addMessage Warning "KEIN Knopf erkannt"
+  addMessage Error "Löschen der Daten wurde noch nicht implementiert."
+  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| 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| Ü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}>
+          <div>Sind Sie sich absolut sicher, alle gespeicherten Daten zu löschen?
+              Abgegebene Hausaufgaben werden dadurch rückwirkend gelöscht,
+              wodurch eventuell ein Klausurbonus nicht mehr anerkannt wird.
+          <div>
+            <em>Gilt nicht in der Testphase von Uni2work:
+            Klausurnoten können Sie hiermit nicht löschen.
+            Da diese 5 Jahre bis nach Ihrer Exmatrikulation aufbewahrt werden müssen.
+          <div>^{btnWdgt}
+      |]
+  defaultLayout $ do
+    $(widgetFile "profileData")
+    $(widgetFile "dsgvDisclaimer")
+
+
+
+mkOwnedCoursesTable :: UserId -> Handler (Bool, Widget)
+-- Table listing all courses that the given user is a lecturer for
+mkOwnedCoursesTable =
+  let dbtIdent = "courseOwnership" :: Text
+      dbtStyle = def
+
+      withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a)
+               -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Lecturer)) -> a)
+      withType = id
+
+      dbtSQLQuery' uid = \(course `E.InnerJoin` lecturer) -> do
+          E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
+          E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
+          return ( course E.^. CourseTerm
+                 , course E.^. CourseSchool
+                 , course E.^. CourseShorthand
+                 )
+      dbtProj = \x -> return $ x & _dbrOutput %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
+
+      dbtColonnade = mconcat
+          [ dbRow
+          , sortable (Just "term") (i18nCell MsgTerm & cellAttrs .~ [("priority","0")]) $ do
+              tid <- view (_dbrOutput . _1)
+              return $ indicatorCell -- return True if one cell is produced here
+                `mappend` termCell tid
+          , sortable (Just "school") (i18nCell MsgCourseSchool) $
+              schoolCell <$> view (_dbrOutput . _1 . re _Just)
+                         <*> view (_dbrOutput . _2 )
+          , sortable (Just "course") (i18nCell MsgCourse) $
+              courseCellCL <$> view (_dbrOutput)
+          ]
+
+      validator = def & defaultSorting [("term",SortDesc),("school",SortAsc),("course",SortAsc)]
+      dbtSorting = Map.fromList
+          [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseShorthand)
+          , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm     )
+          , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool   )
+          ]
+      dbtFilter  = Map.fromList
+          [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
+          , ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )
+          , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
+          ]
+  in \uid -> let dbtSQLQuery = dbtSQLQuery' uid in (_1 %~ getAny) <$> (dbTableWidget validator DBTable{..})
+
+
+
+mkEnrolledCoursesTable :: UserId -> Handler Widget
+-- Table listing all courses that the given user is enrolled in
+mkEnrolledCoursesTable =
+  let withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
+               -> ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant)) -> a)
+      withType = id
+
+      validator = def & defaultSorting [("time",SortDesc)]
+
+  in \uid -> dbTableWidget' validator
+    DBTable
+      { dbtIdent     = "courseMembership" :: Text
+      , dbtSQLQuery  = \(course `E.InnerJoin` participant) -> do
+          E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
+          E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
+          return (course, participant E.^. CourseParticipantRegistration)
+      , dbtProj      = \x -> return $ x & _dbrOutput . _2 %~ E.unValue
+      , dbtColonnade = mconcat
+          [ dbRow
+          , sortable (Just "term") (i18nCell MsgTerm) $
+              termCell   <$> view (_dbrOutput . _1 . _entityVal . _courseTerm)
+          , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 . _entityVal) $
+              schoolCell <$> view ( _courseTerm . re _Just)
+                          <*> view ( _courseSchool )
+          , sortable (Just "course") (i18nCell MsgCourse) $
+              courseCell <$> view (_dbrOutput . _1 . _entityVal)
+          , sortable (Just "time") (i18nCell MsgRegistered) $ do
+              regTime <- view $ _dbrOutput . _2
+              return $ timeCell regTime
+            ]
+      , dbtSorting   = Map.fromList
+          [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseName  )
+          , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseTerm  )
+          , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _) -> crse E.^. CourseSchool)
+          , ( "time"  , SortColumn $ \(_ `E.InnerJoin` participant) -> participant E.^. CourseParticipantRegistration)
+          ]
+      , dbtFilter    = Map.fromList
+          [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseName  )
+          , ( "term"  , FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm  )
+          , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool)
+--          , ( "time"  , FilterColumn $ \(_ `E.InnerJoin` part :: CourseTableData) -> emptyOrIn $ part E.^. CourseParticipantRegistration )
+          ]
+      , dbtStyle     = def
+      }
+
+
+
+mkSubmissionTable :: UserId -> Handler Widget
+-- Table listing all submissions for the given user
+mkSubmissionTable =
+  let dbtIdent = "submissions" :: Text
+      dbtStyle = def
+
+      withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a)
+              ->  ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)`E.InnerJoin` E.SqlExpr (Entity SubmissionUser) )->a)
+      withType = id
+
+      dbtSQLQuery' uid = \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` subUser) -> do
+        E.on $ submission E.^. SubmissionId E.==. subUser E.^. SubmissionUserSubmission
+        E.on $ sheet  E.^. SheetId  E.==. submission E.^. SubmissionSheet
+        E.on $ course E.^. CourseId E.==. sheet      E.^. SheetCourse
+        E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
+        let crse =  ( course E.^. CourseTerm
+                    , course E.^. CourseSchool
+                    , course E.^. CourseShorthand
+                    )
+        let sht  =  ( sheet E.^. SheetName
+                    )
+        return (crse, sht, submission, lastSubEdit uid submission)
+
+      lastSubEdit uid submission = -- latest Edit-Time of this user for submission
+        E.sub_select . E.from $ \subEdit -> do
+          E.where_ $ subEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
+              E.&&.  subEdit E.^. SubmissionEditUser E.==. E.val uid
+          return . E.max_ $ subEdit E.^. SubmissionEditTime
+
+      dbtProj = \x -> return $ x
+        & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
+        & _dbrOutput . _2 %~ E.unValue
+        & _dbrOutput . _4 %~ E.unValue
+
+      dbtColonnade = mconcat
+        [ dbRow
+        , sortable (Just "term") (i18nCell MsgTerm) $
+            termCell    <$> view (_dbrOutput . _1 . _1)
+        , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
+            schoolCell  <$> view ( _1. re _Just)
+                        <*> view ( _2 )
+        , sortable (Just "course") (i18nCell MsgCourse) $
+            courseCellCL <$> view (_dbrOutput . _1)
+        , sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $
+            sheetCell <$> view _1
+                      <*> view _2
+        , sortable (toNothingS "submission") (i18nCell MsgSubmission) . magnify _dbrOutput $
+            submissionCell  <$> view  _1
+                            <*> view  _2
+                            <*> view (_3 . _entityKey)
+--           , sortable (Just "edit") (i18nCell MsgSubmissionEditUser) $ do
+--               regTime <- view $ _dbrOutput . _4
+--               return $ maybe mempty timeCell regTime
+        , sortable (Just "edit") (i18nCell MsgLastEditByUser) $
+            maybe mempty timeCell <$> view (_dbrOutput . _4)
+        ]
+
+      validator = def -- DUPLICATED CODE: Handler.Corrections
+        & restrictFilter  (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
+        & restrictSorting (\name _ -> name /= "corrector")
+        & defaultSorting [("edit",SortDesc)]
+      dbtSorting' uid = Map.fromList
+        [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseShorthand)
+        , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseTerm     )
+        , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> crse E.^. CourseSchool   )
+        , ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet E.^. SheetName    )
+        , ( "edit"  , SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` submission `E.InnerJoin` _) -> lastSubEdit uid submission )
+        ]
+      dbtFilter = Map.fromList
+        [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
+        , ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )
+        , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
+        ]
+  in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
+                  dbtSorting  = dbtSorting'  uid
+              in  dbTableWidget' validator $ DBTable {..}
+--   in do dbtSQLQuery <- dbtSQLQuery'
+--         dbtSorting  <- dbtSorting'
+--         return $ dbTableWidget' validator $ DBTable {..}
+
+
+
+mkSubmissionGroupTable :: UserId -> Handler Widget
+-- Table listing all submissions for the given user
+mkSubmissionGroupTable =
+  let dbtIdent = "subGroups" :: Text
+      dbtStyle = def
+      withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
+              ->  ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroup) `E.InnerJoin` E.SqlExpr (Entity SubmissionGroupUser) )->a)
+      withType = id
+
+      dbtSQLQuery' uid = \(course `E.InnerJoin` sgroup `E.InnerJoin` sguser) -> do
+        E.on $ sguser E.^. SubmissionGroupUserSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
+        E.on $ sgroup E.^. SubmissionGroupCourse              E.==. course E.^. CourseId
+        E.where_ $ sguser E.^. SubmissionGroupUserUser E.==. E.val uid
+        let crse =  ( course E.^. CourseTerm
+                    , course E.^. CourseSchool
+                    , course E.^. CourseShorthand
+                    )
+        return (crse, sgroup, lastSGEdit sgroup)
+
+      lastSGEdit sgroup = -- latest Edit-Time of this Submission Group by a user
+        E.sub_select . E.from $ \(user `E.InnerJoin` sgEdit) -> do
+          E.on $ user E.^. UserId E.==. sgEdit E.^. SubmissionGroupEditUser
+          E.where_ $ sgEdit E.^. SubmissionGroupEditSubmissionGroup E.==. sgroup E.^. SubmissionGroupId
+          return . E.max_ $ sgEdit E.^. SubmissionGroupEditTime
+
+      dbtProj = \x -> return $ x
+        & _dbrOutput . _1 %~ (\(E.Value tid, E.Value ssh, E.Value csh) -> (tid,ssh,csh))
+        & _dbrOutput . _3 %~ E.unValue
+
+      dbtColonnade = mconcat
+        [ dbRow
+        , sortable (Just "term") (i18nCell MsgTerm) $
+            termCell    <$> view (_dbrOutput . _1 . _1)
+        , sortable (Just "school") (i18nCell MsgCourseSchool) . magnify (_dbrOutput . _1 ) $
+            schoolCell  <$> view ( _1. re _Just)
+                        <*> view ( _2 )
+        , sortable (Just "course") (i18nCell MsgCourse) $
+            courseCellCL <$> view (_dbrOutput . _1)
+        , sortable (Just "submissiongroup") (i18nCell MsgSubmissionGroupName) . magnify (_dbrOutput . _2 . _entityVal) $
+            maybe mempty textCell <$> view _submissionGroupName
+        , sortable (Just "edit") (i18nCell MsgLastEdit) $
+            maybe mempty timeCell <$> view (_dbrOutput . _3)
+        ]
+
+      validator = def -- DUPLICATED CODE: Handler.Corrections
+        & restrictFilter  (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
+        & restrictSorting (\name _ -> name /= "corrector")
+        & defaultSorting [("edit",SortDesc)]
+      dbtSorting = Map.fromList
+        [ ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseShorthand)
+        , ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseTerm     )
+        , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse E.^. CourseSchool   )
+        , ( "submissiongroup" , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _) -> sgroup E.^. SubmissionGroupName )
+        , ( "edit"  , SortColumn $ withType $ \(_ `E.InnerJoin` sgroup `E.InnerJoin` _ ) -> lastSGEdit sgroup)
+        ]
+      dbtFilter = Map.fromList
+        [ ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
+        , ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )
+        , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
+        ]
+  in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
+              in  dbTableWidget' validator $ DBTable {..}
+
+
+
+mkCorrectionsTable :: UserId -> Handler Widget
+-- Table listing sum of corrections made by the given user per sheet
+mkCorrectionsTable =
+  let dbtIdent = "corrections" :: Text
+      dbtStyle = def
+-- TODO Continue here
+      withType :: ((E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity SheetCorrector))->a)
+              ->  ((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
+        E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
+        let crse =  ( course E.^. CourseTerm
+                    , course E.^. CourseSchool
+                    , course E.^. CourseShorthand
+                    )
+        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))
+        & _dbrOutput . _2 %~ E.unValue
+
+      dbtColonnade = mconcat
+        [ dbRow
+        , sortable (Just "term") (i18nCell MsgTerm) $
+            termCellCL   <$> view (_dbrOutput . _1)
+        , sortable (Just "school") (i18nCell MsgCourseSchool) $
+            schoolCellCL <$> view (_dbrOutput . _1)
+        , sortable (Just "course") (i18nCell MsgCourse) $
+            courseCellCL <$> view (_dbrOutput . _1)
+        , sortable (Just "sheet") (i18nCell MsgSheet) . magnify _dbrOutput $
+            sheetCell    <$> view _1 <*> view _2
+        , sortable (Just "cstate") (i18nCell MsgCorState) $
+            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)]
+      dbtSorting = Map.fromList
+        [ ( "term"  , SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse  E.^. CourseTerm     )
+        , ( "school", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse  E.^. CourseSchool   )
+        , ( "course", SortColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _ ) -> crse  E.^. CourseShorthand)
+        , ( "sheet" , SortColumn $ withType $ \(_ `E.InnerJoin` sheet `E.InnerJoin` _) -> sheet E.^. SheetName      )
+        , ( "cstate", SortColumn $ withType $ \(_ `E.InnerJoin` _ `E.InnerJoin` cs)    -> cs    E.^. SheetCorrectorState )
+        ]
+      dbtFilter = Map.fromList
+        [ ( "term",   FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseTerm     )
+        , ( "school", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseSchool   )
+        , ( "course", FilterColumn $ withType $ \(crse `E.InnerJoin` _ `E.InnerJoin` _) -> emptyOrIn $ crse E.^. CourseShorthand)
+        ]
+  in \uid ->  let dbtSQLQuery = dbtSQLQuery' uid
+              in  dbTableWidget' validator $ DBTable {..}
+

src/Handler/School.hs

@@ -0,0 +1,53 @@
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Handler.School where
+
+import Import
+
+-- import Control.Lens
+-- import Utils.Lens
+-- import Utils.TH
+-- import Handler.Utils
+-- import Handler.Utils.Table.Cells
+--
+-- -- import Data.Time
+-- import qualified Data.Text as T
+-- import Data.Function ((&))
+-- -- import Yesod.Form.Bootstrap3
+--
+-- import qualified Data.Set as Set
+-- import qualified Data.Map as Map
+--
+-- import Colonnade hiding (fromMaybe,bool)
+--
+-- import qualified Database.Esqueleto as E
+--
+-- import qualified Data.UUID.Cryptographic as UUID
+
+
+getSchoolListR :: Handler Html
+getSchoolListR = do
+  -- muid <- maybeAuthId
+  defaultLayout $ do
+    [whamlet|TODO: Liste aller Institute |] -- TODO
+
+
+getSchoolShowR :: SchoolId -> Handler Html
+getSchoolShowR ssh = do -- TODO
+  -- muid <- maybeAuthId
+  defaultLayout $ do
+    [whamlet|TODO: Informationen zu einem Institut |] -- TODO
+

src/Handler/Sheet.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
@@ -7,33 +9,58 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE MultiWayIf, LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
 
 module Handler.Sheet where
 
-import Import 
+import Import
 import System.FilePath (takeFileName)
 
 import Handler.Utils
-import Handler.Utils.Zip
+-- import Handler.Utils.Zip
+import Handler.Utils.Table.Cells
 
 -- import Data.Time
-import qualified Data.Text as T
+-- import qualified Data.Text as T
 -- import Data.Function ((&))
+--
+-- import Colonnade hiding (fromMaybe, singleton, bool)
+import qualified Yesod.Colonnade as Yesod
+import Text.Blaze (text)
 -- 
-import Colonnade hiding (fromMaybe, singleton)
-import Yesod.Colonnade
--- 
-import qualified Data.UUID.Cryptographic as UUID
+-- import qualified Data.UUID.Cryptographic as UUID
 import qualified Data.Conduit.List as C
 
+-- import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
 import qualified Database.Esqueleto as E
-import qualified Database.Esqueleto.Internal.Sql as E
+-- import qualified Database.Esqueleto.Internal.Sql as E
 
 import Control.Monad.Writer (MonadWriter(..), execWriterT)
+-- import Control.Monad.Trans.RWS.Lazy (RWST, local)
+
+-- import qualified Text.Email.Validate as Email
+
+-- import qualified Data.List as List
 
 import Network.Mime
 
+import Data.Set (Set)
 import qualified Data.Set as Set
+import qualified Data.Map as Map
+
+import Data.Map (Map, (!), (!?))
+import qualified Data.Map as Map
+
+import Data.Monoid (Sum(..))
+
+import Control.Lens
+-- import Utils.Lens
 
 
 instance Eq (Unique Sheet) where
@@ -42,12 +69,12 @@ instance Eq (Unique Sheet) where
 
 {-
   * Implement Handlers
-  * Implement Breadcrumbs in Foundation 
+  * Implement Breadcrumbs in Foundation
   * Implement Access in Foundation
 -}
 
 data SheetForm = SheetForm
-      { sfName         :: Text
+      { sfName         :: SheetName
       , sfDescription  :: Maybe Html
       , sfType         :: SheetType
       , sfGrouping     :: SheetGroup
@@ -55,219 +82,313 @@ data SheetForm = SheetForm
       , sfVisibleFrom  :: Maybe UTCTime
       , sfActiveFrom   :: UTCTime
       , sfActiveTo     :: UTCTime
+      , sfUploadMode   :: UploadMode
       , sfSheetF       :: Maybe (Source Handler (Either FileId File))
       , sfHintFrom     :: Maybe UTCTime
-      , sfHintF        :: Maybe FileInfo
+      , sfHintF        :: Maybe (Source Handler (Either FileId File))
       , sfSolutionFrom :: Maybe UTCTime
-      , sfSolutionF    :: Maybe FileInfo
+      , sfSolutionF    :: Maybe (Source Handler (Either FileId File))
+      , sfMarkingF     :: Maybe (Source Handler (Either FileId File))
       -- Keine SheetId im Formular!
       }
 
+getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileId)
+getFtIdMap sId = do
+  allfIds <- E.select . E.from $ \(sheetFile `E.InnerJoin` file) -> do
+      E.on     $ sheetFile E.^. SheetFileFile  E.==. file E.^. FileId
+      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
+      return    (sheetFile E.^. SheetFileType, file E.^. FileId)
+  return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds]
 
 makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
 makeSheetForm msId template = identForm FIDsheet $ \html -> do
-    let oldFileIds fType
-          | Just sId <- msId = fmap setFromList . fmap (map E.unValue) . runDB . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
-              E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
-              E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val sId
-                   E.&&. sheetFile E.^. SheetFileType    E.==. E.val fType
-              return (file E.^. FileId)
-          | otherwise = return Set.empty
-  
+    oldFileIds <- (return.) <$> case msId of
+      Nothing    -> return $ partitionFileType mempty
+      (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
+    mr <- getMsgRenderer
+    ctime <- liftIO $ getCurrentTime
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
-      <$> areq textField      (fsb "Name")                     (sfName <$> template)
-      <*> aopt htmlField      (fsb "Hinweise für Teilnehmer")  (sfDescription <$> template)
-      <*> sheetTypeAFormReq   (fsb "Bewertung")                (sfType <$> template)
-      <*> sheetGroupAFormReq  (fsb "Abgabegruppengröße") (sfGrouping <$> template)
-      <*> aopt htmlField      (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
-      <*> aopt utcTimeField   (fsb "Sichtbar ab") (sfVisibleFrom  <$> template)
-      <*> areq utcTimeField   (fsb "Abgabe ab")   (sfActiveFrom   <$> template)
-      <*> areq utcTimeField   (fsb "Abgabefrist") (sfActiveTo     <$> template)
-      <*> aopt (multiFileField $ oldFileIds SheetExercise) (fsb "Aufgabenstellung") (sfSheetF <$> template)
-      <*> aopt utcTimeField   (fsb "Hinweis ab")  (sfHintFrom     <$> template)
-      <*> fileAFormOpt        (fsb "Hinweis")
-      <*> aopt utcTimeField   (fsb "Lösung ab")   (sfSolutionFrom <$> template)
-      <*> fileAFormOpt        (fsb "Lösung")
+      <$> areq ciField        (fslI MsgSheetName)         (sfName        <$> template)
+      <*> aopt htmlField      (fslI MsgSheetDescription)  (sfDescription <$> template)
+      <*> sheetTypeAFormReq   (fslI MsgSheetType)         (sfType        <$> template)
+      <*> sheetGroupAFormReq  (fslI MsgSheetGroup)        (sfGrouping    <$> template)
+      <*> aopt htmlField      (fslI MsgSheetMarking)      (sfMarkingText <$> template)
+      <*> aopt utcTimeField   (fslI MsgSheetVisibleFrom
+            & setTooltip MsgSheetVisibleFromTip)
+                                                              ((sfVisibleFrom  <$> template) <|> pure (Just ctime))
+      <*> areq utcTimeField   (fslI MsgSheetActiveFrom
+            & 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)                 (sfHintFrom     <$> template)
+      <*> aopt (multiFileField $ oldFileIds SheetHint)     (fslI MsgSheetHint)      (sfHintF <$> template)
+      <*> aopt utcTimeField   (fslpI MsgSheetSolutionFrom  "Datum, sonst nur für Korrektoren"
+            & setTooltip MsgSheetSolutionFromTip)
+                                                              (sfSolutionFrom <$> template)
+      <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
+      <*> aopt (multiFileField $ oldFileIds SheetMarking)  (fslI MsgSheetMarking
+            & setTooltip MsgSheetMarkingTip)   (sfMarkingF <$> template)
       <*  submitButton
     return $ case result of
       FormSuccess sheetResult
-        | errorMsgs <- validateSheet sheetResult
+        | errorMsgs <- validateSheet mr sheetResult
         , not $ null errorMsgs ->
-            (FormFailure errorMsgs,
-                  [whamlet|
-                    <div class="alert alert-danger">
-                      <h4> Fehler:
-                      <ul>
-                        $forall errmsg <- errorMsgs
-                          <li> #{errmsg}
-                    ^{widget}
-                  |]
-                )
+            (FormFailure errorMsgs, widget)
       _ -> (result, widget)
   where
-    validateSheet :: SheetForm -> [Text]
-    validateSheet (SheetForm{..}) =
+    validateSheet :: MsgRenderer -> SheetForm -> [Text]
+    validateSheet (MsgRenderer {..}) (SheetForm{..}) =
       [ msg | (False, msg) <-
-        [ ( maybe True (sfActiveFrom >=) sfVisibleFrom
-          , "Sichtbarkeit muss vor Beginn der Abgabefrist liegen."
-          )
-        , ( sfActiveTo >= sfActiveFrom
-          , "Ende der Abgabefrist muss nach deren Beginn liegen."
-          )
-        -- TODO: continue validation here!!!
+        [ (      sfVisibleFrom  <=       Just sfActiveFrom  , render MsgSheetErrVisibility)
+        , (      sfActiveFrom   <=            sfActiveTo    , render MsgSheetErrDeadlineEarly)
+        , ( NTop sfHintFrom     >= NTop (Just sfActiveFrom) , render MsgSheetErrHintEarly)
+        , ( NTop sfSolutionFrom >= NTop (Just sfActiveTo)   , render MsgSheetErrSolutionEarly)
       ] ]
 
-
-fetchSheetAux ::  ( BaseBackend backend ~ SqlBackend
-                  , E.SqlSelect b a
-                  , Typeable a, MonadHandler m, IsPersistBackend backend
-                  , PersistQueryRead backend, PersistUniqueRead backend
-                  )
-  =>  (E.SqlExpr (Entity Sheet) -> b)
-      -> Key Term -> Text -> Text -> ReaderT backend m a
-fetchSheetAux prj tid csh shn =
-    let cachId = encodeUtf8 $ tshow (tid,csh,shn)
-    in  cachedBy cachId $ do
-    -- Mit Yesod:
-    -- cid <- getKeyBy404 $ CourseTermShort tid csh
-    -- getBy404 $ CourseSheet cid shn
-    -- Mit Esqueleto:
-        sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
-            E.on     $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
-            E.where_ $ course E.^. CourseTermId    E.==. E.val tid
-                E.&&. course E.^. CourseShorthand E.==. E.val csh
-                E.&&. sheet  E.^. SheetName       E.==. E.val shn
-            return $ prj sheet
-        case sheetList of
-          [sheet] -> return sheet
-          _other  -> notFound
-
-fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
-fetchSheet = fetchSheetAux id
-
-fetchSheetId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet)
-fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn
-
--- List Sheets
-getSheetListCID :: CourseId -> Handler Html
-getSheetListCID cid = getSheetList =<<
-  (Entity cid) <$> (runDB $ get404 cid)
-
-getSheetListR :: TermId -> Text -> Handler Html
-getSheetListR tid csh = getSheetList =<<
-  (runDB $ getBy404 $ CourseTermShort tid csh)
-
-getSheetList :: Entity Course -> Handler Html
-getSheetList courseEnt = do
-  -- mbAid <- maybeAuthId
-  let cid    = entityKey courseEnt
-  let course = entityVal courseEnt
-  let csh    = courseShorthand course
-  let tid    = courseTermId course
-  sheets <- runDB $ do
-    rawSheets <- selectList [SheetCourseId ==. cid] [Desc SheetActiveFrom]
-    forM rawSheets $ \(Entity sid sheet) -> do
-        let sheetsub = [SubmissionSheetId ==. sid]
-        submissions <- count sheetsub
-        rated       <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
-        return (sid, sheet, (submissions, rated))
-  let colBase = mconcat
-        [ headed "Blatt"       $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CourseR tid csh $ SheetR $ SheetShowR $ sheetName sheet
-        , headed "Abgabe ab"   $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
-        , headed "Abgabe bis"  $ toWgt . formatTimeGerWD . sheetActiveTo   . snd3
-        , headed "Bewertung"   $ toWgt . show . sheetType . snd3
-        ]
-  let colAdmin = mconcat -- only show edit button for allowed course assistants
-        [ headed "Korrigiert"  $ toWgt . snd . trd3
-        , headed "Eingereicht" $ toWgt . fst . trd3
-        , headed ""            $ \s -> linkButton "Edit"   BCLink $ CourseR tid csh $ SheetR $ SheetEditR $ sheetName $ snd3 s
-        , headed ""            $ \s -> linkButton "Delete" BCLink $ CourseR tid csh $ SheetR $ SheetDelR  $ sheetName $ snd3 s
-        ]
-  showAdmin <- case sheets of
-    ((_,firstSheet,_):_) -> do
-      setUltDestCurrent
-      (Authorized ==) <$> isAuthorized (CourseR tid csh $ SheetR $ SheetEditR $ sheetName firstSheet) False
-    _otherwise   -> return False
-  let colSheets = if showAdmin
-        then colBase `mappend` colAdmin
-        else colBase
+getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+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
+      E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
+      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, _) -> maybe mempty timeCell mEditTime
+      , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
+          $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveFrom
+      , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
+          $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo
+      , sortable Nothing (i18nCell MsgSheetType)
+          $ \(Entity _ Sheet{..}, _, _) -> textCell $ display sheetType
+      , sortable Nothing (i18nCell MsgSubmission)
+          $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
+              Nothing -> mempty
+              (Just (Entity sid Submission{..})) ->
+                let mkCid = encrypt sid -- TODO: executed twice
+                    mkRoute = do
+                      cid' <- mkCid
+                      return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
+                in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
+      , sortable (Just "rating") (i18nCell MsgRating)
+          $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
+              Nothing -> mempty
+              (Just (Entity sid Submission{..})) ->
+                let mkCid = encrypt sid
+                    mkRoute = do
+                      cid <- mkCid
+                      return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
+                    protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating")
+                in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints)))
+      , sortable Nothing -- (Just "percent")
+                        (i18nCell MsgRatingPercent)
+          $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of
+              (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
+                case sType of
+                  NotGraded -> mempty
+                  _ | maxPoints sType > 0 ->
+                        let percent = sPoints / maxPoints sType
+                        in textCell $ textPercent $ realToFrac percent
+                  _other -> mempty
+              _other -> mempty
+      ]
+    psValidator = def
+      & defaultSorting [("submission-since", SortAsc)]
+  (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable
+    { dbtSQLQuery  = sheetData
+    , dbtColonnade = sheetCol
+    , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) }
+                   -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False)
+    , dbtSorting   = Map.fromList
+      [ ( "name"
+        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
+        )
+      , ( "last-edit"
+        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
+        )
+      , ( "submission-since"
+        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
+        )
+      , ( "submission-until"
+        , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
+        )
+      , ( "rating"
+        , SortColumn $ \(_ `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) -> submission E.?. SubmissionRatingPoints
+        )
+--    GitLab Issue $143: HOW TO SORT?
+--       , ( "percent"
+--         , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
+--             case sheetType of -- no Haskell inside Esqueleto, right?
+--             (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
+--         )
+      ]
+    , dbtFilter    = Map.fromList
+      []
+    , dbtStyle     = def
+    , dbtIdent     = "sheets" :: Text
+    }
   defaultLayout $ do
-    setTitle $ toHtml $ T.append "Übungsblätter " csh
-    if null sheets
-      then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
-      else encodeWidgetTable tableDefault colSheets sheets
+    $(widgetFile "sheetList")
+    $(widgetFile "widgets/sheetTypeSummary")
 
 -- Show single sheet
-getSheetShowR :: TermId -> Text -> Text -> Handler Html
-getSheetShowR tid csh shn = do
-  entSheet <- runDB $ fetchSheet tid csh shn
+getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
+getSShowR tid ssh csh shn = do
+  entSheet <- runDB $ fetchSheet tid ssh csh shn
   let sheet = entityVal entSheet
       sid   = entityKey entSheet
-  --
-  fileNameTypes <- runDB $ E.select $ E.from $
-    \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-      -- Restrict to consistent rows that correspond to each other
-      E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFileId)
-      E.on (sheetFile E.^. SheetFileSheetId E.==. sheet     E.^. SheetId)
-      -- filter to requested file
-      E.where_ (sheet     E.^. SheetId      E.==. E.val sid )
-      -- return desired columns
-      return $ (file E.^. FileTitle, sheetFile E.^. SheetFileType)
-  let fileLinks = map (\(E.Value fName, E.Value fType) -> CSheetR tid csh (SheetFileR shn fType fName)) fileNameTypes
+  -- without Colonnade
+--   fileNameTypes <- runDB $ E.select $ E.from $
+--     \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
+--       -- Restrict to consistent rows that correspond to each other
+--       E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFile)
+--       E.on (sheetFile E.^. SheetFileSheet E.==. sheet     E.^. SheetId)
+--       -- filter to requested file
+--       E.where_ (sheet     E.^. SheetId      E.==. E.val sid )
+--       -- return desired columns
+--       return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
+--   let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes
+  -- with Colonnade
 
+  let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do
+        -- Restrict to consistent rows that correspond to each other
+        E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFile)
+        E.on (sheetFile E.^. SheetFileSheet E.==. sheet     E.^. SheetId)
+        -- filter to requested file
+        E.where_ $  sheet     E.^. SheetId      E.==. E.val sid
+              E.&&. E.not_ (E.isNothing $ file E.^. FileContent)
+        -- return desired columns
+        return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
+  let colonnadeFiles = widgetColonnade $ mconcat
+        [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype
+        , sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid ssh csh shn (SFileR fType fName))
+                                                           (\(E.Value fName,_,_) -> str2widget fName)
+        , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
+        ]
+  let psValidator = def
+        & defaultSorting [("type", SortAsc), ("path", SortAsc)]
+  ((), fileTable) <- dbTable psValidator $ DBTable
+    { dbtSQLQuery = fileData
+    , dbtColonnade = colonnadeFiles
+    , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
+                   -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
+    , dbtStyle = def
+    , dbtFilter = Map.empty
+    , dbtIdent = "files" :: Text
+    , dbtSorting = [ ( "type"
+                     , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> sheetFile E.^. SheetFileType
+                     )
+                   , ( "path"
+                     , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
+                     )
+                   , ( "time"
+                     , SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileModified
+                     )
+                   ]
+    }
+  (hasHints, hasSolution) <- runDB $ do
+    hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
+    hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ]
+    return (hasHints, hasSolution)
+  cTime <- Just <$> liftIO getCurrentTime
+  visibleFrom <-    traverse (formatTime SelFormatDateTime) $ sheetVisibleFrom  sheet
+  when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI Warning $
+    maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
   defaultLayout $ do
-    setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
+    setTitleI $ MsgSheetTitle tid ssh csh shn
+    sheetFrom    <-           formatTime SelFormatDateTime  $ sheetActiveFrom   sheet
+    sheetTo      <-           formatTime SelFormatDateTime  $ sheetActiveTo     sheet
+    hintsFrom    <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom     sheet
+    solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
     $(widgetFile "sheetShow")
-    [whamlet| Under Construction !!! |] -- TODO
 
-
-getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
-getSheetFileR tid csh shn typ title = do
-  content <- runDB $ E.select $ E.from $
+getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
+getSFileR tid ssh csh shn typ title = do
+  results <- runDB $ E.select $ E.from $
     \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
       -- Restrict to consistent rows that correspond to each other
-      E.on (file      E.^. FileId           E.==. sheetFile E.^. SheetFileFileId)
-      E.on (sheetFile E.^. SheetFileSheetId E.==. sheet     E.^. SheetId)
-      E.on (sheet     E.^. SheetCourseId    E.==. course    E.^. CourseId)
+      E.on (file      E.^. FileId         E.==. sheetFile E.^. SheetFileFile)
+      E.on (sheetFile E.^. SheetFileSheet E.==. sheet     E.^. SheetId)
+      E.on (sheet     E.^. SheetCourse    E.==. course    E.^. CourseId)
       -- filter to requested file
       E.where_ ((file      E.^. FileTitle       E.==. E.val title)
         E.&&.   (sheetFile E.^. SheetFileType   E.==. E.val typ  )
         E.&&.   (sheet     E.^. SheetName       E.==. E.val shn  )
         E.&&.   (course    E.^. CourseShorthand E.==. E.val csh  )
-        E.&&.   (course    E.^. CourseTermId    E.==. E.val tid  )
+        E.&&.   (course    E.^. CourseSchool    E.==. E.val ssh  )
+        E.&&.   (course    E.^. CourseTerm      E.==. E.val tid  )
         )
       -- return desired columns
-      return $ file E.^. FileContent
+      return $ (file E.^. FileTitle, file E.^. FileContent)
   let mimeType = defaultMimeLookup $ pack title
-  case content of
-    [E.Value (Just nochmalContent)] -> do
-      addHeader "Content-Disposition" "attachment"
-      respond mimeType nochmalContent
-    []     -> notFound
-    _other -> error "Multiple matching files found."
+  case results of
+    [(E.Value fileTitle, E.Value fileContent)]
+      | Just fileContent' <- fileContent -> do
+          whenM downloadFiles $
+            addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
+          return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
+      | otherwise -> sendResponseStatus noContent204 ()
+    [] -> notFound
+    other -> do
+      $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
+      error "Multiple matching files found."
 
-
-getSheetNewR :: TermId -> Text -> Handler Html
-getSheetNewR tid csh = do
-  let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
+getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getSheetNewR tid ssh csh = do
+  lastSheets <- runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+      E.on     $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+      E.where_ $ course E.^. CourseTerm      E.==. E.val tid
+          E.&&.  course E.^. CourseSchool    E.==. E.val ssh
+          E.&&.  course E.^. CourseShorthand E.==. E.val csh
+      E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
+      E.limit 1
+      return sheet
+  let template = case lastSheets of
+        ((Entity {entityVal=Sheet{..}}):_)  -> Just $ SheetForm
+          { sfName         = stepTextCounterCI sheetName
+          , sfDescription  = sheetDescription
+          , sfType         = sheetType
+          , sfGrouping     = sheetGrouping
+          , sfMarkingText  = sheetMarkingText
+          , sfVisibleFrom  = addOneWeek <$> sheetVisibleFrom
+          , sfActiveFrom   = addOneWeek     sheetActiveFrom
+          , sfActiveTo     = addOneWeek     sheetActiveTo
+          , sfUploadMode   = sheetUploadMode
+          , sfSheetF       = Nothing
+          , sfHintFrom     = addOneWeek <$> sheetHintFrom
+          , sfHintF        = Nothing
+          , sfSolutionFrom = addOneWeek <$> sheetSolutionFrom
+          , sfSolutionF    = Nothing
+          , sfMarkingF     = Nothing
+          }
+        _other -> Nothing
   let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
         insertUnique $ newSheet
-  handleSheetEdit tid csh Nothing template action
+  handleSheetEdit tid ssh csh Nothing template action
 
-postSheetNewR :: TermId -> Text -> Handler Html
+postSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 postSheetNewR = getSheetNewR
 
 
-getSheetEditR :: TermId -> Text -> Text -> Handler Html
-getSheetEditR tid csh shn = do
+getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
+getSEditR tid ssh csh shn = do
   (sheetEnt, sheetFileIds) <- runDB $ do
-    ent <- fetchSheet tid csh shn
-    fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
-      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
-      E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val (entityKey ent)
-           E.&&. sheetFile E.^. SheetFileType    E.==. E.val SheetExercise
-      return (file E.^. FileId)
-    return (ent, fIds)
+    ent <- fetchSheet tid ssh csh shn
+    fti <- getFtIdMap $ entityKey ent
+    return (ent, fti)
   let sid = entityKey sheetEnt
   let oldSheet@(Sheet {..}) = entityVal sheetEnt
   let template = Just $ SheetForm
@@ -279,25 +400,26 @@ getSheetEditR tid csh shn = do
         , sfVisibleFrom  = sheetVisibleFrom
         , sfActiveFrom   = sheetActiveFrom
         , sfActiveTo     = sheetActiveTo
-        , sfSheetF       = Just . yieldMany . map Left $ Set.toList sheetFileIds
+        , sfUploadMode   = sheetUploadMode
+        , sfSheetF       = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
         , sfHintFrom     = sheetHintFrom
-        , sfHintF        = Nothing -- TODO
+        , sfHintF        = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
         , sfSolutionFrom = sheetSolutionFrom
-        , sfSolutionF    = Nothing -- TODO
+        , sfSolutionF    = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution
+        , sfMarkingF     = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
         }
   let action newSheet = do
         replaceRes <- myReplaceUnique sid $ newSheet
         case replaceRes of
           Nothing     -> return $ Just sid
           (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
-  handleSheetEdit tid csh (Just sid) template action
+  handleSheetEdit tid ssh csh (Just sid) template action
 
-postSheetEditR :: TermId -> Text -> Text -> Handler Html
-postSheetEditR = getSheetEditR
+postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
+postSEditR = getSEditR
 
-handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
-handleSheetEdit tid csh msId template dbAction = do
-  let tident = unTermKey tid
+handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
+handleSheetEdit tid ssh csh msId template dbAction = do
   let mbshn  = sfName <$> template
   aid  <- requireAuthId
   ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template
@@ -305,9 +427,9 @@ handleSheetEdit tid csh msId template dbAction = do
     (FormSuccess SheetForm{..}) -> do
       saveOkay <- runDB $ do
         actTime <- liftIO getCurrentTime
-        cid <- getKeyBy404 $ CourseTermShort tid csh
+        cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
         let newSheet = Sheet
-              { sheetCourseId     = cid
+              { sheetCourse       = cid
               , sheetName         = sfName
               , sheetDescription  = sfDescription
               , sheetType         = sfType
@@ -318,55 +440,62 @@ handleSheetEdit tid csh msId template dbAction = do
               , sheetActiveTo     = sfActiveTo
               , sheetHintFrom     = sfHintFrom
               , sheetSolutionFrom = sfSolutionFrom
+              , sheetUploadMode   = sfUploadMode
               }
         mbsid <- dbAction newSheet
         case mbsid of
-          Nothing    -> False <$ addMessageI "danger" (MsgSheetNameDup tident 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 sfHintF     $ insertSheetFile' sid SheetHint
+            whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution
+            whenIsJust sfMarkingF  $ insertSheetFile' sid SheetMarking
             insert_ $ SheetEdit aid actTime sid
-            addMessageI "info" $ MsgSheetEditOk tident csh sfName
+            addMessageI Info $ 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 $ CSheetR tid csh $ SheetShowR sfName -- redirect must happen outside of runDB
-    (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
-    _ -> return ()
-  let pageTitle = maybe (MsgSheetTitleNew tident csh)
-                        (MsgSheetTitle    tident csh) mbshn
-  let formTitle = pageTitle
+      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 Error) . toHtml
+    _ -> 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
   let formText  = Nothing :: Maybe UniWorXMessage
-  actionUrl <- fromMaybe (CSheetR tid csh SheetNewR) <$> getCurrentRoute
+  actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute
   defaultLayout $ do
     setTitleI pageTitle
     $(widgetFile "formPageI18n")
 
 
 
-getSheetDelR :: TermId -> Text -> Text -> Handler Html
-getSheetDelR tid csh shn = do
-  let tident = unTermKey tid
+getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
+getSDelR tid ssh csh shn = do
   ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
   case result of
-    (FormSuccess BtnAbort)  -> redirectUltDest $ CSheetR tid csh $ SheetShowR shn
+    (FormSuccess BtnAbort)  -> redirectUltDest $ CSheetR tid ssh csh shn SShowR
     (FormSuccess BtnDelete) -> do
-      runDB $ fetchSheetId tid csh shn >>= deleteCascade
+      runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade
       -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
-      setMessageI $ MsgSheetDelOk tident csh shn
-      redirect $ CSheetR tid csh SheetListR
+      addMessageI Info $ MsgSheetDelOk tid ssh csh shn
+      redirect $ CourseR tid ssh csh SheetListR
     _other -> do
       submissionno <- runDB $ do
-          sid <- fetchSheetId tid csh shn
-          count [SubmissionSheetId ==. sid]
-      let formTitle = MsgSheetDelTitle tident csh shn
+          sid <- fetchSheetId tid ssh csh shn
+          count [SubmissionSheet ==. sid]
+      let formTitle = MsgSheetDelHead tid ssh csh shn
       let formText  = Just $ MsgSheetDelText submissionno
-      let actionUrl = CSheetR tid csh $ SheetDelR shn
+      let actionUrl = CSheetR tid ssh csh shn SDelR
       defaultLayout $ do
-        setTitleI $ MsgSheetTitle tident csh shn
+        setTitleI $ MsgSheetTitle tid ssh csh shn
         $(widgetFile "formPageI18n")
 
-postSheetDelR :: TermId -> Text -> Text -> Handler Html
-postSheetDelR = getSheetDelR
+postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
+postSDelR = getSDelR
 
 
 
@@ -381,8 +510,8 @@ insertSheetFile sid ftype finfo = do
 insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX ()
 insertSheetFile' sid ftype fs = do
     oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
-      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
-      E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val sid
+      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
+      E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
            E.&&. sheetFile E.^. SheetFileType    E.==. E.val ftype
       return (file E.^. FileId)
     keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
@@ -392,3 +521,200 @@ insertSheetFile' sid ftype fs = do
     finsert (Right file) = lift $ do
       fid <- insert file
       void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
+
+  
+data CorrectorForm = CorrectorForm
+  { cfUserId :: UserId
+  , cfUserName :: Text
+  , cfResult :: FormResult (CorrectorState, Load)
+  , cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX
+  }
+
+type Loads = Map UserId (CorrectorState, Load)
+
+defaultLoads :: SheetId -> DB Loads
+-- ^ Generate `Loads` in such a way that minimal editing is required
+--
+-- For every user, that ever was a corrector for this course, return their last `Load`.
+-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit).
+defaultLoads shid = do
+  cId <- sheetCourse <$> getJust shid
+  fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
+    E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+
+    let creationTime = E.sub_select . E.from $ \sheetEdit -> do
+          E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
+          return . E.min_ $ sheetEdit E.^. SheetEditTime
+
+    E.where_ $ sheet E.^. SheetCourse E.==. E.val cId
+    
+    E.orderBy [E.desc creationTime]
+  
+    return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
+  where
+    toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
+    toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load)
+
+
+correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
+correctorForm shid = do
+  cListIdent <- newFormIdent
+  let
+    guardNonDeleted :: UserId -> Handler (Maybe UserId)
+    guardNonDeleted uid = do
+      cID@CryptoID{..} <- encrypt uid :: Handler CryptoUUIDUser
+      deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
+      return $ bool Just (const Nothing) (isJust deleted) uid
+  formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
+  let
+    currentLoads :: DB Loads
+    currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
+  (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)
+    | 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')
+
+  let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions)
+      didDelete = any (flip Set.member deletions) formCIDs
+
+  (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads'
+  let
+    tutorField :: Field Handler [UserEmail]
+    tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
+      { fieldView = \theId name attrs val isReq -> asWidgetT $ do
+          listIdent <- newIdent
+          userId <- handlerToWidget requireAuthId
+          previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do
+            E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
+            E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+            E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
+            E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
+            E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
+            return $ user E.^. UserEmail
+          [whamlet|
+            $newline never
+            <input id=#{theId} name=#{name} list=#{listIdent} *{attrs} type=email multiple :isReq:required value="" placeholder=_{MsgCorrectorsPlaceholder}>
+            <datalist id=#{listIdent}>
+              $forall E.Value prev <- previousCorrectors
+                <option value=#{prev}>
+          |]
+      }
+  (addTutRes, addTutView) <- mopt tutorField (fsm MsgAddCorrector) (Just Nothing)
+
+  loads <- case addTutRes of
+    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)
+        Just uid
+          | not (Map.member uid loads') -> return $ Map.insert uid (CorrectorNormal, mempty) loads''
+          | otherwise                   -> loads'' <$ addMessageI Warning (MsgCorrectorExists email)
+    FormFailure errs -> loads'' <$ mapM_ (addMessage Error . toHtml) errs
+    _ -> return loads''
+
+  let deletions' = deletions `Set.difference` Map.keysSet loads
+  
+  names <- fmap (Map.fromList . map (\(E.Value a, E.Value b) -> (a, b))) . lift . runDB . E.select . E.from $ \user -> do
+    E.where_ $ user E.^. UserId `E.in_` E.valList (Map.keys  loads)
+    return $ (user E.^. UserId, user E.^. UserDisplayName)
+    
+  let
+    constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm
+    constructFields (uid, uname, (state, Load{..})) = do
+      cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser
+      let
+        fs name = ""
+          { fsName = Just $ tshow ciphertext <> "-" <> name
+          }
+        rationalField = convertField toRational fromRational doubleField
+
+      (stateRes, cfViewState) <- mreq (selectField $ optionsFinite id) (fs "state") (Just state)
+      (byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
+      (propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
+      (_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
+      let
+        cfResult :: FormResult (CorrectorState, Load)
+        cfResult = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
+        tutRes'
+          | FormSuccess True <- byTutRes  = Just <$> countTutRes
+          | otherwise                     = Nothing <$ byTutRes
+        cfUserId = uid
+        cfUserName = uname
+      return CorrectorForm{..}
+
+  corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid
+
+  mr <- getMessageRender
+
+  $logDebugS "SCorrR" $ tshow (didDelete, addTutRes)
+
+  let
+    corrColonnade = mconcat
+      [ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName
+      , headed (Yesod.textCell $ mr MsgCorState) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewState
+      , headed (Yesod.textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut
+      , headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp
+      , headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel
+      ]
+    corrResults
+      | FormSuccess (Just es) <- addTutRes
+      , not $ null es = FormMissing
+      | didDelete = FormMissing
+      | otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> (snd <$> cfResult) <*> (fst <$> cfResult)
+                                                  | CorrectorForm{..} <- corrData
+                                                  ]
+    idField CorrectorForm{..} = do
+      cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
+      toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
+
+    delField uid = do
+      cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
+      toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
+
+  return (corrResults, [ countTutView
+                       , FieldView
+                           { fvLabel = text $ mr MsgCorrectors
+                           , fvTooltip = Nothing
+                           , fvId = ""
+                           , fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions
+                           , fvErrors = Nothing
+                           , fvRequired = True
+                           }
+                       , addTutView
+                           { fvInput = [whamlet|
+                               <div>
+                                 ^{fvInput addTutView}
+                                 <button type=submit formnovalidate data-formnorequired>Hinzufügen
+                             |]
+                           }
+                       ])
+  
+  -- Eingabebox für Korrektor hinzufügen
+  -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
+
+getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
+postSCorrR = getSCorrR
+getSCorrR tid ssh csh shn = do
+  Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
+
+  ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
+
+  case res of
+    FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
+    FormSuccess res -> runDB $ do
+      deleteWhere [SheetCorrectorSheet ==. shid]
+      insertMany_ $ Set.toList res
+      addMessageI Success MsgCorrectorsUpdated
+    FormMissing -> return ()
+
+  let
+    --     formTitle = MsgSheetCorrectorsTitle tid ssh csh shn
+    formText  = Nothing :: Maybe (SomeMessage UniWorX)
+    actionUrl = CSheetR tid ssh csh shn SCorrR
+    -- actionUrl = CSheetR tid ssh csh shn SShowR
+  defaultLayout $ do
+    setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn
+    $(widgetFile "formPageI18n")

src/Handler/Submission.hs

@@ -1,6 +1,8 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE ParallelListComp #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -9,6 +11,10 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE MultiWayIf #-}
 
 module Handler.Submission where
 
@@ -17,247 +23,377 @@ import Import hiding (joinPath)
 -- import Yesod.Form.Bootstrap3  
 
 import Handler.Utils
+import Handler.Utils.Table.Cells
 
 import Network.Mime
 
-import Control.Monad.Trans.Maybe
-import Control.Monad.State.Class
-import Control.Monad.Trans.State.Strict (StateT)
+-- import Control.Monad.Trans.Maybe
+-- import Control.Monad.State.Class
+-- import Control.Monad.Trans.State.Strict (StateT)
 
+import Data.Monoid (Any(..))
+import Data.Maybe (fromJust)
+-- import qualified Data.Maybe
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
-import qualified Data.CaseInsensitive as CI
+
+import Data.CaseInsensitive (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 qualified Data.Set as Set
 import Data.Map (Map)
 import qualified Data.Map as Map
+-- import Data.Bifunctor
 
 import System.FilePath
 
-import Colonnade
-import Yesod.Colonnade
-import qualified Text.Blaze.Html5.Attributes as HA
+-- import Colonnade hiding (bool, fromMaybe)
+-- import qualified Yesod.Colonnade as Yesod
+-- import qualified Text.Blaze.Html5.Attributes as HA
 
-submissionTable :: MForm Handler (FormResult [SubmissionId], Widget)
-submissionTable = do
-  subs <- lift . runDB $ E.select . E.from $ \(sub `E.InnerJoin` sheet `E.InnerJoin` course) -> do
-    E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
-    E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheetId
-
-    return (sub, sheet, course)
-
-  cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) ->
-    (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
-
-  let
-    anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTermId courseShorthand CourseShowR
-    courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
-    anchorSubmission (_, cUUID, _) = SubmissionR cUUID
-    submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
-    colonnade = mconcat
-      [ headed "Abgabe-ID" $ anchorCell anchorSubmission submissionText
-      , headed "Kurs" $ anchorCell anchorCourse courseText
-      , headed "Blatt" $ \(_, _, (_, Entity _ Sheet{..}, _)) -> textCell $ sheetName
-      ]
-    toExternal :: (CryptoFileNameSubmission, CryptoUUIDSubmission, a) -> Handler CryptoUUIDSubmission
-    toExternal (_, cID, _) = return cID
-    fromExternal :: CryptoUUIDSubmission -> Handler SubmissionId
-    fromExternal = decrypt
-  headedRowSelector toExternal fromExternal (HA.class_ "table table-striped table-hover") colonnade cryptedSubs
+-- DEPRECATED: We always show all edits!
+-- numberOfSubmissionEditDates :: Int64
+-- numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
 
 
-getSubmissionListR, postSubmissionListR :: Handler Html
-getSubmissionListR = postSubmissionListR
-postSubmissionListR = do
-  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
-    <$> areq checkBoxField "Dies sind Korrekturen" (Just False)
-    <*> fileAFormReq "Archiv"
-    <*  submitButton
+makeSubmissionForm :: Maybe SubmissionId -> UploadMode -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
+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 $ (,)
+      <$> fileUpload
+      <*> (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
+                                    ])
+      <*  submitButton
+  where
+    (groupNr, editableBuddies)
+      | Arbitrary{..} <- grouping = (pred maxParticipants, True) -- pred to account for the person submitting
+      | otherwise = (0, False)
 
+    aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
+    aforced' _ _  _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary"
+
+getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
+getSubmissionNewR = postSubmissionNewR
+postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn NewSubmission
+
+
+getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
+getSubShowR = postSubShowR
+postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ ExistingSubmission cid
+
+getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
+getSubmissionOwnR tid ssh csh shn = do
+  authId <- requireAuthId
+  sid <- runDB $ do
+    shid <- fetchSheetId tid ssh csh shn
+    submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
+      E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
+      E.where_ $ submissionUser E.^. SubmissionUserUser   E.==. E.val authId
+           E.&&. submission     E.^. SubmissionSheet    E.==. E.val shid
+      return $ submission E.^. SubmissionId
+    case submissions of
+      ((E.Value sid):_) -> return sid
+      []      -> notFound
+  cID <- encrypt sid
+  redirect $ CSubmissionR tid ssh csh shn cID SubShowR
+
+submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
+submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
+  uid       <- requireAuthId
+  msmid     <- traverse decrypt mcid
+  actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
+  maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc.
+
+  (Entity shid Sheet{..}, buddies, lastEdits)  <- runDB $ do
+    csheet@(Entity shid Sheet{..})  <- fetchSheet tid ssh csh shn
+    case msmid of
+      Nothing     -> do
+        submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
+          E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
+          E.where_ $ submissionUser E.^. SubmissionUserUser   E.==. E.val uid
+               E.&&. submission     E.^. SubmissionSheet    E.==. E.val shid
+          return $ submission E.^. SubmissionId
+        -- $logDebugS "Submission.DUPLICATENEW" (tshow submissions)
+        case submissions of
+          []    -> do
+            -- fetch buddies from previous submission in this course
+            buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+              E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
+              let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` subUser `E.InnerJoin` submissionEdit) -> do
+                    E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
+                    E.on (subUser        E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
+                    E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet)
+                    E.where_ $  subUser E.^. SubmissionUserUser E.==. E.val uid
+                          E.&&. sheet   E.^.        SheetCourse E.==. E.val sheetCourse
+                    E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
+                    E.limit 1
+                    return $ submission E.^. SubmissionId
+              E.where_ $  submissionUser E.^. SubmissionUserSubmission `E.in_` oldids
+                    E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
+              E.orderBy  [E.asc $ user E.^. UserEmail]
+              return $ user E.^. UserEmail
+            return (csheet, map E.unValue buddies, [])
+          (E.Value smid:_) -> do
+            cID <- encrypt smid
+            addMessageI Info $ MsgSubmissionAlreadyExists
+            redirect $ CSubmissionR tid ssh csh shn cID SubShowR
+      (Just smid) -> do
+        void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
+        
+        shid' <- submissionSheet <$> get404 smid
+        -- fetch buddies from current submission
+        (Any isOwner, buddies) <- do
+          submittors <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
+            E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
+            E.where_ $  submissionUser E.^. SubmissionUserSubmission E.==. E.val smid
+            E.orderBy  [E.asc $ user E.^. UserEmail]
+            return $ (user E.^. UserId, user E.^. UserEmail)
+          let breakUserFromBuddies (E.Value userID, E.Value email)
+                | uid == userID  =  (Any True ,      [])
+                | otherwise      =  (Any False, [email])
+          return $ foldMap breakUserFromBuddies submittors
+
+        lastEdits <- do
+            raw <- E.select . E.from $ \(user `E.InnerJoin` submissionEdit) -> do
+              E.on (user E.^. UserId E.==. submissionEdit E.^. SubmissionEditUser)
+              E.where_ $ submissionEdit E.^. SubmissionEditSubmission E.==. E.val smid
+              E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
+              -- E.limit numberOfSubmissionEditDates -- DEPRECATED we always show all edit times
+              let userName = if isOwner || maySubmit
+                              then E.just $ user E.^. UserDisplayName
+                              else E.nothing
+              return $ (userName, submissionEdit E.^. SubmissionEditTime)
+            forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
+        return (csheet,buddies,lastEdits)
+  ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies
+  mCID <- runDB $ do
+    res' <- case res of
+      (FormMissing )           -> return $ FormMissing
+      (FormFailure failmsgs)   -> return $ FormFailure failmsgs
+      (FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change
+      (FormSuccess (mFiles,gEMails@(_:_))) -- Validate AdHoc Group Members
+        | (Arbitrary {..}) <- sheetGrouping -> do
+          -- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
+          let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))
+              prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
+          participants <- fmap prep . E.select . E.from $ \user -> do
+            E.where_ $ (user E.^. UserEmail) `E.in_` E.valList gEMails
+            let
+              isParticipant = E.sub_select . E.from $ \courseParticipant -> do
+                E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
+                     E.&&. courseParticipant E.^. CourseParticipantCourse E.==. E.val sheetCourse
+                return $ E.countRows E.>. E.val (0 :: Int64)
+              hasSubmitted = E.sub_select . E.from $ \(submissionUser `E.InnerJoin` submission) -> do
+                E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
+                E.where_ $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
+                     E.&&. submission E.^. SubmissionSheet E.==. E.val shid
+                case msmid of -- Multiple `E.where_`-Statements are merged with `&&` in esqueleto 2.5.3
+                  Nothing   -> return ()
+                  Just smid -> E.where_ $ submission E.^. SubmissionId E.!=. E.val smid 
+                return $ E.countRows E.>. E.val (0 :: Int64)
+            return (user E.^. UserEmail, (user E.^. UserId, isParticipant, hasSubmitted))
+
+          $logDebugS "SUBMISSION.AdHocGroupValidation" $ tshow participants
+
+          mr <- getMessageRender
+          let
+            failmsgs = (concat :: [[Text]] -> [Text])
+              [ flip Map.foldMapWithKey participants $ \email -> \case
+                  Nothing            -> pure . mr $ MsgEMailUnknown email
+                  (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
+                  (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email
+                  _other             -> mempty
+              , case length participants `compare` maxParticipants of
+                  LT -> mempty
+                  _  -> pure $ mr MsgTooManyParticipants
+              ]
+          return $ if null failmsgs
+            then FormSuccess (mFiles, foldMap (\(Just (i,_,_)) -> [i]) participants)
+            else FormFailure failmsgs
+        | otherwise -> return $ FormFailure ["Mismatching number of group participants"]
+
+
+    case res' of
+      (FormSuccess (mFiles,(setFromList -> adhocIds))) -> do
+        now <- liftIO $ getCurrentTime
+        smid <- do
+          smid <- case (mFiles, msmid) of
+            (Nothing, Just smid)   -- no new files, existing submission partners updated
+              -> return smid
+            (Just files, _)  -- new files
+              -> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
+            (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
+            E.on $ submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
+            E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
+                E.&&.  submissionGroup     E.^. SubmissionGroupCourse   E.==. E.val sheetCourse
+            return $ submissionGroupUser' E.^. SubmissionGroupUserUser
+          -- SubmissionUser for all group members (pre-registered & ad-hoc)
+          let subUsers = Set.insert uid $ groupUids `Set.union` adhocIds
+          -- remove obsolete old entries
+          deleteWhere [SubmissionUserSubmission ==. smid, SubmissionUserUser /<-. setToList subUsers]
+          -- maybe add current users
+          forM_ subUsers $ \uid' -> void . insertUnique $ SubmissionUser uid' smid
+          return smid
+        cID <- encrypt smid
+        return $ Just cID
+      (FormFailure msgs) -> Nothing <$ forM_ msgs (addMessage Warning . toHtml)
+      _other -> return Nothing
+  
+  case mCID of
+    Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR
+    Nothing  -> return ()
+
+  -- Maybe construct a table to display uploaded archive files
+  let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ())
+      colonnadeFiles cid = mconcat
+        [ sortable (Just "path") (i18nCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let
+              Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr)
+              origIsFile = fmap (isJust . fileContent . entityVal . snd) mOrig
+              corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr
+              Just isFile = origIsFile <|> corrIsFile
+            in if
+              | Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle')
+                                                      ([whamlet|#{fileTitle'}|])
+              | otherwise               -> textCell $ bool (<> "/") id isFile fileTitle'
+        , sortable (toNothing "state") (i18nCell MsgCorState) $ \(coalesce -> (_, mCorr)) -> case mCorr of
+            Nothing -> cell mempty
+            Just (_, Entity _ File{..})
+              | isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle)
+                                                 ([whamlet|_{MsgFileCorrected}|])
+              | otherwise -> i18nCell MsgCorrected
+        , sortable (Just "time") (i18nCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let
+              origTime = fileModified . entityVal . snd <$> mOrig
+              corrTime = fileModified . entityVal . snd <$> mCorr
+              Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
+            in timeCell fileTime
+        ]
+      coalesce :: ((Maybe (Entity SubmissionFile), Maybe (Entity File)), (Maybe (Entity SubmissionFile), Maybe (Entity File))) -> (Maybe (Entity SubmissionFile, Entity File), Maybe (Entity SubmissionFile, Entity File))   
+      coalesce ((ma, mb), (mc, md)) = ((,) <$> ma <*> mb, (,) <$> mc <*> md)
+      submissionFiles :: _ -> _ -> E.SqlQuery _
+      submissionFiles smid ((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) = do
+        E.on $ f2 E.?. FileId E.==. sf2 E.?. SubmissionFileFile
+        E.on $ f1 E.?. FileTitle E.==. f2 E.?. FileTitle
+         E.&&. sf1 E.?. SubmissionFileSubmission E.==. sf2 E.?. SubmissionFileSubmission
+         E.&&. sf1 E.?. SubmissionFileId E.!=. sf2 E.?. SubmissionFileId
+        E.on $ f1 E.?. FileId E.==. sf1 E.?. SubmissionFileFile
+
+        E.where_ $ (sf1 E.?. SubmissionFileIsUpdate E.==. E.val (Just False) E.||. E.isNothing (sf1 E.?. SubmissionFileIsUpdate))
+             E.&&. (sf2 E.?. SubmissionFileIsUpdate E.==. E.val (Just True)  E.||. E.isNothing (sf2 E.?. SubmissionFileIsUpdate))
+             E.&&. (sf1 E.?. SubmissionFileSubmission E.==. E.val (Just smid) E.||. sf2 E.?. SubmissionFileSubmission E.==. E.val (Just smid))
+
+        return ((sf1, f1), (sf2, f2))
+      smid2ArchiveTable (smid,cid) = DBTable
+        { dbtSQLQuery = submissionFiles smid
+        , dbtColonnade = colonnadeFiles cid
+        , dbtProj = return . dbrOutput
+        , dbtStyle = def
+        , dbtIdent = "files" :: Text
+        , dbtSorting =  [ ( "path"
+                          , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> E.coalesce [f1 E.?. FileTitle, f2 E.?. FileTitle]
+                          )
+                        , ( "time"
+                          , SortColumn $ \((sf1 `E.InnerJoin` f1) `E.FullOuterJoin` (sf2 `E.InnerJoin` f2)) -> (E.unsafeSqlFunction "GREATEST" ([f1 E.?. FileModified, f2 E.?. FileModified] :: [E.SqlExpr (E.Value (Maybe UTCTime))]) :: E.SqlExpr (E.Value (Maybe UTCTime)))
+                          )
+                        ]
+        , dbtFilter = []
+        }
+  mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
+
+  defaultLayout $ do
+    setTitleI $ MsgSubmissionEditHead tid ssh csh shn
+    let urlArchive  cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))
+        urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))
+    $(widgetFile "submission")
+
+
+getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
+getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
   runDB $ do
-    case uploadResult of
-      FormMissing -> return ()
-      FormFailure _ -> addMessage "warning" "Bitte Eingabe korrigieren."
-      FormSuccess (isUpdate, fInfo) -> do
-        userId <- lift requireAuthId
-        let feed :: SubmissionId -> SubmissionContent -> StateT (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId)) (YesodDB UniWorX) ()
-            feed sId val = do
-              mSink <- gets $ Map.lookup sId
-              sink <- case mSink of
-                Just sink -> return sink
-                Nothing -> do
-                  Submission{..} <- lift $ get404 sId
-                  return . newResumableSink $ sinkSubmission submissionSheetId userId (Just (sId, isUpdate))
-              sink' <- lift $ yield val ++$$ sink
-              case sink' of
-                Left _ -> error "sinkSubmission returned prematurely"
-                Right nSink -> modify $ Map.insert sId nSink
-            sinkSubmissions :: Sink SubmissionContent (YesodDB UniWorX) ()
-            sinkSubmissions = do
-              sinks <- execStateC Map.empty . awaitForever $ \case
-                v@(Right (sId, _)) -> lift $ feed sId v
-                (Left f@File{..})  -> case splitDirectories fileTitle of
-                  (cID:rest) 
-                    | not (null rest) -> do
-                        sId <- decrypt (CryptoID $ CI.mk cID :: CryptoFileNameSubmission)
-                        lift . feed sId $ Left f{ fileTitle = joinPath rest }
-                    | otherwise -> return ()
-                  [] -> invalidArgs ["Encountered file/directory with empty name"]
-              lift $ mapM_ (void . closeResumableSink) sinks
-                  
-        runConduit $ fileSource fInfo =$= void consumeZip =$= extractRatings =$= void sinkSubmissions
- 
-  (subTable, selectEncoding) <- generateFormPost . identifyForm "selection" . withFragment $ submissionTable
+    submissionID <- submissionMatchesSheet tid ssh csh shn cID
 
-  defaultLayout $(widgetFile "submission-list")
-
-getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent
-getSubmissionDownloadSingleR cID path = do
-  submissionID <- decrypt cID
-  cID' <- encrypt submissionID
-
-  runDB $ do
     isRating <- maybe False (== submissionID) <$> isRatingFile path
+
+    when (isUpdate || isRating) $
+      guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
+  
     case isRating of
-      True  -> do
-        file <- runMaybeT $ lift . ratingFile cID' =<< MaybeT (getRating submissionID)
-        maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
+      True
+        | isUpdate -> do
+            file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
+            maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
+        | otherwise -> notFound
       False -> do
-        results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
-          E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
-          E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID)
-          E.where_ (f E.^. FileTitle E.==. E.val path)
-          E.where_ . E.not_ . E.isNothing $ f E.^. FileContent
-          E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion
-          E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
+        results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
+          E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
+          E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
+               E.&&. f E.^. FileTitle E.==. E.val path
+               E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
+               E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
+               -- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
           return f
 
         let fileName = Text.pack $ takeFileName path
         case results of
-          [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c)
-          _ -> notFound
+          [Entity _ File{ fileContent = Just c, fileTitle }] -> do
+            whenM downloadFiles $ 
+              addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
+            return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
+          [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
+          other -> do
+            $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
+            error "Multiple matching files found."
 
-submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
-submissionFileSource submissionID = E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
-  E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
-  E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID
-  E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion
-  E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
-  return f
+getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
+getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
+  when (sfType == SubmissionCorrected) $ 
+    guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False
 
-postSubmissionDownloadMultiArchiveR :: Handler TypedContent
-postSubmissionDownloadMultiArchiveR = do
-  ((selectResult, _), _) <- runFormPost . withFragment $ submissionTable
-
-  case selectResult of
-    FormMissing -> invalidArgs ["Missing submission numbers"]
-    FormFailure errs -> invalidArgs errs
-    FormSuccess ids -> do
-      (dbrunner, cleanup) <- getDBRunner
-
-      ratedSubmissions <- runDBRunner dbrunner $ do
-        submissions <- selectList [ SubmissionId <-. ids ] []
-        forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
+  let filename
+        | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType
+        | otherwise = ZIPArchiveName $ toPathPiece cID
   
-      (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
-        let
-          fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
-          fileEntitySource' (rating, Entity submissionID Submission{..}) = do
-            cID <- encrypt submissionID
-
-            let
-              directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
-              
-              fileEntitySource = do
-                submissionFileSource submissionID =$= Conduit.map entityVal
-                yieldM (ratingFile cID rating)
-
-              withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
-
-            lastEditMb <- lift $ selectList [SubmissionEditSubmission ==. submissionID] [Desc SubmissionEditTime, LimitTo 1]
-            lastEditTime <- case lastEditMb of
-                [(submissionEditTime.entityVal -> time)] -> return time
-                _other -> liftIO getCurrentTime
-            yield $ File
-              { fileModified = lastEditTime
-              , fileTitle = directoryName
-              , fileContent = Nothing
-              }
-
-            fileEntitySource =$= mapC withinDirectory
-          
-        mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
-
-
-getSubmissionDownloadArchiveR :: FilePath -> Handler TypedContent
-getSubmissionDownloadArchiveR path = do
-  let (baseName, ext) = splitExtension path
-      cID :: CryptoFileNameSubmission
-      cID = CryptoID $ CI.mk baseName
-  unless (ext == ".zip") notFound
-  submissionID <- decrypt cID
-  cUUID <- encrypt submissionID
+  addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
   respondSourceDB "application/zip" $ do
+    submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
     rating <- lift $ getRating submissionID
-    case rating of
-      Nothing -> lift notFound
-      Just rating' -> do
-        let fileEntitySource' :: Source (YesodDB UniWorX) File
-            fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating')
-            info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) }
-        fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder
 
-getSubmissionR, postSubmissionR :: CryptoUUIDSubmission -> Handler Html
-getSubmissionR = postSubmissionR
-postSubmissionR cID = do
-  submissionId <- decrypt cID
-  
-  ((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
-    <$> areq checkBoxField "Dies ist eine Korrektur" (Just False)
-    <*> fileAFormReq "Datei"
-    <*  submitButton
+    let
+      fileSource = case sfType of
+        SubmissionOriginal -> E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
+          E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile
+          E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
+               E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False
+          return f
+        _ -> submissionFileSource submissionID
 
-  (submission, files) <- runDB $ do
-    submission <- do
-      submission@Submission{..} <- get404 submissionId
-      case uploadResult of
-        FormMissing -> return submission
-        FormFailure _ -> submission <$ addMessage "warning" "Bitte Eingabe korrigieren."
-        FormSuccess (isUpdate, fInfo) -> do
-          userId <- lift requireAuthId
-          let mimeType = defaultMimeLookup (fileName fInfo) 
-              source
-                | mimeType == "application/zip" = fileSource fInfo =$= void consumeZip
-                | otherwise = do
-                  let fileTitle = Text.unpack $ fileName fInfo
-                  fileModified <- liftIO getCurrentTime
-                  yieldM $ do
-                    fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
-                    return File{..}
-          submissionId' <- runConduit $ source =$= extractRatings =$= sinkSubmission submissionSheetId userId (Just (submissionId, isUpdate))
-          get404 submissionId'
-  
-    files <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
-      E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
-      E.where_ (sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId)
-      E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
-      return (f, sf)
-    return (submission, files)
+      fileSource' = do
+        fileSource .| Conduit.map entityVal
+        when (sfType == SubmissionCorrected) $
+          maybe (return ()) (yieldM . ratingFile cID) rating
 
-  let
-    Rating'{..} = Rating'
-      { ratingPoints = submissionRatingPoints submission
-      , ratingComment = submissionRatingComment submission
-      , ratingTime = submissionRatingTime submission
-      }
+      zipComment = Text.encodeUtf8 $ toPathPiece cID
 
-  cID' <- encrypt submissionId
-  let
-    archiveBaseName = CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission)
-    archiveName = archiveBaseName <.> "zip"
-
-  defaultLayout $(widgetFile "submission")
+    fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder

src/Handler/Term.hs

@@ -7,6 +7,7 @@
            , MultiParamTypeClasses
            , TypeFamilies
            , FlexibleContexts
+           , PartialTypeSignatures
   #-}
 
 module Handler.Term where
@@ -16,12 +17,40 @@ import Handler.Utils
 
 -- import qualified Data.Text as T
 import Yesod.Form.Bootstrap3
-
-import Colonnade hiding (bool)
-import Yesod.Colonnade
+-- import Colonnade hiding (bool)
 
 import qualified Database.Esqueleto as E
 
+
+
+validateTerm :: Term -> [Text]
+validateTerm (Term{..}) =
+  [ msg  | (False, msg) <-
+    [ --startOk
+      ( termStart `withinTerm` termName
+      , "Jahreszahl im Namenskürzel stimmt nicht mit Semesterbeginn überein."
+      )
+    , -- endOk
+      ( termStart < termEnd
+      , "Semester darf nicht enden, bevor es begann."
+      )
+    , -- startOk
+      ( termLectureStart < termLectureEnd
+      , "Vorlesungszeit muss vor ihrem Ende anfgangen."
+      )
+    , -- lecStartOk
+      ( termStart <= termLectureStart
+      , "Semester muss vor der Vorlesungszeit beginnen."
+      )
+    , -- lecEndOk
+      ( termEnd >= termLectureEnd
+      , "Vorlesungszeit muss vor dem Semester enden."
+      )
+  ] ]
+
+
+
+
 getTermShowR :: Handler TypedContent
 getTermShowR = do
 --   terms <- runDB $ selectList [] [Desc TermStart]
@@ -31,48 +60,57 @@ getTermShowR = do
 --              return term
 --
   let
+    termData :: E.SqlExpr (Entity Term) -> E.SqlQuery (E.SqlExpr (Entity Term), E.SqlExpr (E.Value Int64))
     termData term = do
       -- E.orderBy [E.desc $ term E.^. TermStart ]
-      let courseCount :: E.SqlExpr (E.Value Int)
-          courseCount = E.sub_select . E.from $ \course -> do
-            E.where_ $ term E.^. TermId E.==. course E.^. CourseTermId
+      let courseCount = E.sub_select . E.from $ \course -> do
+            E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
             return E.countRows
       return (term, courseCount)
   selectRep $ do
     provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
     provideRep $ do
-      let colonnadeTerms = mconcat
-            [ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do
-                -- Scrap this if to slow, create term edit page instead
-                adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
-                [whamlet|
-                  $if adminLink == Authorized
-                    <a href=@{TermEditExistR tid}>
-                      #{termToText termName}
-                  $else
-                      #{termToText termName}
-                |]
-            , sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
-                stringCell $ formatTimeGerWD termLectureStart
+      let colonnadeTerms = widgetColonnade $ mconcat
+            [ sortable Nothing "Kürzel" $
+                anchorCell' (\(Entity tid _, _) -> TermCourseListR tid)
+                            (\(Entity tid _, _) -> [whamlet|#{toPathPiece tid}|])
+            , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
+                cell $ formatTime SelFormatDate termLectureStart >>= toWidget
             , sortable (Just "lecture-end") "Ende Vorlesungen"   $ \(Entity _ Term{..},_) ->
-                stringCell $ formatTimeGerWD termLectureEnd
+                cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
             , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
-                textCell $ bool "" tickmark termActive
-            , sortable Nothing "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) ->
-                cell [whamlet|
-                  <a href=@{CourseListTermR tid}>
-                    #{show numCourses} Kurse
-                |]
+                textCell $ (bool "" tickmark termActive :: Text)
+            , sortable Nothing "Kurse" $ \(_, E.Value numCourses) ->
+                cell [whamlet|_{MsgNumCourses numCourses}|]
             , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
-              stringCell $ formatTimeGerWD termStart
+                cell $ formatTime SelFormatDate termStart >>= toWidget
             , sortable (Just "end") "Semesterende"   $ \(Entity _ Term{..},_) ->
-              stringCell $ formatTimeGerWD termEnd
+                cell $ formatTime SelFormatDate termEnd >>= toWidget
             , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
-              stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays
+                cell $ do
+                  termHolidays' <- mapM (formatTime SelFormatDate) termHolidays
+                  [whamlet|
+                    <ul .list--inline .list--comma-separated>
+                      $forall holiday <- termHolidays'
+                        <li>#{holiday}
+                  |]
             ]
-      table <- dbTable def $ DBTable
+--       let adminColonnade =
+--           [ sortable Nothing "Edit" $ \(Entity tid Term{..},_) -> cell $ do
+--                 -- Scrap this if to slow, create term edit page instead
+--                 adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
+--                 [whamlet|
+--                   $if adminLink == Authorized
+--                     <a href=@{TermEditExistR tid}>
+--                       #{termToText termName}
+--                   $else
+--                       #{termToText termName}
+--                 |]
+--           ]
+      ((), table) <- dbTable def $ DBTable
         { dbtSQLQuery = termData
         , dbtColonnade = colonnadeTerms
+        , dbtProj = return . dbrOutput
         , dbtSorting = [ ( "start"
                          , SortColumn $ \term -> term E.^. TermStart
                          )
@@ -86,7 +124,18 @@ getTermShowR = do
                          , SortColumn $ \term -> term E.^. TermLectureEnd
                          )
                        ]
-        , dbtAttrs = tableDefault
+        , dbtFilter = [ ( "active"
+                        , FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool))
+                        )
+                      , ( "course"
+                        , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are 
+                            []   -> E.val True :: E.SqlExpr (E.Value Bool)
+                            cshs -> E.exists . E.from $ \course -> do
+                              E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
+                                   E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
+                        )
+                      ]
+        , dbtStyle = def
         , dbtIdent = "terms" :: Text
         }
       defaultLayout $ do
@@ -112,32 +161,33 @@ termEditHandler term = do
     ((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
     case result of
       (FormSuccess res) -> do
+          let tid = TermKey $ termName res
           -- term <- runDB $ get $ TermKey termName
-          runDB $ repsert (TermKey $ termName res) res
+          runDB $ repsert tid res
 -- 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 $ termName res
+          addMessageI Success $ MsgTermEdited tid
           redirect TermShowR
       (FormMissing  ) -> return ()
-      (FormFailure _) -> addMessageI "warning" MsgInvalidInput
-    let formTitle   = "Semester editieren/anlegen" :: Text
+      (FormFailure _) -> addMessageI Warning MsgInvalidInput
     let actionUrl   = TermEditR
     defaultLayout $ do
-      setTitle [shamlet| #{formTitle} |]
+      setTitleI MsgTermEditHeading
       $(widgetFile "formPage")
 
 newTermForm :: Maybe Term -> Form Term
 newTermForm template html = do
+    mr <- getMessageRender
     (result, widget) <- flip (renderAForm FormStandard) html $ Term
-      <$> areq termNewField (bfs ("Semester" :: Text)) (termName  <$> template)
-      <*> areq dayField  (bfs ("Erster Tag" :: Text)) (termStart <$> template)
-      <*> areq dayField  (bfs ("Letzer Tag" :: Text)) (termEnd   <$> 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
-      <*> areq dayField  (bfs ("Beginn Vorlesungen" :: Text)) (termLectureStart <$> template)
-      <*> areq dayField  (bfs ("Ende Vorlesungen" :: Text)) (termLectureEnd   <$> template)
+      <*> areq dayField  (fsl "Beginn Vorlesungen") (termLectureStart <$> template)
+      <*> areq dayField  (fsl ("Ende Vorlesungen" :: Text)) (termLectureEnd   <$> template)
       <*> areq checkBoxField (bfs ("Aktiv" :: Text)) (termActive <$> template)
       <*  submitButton
     return $ case result of
@@ -147,10 +197,11 @@ newTermForm template html = do
           (FormFailure errorMsgs,
                 [whamlet|
                   <div class="alert alert-danger">
-                    <h4> Fehler:
-                    <ul>
-                      $forall errmsg <- errorMsgs
-                        <li> #{errmsg}
+                    <div class="alert__content">
+                      <h4> Fehler:
+                      <ul>
+                        $forall errmsg <- errorMsgs
+                          <li> #{errmsg}
                   ^{widget}
                 |]
               )

src/Handler/Users.hs

@@ -1,8 +1,10 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
 
 module Handler.Users where
 
@@ -10,36 +12,113 @@ import Import
 -- import Data.Text
 import Handler.Utils
 
-import Colonnade hiding (fromMaybe)
-import Yesod.Colonnade
+import Utils.Lens
 
--- import qualified Database.Esqueleto as E
--- import           Database.Esqueleto      ((^.))
+import qualified Data.CaseInsensitive as CI
 
+import qualified Data.Map as Map
+import qualified Data.Set as Set
+
+import qualified Database.Esqueleto as E
+
+
+hijackUserForm :: UserId -> Form UserId
+hijackUserForm uid csrf = do
+  cID <- encrypt uid
+  (uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser)
+  (btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing 
+
+  return (uid <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView])
 
 getUsersR :: Handler Html
 getUsersR = do
-  -- TODO: Esqueleto, combine the two queries into one
-  (users,schools) <- runDB $ (,)
-    <$> (selectList [] [Asc UserDisplayName]
-        >>= mapM (\usr -> (,,)
-          <$> pure usr
-          <*> selectList [UserAdminUser    ==. entityKey usr] [Asc UserAdminSchool]
-          <*> selectList [UserLecturerUser ==. entityKey usr] [Asc UserLecturerSchool]
-        ))
-    <*> selectList [] [Asc SchoolShorthand]
-  let schoolnames = entities2map schools
-  let getSchoolname = \sid ->
-        case lookup sid schoolnames of
-          Nothing -> "???"
-          (Just school) -> schoolShorthand school
-  let colonnadeUsers = mconcat $
-        [ headed "User" $ text2widget.userDisplayName.entityVal.fst3
-        , headed "Admin for Schools"   $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userAdminSchool   .entityVal) $ snd3 u)
-        , headed "Lecturer at Schools" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userLecturerSchool.entityVal) $ trd3 u)
+  let
+    dbtColonnade = dbColonnade . mconcat $
+      [ dbRow
+      , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
+          (AdminUserR <$> encrypt uid)
+          (nameWidget userDisplayName userSurname)
+      , sortable (Just "matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
+          (AdminUserR <$> encrypt uid)
+          (toWidget . display $ userMatrikelnummer)
+--       , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
+--           (AdminUserR <$> encrypt uid)
+--           (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
+      , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
+          schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do
+            E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool
+            E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
+            E.orderBy [E.asc $ school E.^. SchoolShorthand]
+            return $ school E.^. SchoolShorthand
+          return [whamlet|
+            <ul .list--inline .list--comma-separated>
+              $forall (E.Value sh) <- schools
+                <li>#{sh}
+            |]
+      , sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
+          schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do
+            E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool
+            E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
+            E.orderBy [E.asc $ school E.^. SchoolShorthand]
+            return $ school E.^. SchoolShorthand
+          return [whamlet|
+            <ul .list--inline .list--comma-separated>
+              $forall (E.Value sh) <- schools
+                <li>#{sh}
+            |]
+      , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
+          (hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm uid
+          cID <- encrypt uid
+          [whamlet|
+            <form method=POST action=@{AdminHijackUserR cID} enctype=#{hijackEnctype}>
+              ^{hijackView}
+          |]
+      ]
+    psValidator = def
+      & defaultSorting [("name", SortAsc),("display-name", SortAsc)]
+  
+  ((), userList) <- dbTable psValidator $ DBTable
+    { dbtSQLQuery  = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
+    , dbtColonnade
+    , dbtProj      = return
+    , dbtSorting   = Map.fromList
+        [ ( "name"
+          , SortColumn $ \user -> user E.^. UserSurname
+          )
+        , ( "display-name"
+          , SortColumn $ \user -> user E.^. UserDisplayName
+          )
+        , ( "matriculation"
+          , SortColumn $ \user -> user E.^. UserMatrikelnummer
+          )
         ]
-        -- ++  map (\school -> headed (text2widget $ schoolName $ entityVal school) (\u -> "xx")) schools
+    , dbtFilter    = mempty
+    , dbtStyle     = def
+    , dbtIdent     = "users" :: Text
+    }
+  
   defaultLayout $ do
-    setTitle "Comprehensive User List"
-    let userList = encodeWidgetTable tableSortable colonnadeUsers users
+    setTitleI MsgUserListTitle
     $(widgetFile "users")
+
+postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
+postAdminHijackUserR cID = do
+  uid <- decrypt cID
+  ((hijackRes, _), _) <- runFormPost $ hijackUserForm uid
+
+  case hijackRes of
+    FormSuccess uid'
+      | uid' == uid -> do
+          myUid <- requireAuthId
+          User{..} <- runDB $ do
+            otherSchoolsAdmin <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] []
+            otherSchoolsLecturer <- Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] []
+            mySchools <- Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. myUid] []
+            when (not $ (otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) $
+              permissionDenied "Cannot escalate admin status to additional schools"
+
+            get404 uid
+          setCredsRedirect $ Creds "dummy" (CI.original userIdent) []
+      | otherwise -> error "This should be impossible by definition of `hijackUserForm`"
+    FormFailure errs -> toTypedContent <$> mapM_ (addMessage Error . toHtml) errs
+    FormMissing -> return $ toTypedContent ()

src/Handler/Utils.hs

@@ -2,21 +2,74 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
 
 
 module Handler.Utils
   ( module Handler.Utils
   ) where
 
+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.Term as Handler.Utils
 import Handler.Utils.Form as Handler.Utils
 import Handler.Utils.Table as Handler.Utils
 import Handler.Utils.Table.Pagination as Handler.Utils
 
-import Handler.Utils.Zip as Handler.Utils
-import Handler.Utils.Rating as Handler.Utils
+import Handler.Utils.Zip        as Handler.Utils
+import Handler.Utils.Rating     as Handler.Utils hiding (extractRatings)
 import Handler.Utils.Submission as Handler.Utils
-import Handler.Utils.Templates as Handler.Utils
+import Handler.Utils.Sheet      as Handler.Utils
+import Handler.Utils.Templates  as Handler.Utils
+
+
+downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
+downloadFiles = do
+  mauth <- liftHandlerT maybeAuth
+  case mauth of
+    Just (Entity _ User{..}) -> return userDownloadFiles
+    Nothing -> 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
+  | null surname = toWidget displayName
+  | otherwise = case reverse $ T.splitOn surname displayName of
+      [_notContained] -> [whamlet|$newline never
+                            #{displayName} (
+                            <b .surname>#{surname}
+                            )|]
+      (suffix:prefixes) ->
+        let prefix = T.intercalate surname $ reverse prefixes
+        in [whamlet|$newline never
+              #{prefix}
+              <b .surname>#{surname}
+              #{suffix}
+            |]
+      [] -> 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/DateTime.hs

@@ -1,56 +1,141 @@
-module Handler.Utils.DateTime where
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , OverloadedStrings
+           , RecordWildCards
+           , TypeFamilies
+  #-}
 
-import Data.Time
+module Handler.Utils.DateTime
+  ( utcToLocalTime
+  , localTimeToUTC, TZ.LocalToUTCResult(..)
+  , formatTime, formatTime', formatTimeW
+  , getTimeLocale, getDateTimeFormat
+  , validDateTimeFormats, dateTimeFormatOptions
+  , addOneWeek
+  ) where
+
+import Import
+
+import Data.Time.Zones hiding (localTimeToUTCFull)
+import qualified Data.Time.Zones as TZ
+
+import Data.Time hiding (formatTime, localTimeToUTC, utcToLocalTime)
+import Data.Time.Clock (addUTCTime,nominalDay)
+import qualified Data.Time.Format as Time
+
+import Data.Set (Set)
+import qualified Data.Set as Set
+
+utcToLocalTime :: UTCTime -> LocalTime
+utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
+
+localTimeToUTC :: LocalTime -> LocalToUTCResult
+localTimeToUTC = TZ.localTimeToUTCFull appTZ
+
+class FormatTime t => HasLocalTime t where
+  toLocalTime :: t -> LocalTime
+
+instance HasLocalTime LocalTime where
+  toLocalTime = id
+
+instance HasLocalTime Day where
+  toLocalTime d = LocalTime d midnight
+
+instance HasLocalTime UTCTime where
+  toLocalTime t = utcToLocalTime t
+
+formatTime' :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => String -> t -> m Text
+formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> pure fmtStr <*> pure (toLocalTime t)
+
+-- formatTime :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => (DateTimeFormat -> String) -> t -> m str
+-- Restricted type for safety
+formatTime :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> t -> m Text
+formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeFormat proj)
+
+-- formatTimeH :: (HasLocalTime t) => SelDateTimeFormat -> t -> Handler Text
+-- formatTimeH = formatTime
+
+formatTimeW :: (HasLocalTime t) => SelDateTimeFormat -> t -> Widget
+formatTimeW s t = toWidget =<< formatTime s t
+
+getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale
+getTimeLocale = getTimeLocale' <$> languages
+
+getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
+getDateTimeFormat sel = do
+  mauth <- liftHandlerT maybeAuth
+  AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
+  let
+    fmt
+      | Just (Entity _ User{..}) <- mauth
+      = case sel of
+          SelFormatDateTime -> userDateTimeFormat
+          SelFormatDate     -> userDateFormat
+          SelFormatTime     -> userTimeFormat
+      | otherwise
+      = case sel of
+          SelFormatDateTime -> userDefaultDateTimeFormat
+          SelFormatDate     -> userDefaultDateFormat
+          SelFormatTime     -> userDefaultTimeFormat
+  return fmt
+
+validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat
+-- ^ We use a whitelist instead of just letting the user specify their own format string since vulnerabilities in printf-like functions are not uncommon
+validDateTimeFormats _ SelFormatDateTime = Set.fromList $
+  [ DateTimeFormat "%a %d %b %Y %R"
+  , DateTimeFormat "%a %b %d %Y %R"
+  , DateTimeFormat "%A, %d %B %Y %R"
+  , DateTimeFormat "%A, %B %d %Y %R"
+  , DateTimeFormat "%a %d %b %Y %T"
+  , DateTimeFormat "%a %b %d %Y %T"
+  , DateTimeFormat "%A, %d %B %Y %T"
+  , DateTimeFormat "%A, %B %d %Y %T"
+  , DateTimeFormat "%d.%m.%Y %R"
+  , DateTimeFormat "%d.%m.%Y %T"
+  , DateTimeFormat "%R %d.%m.%Y"
+  , DateTimeFormat "%T %d.%m.%Y"
+  , DateTimeFormat "%Y-%m-%d %R"
+  , DateTimeFormat "%Y-%m-%d %T"
+  , DateTimeFormat "%Y-%m-%dT%T"
+  ]
+validDateTimeFormats _ SelFormatDate = Set.fromList $
+  [ DateTimeFormat "%a %d %b %Y"
+  , DateTimeFormat "%a %b %d %Y"
+  , DateTimeFormat "%A, %d %B %Y"
+  , DateTimeFormat "%A, %B %d %Y"
+  , DateTimeFormat "%d.%m.%Y"
+  , DateTimeFormat "%Y-%m-%d"
+  ]
+validDateTimeFormats TimeLocale{..} SelFormatTime = Set.fromList . concat . catMaybes $
+  [ Just
+    [ DateTimeFormat "%R"
+    , DateTimeFormat "%T"
+    ]
+  , do
+      guard $ uncurry (/=) amPm
+      Just
+        [ DateTimeFormat "%I:%M %p"
+        , DateTimeFormat "%I:%M %P"
+        , DateTimeFormat "%I:%M:%S %p"
+        , DateTimeFormat "%I:%M:%S %P"
+        ]
+  ]
+
+dateTimeFormatOptions :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m (OptionList DateTimeFormat)
+dateTimeFormatOptions sel = do
+  now <- liftIO getCurrentTime
+  tl <- getTimeLocale
+
+  let
+    toOption fmt@DateTimeFormat{..} = do
+      dateTime <- formatTime' unDateTimeFormat now 
+      return $ (dateTime, fmt)
+  
+  optionsPairs <=< mapM toOption . Set.toList $ validDateTimeFormats tl sel 
 
 
-germanTimeLocale :: TimeLocale 
-germanTimeLocale = TimeLocale 
-  { wDays   = [("Montag"     ,"Mo")
-              ,("Dienstag"   ,"Di")
-              ,("Mittwoch"   ,"Mi")  
-              ,("Donnerstag" ,"Do") 
-              ,("Freitag"    ,"Fr")
-              ,("Samstag"    ,"Sa")  
-              ,("Sonntag"    ,"So") 
-              ]
-  , months  = [("Januar"     ,"Jan")
-              ,("Februar"    ,"Feb")
-              ,("März"       ,"Mär")
-              ,("April"      ,"Apr")
-              ,("Mai"        ,"Mai")
-              ,("Juni"       ,"Jun")
-              ,("Juli"       ,"Jul")
-              ,("August"     ,"Aug")
-              ,("September"  ,"Sep") 
-              ,("Oktober"    ,"Okt")
-              ,("November"   ,"Nov")
-              ,("Dezember"   ,"Dez")
-            ] 
-  , amPm = ("am","pm")
-  , dateTimeFmt = "%a %e.%m.%y %k:%M"
-  , dateFmt     = "%e.%m.%y"
-  , timeFmt     = "%k:%M"
-  , time12Fmt   = "%H:%M"
-  , knownTimeZones = [] -- TODO?
-  }
+addOneWeek :: UTCTime -> UTCTime
+addOneWeek = addUTCTime (7 * nominalDay)
 
-formatTimeGer ::  FormatTime t => String -> t -> String
-formatTimeGer = formatTime germanTimeLocale
+-- addOneTerm? -> Move Handler.Utils.DateTime
 
-formatTimeGerDTlong :: FormatTime t => t -> String
-formatTimeGerDTlong = formatTimeGer "%A, %e. %B %Y, %k:%M:%S"
-
-formatTimeGerWDT :: FormatTime t => t -> String
-formatTimeGerWDT = formatTimeGer $ dateTimeFmt germanTimeLocale
-
-formatTimeGerDT :: FormatTime t => t -> String
-formatTimeGerDT = formatTimeGer "%e.%m.%y %k:%M"
-
-formatTimeGerWD :: FormatTime t => t -> String
-formatTimeGerWD = formatTimeGer "%a %e.%m.%y"
-
-formatTimeGerD :: FormatTime t => t -> String
-formatTimeGerD = formatTimeGer $ dateFmt germanTimeLocale
-
-formatTimeGerT :: FormatTime t => t -> String
-formatTimeGerT = formatTimeGer $ timeFmt germanTimeLocale

src/Handler/Utils/Form.hs

@@ -11,15 +11,26 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE LambdaCase #-}
 
-module Handler.Utils.Form where
+module Handler.Utils.Form
+  ( module Handler.Utils.Form
+  , module Utils.Form
+  ) where
+
+import Utils.Form
 
 import Handler.Utils.Form.Types
+import Handler.Utils.Templates
+
+import Handler.Utils.DateTime
+import qualified Data.Time as Time
 
 import Import
 import qualified Data.Char as Char
-import Handler.Utils.DateTime
 import Data.String (IsString(..))
 
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
 import qualified Data.Foldable as Foldable
 
 -- import Yesod.Core
@@ -28,8 +39,6 @@ import qualified Data.Text as T
 import Yesod.Form.Functions (parseHelper)
 import Yesod.Form.Bootstrap3
 
-import qualified Text.Blaze.Internal as Blaze (null)
-
 import Web.PathPieces (showToPathPiece, readFromPathPiece)
 
 import Handler.Utils.Zip
@@ -38,56 +47,22 @@ import qualified Data.Conduit.List as C
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E
 
+import Data.Set (Set)
 import qualified Data.Set as Set
 
-------------------------------------------------
--- Unique Form Identifiers to avoid accidents --
-------------------------------------------------
+import Data.Map (Map)
+import qualified Data.Map as Map
 
-data FormIdentifier = FIDcourse | FIDsheet
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+import Control.Monad.Writer.Class
 
-
-identForm :: FormIdentifier -> Form a -> Form a
-identForm fid = identifyForm (T.pack $ show fid)
-
-{- Hinweise zur Erinnerung:
-  - identForm primär, wenn es mehr als ein Formular pro Handler gibt
-  - nur einmal pro makeForm reicht
--}
-
--------------------
--- Form Renderer --
--------------------
-
--- | Use this type to pass information to the form template
-data FormLayout = FormStandard
-
-renderAForm :: Monad m => FormLayout -> FormRender m a
-renderAForm formLayout aform fragment = do
-  (res, (($ []) -> views)) <- aFormToForm aform
-  let widget = $(widgetFile "widgets/form")
-  return (res, widget)
+import Data.Scientific (Scientific)
+import Data.Ratio
+import Text.Read (readMaybe)
 
 ----------------------------
 -- Buttons (new version ) --
 ----------------------------
 
-data ButtonCssClass = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
-
-bcc2txt :: ButtonCssClass -> Text -- a Hack; maybe define Read/Show manually
-bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> (drop 2 $ show bcc))
-
-class (Enum a, Bounded a, Ord a, PathPiece a) => Button a where
-  label :: a -> Widget
-  label = toWidget . toPathPiece
-
-  cssClass :: a -> ButtonCssClass
-  cssClass _ = BCDefault
-
-
-
 data BtnDelete = BtnDelete | BtnAbort
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
@@ -95,25 +70,39 @@ instance PathPiece BtnDelete where    -- for displaying the button only, not rea
   toPathPiece   = showToPathPiece
   fromPathPiece = readFromPathPiece
 
-instance Button BtnDelete where
-  label BtnDelete = "Löschen"
-  label BtnAbort  = "Abrechen"
+instance Button UniWorX BtnDelete where
+  label BtnDelete = [whamlet|_{MsgBtnDelete}|]
+  label BtnAbort  = [whamlet|_{MsgBtnAbort}|]
 
   cssClass BtnDelete = BCDanger
   cssClass BtnAbort  = BCDefault
 
-
-data SubmitButton = BtnSubmit
+data RegisterButton = BtnRegister  | BtnDeregister
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
-instance PathPiece SubmitButton where
+instance PathPiece RegisterButton where
   toPathPiece   = showToPathPiece
   fromPathPiece = readFromPathPiece
 
-instance Button SubmitButton where
-  label BtnSubmit = "Submit"
+instance Button UniWorX RegisterButton where
+  label BtnRegister   = [whamlet|_{MsgBtnRegister}|]
+  label BtnDeregister = [whamlet|_{MsgBtnDeregister}|]
+
+  cssClass BtnRegister   = BCPrimary
+  cssClass BtnDeregister = BCDanger
+
+data AdminHijackUserButton = BtnHijack
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance PathPiece AdminHijackUserButton where
+  toPathPiece   = showToPathPiece
+  fromPathPiece = readFromPathPiece
+
+instance Button UniWorX AdminHijackUserButton where
+  label BtnHijack = [whamlet|_{MsgBtnHijack}|]
+
+  cssClass BtnHijack = BCDefault
 
-  cssClass BtnSubmit = BCPrimary
 
 -- -- Looks like a button, but is just a link (e.g. for create course, etc.)
 -- data LinkButton = LinkButton (Route UniWorX)
@@ -122,7 +111,7 @@ instance Button SubmitButton where
 -- instance PathPiece LinkButton where
 --     LinkButton route = ???
 
-linkButton :: Widget -> ButtonCssClass -> 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}>
@@ -131,32 +120,6 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
 --   |]
   --  <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
 
-
-buttonField :: Button a => a -> Field Handler a
-buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
-  where
-    fieldEnctype = UrlEncoded
-
-    fieldView fid name attrs _val _ =
-      [whamlet|
-        <button .btn .#{bcc2txt $ cssClass btn} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
-      |]
-
-    fieldParse []    _ = return $ Right Nothing
-    fieldParse [str] _
-      | str == toPathPiece btn = return $ Right $ Just btn
-      | otherwise  = return $ Left "Wrong button value"
-    fieldParse _ _ = return $ Left "Multiple button values"
-
-
-combinedButtonField :: Button a => [a] -> AForm Handler [Maybe a]
-combinedButtonField btns = traverse b2f btns
-  where
-    b2f b = aopt (buttonField b) "" Nothing
-
-submitButton :: AForm Handler ()
-submitButton = void $ combinedButtonField [BtnSubmit]
-
     {-
 combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
 combinedButtonField btns inner csrf = do
@@ -190,7 +153,7 @@ combinedButtonField btns inner csrf = do
     -}
 
 -- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
-buttonForm :: (Button a) => Form a
+buttonForm :: (Button UniWorX a) => Form a
 buttonForm csrf = do
     buttonIdent <- newFormIdent
     let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
@@ -220,6 +183,11 @@ buttonForm csrf = do
 -- Fields --
 ------------
 
+-- ciField moved to Utils.Form
+
+natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
+natFieldI msg = checkBool (>= 0) msg intField
+
 natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
 natField d = checkBool (>= 0) (T.append  d " muss eine natürliche Zahl sein.") $ intField
 
@@ -232,18 +200,51 @@ posIntField d = checkBool (>= 1) (T.append  d " muss eine positive Zahl sein.")
 minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
 minIntField m d = checkBool (>= m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) $ intField
 
+pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points --TODO allow fractions
+pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
+  where
+    fieldEnctype = UrlEncoded
+    fieldView theId name attrs val isReq
+      = [whamlet|
+          $newline never
+          <input id=#{theId} name=#{name} *{attrs} type=number step="0.01" :isReq:required value=#{either id tshow val}>
+        |]
+    fieldParse = parseHelper $ \t -> do
+      sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific)
+      return . fromRational $ round (sci * 100) % 100
 
---termField: see Utils.Term
+
+termsActiveField :: Field Handler TermId
+termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [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 (return.termFromText) termToText textField
 
 schoolField :: Field Handler SchoolId
-schoolField = selectField schools
-  where
-    schools = optionsPersistKey [] [Asc SchoolName] schoolName
+schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName
 
-schoolEntField :: Field Handler (Entity School)
-schoolEntField = selectField schools
-  where
-    schools = optionsPersist [] [Asc SchoolName] schoolName
+schoolFieldEnt :: Field Handler (Entity School)
+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)
@@ -327,84 +328,59 @@ sheetGroupAFormReq d _other = -- TODO
   -- TODO, offer options to choose between Arbitrary/Registered/NoGroups
   Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1)
 
-utcTimeField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m UTCTime
+{-
+dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime
+dayTimeField fs mutc = do
+    let (mbDay,mbTime) = case mutcs of
+          Nothing    -> return (Nothing,Nothing)
+          (Just utc) ->
+
+    (dayResult, dayView) <- mreq dayField fs
+
+    (result, view) <- (,) <$> dayField <*> timeField
+  where
+    (mbDay,mbTime)
+      | (Just utc) <- mutc =
+          let lt = utcToLocalTime ??? utcs
+          in  (Just $ localDay lt, Just $ localTimeOfDay lt)
+      | otherwise = (Nothing,Nothing)
+-}
+
+
+utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
 -- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
--- TODO: Verify whether this is UTC or local time from Browser
+-- Browser returns LocalTime
 utcTimeField = Field
-    { fieldParse = parseHelper $ readTime
-    , fieldView = \theId name attrs val isReq ->
+    { fieldParse = parseHelperGen $ readTime
+    , fieldView = \theId name attrs val isReq -> do
+        val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val
         [whamlet|
           $newline never
-          <input id="#{theId}" name="#{name}" *{attrs} type="datetime-local" :isReq:required value="#{either id showTime val}">
+          <input id="#{theId}" name="#{name}" *{attrs} type="datetime-local" :isReq:required value="#{val'}">
         |]
     , fieldEnctype = UrlEncoded
     }
   where
     fieldTimeFormat :: String
     --fieldTimeFormat = "%e.%m.%y %k:%M"
-    fieldTimeFormat = "%Y-%m-%eT%H:%M"
-
-    readTime :: Text -> Either FormMessage UTCTime
+    fieldTimeFormat = "%Y-%m-%dT%H:%M"
+    
+    -- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any 
+    readTime :: Text -> Either UniWorXMessage UTCTime
     readTime t =
-      case parseTimeM True germanTimeLocale fieldTimeFormat (T.unpack t) of
-        (Just time) -> Right time
-        Nothing -> Left $ MsgInvalidEntry $ "Datum/Zeit Format: tt.mm.yy hh:mm " ++ t
-
-    showTime :: UTCTime -> Text
-    showTime = fromString . (formatTime germanTimeLocale fieldTimeFormat)
+      case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
+        (Just (LTUUnique time _))     -> Right time
+        (Just (LTUNone _ _))          -> Left MsgIllDefinedUTCTime
+        (Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime
+        Nothing -> Left MsgInvalidDateTimeFormat
 
 
-fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX
-fsm = bfs
+fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
+fsm = bfs -- TODO: get rid of Bootstrap
 
-fsb :: Text -> FieldSettings site
+fsb :: Text -> FieldSettings site -- DEPRECATED
 fsb = bfs -- Just to avoid annoying Ambiguous Type Errors
 
-addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
-addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
-  where
-    newAttrs :: [(Text,Text)] -> [(Text,Text)]
-    newAttrs [] = [(attr,valu)]
-    newAttrs (p@(a,v):t)
-      | attr==a   = (a,T.append valu $ cons ' ' v):t
-      | otherwise = p:(newAttrs t)
-
-addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
-addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
-  where
-    newAttrs :: [(Text,Text)] -> [(Text,Text)]
-    newAttrs [] = [(attr,T.intercalate " " valus)]
-    newAttrs (p@(a,v):t)
-      | attr==a   = (a,T.intercalate " " (v:valus)):t
-      | otherwise = p:(newAttrs t)
-
-addClass :: Text -> FieldSettings site -> FieldSettings site
-addClass = addAttr "class"
-
-addClasses :: [Text] -> FieldSettings site -> FieldSettings site
-addClasses = addAttrs "class"
-
-addName :: Text -> FieldSettings site -> FieldSettings site
-addName nm fs = fs { fsName = Just nm }
-
-addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
-addNameClass gName gClass fs = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
-
-addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
-addIdClass gId gClass fs = fs { fsId= Just gId, fsAttrs=("class",gClass):(fsAttrs fs) }
-
-
-setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated
-setClass fs c = fs { fsAttrs=("class",c):(fsAttrs fs) }
-
-setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
-setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
-
-setTooltip :: String -> FieldSettings site -> FieldSettings site
-setTooltip tt fs
-  | null tt   = fs { fsTooltip = Nothing }
-  | otherwise = fs { fsTooltip = Just $ fromString tt }
-
 optionsPersistCryptoId :: forall site backend a msg.
                           ( YesodPersist site
                           , PersistQueryRead backend
@@ -416,13 +392,61 @@ optionsPersistCryptoId :: forall site backend a msg.
                        => [Filter a]
                        -> [SelectOpt a]
                        -> (a -> msg)
-                       -> HandlerT site IO (OptionList (Key a))
+                       -> HandlerT site IO (OptionList (Entity a))
 optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
   mr <- getMessageRender
   pairs <- runDB $ selectList filts ords
   cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e
-  return $ map (\(cId, Entity key value) -> Option
+  return $ map (\(cId, e@(Entity key value)) -> Option
                  { optionDisplay = mr (toDisplay value)
-                 , optionInternalValue = key
+                 , optionInternalValue = e
                  , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
                  }) cPairs
+
+optionsFinite :: ( MonadHandler m, Finite a, RenderMessage site msg, HandlerSite m ~ site, PathPiece a )
+              => (a -> msg) -> m (OptionList a)
+optionsFinite toMsg = do
+  mr <- getMessageRender
+  let
+    mkOption a = Option
+      { optionDisplay       = mr $ toMsg a
+      , optionInternalValue = a
+      , optionExternalValue = toPathPiece a
+      }
+  return . mkOptionList $ mkOption <$> universeF
+
+mforced :: (site ~ HandlerSite m, MonadHandler m)
+        => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
+mforced Field{..} FieldSettings{..} val = do
+  tell fieldEnctype
+  name <- maybe newFormIdent return fsName
+  theId <- lift $ maybe newIdent return fsId
+  mr <- getMessageRender
+  let fsAttrs' = fsAttrs <> [("disabled", "")]
+  return ( FormSuccess val
+         , FieldView
+           { fvLabel = toHtml $ mr fsLabel
+           , fvTooltip = toHtml <$> fmap mr fsTooltip
+           , fvId = theId
+           , fvInput = fieldView theId name fsAttrs' (Right val) False
+           , fvErrors = Nothing
+           , fvRequired = False
+           }
+         )
+
+aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
+        => Field m a -> FieldSettings site -> a -> AForm m a
+aforced field settings val = formToAForm $ second pure <$> mforced field settings val
+
+multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
+            => Map action (MForm (HandlerT UniWorX IO) (FormResult a, Maybe Widget))
+            -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
+multiAction acts = do
+  mr <- getMessageRender
+  let
+    options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
+  (actionRes, actionView) <- mreq (selectField $ return options) "" Nothing
+  results <- sequence acts
+  let actionWidgets = Map.foldrWithKey (\act -> \case (_, Just w) -> ($(widgetFile "widgets/multiAction") :); (_, Nothing) -> id) [] results
+      actionResults = Map.map fst results
+  return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))

src/Handler/Utils/Rating.hs

@@ -66,8 +66,10 @@ instance Pretty x => Pretty (CI x) where
 
 
 data Rating = Rating
-  { ratingCourseName :: Text
-  , ratingSheetName :: Text
+  { ratingCourseName :: CourseName
+  , ratingSheetName :: SheetName
+  , ratingCorrectorName :: Maybe Text
+  , ratingSheetType :: SheetType
   , ratingValues :: Rating'
   } deriving (Read, Show, Eq, Generic, Typeable)
 
@@ -89,15 +91,18 @@ instance Exception RatingException
 
 getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)
 getRating submissionId = runMaybeT $ do
-  let query = E.select . E.from $ \(submission `E.InnerJoin` sheet `E.InnerJoin` course) -> do
-        E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
-        E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheetId
+  let query = E.select . E.from $ \(corrector `E.RightOuterJoin` (submission `E.InnerJoin` sheet `E.InnerJoin` course)) -> do
+        E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
+        E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
+        E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
 
         E.where_ $ submission E.^. SubmissionId E.==. E.val submissionId
 
         -- Yes, we can only pass a tuple through 'E.select'
         return ( course E.^. CourseName
                , sheet E.^. SheetName
+               , corrector E.?. UserDisplayName
+               , sheet E.^. SheetType
                , submission E.^. SubmissionRatingPoints
                , submission E.^. SubmissionRatingComment
                , submission E.^. SubmissionRatingTime
@@ -105,6 +110,8 @@ getRating submissionId = runMaybeT $ do
 
   [ ( E.unValue -> ratingCourseName
     , E.unValue -> ratingSheetName
+    , E.unValue -> ratingCorrectorName
+    , E.unValue -> ratingSheetType
     , E.unValue -> ratingPoints
     , E.unValue -> ratingComment
     , E.unValue -> ratingTime
@@ -117,14 +124,16 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
   doc = renderPretty 1 45 $ foldr (<$$>) mempty
     [ "= Bitte nur Bewertung und Kommentare ändern ="
     , "============================================="
-    , "========== UniWorx Bewertungsdatei =========="
+    , "========== Uni2work Bewertungsdatei ========="
     , "======= diese Datei ist UTF8 encodiert ======"
     , "Informationen zum Übungsblatt:"
-    , indent 2 $ foldr (<$$>) mempty
-      [ "Veranstaltung:" <+> pretty ratingCourseName
-      , "Blatt:" <+> pretty ratingSheetName
+    , indent 2 . foldr (<$$>) mempty . catMaybes $
+      [ Just $ "Veranstaltung:" <+> pretty ratingCourseName
+      , Just $ "Blatt:" <+> pretty ratingSheetName
+      , ("Korrektor:" <+>) . pretty <$> ratingCorrectorName
+      , Just $ "Bewertung:" <+> pretty (display ratingSheetType)
       ]
-    , "Abgabe-Id:" <+> pretty (ciphertext cID)
+    , "Abgabe-Id:" <+> pretty (Text.unpack $ toPathPiece cID)
     , "============================================="
     , "Bewertung:" <+> pretty ratingPoints
     , "=========== Beginn der Kommentare ==========="
@@ -136,7 +145,7 @@ ratingFile :: MonadIO m => CryptoFileNameSubmission -> Rating -> m File
 ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do
   fileModified <- maybe (liftIO getCurrentTime) return ratingTime
   let
-    fileTitle = "bewertung_" <> (CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)) <.> "txt"
+    fileTitle = "bewertung_" <> (Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)) <.> "txt"
     fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating
   return File{..}
 
@@ -144,9 +153,11 @@ parseRating :: MonadThrow m => File -> m Rating'
 parseRating File{ fileContent = Just input, .. } = do
   inputText <- either (throw . RatingNotUnicode) return $ Text.decodeUtf8' input
   let
-    (headerLines, commentLines) = break (sep `Text.isInfixOf`) $ Text.lines inputText
-    ratingLines = filter (rating `Text.isInfixOf`) headerLines
+    (headerLines', commentLines) = break (sep `Text.isInfixOf`) $ Text.lines inputText
+    (reverse -> ratingLines, reverse -> headerLines) = break (sep' `Text.isInfixOf`) $ reverse headerLines'
+    ratingLines' = filter (rating `Text.isInfixOf`) ratingLines
     sep = "Beginn der Kommentare"
+    sep' = Text.pack $ replicate 40 '='
     rating = "Bewertung:"
   comment' <- case commentLines of
     (_:commentLines') -> return . Text.strip $ Text.unlines commentLines'
@@ -201,7 +212,8 @@ isRatingFile fName
 isRatingFile' :: FilePath -> Maybe CryptoFileNameSubmission
 isRatingFile' (takeFileName -> fName)
   | (bName, ".txt") <- splitExtension fName
-  , Just (CI.mk -> ciphertext) <- stripPrefix "bewertung_" bName
-  = Just CryptoID{..}
+  , Just piece <- stripPrefix "bewertung_" bName
+  , Just cID <- fromPathPiece $ Text.pack piece
+  = Just cID
   | otherwise
   = Nothing

src/Handler/Utils/Sheet.hs

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

src/Handler/Utils/Submission.hs

@@ -8,28 +8,272 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 
 module Handler.Utils.Submission
-  ( SubmissionSinkException(..)
-  , sinkSubmission
+  ( AssignSubmissionException(..)
+  , assignSubmissions
+  , submissionBlacklist, filterSubmission, extractRatings, extractRatingsMsg
+  , submissionFileSource, submissionFileQuery
+  , submissionMultiArchive 
+  , SubmissionSinkException(..)
+  , sinkSubmission, sinkMultiSubmission
+  , submissionMatchesSheet
   ) where
 
-import Import
+import Import hiding ((.=), joinPath)
+import Prelude (lcm)
+import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
 
-import Control.Monad.State hiding (forM_)
+import Control.Lens
+import Control.Lens.Extras (is)
+import Utils.Lens
 
+import Control.Monad.State hiding (forM_, mapM_,foldM)
+import Control.Monad.Writer (MonadWriter(..), execWriterT)
+import Control.Monad.RWS.Lazy (RWST)
+import qualified Control.Monad.Random as Rand
+import qualified System.Random.Shuffle as Rand (shuffleM)
+
+import Data.Maybe
+
+import qualified Data.List as List
 import Data.Set (Set)
 import qualified Data.Set as Set
-  
-import Data.Monoid (Monoid, Any(..))
+import Data.Map (Map, (!?))
+import qualified Data.Map as Map
+
+import qualified Data.Text as Text
+import Data.Ratio
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
+import Data.Monoid (Monoid, Any(..), Sum(..))
 import Generics.Deriving.Monoid (memptydefault, mappenddefault)
 
-import Handler.Utils.Rating
+import Handler.Utils.Rating hiding (extractRatings)
+import qualified Handler.Utils.Rating as Rating (extractRatings)
+import Handler.Utils.Zip
+import Handler.Utils.Sheet
+import Handler.Utils.Submission.TH
 
 import qualified Database.Esqueleto as E
 
+import Data.Conduit
 import qualified Data.Conduit.List as Conduit
+import Data.Conduit.ResumableSink
+
+import System.FilePath
+import System.FilePath.Glob
+
+import Text.Hamlet (ihamletFile)
+
+import qualified Control.Monad.Catch as E (Handler(..))
+
+
+data AssignSubmissionException = NoCorrectorsByProportion
+  deriving (Typeable, Show)
+
+instance Exception AssignSubmissionException
+
+-- | Assigns all submissions according to sheet corrector loads
+assignSubmissions :: SheetId -- ^ Sheet do distribute to correction
+                  -> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
+                  -> YesodDB UniWorX ( Set SubmissionId -- ^ assigned submissions
+                                     , Set SubmissionId -- ^ unassigend submissions (no tutors by load)
+                                     )
+assignSubmissions sid restriction = do
+    Sheet{..} <- getJust sid
+    correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] []
+    let
+      byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ]
+      corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto
+      corrsProp  = filter hasPositiveLoad correctors
+      countsToLoad' :: UserId -> Bool
+      countsToLoad' uid = Map.findWithDefault True uid loadMap
+      loadMap :: Map UserId Bool
+      loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsTutorial]
+
+    currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor) -> do
+        let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do
+              -- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group
+              -- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do
+                E.on (tutorial       E.^. TutorialId         E.==. tutorialUser E.^. TutorialUserTutorial)
+                E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser)
+                E.where_ (tutorial   E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial))
+                return $ tutorial E.^. TutorialTutor
+        E.on $ tutor E.?. UserId `E.in_` E.justList tutors
+        E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid
+             E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction)
+        return (submission E.^. SubmissionId, tutor)
+
+    let subTutor' :: Map SubmissionId (Set UserId)
+        subTutor' = Map.fromListWith Set.union $ currentSubs
+          & mapped._2 %~ maybe Set.empty Set.singleton
+          & mapped._2 %~ Set.mapMonotonic entityKey
+          & mapped._1 %~ E.unValue
+
+    prevSubs <- E.select . E.from $ \((sheet `E.InnerJoin` sheetCorrector) `E.LeftOuterJoin` submission) -> do
+        E.on $ E.joinV (submission E.?. SubmissionRatingBy) E.==. E.just (sheetCorrector E.^. SheetCorrectorUser)
+        E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
+        let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do
+              E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial
+              E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser
+              E.where_ $ tutorial E.^. TutorialTutor E.==. sheetCorrector E.^. SheetCorrectorUser
+                   E.&&. submission E.?. SubmissionId E.==. E.just (submissionUser E.^. SubmissionUserSubmission)
+        E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse
+             E.&&. sheetCorrector E.^. SheetCorrectorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) correctors)
+        return (sheetCorrector, isByTutorial, E.isNothing (submission E.?. SubmissionId))
+
+    let
+      prevSubs' :: Map SheetId (Map UserId (Rational, Integer))
+      prevSubs' = Map.unionsWith (Map.unionWith $ \(prop, n) (_, n') -> (prop, n + n')) $ do
+        (Entity _ sc@SheetCorrector{ sheetCorrectorLoad = Load{..}, .. }, E.Value isByTutorial, E.Value isPlaceholder) <- prevSubs
+        guard $ maybe True (not isByTutorial ||) byTutorial
+        let proportion
+              | CorrectorExcused <- sheetCorrectorState = 0
+              | otherwise                               = byProportion
+        return . Map.singleton sheetCorrectorSheet $ Map.singleton sheetCorrectorUser (proportion, bool 1 0 isPlaceholder)
+
+      deficit :: Map UserId Integer
+      deficit = Map.filter (> 0) $ Map.foldr (Map.unionWith (+) . toDeficit) Map.empty prevSubs'
+
+      toDeficit :: Map UserId (Rational, Integer) -> Map UserId Integer
+      toDeficit assignments = toDeficit' <$> assignments
+        where
+          assigned' = getSum $ foldMap (Sum . snd) assignments
+          props = getSum $ foldMap (Sum . fst) assignments
+
+          toDeficit' (prop, assigned) = let
+              target = round $ fromInteger assigned' * (prop / props)
+            in target - assigned
+
+    $logDebugS "assignSubmissions" $ "Previous submissions: " <> tshow prevSubs'
+    $logDebugS "assignSubmissions" $ "Current deficit: " <> tshow deficit
+
+    let
+      lcd :: Integer
+      lcd = foldr lcm 1 $ map (denominator . byProportion . sheetCorrectorLoad . entityVal) corrsProp
+      wholeProps :: Map UserId Integer
+      wholeProps = Map.fromList [ ( sheetCorrectorUser, round $ byProportion * fromInteger lcd ) | Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. } <- corrsProp ]
+      detQueueLength = fromIntegral (Map.size $ Map.filter (\tuts -> all countsToLoad' tuts) subTutor') - sum deficit
+      detQueue = concat . List.genericReplicate (detQueueLength `div` sum wholeProps) . concatMap (uncurry $ flip List.genericReplicate) $ Map.toList wholeProps
+    
+    $logDebugS "assignSubmissions" $ "Deterministic Queue: " <> tshow detQueue
+    
+    queue <- liftIO . Rand.evalRandIO . execWriterT $ do
+      tell $ map Just detQueue
+      forever $
+        tell . pure =<< Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp ]
+
+    $logDebugS "assignSubmissions" $ "Queue: " <> tshow (take (Map.size subTutor') queue)
+
+    let
+      assignSubmission :: MonadState (Map SubmissionId UserId, [Maybe UserId], Map UserId Integer) m => Bool -> SubmissionId -> UserId -> m ()
+      assignSubmission countsToLoad smid tutid = do
+        _1 %= Map.insert smid tutid
+        _3 . at tutid %= assertM' (> 0) . maybe (-1) pred
+        when countsToLoad $
+          _2 %= List.delete (Just tutid)
+
+      maximumDeficit :: (MonadState (_a, _b, Map UserId Integer) m, MonadIO m) => m (Maybe UserId)
+      maximumDeficit = do
+        transposed <- uses _3 invertMap 
+        traverse (liftIO . Rand.evalRandIO . Rand.uniform . snd) (Map.lookupMax transposed)
+
+    subTutor'' <- liftIO . Rand.evalRandIO . Rand.shuffleM $ Map.toList subTutor'
+          
+    subTutor <- fmap (view _1) . flip execStateT (Map.empty, queue, deficit) . forM_ subTutor'' $ \(smid, tuts) -> do
+      let
+        restrictTuts
+          | Set.null tuts = id
+          | otherwise     = flip Map.restrictKeys tuts
+      byDeficit <- withStateT (over _3 restrictTuts) maximumDeficit
+      case byDeficit of
+        Just q' -> do
+          $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (byDeficit)"
+          assignSubmission False smid q'
+        Nothing 
+          | Set.null tuts -> do
+              q <- preuse $ _2 . _head . _Just
+              case q of
+                Just q' -> do
+                  $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (queue)"
+                  assignSubmission True smid q'
+                Nothing -> return ()
+          | otherwise -> do
+              q <- liftIO . Rand.evalRandIO $ Rand.uniform tuts
+              $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q <> " (tutorial)"
+              assignSubmission (countsToLoad' q) smid q
+
+    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
+    return (assignedSubmissions, unassigendSubmissions)
+    where
+      hasPositiveLoad = (> 0)  . byProportion . sheetCorrectorLoad . entityVal
+      hasTutorialLoad = isJust . byTutorial   . sheetCorrectorLoad . entityVal
+
+
+submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
+submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery
+
+submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
+                        -> E.SqlQuery (E.SqlExpr (Entity SubmissionFile), E.SqlExpr (Entity File))
+submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
+  E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
+  E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
+  E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor
+  E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]  -- E.desc returns corrector updated data first
+  return (sf, f)
+
+submissionMultiArchive :: Set SubmissionId -> Handler TypedContent
+submissionMultiArchive (Set.toList -> ids) = do
+  (dbrunner, cleanup) <- getDBRunner
+
+  ratedSubmissions <- runDBRunner dbrunner $ do
+    submissions <- selectList [ SubmissionId <-. ids ] []
+    forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
+  
+  (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
+    let
+      fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
+      fileEntitySource' (rating, Entity submissionID Submission{..}) = do
+        cID <- encrypt submissionID
+
+        let
+          directoryName = Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)
+              
+          fileEntitySource = do
+            submissionFileSource submissionID =$= Conduit.map entityVal
+            yieldM (ratingFile cID rating)
+
+          withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
+
+        lastEditMb <- lift $ selectList [SubmissionEditSubmission ==. submissionID] [Desc SubmissionEditTime, LimitTo 1]
+        lastEditTime <- case lastEditMb of
+          [(submissionEditTime.entityVal -> time)] -> return time
+          _other -> liftIO getCurrentTime
+        yield $ File
+          { fileModified = lastEditTime
+          , fileTitle = directoryName
+          , fileContent = Nothing
+          }
+
+        fileEntitySource =$= mapC withinDirectory
+          
+    mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
+
+
+
 
 
 data SubmissionSinkState = SubmissionSinkState
@@ -45,14 +289,50 @@ instance Monoid SubmissionSinkState where
 data SubmissionSinkException = DuplicateFileTitle FilePath
                              | DuplicateRating
                              | RatingWithoutUpdate
-                             | ForeignRating
+                             | ForeignRating CryptoFileNameSubmission
   deriving (Typeable, Show)
 
 instance Exception SubmissionSinkException
 
-sinkSubmission :: SheetId
-               -> UserId
-               -> Maybe (SubmissionId, Bool {-^ Is this a correction -})
+submissionBlacklist :: [Pattern]
+submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
+
+filterSubmission :: MonadLogger m => ConduitM File File m (Set FilePath)
+-- ^ Removes all `File`s matching `submissionBlacklist`, returning their `fileTitle`s
+filterSubmission = do
+  $logDebugS "filterSubmission" $ tshow submissionBlacklist
+  execWriterLC . awaitForever $ \case
+    File{fileTitle}
+      | any (`match'` fileTitle) submissionBlacklist -> tell $ Set.singleton fileTitle
+    file -> yield file
+  where
+    match' = matchWith $ matchDefault
+      { matchDotsImplicitly = True -- Special treatment for . makes no sense since we're multiplatform
+      }
+
+extractRatings :: ( MonadHandler m
+                  , HandlerSite m ~ UniWorX
+                  , MonadCatch m
+                  , MonadLogger m
+                  ) => ConduitM File SubmissionContent m (Set FilePath)
+extractRatings = filterSubmission `fuseUpstream` Rating.extractRatings
+
+extractRatingsMsg :: ( MonadHandler m
+                     , HandlerSite m ~ UniWorX
+                     , MonadCatch m
+                     , MonadLogger m
+                     ) => Conduit File m SubmissionContent
+extractRatingsMsg = do
+  ignored' <- filterSubmission `fuseUpstream` Rating.extractRatings
+  let ignored :: Set (Either CryptoFileNameSubmission FilePath)
+      ignored = Right `Set.map` ignored'
+  unless (null ignored) $ do
+    mr <- (toHtml . ) <$> getMessageRender
+    addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
+
+sinkSubmission :: UserId
+               -> Either SheetId SubmissionId
+               -> Bool -- ^ Is this a correction
                -> Sink SubmissionContent (YesodDB UniWorX) SubmissionId
 -- ^ Replace the currently saved files for the given submission (either
 --   corrected files or original ones, depending on arguments) with the supplied
@@ -62,36 +342,41 @@ sinkSubmission :: SheetId
 -- are deleted (or marked as deleted in the case of this being a correction).
 --
 -- A 'Submission' is created if no 'SubmissionId' is supplied
-sinkSubmission sheetId userId mExists = do
-  now <- liftIO getCurrentTime
-  let
-    submissionSheetId       = sheetId
-    submissionRatingPoints  = Nothing
-    submissionRatingComment = Nothing
-    submissionRatingBy      = Nothing
-    submissionRatingTime    = Nothing
-
-  (sId, isUpdate) <- lift $ maybe ((, False) <$> (insert Submission{..} >>= (\sid -> sid <$ insert (SubmissionEdit userId now sid)))) return mExists
+sinkSubmission userId mExists isUpdate = do
+  sId <- lift $ case mExists of
+    Left sheetId -> do
+      let
+        submissionSheet          = sheetId
+        submissionRatingPoints   = Nothing
+        submissionRatingComment  = Nothing
+        submissionRatingBy       = 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
+      return sId
+    Right sId -> return sId
 
   sId <$ sinkSubmission' sId isUpdate
   where
     tell = modify . mappend
 
     sinkSubmission' :: SubmissionId
-                   -> Bool -- ^ Is this a correction
-                   -> Sink SubmissionContent (YesodDB UniWorX) ()
+                    -> Bool -- ^ Is this a correction
+                    -> Sink SubmissionContent (YesodDB UniWorX) ()
     sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
       Left file@(File{..}) -> do
         $logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
-        
+
         alreadySeen <- gets (Set.member fileTitle . sinkFilenames)
         when alreadySeen . throwM $ DuplicateFileTitle fileTitle
         tell $ mempty{ sinkFilenames = Set.singleton fileTitle  }
 
         otherVersions <- lift . E.select . E.from $ \(sf `E.InnerJoin` f) -> do
-          E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId
-          E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId
+          E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
+          E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
           -- E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
           E.where_ $ f E.^. FileTitle E.==. E.val fileTitle -- 'Zip.hs' normalises filenames already, so this should work
           return (f, sf)
@@ -121,8 +406,8 @@ sinkSubmission sheetId userId mExists = do
             _   -> do
               fileId <- insert file
               insert_ $ SubmissionFile
-                { submissionFileSubmissionId = submissionId
-                , submissionFileFileId = fileId
+                { submissionFileSubmission = submissionId
+                , submissionFileFile = fileId
                 , submissionFileIsUpdate = isUpdate
                 , submissionFileIsDeletion = False
                 }
@@ -133,7 +418,9 @@ sinkSubmission sheetId userId mExists = do
       Right (submissionId', Rating'{..}) -> do
         $logDebugS "sinkSubmission" $ tshow submissionId'
 
-        unless (submissionId' == submissionId) $ throwM ForeignRating
+        unless (submissionId' == submissionId) $ do
+          cID <- encrypt submissionId'
+          throwM $ ForeignRating cID
         
         alreadySeen <- gets $ getAny . sinkSeenRating
         when alreadySeen $ throwM DuplicateRating
@@ -184,13 +471,14 @@ sinkSubmission sheetId userId mExists = 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 ()
         finalize SubmissionSinkState{..} = do
           missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
-            E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId
-            E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId
+            E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
+            E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
             when (not isUpdate) $
               E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
             E.where_ $ f E.^. FileTitle `E.notIn` E.valList (Set.toList sinkFilenames)
@@ -202,8 +490,8 @@ sinkSubmission sheetId userId mExists = do
             False -> deleteCascadeWhere [ FileId <-. [ fileId | (Entity fileId _, _) <- missingFiles ] ]
             True  -> forM_ missingFiles $ \(Entity fileId File{..}, Entity sfId SubmissionFile{..}) -> do
               shadowing <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
-                E.on $ sf E.^. SubmissionFileFileId E.==. f E.^. FileId
-                E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionId
+                E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
+                E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionId
                 E.where_ $ sf E.^. SubmissionFileIsUpdate E.==. E.val (not isUpdate)
                 E.where_ $ f E.^. FileTitle E.==. E.val fileTitle
                 return $ f E.^. FileId
@@ -212,13 +500,13 @@ sinkSubmission sheetId userId mExists = do
                 ([], _) -> deleteCascade fileId
                 (E.Value f:_, False) -> do
                   insert_ $ SubmissionFile
-                    { submissionFileSubmissionId = submissionId
-                    , submissionFileFileId = f
+                    { submissionFileSubmission = submissionId
+                    , submissionFileFile = f
                     , submissionFileIsUpdate = True
                     , submissionFileIsDeletion = True
                     }
                 (E.Value f:_, True) -> do
-                  update sfId [ SubmissionFileFileId =. f, SubmissionFileIsDeletion =. True ]
+                  update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ]
                   deleteCascade fileId
 
           when (isUpdate && not (getAny sinkSeenRating)) $
@@ -228,3 +516,99 @@ sinkSubmission sheetId userId mExists = do
               , SubmissionRatingBy =. Nothing
               , SubmissionRatingComment =. Nothing
               ]
+
+data SubmissionMultiSinkException
+  = SubmissionSinkException
+    { submissionSinkId :: CryptoFileNameSubmission
+    , submissionSinkFedFile :: Maybe FilePath
+    , submissionSinkException :: SubmissionSinkException
+    }                                   
+  deriving (Typeable, Show)
+
+instance Exception SubmissionMultiSinkException
+
+sinkMultiSubmission :: UserId
+                    -> Bool {-^ Are these corrections -}
+                    -> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId)
+               
+-- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'.
+--
+-- Files that don't occur in the 'SubmissionContent' but are in the database are deleted (or marked as deleted in the case of this being a correction).
+--
+-- In contrast to `sinkSubmission` this function does authorization-checks against `CorrectionR`
+sinkMultiSubmission userId isUpdate = do
+  let
+    feed :: SubmissionId
+         -> SubmissionContent
+         -> RWST
+              ()
+              _
+              (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId))
+              (YesodDB UniWorX)
+              ()
+    feed sId val = do
+      mSink <- gets $ Map.lookup sId
+      sink <- case mSink of
+        Just sink -> return sink
+        Nothing -> do
+          lift $ do
+            cID <- encrypt sId
+            $(logDebugS) "sinkMultiSubmission" $ "Doing auth checks for " <> toPathPiece cID 
+            Submission{..} <- get404 sId
+            Sheet{..} <- get404 submissionSheet
+            Course{..} <- get404 sheetCourse
+            guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseSchool courseShorthand sheetName cID CorrectionR) True
+          return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate
+      sink' <- lift $ yield val ++$$ sink
+      case sink' of
+        Left _ -> error "sinkSubmission returned prematurely"
+        Right nSink -> modify $ Map.insert sId nSink
+  (sinks, ignored) <- execRWSLC () Map.empty . awaitForever $ \case
+    v@(Right (sId, _)) -> do
+      cID <- encrypt sId
+      $logDebugS "sinkMultiSubmission" $ "Feeding rating for " <> toPathPiece cID
+      lift (feed sId v) `catches` [ E.Handler (throwM . SubmissionSinkException cID Nothing), E.Handler (void . handleHCError (Left cID)) ]
+    (Left f@File{..})  -> do
+      let
+        acc :: (Maybe SubmissionId, [FilePath]) -> FilePath -> _ (Maybe SubmissionId, [FilePath])
+        acc (Just sId, fp) segment = return (Just sId, fp ++ [segment])
+        acc (Nothing , fp) segment = do
+          let
+            tryDecrypt (Text.pack -> ciphertext)
+              | Just cID <- fromPathPiece ciphertext = do
+                  sId <- decrypt (cID :: CryptoFileNameSubmission)
+                  Just sId <$ get404 sId
+              | otherwise = return Nothing
+          msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]
+          return (msId, fp)
+      (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
+      case msId of
+        Nothing -> do
+          $logDebugS "sinkMultiSubmission" $ "Dropping " <> tshow (splitDirectories fileTitle, msId, fileTitle')
+        Just sId -> do
+          $logDebugS "sinkMultiSubmission" $ "Feeding " <> tshow (splitDirectories fileTitle, msId, fileTitle')
+          cID <- encrypt sId
+          handle (throwM . SubmissionSinkException cID (Just fileTitle)) $
+            lift . feed sId $ Left f{ fileTitle = fileTitle' }
+  when (not $ null ignored) $ do
+    mr <- (toHtml .) <$> getMessageRender
+    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) $
+      void $ closeResumableSink sink
+  where
+    handleHCError :: Either CryptoFileNameSubmission FilePath -> HandlerContents -> _ (Maybe a)
+    handleHCError ident (HCError NotFound) = Nothing <$ tell (Set.singleton ident)
+    handleHCError _ e = throwM e
+    handleCryptoID :: CryptoIDError -> _ (Maybe a)
+    handleCryptoID _ = return Nothing
+    
+
+submissionMatchesSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId
+submissionMatchesSheet tid ssh csh shn cid = do
+  sid <- decrypt cid
+  shid <- fetchSheetId tid ssh csh shn
+  Submission{..} <- get404 sid
+  when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
+  return sid

src/Handler/Utils/Submission/TH.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , ViewPatterns
+           , OverloadedStrings
+           , StandaloneDeriving
+           , DeriveLift
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Handler.Utils.Submission.TH
+  ( patternFile
+  ) where
+
+import ClassyPrelude.Yesod
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..))
+
+import System.FilePath.Glob
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.IO as Text
+
+deriving instance Lift CompOptions
+
+-- $(patternFile compDefault file) :: [System.FilePath.Glob.Pattern]
+patternFile :: CompOptions -> FilePath -> ExpQ
+patternFile opts file = do
+  qAddDependentFile file
+  patternStrings <- runIO $ filter (not . isComment) . Text.lines <$> Text.readFile file
+  listE $ map (\(Text.unpack -> pat) -> [|compileWith opts pat|]) patternStrings
+
+isComment :: Text -> Bool
+isComment line = or
+  [ commentSymbol `Text.isPrefixOf` Text.stripStart line
+  , Text.null $ Text.strip line
+  ]
+  where
+    commentSymbol = "$#"

src/Handler/Utils/Table.hs

@@ -91,3 +91,5 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
   return ( catMaybes <$> collectResult selectionResults
          , encodeCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata)
          )
+
+

src/Handler/Utils/Table/Cells.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Handler.Utils.Table.Cells where
+
+import Import
+
+import Data.Monoid (Any(..))
+import Control.Monad.Writer.Class (MonadWriter(..))
+
+import Utils.Lens
+import Handler.Utils
+
+
+type CourseLink = (TermId, SchoolId, CourseShorthand) -- TODO: Refactor with WithHoles !
+
+--------------------
+-- Special cells
+
+indicatorCell :: IsDBTable m Any => DBCell m Any -- For dbTables that return a Bool to indicate content
+indicatorCell = mempty & cellContents %~ (tell (Any True) *>)
+
+-- Datatype cells
+timeCell :: IsDBTable m a => UTCTime -> DBCell m a
+timeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget
+
+userCell :: IsDBTable m a => Text -> Text -> DBCell m a
+userCell displayName surname = cell $ nameWidget displayName surname
+
+-- Just for documentation purposes; inline this code instead:
+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
+    link = TermCourseListR tid
+    name = text2widget $ display tid
+
+termCellCL :: IsDBTable m a => CourseLink -> DBCell m a
+termCellCL (tid,_,_) = termCell tid
+
+schoolCell :: IsDBTable m a => Maybe TermId -> SchoolId -> DBCell m a
+schoolCell (Just tid) ssh  = anchorCell link name
+  where
+    link = TermSchoolCourseListR tid ssh
+    name = text2widget $ display ssh
+schoolCell Nothing ssh  = anchorCell link name
+  where
+    link = SchoolShowR ssh
+    name = text2widget $ display ssh
+
+schoolCellCL :: IsDBTable m a => CourseLink -> DBCell m a
+schoolCellCL (tid,ssh,_) = schoolCell (Just tid) ssh
+
+courseCellCL :: IsDBTable m a => CourseLink -> DBCell m a
+courseCellCL (tid,ssh,csh) = anchorCell link name
+  where
+    link = CourseR tid ssh csh CShowR
+    name = citext2widget csh
+
+courseCell :: IsDBTable m a => Course -> DBCell m a
+courseCell (Course {..}) = anchorCell link name `mappend` desc
+  where
+    link = CourseR courseTerm courseSchool courseShorthand CShowR
+    name = citext2widget courseName
+    desc = case courseDescription of
+            Nothing      -> mempty
+            (Just descr) -> cell [whamlet| <span style="float:right"> ^{modalStatic descr} |]
+
+sheetCell :: IsDBTable m a => CourseLink -> SheetName -> DBCell m a
+sheetCell crse shn =
+  let tid = crse ^. _1
+      ssh = crse ^. _2
+      csh = crse ^. _3
+      link= CSheetR tid ssh csh shn SShowR
+  in anchorCell link $ display2widget shn
+
+submissionCell :: IsDBTable m a => CourseLink -> SheetName -> SubmissionId -> DBCell m a
+submissionCell crse shn sid =
+  let tid = crse ^. _1
+      ssh = crse ^. _2
+      csh = crse ^. _3
+      mkCid = encrypt sid
+      mkRoute cid = CSubmissionR tid ssh csh shn cid SubShowR
+      mkText  cid = display2widget cid
+  in anchorCellM' mkCid mkRoute mkText
+
+correctorStateCell :: IsDBTable m a => SheetCorrector -> DBCell m a
+correctorStateCell sc =
+  i18nCell $ sheetCorrectorState sc
+
+correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a
+correctorLoadCell sc =
+  i18nCell $ sheetCorrectorLoad sc

src/Handler/Utils/Table/Pagination.hs

@@ -1,33 +1,59 @@
 {-# LANGUAGE NoImplicitPrelude
            , ExistentialQuantification
            , RecordWildCards
+           , NamedFieldPuns
            , OverloadedStrings
            , TemplateHaskell
            , QuasiQuotes
            , LambdaCase
            , ViewPatterns
            , FlexibleContexts
+           , FlexibleInstances
+           , MultiParamTypeClasses
+           , TypeFamilies
+           , ScopedTypeVariables
+           , TupleSections
+           , RankNTypes
+           , MultiWayIf
+           , FunctionalDependencies
   #-}
 
 module Handler.Utils.Table.Pagination
   ( SortColumn(..), SortDirection(..)
-  , DBTable(..)
-  , PaginationSettings(..)
+  , FilterColumn(..), IsFilterColumn
+  , DBRow(..), _dbrOutput, _dbrIndex, _dbrCount
+  , DBStyle(..), DBEmptyStyle(..)
+  , DBTable(..), IsDBTable(..), DBCell(..)
+  , cellAttrs, cellContents
+  , PaginationSettings(..), PaginationInput(..), piIsUnset
   , PSValidator(..)
-  , Sortable(..), sortable
+  , defaultFilter, defaultSorting
+  , restrictFilter, restrictSorting
+  , ToSortable(..), Sortable(..), sortable
   , dbTable
+  , dbTableWidget, dbTableWidget'
+  , widgetColonnade, formColonnade, dbColonnade
+  , cell, textCell, stringCell, i18nCell
+  , anchorCell, anchorCell', anchorCellM, anchorCellM'
+  , tickmarkCell
+  , listCell
+  , formCell, DBFormResult, getDBFormResult
+  , dbRow, dbSelect
+  , (&)
+  , module Control.Monad.Trans.Maybe
+  , module Colonnade
   ) where
 
 import Handler.Utils.Table.Pagination.Types
+import Utils.Lens.TH
 
-import Import
+import Import hiding (Proxy(..))
 import qualified Database.Esqueleto as E
-import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect)
+import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
 import qualified Database.Esqueleto.Internal.Language as E (From)
 import Text.Blaze (Attribute)
 import qualified Text.Blaze.Html5.Attributes as Html5
 import qualified Text.Blaze.Html5 as Html5
-import Yesod.Core.Types (Body(..),GWData(..),WidgetT(..))
 
 import qualified Data.Binary.Builder as Builder
 
@@ -36,18 +62,30 @@ import qualified Network.Wai as Wai
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
-import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_)
+import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_)
+import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_)
+import Control.Monad.Reader (ReaderT(..), mapReaderT)
+import Control.Monad.Trans.Maybe
+
+import Data.Foldable (Foldable(foldMap))
 
 import Data.Map (Map, (!))
+import qualified Data.Map as Map
 
-import Colonnade hiding (bool, fromMaybe)
+import Data.Profunctor (lmap)
+
+import Colonnade hiding (bool, fromMaybe, singleton)
+import qualified Colonnade (singleton)
 import Colonnade.Encode
-import Yesod.Colonnade
 
 import Text.Hamlet (hamletFile)
 
 import Data.Ratio ((%))
 
+import Control.Lens
+
+import Data.Proxy
+
 
 data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
 
@@ -64,132 +102,465 @@ instance PathPiece SortDirection where
 sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy
 sqlSortDirection t (SortColumn e, SortAsc ) = E.asc  $ e t
 sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
-  
-data DBTable = forall a r h i t.
-  ( ToSortable h
-  , E.SqlSelect a r
-  , PathPiece i
-  , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
-  ) => DBTable
-  { dbtSQLQuery :: t -> E.SqlQuery a
-  , dbtColonnade :: Colonnade h r (Cell UniWorX)
-  , dbtSorting :: Map Text (SortColumn t)
-  , dbtAttrs :: Attribute
-  , dbtIdent :: i
-  }
+
+
+data FilterColumn t = forall a. IsFilterColumn t a => FilterColumn a
+
+filterColumn :: FilterColumn t -> [Text] -> t -> E.SqlExpr (E.Value Bool)
+filterColumn (FilterColumn f) = filterColumn' f
+
+class IsFilterColumn t a where
+  filterColumn' :: a -> [Text] -> t -> E.SqlExpr (E.Value Bool)
+
+instance IsFilterColumn t (E.SqlExpr (E.Value Bool)) where
+  filterColumn' fin _ _ = fin
+
+instance IsFilterColumn t cont => IsFilterColumn t (t -> cont) where
+  filterColumn' cont is t = filterColumn' (cont t) is t
+
+instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, MonoPointed l, Monoid l) => IsFilterColumn t (l -> cont) where
+  filterColumn' cont is t = filterColumn' (cont input) is' t
+    where
+      (input, ($ []) -> is') = go (mempty, id) is
+      go acc [] = acc
+      go (acc, is') (i:is)
+        | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is
+        | otherwise = go (acc, is' . (i:)) is
 
 data PaginationSettings = PaginationSettings
-  { psSorting      :: [(Text, SortDirection)]
+  { psSorting      :: [(CI Text, SortDirection)]
+  , psFilter       :: Map (CI Text) [Text]
   , psLimit        :: Int64
   , psPage         :: Int64
   , psShortcircuit :: Bool
   }
 
+makeLenses_ ''PaginationSettings
+
 instance Default PaginationSettings where
   def = PaginationSettings
     { psSorting      = []
+    , psFilter       = Map.empty
     , psLimit        = 50
     , psPage         = 0
     , psShortcircuit = False
     }
 
-newtype PSValidator = PSValidator { runPSValidator :: Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
+data PaginationInput = PaginationInput
+  { piSorting      :: Maybe [(CI Text, SortDirection)]
+  , piFilter       :: Maybe (Map (CI Text) [Text])
+  , piLimit        :: Maybe Int64
+  , piPage         :: Maybe Int64
+  , piShortcircuit :: Bool
+  }
 
-instance Default PSValidator where
-  def = PSValidator $ \case
+makeLenses_ ''PaginationInput
+
+piIsUnset :: PaginationInput -> Bool
+piIsUnset PaginationInput{..} = and
+  [ isNothing piSorting
+  , isNothing piFilter
+  , isNothing piLimit
+  , isNothing piPage
+  , not piShortcircuit
+  ]
+
+data DBRow r = DBRow
+  { dbrOutput :: r
+  , dbrIndex, dbrCount :: Int64
+  } deriving (Show, Read, Eq, Ord)
+
+makeLenses_ ''DBRow
+
+instance Functor DBRow where
+  fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. }
+
+instance Foldable DBRow where
+  foldMap f DBRow{..} = f dbrOutput
+
+instance Traversable DBRow where
+  traverse f DBRow{..} = DBRow <$> f dbrOutput <*> pure dbrIndex <*> pure dbrCount
+
+newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) }
+
+instance Default (PSValidator m x) where
+  def = PSValidator $ \DBTable{..} -> \case
     Nothing -> def
-    Just ps -> swap . (\act -> execRWS act () ps) $ do
-      l <- gets psLimit
-      when (l <= 0) $ do
-        modify $ \ps -> ps { psLimit = psLimit def }
-        tell . pure $ SomeMessage MsgPSLimitNonPositive
+    Just pi -> swap . (\act -> execRWS act pi def) $ do
+      asks piSorting >>= maybe (return ()) (\s -> modify $ \ps -> ps { psSorting = s })
+      asks piFilter >>= maybe (return ()) (\f -> modify $ \ps -> ps { psFilter = f })
+      
+      l <- asks piLimit
+      case l of
+        Just l'
+          | l' <= 0   -> tell . pure $ SomeMessage MsgPSLimitNonPositive
+          | otherwise -> modify $ \ps -> ps { psLimit = l' }
+        Nothing -> return ()
+
+      asks piPage >>= maybe (return ()) (\p -> modify $ \ps -> ps { psPage = p })
+      asks piShortcircuit >>= (\s -> modify $ \ps -> ps { psShortcircuit = s })
+
+defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x
+defaultFilter psFilter (runPSValidator -> f) = PSValidator $ \dbTable -> injectDefault <*> f dbTable
+  where
+    injectDefault x = case x >>= piFilter of
+      Just _  -> id
+      Nothing -> set (_2._psFilter) psFilter
+
+defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x
+defaultSorting psSorting (runPSValidator -> f) = PSValidator $ \dbTable -> injectDefault <*> f dbTable
+  where
+    injectDefault x = case x >>= piSorting of
+      Just _  -> id
+      Nothing -> set (_2._psSorting) psSorting
+
+restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
+restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
+  where
+    restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
+
+restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
+restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
+  where
+    restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p }
 
 
-dbTable :: PSValidator -> DBTable -> Handler Widget
-dbTable PSValidator{..} DBTable{ dbtIdent = (toPathPiece -> dbtIdent), .. } = do
+data DBEmptyStyle = DBESNoHeading | DBESHeading
+  deriving (Enum, Bounded, Ord, Eq, Show, Read)
+
+instance Default DBEmptyStyle where
+  def = DBESHeading
+
+data DBStyle = DBStyle
+  { dbsEmptyStyle :: DBEmptyStyle
+  , dbsEmptyMessage :: UniWorXMessage
+  , dbsAttrs :: [(Text, Text)]
+  }
+
+instance Default DBStyle where
+  def = DBStyle
+    { dbsEmptyStyle = def
+    , dbsEmptyMessage = MsgNoTableContent
+    , dbsAttrs = [ ("class", "table table--striped table--hover table--sortable") ]
+    }
+
+data DBTable m x = forall a r r' h i t.
+  ( ToSortable h, Functor h
+  , E.SqlSelect a r
+  , PathPiece i
+  , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
+  ) => DBTable
+  { dbtSQLQuery :: t -> E.SqlQuery a
+  , dbtProj :: DBRow r -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) r'
+  , dbtColonnade :: Colonnade h r' (DBCell m x)
+  , dbtSorting :: Map (CI Text) (SortColumn t)
+  , dbtFilter :: Map (CI Text) (FilterColumn t)
+  , dbtStyle :: DBStyle
+  , dbtIdent :: i
+  }
+
+class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) (x :: *) where
+  type DBResult m x :: *
+  -- type DBResult' m x :: *
+
+  data DBCell m x :: *
+  dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
+    
+  -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
+  dbWidget   :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget
+  dbHandler  :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
+  runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
+
+cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
+cellAttrs = dbCell . _1
+
+cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
+cellContents = dbCell . _2
+
+instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
+  type DBResult (HandlerT UniWorX IO) x = (x, Widget)
+  -- type DBResult' (WidgetT UniWorX IO) () = ()
+
+  data DBCell (HandlerT UniWorX IO) x = WidgetCell
+    { wgtCellAttrs :: [(Text, Text)]
+    , wgtCellContents :: WriterT x (HandlerT UniWorX IO) Widget
+    }
+
+  dbCell = iso
+    (\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents))
+    (\(attrs, mkWidget) -> WidgetCell attrs mkWidget)
+  
+  -- dbWidget Proxy Proxy = iso (, ()) $ view _1
+  dbWidget _ = return . snd
+  dbHandler _ f = return . over _2 f
+  runDBTable act = liftHandlerT act
+
+instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
+  mempty = WidgetCell mempty $ return mempty
+  (WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c')
+
+instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
+  type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget)
+
+  data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBCell
+    { dbCellAttrs :: [(Text, Text)]
+    , dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerT UniWorX IO)) Widget
+    }
+
+  dbCell = iso
+    (\DBCell{..} -> (dbCellAttrs, dbCellContents))
+    (\(attrs, mkWidget) -> DBCell attrs mkWidget)
+
+  dbWidget _ = return . snd
+  dbHandler _ f = return . over _2 f
+  -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
+  runDBTable = mapReaderT liftHandlerT
+
+instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
+  mempty = DBCell mempty $ return mempty
+  (DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c')
+
+instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where
+  -- type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype)
+  type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a
+  -- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
+
+  data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = FormCell
+    { formCellAttrs :: [(Text, Text)]
+    , formCellContents :: MForm (HandlerT UniWorX IO) (FormResult a, Widget)
+    }
+
+  -- dbCell :: Iso'
+  --             (DBCell (RWST ... ... ... (HandlerT UniWorX IO)) (FormResult a))
+  --             ([(Text, Text)], WriterT (FormResult a) (RWST ... ... ... (HandlerT UniWorX IO)) Widget)
+  dbCell = iso
+    (\FormCell{..} -> (formCellAttrs, WriterT $ fmap swap formCellContents))
+    (\(attrs, mkWidget) -> FormCell attrs . fmap swap $ runWriterT mkWidget)
+  
+  -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
+  --                            ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
+  dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . identifyForm dbtIdent
+  dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> identifyForm dbtIdent form csrf
+  -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
+  -- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
+  -- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
+  runDBTable = return . withFragment
+
+instance Monoid a => Monoid (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a)) where
+  mempty = FormCell mempty (return mempty)
+  (FormCell a c) `mappend` (FormCell a' c') = FormCell (mappend a a') (mappend <$> c <*> c')
+  
+instance IsDBTable m a => IsString (DBCell m a) where
+  fromString = cell . fromString
+      
+
+dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x)
+dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtStyle = DBStyle{..}, .. }) = do
   let
     sortingOptions = mkOptionList
       [ Option t' (t, d) t'
       | (t, _) <- mapToList dbtSorting
       , d <- [SortAsc, SortDesc]
-      , let t' = t <> "-" <> toPathPiece d
+      , let t' = CI.foldedCase t <> "-" <> toPathPiece d
       ]
-    (_, defPS) = runPSValidator Nothing
+    (_, defPS) = runPSValidator dbtable Nothing
     wIdent n
       | not $ null dbtIdent = dbtIdent <> "-" <> n
       | otherwise           = n
-    dbtAttrs'
-      | not $ null dbtIdent = Html5.id (fromString $ unpack dbtIdent) <> dbtAttrs
-      | otherwise           = dbtAttrs
+    dbsAttrs'
+      | not $ null dbtIdent = ("id", dbtIdent) : dbsAttrs
+      | otherwise           = dbsAttrs
+    multiTextField = Field
+      { fieldParse = \ts _ -> return . Right $ Just ts
+      , fieldView = undefined
+      , fieldEnctype = UrlEncoded
+      }
     
-  psResult <- runInputGetResult $ PaginationSettings
-    <$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting"))
-    <*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize"))
-    <*> (fromMaybe (psPage  defPS) <$> iopt intField (wIdent "page"))
+  psResult <- runInputGetResult $ PaginationInput
+    <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
+    <*> ((assertM' $ not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
+    <*> iopt intField (wIdent "pagesize")
+    <*> iopt intField (wIdent "page")
     <*> ireq checkBoxField (wIdent "table-only")
 
-  $(logDebug) . tshow $ (,,,) <$> (length . psSorting <$> psResult)
-                              <*> (psLimit <$> psResult)
-                              <*> (psPage <$> psResult)
-                              <*> (psShortcircuit <$> psResult)
+  $(logDebug) . tshow $ (,,,,) <$> (piSorting <$> psResult)
+                               <*> (piFilter <$> psResult)
+                               <*> (piLimit <$> psResult)
+                               <*> (piPage <$> psResult)
+                               <*> (piShortcircuit <$> psResult)
 
   let
     (errs, PaginationSettings{..}) = case psResult of
-      FormSuccess ps   -> runPSValidator $ Just ps
-      FormFailure errs -> first (map SomeMessage errs <>) $ runPSValidator Nothing
-      FormMissing      -> runPSValidator Nothing
+      FormSuccess pi
+        | not (piIsUnset pi) -> runPSValidator dbtable $ Just pi
+      FormFailure errs       -> first (map SomeMessage errs <>) $ runPSValidator dbtable Nothing
+      _                      -> runPSValidator dbtable Nothing
     psSorting' = map (first (dbtSorting !)) psSorting
     sqlQuery' = E.from $ \t -> dbtSQLQuery t
       <* E.orderBy (map (sqlSortDirection t) psSorting')
       <* E.limit psLimit
       <* E.offset (psPage * psLimit)
+      <* Map.foldrWithKey (\key args expr -> E.where_ (filterColumn (dbtFilter ! key) args t) >> expr) (return ()) psFilter
 
-  mapM_ (addMessageI "warning") errs
+  mapM_ (addMessageI Warning) errs
 
-  (rows, [E.Value rowCount]) <- runDB $ (,) <$> E.select sqlQuery' <*> E.select (E.countRows <$ E.from dbtSQLQuery :: E.SqlQuery (E.SqlExpr (E.Value Int64)))
+  runDB $ do
+    rows' <- E.select $ (,) <$> pure (E.unsafeSqlValue "count(*) OVER ()" :: E.SqlExpr (E.Value Int64)) <*> sqlQuery'
 
-  bool return (sendResponse <=< tblLayout) psShortcircuit $ do
-    getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
-    let table = $(widgetFile "table/colonnade")
-        pageCount = max 1 . ceiling $ rowCount % psLimit
-        pageNumbers = [0..pred pageCount]
-        tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
+    let mapMaybeM f = fmap catMaybes . mapM (runMaybeT . f)
+  
+    rows <- mapMaybeM dbtProj . map (\(dbrIndex, (E.Value dbrCount, dbrOutput)) -> DBRow{..}) $ zip [succ (psPage * psLimit)..] rows'
 
-        withSortLinks Sortable{ sortableContent = Cell{..}, .. } = Cell
-          { cellContents = $(widgetFile "table/sortable-header")
-          , cellAttrs = maybe mempty (const sortableAttr) sortableKey <> cellAttrs
-          }
-          where
-            directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
-            sortableAttr = Html5.class_ . fromString . unwords $ "sortable" : foldMap toAttr directions
-            toAttr SortAsc = ["sorted-asc"]
-            toAttr SortDesc = ["sorted-desc"]
-    $(widgetFile "table/layout")
+    let
+      rowCount
+        | (E.Value n, _):_ <- rows' = n
+        | otherwise = 0
+
+      table' :: WriterT x m Widget
+      table' = do
+        getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+
+        let
+          tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
+
+          genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
+            widget <- sortableContent ^. cellContents
+            let
+              directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
+              isSortable = isJust sortableKey
+              isSorted = (`elem` directions)
+              attrs = sortableContent ^. cellAttrs
+            return $(widgetFile "table/cell/header")
+
+          columnCount :: Int64
+          columnCount = olength64 $ getColonnade dbtColonnade
+
+        wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
+
+        wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do
+          widget <- cell ^. cellContents
+          let attrs = cell ^. cellAttrs
+          return $(widgetFile "table/cell/body")
+      
+        let table = $(widgetFile "table/colonnade")
+            pageCount = max 1 . ceiling $ rowCount % psLimit
+            pageNumbers = [0..pred pageCount]
+
+        return $(widgetFile "table/layout")
+
+    bool (dbHandler dbtable $ \table -> $(widgetFile "table/layout-wrapper")) (sendResponse <=< tblLayout <=< dbWidget dbtable) psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
   where
-    tblLayout :: Widget -> Handler Html
+    tblLayout :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Widget -> m' Html
     tblLayout tbl' = do
-      tbl <- widgetToPageContent tbl'
-      withUrlRenderer $(hamletFile "templates/table/layout-wrapper.hamlet")
+      tbl <- liftHandlerT $ widgetToPageContent tbl'
+      withUrlRenderer $(hamletFile "templates/table/layout-standalone.hamlet")
 
     setParam :: Text -> Maybe Text -> QueryText -> QueryText
     setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
 
-widgetFromCell ::
-  (Attribute -> WidgetT site IO () -> WidgetT site IO ())
-  -> Cell site
-  -> WidgetT site IO ()
-widgetFromCell f (Cell attrs contents) =
-  f attrs contents
-td,th ::
-  Attribute -> WidgetT site IO () -> WidgetT site IO ()
+dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
+    -> Handler (DBResult (HandlerT UniWorX IO) x)
+dbTableWidget = dbTable
 
-td = liftParent Html5.td
-th = liftParent Html5.th
+dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> Handler Widget
+dbTableWidget' = fmap (fmap snd) . dbTable
 
-liftParent :: (Html -> Html) -> Attribute -> WidgetT site IO a -> WidgetT site IO a
-liftParent el attrs (WidgetT f) = WidgetT $ \hdata -> do
-  (a,gwd) <- f hdata
-  let Body bodyFunc = gwdBody gwd
-      newBodyFunc render =
-        el Html5.! attrs $ (bodyFunc render)
-  return (a,gwd { gwdBody = Body newBodyFunc })
+widgetColonnade :: (Headedness h, Monoid x)
+                => Colonnade h r (DBCell (HandlerT UniWorX IO) x)
+                -> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
+widgetColonnade = id
+
+formColonnade :: (Headedness h, Monoid a)
+              => Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
+              -> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
+formColonnade = id
+
+dbColonnade :: (Headedness h, Monoid x)
+            => Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
+            -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
+dbColonnade = id
+
+
+--- DBCell utility functions
+
+cell :: IsDBTable m a => Widget -> DBCell m a
+cell wgt = dbCell # ([], return wgt)
+
+textCell, stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a
+textCell = cell . toWidget . (pack :: [Char] -> Text) . otoList
+stringCell = textCell
+
+i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
+i18nCell msg = cell $ do
+  mr <- getMessageRender
+  toWidget $ mr msg
+
+tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
+tickmarkCell True  = textCell (tickmark :: Text)
+tickmarkCell False = mempty
+
+
+anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
+anchorCell = anchorCellM . return
+
+{-# DEPRECATED anchorCell' "For compatibility with Colonnade; better use anchorCell instead." #-}
+anchorCell' :: IsDBTable m a
+           => (r -> Route UniWorX)
+           -> (r -> Widget)
+           -> (r -> DBCell m a)
+anchorCell' mkRoute mkWidget val = anchorCell (mkRoute val) (mkWidget val)
+
+anchorCellM :: IsDBTable m a => (WidgetT UniWorX IO (Route UniWorX)) -> Widget -> DBCell m a
+anchorCellM routeM widget = anchorCellM' routeM id (const widget)
+
+anchorCellM' :: IsDBTable m a => (WidgetT UniWorX IO x) -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a
+anchorCellM' xM x2route x2widget = cell $ do
+  x <- xM
+  let route  = x2route  x
+      widget = x2widget x
+  authResult <- liftHandlerT $ isAuthorized route False
+  case authResult of
+    Authorized -> $(widgetFile "table/cell/link") -- show allowed link
+    _otherwise -> widget                          -- don't show prohibited link
+
+
+listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a
+listCell xs mkCell = review dbCell . ([], ) $ do
+  cells <- forM xs $
+    \(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
+  return $(widgetFile "table/cell/list")
+
+newtype DBFormResult r i a = DBFormResult (Map i (r, a -> a))
+
+instance Ord i => Monoid (DBFormResult r i a) where
+  mempty = DBFormResult Map.empty
+  (DBFormResult m1) `mappend` (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2
+
+getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult r i a -> Map i a
+getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
+
+formCell :: forall r i a. Ord i
+         => (r -> MForm (HandlerT UniWorX IO) i)
+         -> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
+         -> (r -> DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
+formCell genIndex genForm input = FormCell
+  { formCellAttrs    = []
+  , formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
+      i <- genIndex input
+      (edit, w) <- genForm input i
+      return (DBFormResult . Map.singleton i . (input,) <$> edit, w)
+  }
+
+
+-- Predefined colonnades
+
+dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
+dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
+
+dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i)
+         => Setter' a Bool
+         -> (r -> MForm (HandlerT UniWorX IO) i)
+         -> Colonnade h r (DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
+dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do
+  (selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
+  return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|])

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

@@ -11,18 +11,23 @@ import Import hiding (singleton)
 import Colonnade
 import Colonnade.Encode
 
+import Data.CaseInsensitive (CI)
+
 data Sortable a = Sortable
-  { sortableKey :: (Maybe Text)
+  { sortableKey :: Maybe (CI Text)
   , sortableContent :: a
   }
 
-sortable :: Maybe Text -> c -> (a -> c) -> Colonnade Sortable a c
+sortable :: Maybe (CI Text) -> c -> (a -> c) -> Colonnade Sortable a c
 sortable k h = singleton (Sortable k h)
 
 instance Headedness Sortable where
   headednessPure = Sortable Nothing
   headednessExtract = Just $ \(Sortable _ x) -> x
   headednessExtractForall = Just $ ExtractForall (\(Sortable _ x) -> x)
+
+instance Functor Sortable where
+  fmap f Sortable{..} = Sortable { sortableContent = f sortableContent, .. }
                                                  
 newtype SortableP s = SortableP { toSortable :: forall a. s a -> Sortable a}
 
@@ -37,4 +42,3 @@ instance ToSortable Headed where
 
 instance ToSortable Headless where
   pSortable = Nothing
- 

src/Handler/Utils/Templates.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-}
+{-# LANGUAGE NoImplicitPrelude, TemplateHaskell, QuasiQuotes #-}
 
 module Handler.Utils.Templates where
 
@@ -7,8 +7,26 @@ import Import.NoFoundation
 lipsum :: WidgetT site IO ()
 lipsum = $(widgetFile "widgets/lipsum")
 
-modal :: [Char] -> Maybe [Char] -> WidgetT site IO ()
-modal modalTrigger (Just modalContent) = do
+modalStatic :: Html -> WidgetT site IO ()
+modalStatic modalContent = do
+  uniqueId <- newIdent
+  let modalTrigger = cons '#' uniqueId -- SJ: I am confused why this is needed here?
+      modalId :: Int32
+      modalId = 13
+  $(widgetFile "widgets/modalStatic")
+  [whamlet|<div .tooltip__handle ##{uniqueId}>?|] -- SJ: confused why ## is needed here either?
+
+modalWidget :: Html -> WidgetT site IO () -> WidgetT site IO ()
+modalWidget modalTrigger modalContent = do
+  uniqueId <- newIdent
+  let modalTriggerId = cons '#' uniqueId -- SJ: I am confused why this is needed here?
+      modalId :: Int32
+      modalId = 13
+  $(widgetFile "widgets/modalWidget")
+  [whamlet|<div .btn ##{uniqueId}>#{modalTrigger}|] -- 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

src/Handler/Utils/Term.hs

@@ -1,59 +0,0 @@
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies #-}
-module Handler.Utils.Term where
-
-import Import
-import qualified Data.Text as T
-import Model.Types
--- import Data.Maybe
-
-
-termActiveField :: Field Handler TermId
-termActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
-
-termActiveOld :: Field Handler TermIdentifier
-termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
-
-termNewField :: Field Handler TermIdentifier
-termNewField = checkMMap checkTerm 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
-
-validateTerm :: Term -> [Text]        
-validateTerm (Term{..}) = 
-  [ msg  | (False, msg) <- 
-    [ --startOk
-      ( termStart `withinTerm` termName
-      , "Jahreszahl im Namenskürzel stimmt nicht mit Semesterbeginn überein."
-      )
-    , -- endOk 
-      ( termStart < termEnd    
-      , "Semester darf nicht enden, bevor es begann."
-      )  
-    , -- startOk
-      ( termLectureStart < termLectureEnd
-      , "Vorlesungszeit muss vor ihrem Ende anfgangen."
-      )
-    , -- lecStartOk
-      ( termStart <= termLectureStart
-      , "Semester muss vor der Vorlesungszeit beginnen."
-      )
-    , -- lecEndOk   
-      ( termEnd >= termLectureEnd
-      , "Vorlesungszeit muss vor dem Semester enden."
-      )
-  ] ]

src/Handler/Utils/Zip.hs

@@ -56,7 +56,7 @@ consumeZip = unZipStream `fuseUpstream` consumeZip'
         Just (Left ZipEntry{..}) -> do
           contentChunks <- toConsumer accContents
           let
-            fileTitle = normalise $ makeValid zipEntryName
+            fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise $ makeValid zipEntryName
             fileModified = localTimeToUTC utc zipEntryTime
             fileContent
               | hasTrailingPathSeparator zipEntryName = Nothing
@@ -108,7 +108,7 @@ sourceFiles fInfo
 
 acceptFile :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> m File
 acceptFile fInfo = do
-  let fileTitle = unpack $ fileName fInfo
+  let fileTitle = dropWhile isPathSeparator . dropTrailingPathSeparator . normalise . unpack $ fileName fInfo
   fileModified <- liftIO getCurrentTime
   fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
   return File{..}

src/Import.hs

@@ -4,3 +4,4 @@ module Import
 
 import Foundation            as Import
 import Import.NoFoundation   as Import
+

src/Import/NoFoundation.hs

@@ -1,22 +1,28 @@
 {-# LANGUAGE CPP #-}
 module Import.NoFoundation
     ( module Import
+    , addMessage, addMessageI
     ) where
 
-import ClassyPrelude.Yesod   as Import
-import Model                 as Import
-import Settings              as Import
-import Settings.StaticFiles  as Import
-import Yesod.Auth            as Import
-import Yesod.Core.Types      as Import (loggerSet)
-import Yesod.Default.Config2 as Import
-import Utils                 as Import
+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
+import Settings               as Import
+import Settings.StaticFiles   as Import
+import Yesod.Auth             as Import
+import Yesod.Core.Types       as Import (loggerSet)
+import Yesod.Default.Config2  as Import
+import Utils                  as Import
 
 
-import Data.Fixed            as Import
+import Data.Fixed             as Import
 
-import CryptoID              as Import
-import Data.UUID             as Import (UUID)
+import CryptoID               as Import
+import Data.UUID              as Import (UUID)
 
+import Text.Lucius            as Import
 
-import Text.Lucius           as Import
+import Text.Shakespeare.Text  as Import hiding (text, stext)
+
+import Data.Universe          as Import

src/Jobs.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE NoImplicitPrelude
+           , RecordWildCards
+           , TemplateHaskell
+           , OverloadedStrings
+           , FlexibleContexts
+           , ViewPatterns
+           , TypeFamilies
+           , DeriveGeneric
+           , DeriveDataTypeable
+  #-}
+
+module Jobs
+  ( handleJobs
+  , Job(..), Notification(..)
+  ) where
+
+import Import
+
+import Data.Conduit.TMChan
+import qualified Data.Conduit.List as C
+
+import Data.Aeson (fromJSON, Result(..), defaultOptions, Options(..))
+import qualified Data.Aeson as Aeson
+import Data.Aeson.TH (deriveJSON)
+import Database.Persist.Sql (rawExecute, fromSqlKey)
+
+  
+data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
+  deriving (Eq, Ord, Show, Read)
+data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId, nTimestamp :: UTCTime }
+  deriving (Eq, Ord, Show, Read)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , tagSingleConstructors = True
+  } ''Job
+
+deriveJSON defaultOptions
+  { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
+  , tagSingleConstructors = True
+  } ''Notification
+
+data JobQueueException = JInvalid QueuedJob
+                       | JLocked QueuedJobId UUID UTCTime
+                       | JNonexistant QueuedJobId
+  deriving (Read, Show, Eq, Generic, Typeable)
+
+instance Exception JobQueueException
+  
+
+handleJobs :: UniWorX -> IO ()
+handleJobs foundation@UniWorX{..} = unsafeHandler foundation . bracket_ logStart logStop . runConduit $ sourceTMChan appJobCtl .| handleJobs'
+  where
+    logStart = $(logDebugS) "Jobs" "Started"
+    logStop = $(logDebugS) "Jobs" "Shutting down"
+
+handleJobs' :: Sink JobCtl Handler ()
+handleJobs' = C.mapM_ $ void . handleAny ($(logErrorS) "Jobs" . tshow) . handleCmd
+  where
+    handleQueueException :: MonadLogger m => JobQueueException -> m ()
+    handleQueueException (JInvalid j) = $(logWarnS) "Jobs" $ "Invalid QueuedJob: " ++ tshow j
+    handleQueueException (JNonexistant jId) = $(logInfoS) "Jobs" $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId)
+    handleQueueException (JLocked jId lInstance lTime)  = $(logDebugS) "Jobs" $ "Saw locked QueuedJob: " ++ tshow (jId, lInstance, lTime)
+    
+    handleCmd NCtlFlush = void . fork . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreated ] .| C.mapM_ cmdPerform
+    handleCmd (NCtlPerform jId) = handle handleQueueException . (`finally` jUnlock jId) $ do
+      j@QueuedJob{..} <- jLock jId
+
+      let
+        content :: Job
+        Aeson.Success content = fromJSON queuedJobContent
+      
+      $(logDebugS) "Jobs" $ "Would do: " <> tshow content -- FIXME
+
+      runDB $ delete jId
+
+jLock :: QueuedJobId -> Handler QueuedJob
+jLock jId = runDB $ do
+  rawExecute "SET TRANSACTION ISOLATION LEVEL SERIALIZABLE" []
+  j@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
+  maybe (return ()) throwM $ JLocked <$> pure jId <*> queuedJobLockInstance <*> queuedJobLockTime
+  let isSuccess (Aeson.Success _) = True
+      isSuccess _ = False
+  unless (isSuccess (fromJSON queuedJobContent :: Result Job)) . throwM $ JInvalid j
+  instanceID <- getsYesod appInstanceID
+  now <- liftIO getCurrentTime
+  updateGet jId [ QueuedJobLockInstance =. Just instanceID
+                , QueuedJobLockTime =. Just now
+                ]
+
+jUnlock :: QueuedJobId -> Handler ()
+jUnlock jId = runDB $ update jId [ QueuedJobLockInstance =. Nothing
+                                 , QueuedJobLockTime =. Nothing
+                                 ]
+
+
+cmdPerform :: ( MonadHandler m
+              , HandlerSite m ~ UniWorX
+              ) => QueuedJobId -> m ()
+cmdPerform (NCtlPerform -> cmd) = do
+  chan <- getsYesod appJobCtl 
+  liftIO . atomically $ writeTMChan chan cmd

src/Model.hs

@@ -9,6 +9,10 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE DeriveDataTypeable         #-}
 {-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+
+
 module Model
   ( module Model
   , module Model.Types
@@ -19,18 +23,29 @@ import Database.Persist.Quasi
 -- import Data.Time
 -- import Data.ByteString
 import Model.Types
+
 import Data.UUID
 import Data.Aeson (Value)
 import Data.Aeson.TH (deriveJSON, defaultOptions)
 
+import Data.CaseInsensitive (CI)
+import Data.CaseInsensitive.Instances ()
+
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities
 -- at:
 -- http://www.yesodweb.com/book/persistent/
-share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"]
+share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"]
     $(persistFileWith lowerCaseSettings "models")
 
-data Notification = SubmissionRated SubmissionId UTCTime
-  deriving (Eq, Ord, Show, Read)
-deriveJSON defaultOptions ''Notification
+-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
+deriving instance Eq (Unique Course)
 
+data PWEntry = PWEntry
+  { pwUser :: User
+  , pwHash :: Text
+  } deriving (Show)
+$(deriveJSON defaultOptions ''PWEntry)
+
+submissionRatingDone :: Submission -> Bool
+submissionRatingDone Submission{..} = isJust submissionRatingPoints

src/Model/Migration.hs

@@ -0,0 +1,201 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies, FlexibleInstances #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Model.Migration
+  ( migrateAll
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Utils (lastMaybe)
+
+import Model
+import Model.Migration.Version
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Data.Set ()
+import qualified Data.Set as Set
+
+import Database.Persist.Sql
+import Database.Persist.Postgresql
+
+import Text.Read (readMaybe)
+import Data.CaseInsensitive (CI)
+
+-- Database versions must follow https://pvp.haskell.org:
+--   - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
+--   - Non-breaking changes are instances where the automatic migration done by persistent is sufficient (i.e. adding a column or table)
+
+-- Note that only one automatic migration is done (after all manual migrations).
+-- Manual migrations can therefore not rely on non-breaking changes being applied when they are executed (i.e. columns existing, that were added as non-breaking changes after InitialVersion)
+-- If that is inconvenient a custom migration between minor version numbers can be formulated using `migration`, `runMigration`, and manually defined `EntityDef`s so as to use persistent's automatic migration system
+
+-- Database versions must be marked with git tags:
+--   The first commit corresponding to a new database version x.x.x must be tagged dbx.x.x
+--   Tags should be annotated with a description of the changes affecting the database.
+--
+--   Example:
+--     $ git tag -a db0.0.0 -m "Simplified format of UserTheme"
+--
+--   Doing so creates sort of parallel commit history tracking changes to the database schema
+
+  
+share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
+  [persistLowerCase|
+    AppliedMigration json
+      from MigrationVersion
+      to Version
+      time UTCTime
+      UniqueAppliedMigration from
+      Primary from to
+      deriving Show Eq Ord
+  |]
+
+migrateAll :: MonadIO m => ReaderT SqlBackend m ()
+migrateAll = do
+  runMigration $ do
+    -- Manual migrations to go to InitialVersion below:
+    migrateEnableExtension "citext"
+
+    migrateDBVersioning
+
+  appliedMigrations <- map entityKey <$> selectList [] []
+  let
+    missingMigrations = customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
+    doCustomMigration acc desc migration = acc <* do
+      let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc
+      appliedMigrationTime <- liftIO getCurrentTime
+      _ <- migration
+      insert AppliedMigration{..} 
+  -- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey
+  Map.foldlWithKey doCustomMigration (return ()) missingMigrations 
+  
+  runMigration migrateAll'
+
+{-
+  Confusion about quotes, from the PostgreSQL Manual:
+    Single quotes for string constants, double quotes for table/column names.
+
+    QuasiQuoter: ^{TableName} @{ColumnName} (includes Escaping);
+                  #{anything} (no escaping);
+-}
+
+
+customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
+customMigrations = Map.fromListWith (>>)
+  [ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|]
+    , whenM (tableExists "user") $ do -- New theme format
+        userThemes <- [sqlQQ| SELECT "id", "theme" FROM "user"; |]
+        forM_ userThemes $ \(uid, Single str) -> case stripPrefix "theme--" str of
+          Just v
+            | Just theme <- fromPathPiece v -> update uid [UserTheme =. theme]
+          other -> error $ "Could not parse theme: " <> show other
+    )
+  , ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|]
+    , whenM (tableExists "sheet") $ -- Better JSON encoding
+        [executeQQ|
+          ALTER TABLE "sheet" ALTER COLUMN "type" TYPE json USING "type"::json;
+          ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE json USING "grouping"::json;
+        |]
+    )
+  , ( AppliedMigrationKey [migrationVersion|1.0.0|] [version|2.0.0|]
+    , whenM (tableExists "school") $ do -- SchoolId is the Shorthand CI Text now
+        -- Read old table into memory
+        schoolTable <- [sqlQQ| SELECT "id", "shorthand" FROM "school"; |]
+        let _sT = schoolTable :: [(Single Int64, Single (CI Text))] -- Types needed
+        -- Convert columns containing SchoolId
+        whenM (tableExists "user_admin") $ do
+            [executeQQ|
+              ALTER TABLE "user_admin" DROP CONSTRAINT "user_admin_school_fkey";
+              ALTER TABLE "user_admin" ALTER COLUMN "school" TYPE citext USING "school"::citext;
+              |]
+            forM_ schoolTable $ \(Single idnr, Single ssh) ->
+              [executeQQ|
+                UPDATE "user_admin" SET "school" = #{ssh} WHERE "school" = #{tshow idnr};
+              |]
+            [executeQQ|
+              ALTER TABLE "user_admin" ADD CONSTRAINT "user_admin_school_fkey"
+                FOREIGN KEY (school) REFERENCES school(shorthand);
+              |]
+        whenM (tableExists "user_lecturer") $ do
+            [executeQQ|
+              ALTER TABLE "user_lecturer" DROP CONSTRAINT "user_lecturer_school_fkey";
+              ALTER TABLE "user_lecturer" ALTER COLUMN "school" TYPE citext USING "school"::citext;
+              |]
+            forM_ schoolTable $ \(Single idnr, Single ssh) ->
+              [executeQQ|
+                UPDATE "user_lecturer" SET "school" = #{ssh} WHERE "school" = #{tshow idnr};
+              |]
+            [executeQQ|
+              ALTER TABLE "user_lecturer" ADD CONSTRAINT "user_lecturer_school_fkey"
+                  FOREIGN KEY (school) REFERENCES school(shorthand);
+              |]
+        whenM (tableExists "course") $ do
+            [executeQQ|
+              ALTER TABLE "course" DROP CONSTRAINT "course_school_fkey";
+              ALTER TABLE "course" ALTER COLUMN "school" TYPE citext USING "school"::citext;
+              |]
+            forM_ schoolTable $ \(Single idnr, Single ssh) ->
+              [executeQQ|
+                UPDATE "course" SET "school" = #{ssh} WHERE "school" = #{tshow idnr};
+              |]
+            [executeQQ|
+              ALTER TABLE "course" ADD CONSTRAINT "course_school_fkey"
+                  FOREIGN KEY (school) REFERENCES school(shorthand);
+              |]
+        [executeQQ|
+            ALTER TABLE "school" DROP COLUMN "id";
+            ALTER TABLE "school" ADD PRIMARY KEY (shorthand);
+          |]
+    )
+  , ( AppliedMigrationKey [migrationVersion|2.0.0|] [version|3.0.0|]
+    , whenM (tableExists "sheet_corrector") $ do -- Load is encoded as JSON now.
+        correctorLoads <- [sqlQQ| SELECT "id", "load" FROM "sheet_corrector"; |]
+        forM_ correctorLoads $ \(uid, Single str) -> case readMaybe str of
+          Just load -> update uid [SheetCorrectorLoad =. load]
+          _other -> error $ "Could not parse Load: " <> show str
+        [executeQQ|
+          ALTER TABLE "sheet_corrector" ALTER COLUMN "load" TYPE json USING "load"::json;
+        |]
+    )
+  , ( AppliedMigrationKey [migrationVersion|3.0.0|] [version|3.1.0|]
+    , whenM (tableExists "user") $ do
+        userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |]
+        [executeQQ|
+          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"';
+        |]
+    )
+  ]
+
+
+
+tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
+tableExists table = do
+  haveSchoolTable <- [sqlQQ| SELECT to_regclass(#{table}); |]
+  case haveSchoolTable :: [Maybe (Single PersistValue)] of
+    [Just _] -> return True
+    _other   -> return False

src/Model/Migration/Version.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveLift, DeriveGeneric, DeriveDataTypeable #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Model.Migration.Version
+  ( MigrationVersion(..)
+  , version, migrationVersion
+  , module Data.Version
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Database.Persist.Sql
+import Text.ParserCombinators.ReadP
+import Data.Maybe (fromJust)
+
+import Data.Version
+
+import Data.Aeson.TH
+
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax (Lift)
+import qualified Language.Haskell.TH.Syntax as TH (lift)
+
+import Data.Data (Data)
+
+
+deriving instance Lift Version
+  
+
+data MigrationVersion = InitialVersion | MigrationVersion Version
+  deriving (Eq, Ord, Show, Read, Generic, Typeable, Data, Lift)
+
+deriveJSON defaultOptions
+  { constructorTagModifier = toLower . fromJust . stripSuffix "Version"
+  , sumEncoding = UntaggedValue
+  } ''MigrationVersion
+
+instance PersistField MigrationVersion where
+  toPersistValue  InitialVersion      = PersistText "initial"
+  toPersistValue (MigrationVersion v) = PersistText . pack $ showVersion v
+
+  fromPersistValue (PersistText t)
+    | t == "initial" = return InitialVersion
+    | otherwise = case [ x | (x, "") <- readP_to_S parseVersion $ unpack t] of
+        [x] -> Right $ MigrationVersion x
+        []  -> Left "No parse"
+        _   -> Left "Ambiguous parse"
+  fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x
+
+instance PersistFieldSql MigrationVersion where
+  sqlType _ = SqlString
+
+
+instance PersistField Version where
+  toPersistValue = PersistText . pack . showVersion
+
+  fromPersistValue (PersistText t) = case [ x | (x, "") <- readP_to_S parseVersion $ unpack t] of
+    [x] -> Right x
+    []  -> Left "No parse"
+    _   -> Left "Ambiguous parse"
+  fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x
+
+instance PersistFieldSql Version where
+  sqlType _ = SqlString
+
+
+version, migrationVersion :: QuasiQuoter
+version = QuasiQuoter{..}
+  where
+    quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of
+      [x] -> x
+      []  -> error "No parse"
+      _   -> error "Ambiguous parse"
+    quotePat = error "version cannot be used as pattern"
+    quoteType = error "version cannot be used as type"
+    quoteDec = error "version cannot be used as declaration"
+migrationVersion = QuasiQuoter{..}
+  where
+    quoteExp "initial" = TH.lift InitialVersion
+    quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of
+      [x] -> MigrationVersion x
+      []  -> error "No parse"
+      _   -> error "Ambiguous parse"
+    quotePat = error "version cannot be used as pattern"
+    quoteType = error "version cannot be used as type"
+    quoteDec = error "version cannot be used as declaration"

src/Model/Types.hs

@@ -1,50 +1,96 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
-
+{-# LANGUAGE ViewPatterns #-}
+{-- # LANGUAGE ExistentialQuantification #-} -- for DA type
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
 
 module Model.Types where
 
 import ClassyPrelude
 import Utils
+import Control.Lens
 
+import Data.Set (Set)
+import qualified Data.Set as Set
+import qualified Data.Map as Map
 import Data.Fixed
+import Data.Monoid (Sum(..))
+import Data.Maybe (fromJust)
+import Data.Universe
+import Data.Universe.Helpers
+import Data.UUID.Types
 
-import Database.Persist.TH
+import Text.Read (readMaybe)
+
+import Database.Persist.TH hiding (derivePersistFieldJSON)
+import Model.Types.JSON
 import Database.Persist.Class
 import Database.Persist.Sql
 
 import Web.HttpApiData
+import Web.PathPieces
 
 import Data.Text (Text)
 import qualified Data.Text as Text
+import qualified Data.Text.Lens as Text
 
-import Text.Read (readMaybe)
-
--- import Data.CaseInsensitive (CI)
+import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
-
-import Data.UUID
+import Data.CaseInsensitive.Instances ()
 
 import Yesod.Core.Dispatch (PathPiece(..))
-import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..), encode, eitherDecode)
-import Data.Aeson.TH (deriveJSON, defaultOptions)
+import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
+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
+  toPathPiece = pack . toString
+
+instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
+  fromPathPiece = fmap CI.mk . fromPathPiece
+  toPathPiece = toPathPiece . CI.original
+
+instance {-# OVERLAPS #-} PathMultiPiece FilePath where
+  fromPathMultiPiece = Just . unpack . intercalate "/"
+  toPathMultiPiece = Text.splitOn "/" . pack
+
+instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
+  fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
+  toPathMultiPiece = toPathMultiPiece . CI.foldedCase
+
+instance ToHttpApiData (CI Text) where
+  toUrlPiece = CI.original
+
+instance FromHttpApiData (CI Text) where
+  parseUrlPiece = return . CI.mk
+
+
 
 type Points = Centi
 
-toPoints :: Integral a => a -> Points
-toPoints = MkFixed . fromIntegral
+toPoints :: Integral a => a -> Points -- deprecated
+toPoints = fromIntegral
 
-fromPoints :: Integral a => Points -> a
-fromPoints (MkFixed c) = fromInteger c
+pToI :: Points -> Integer -- deprecated
+pToI = fromPoints
+
+fromPoints :: Integral a => Points -> a -- deprecated
+fromPoints = round
+
+instance DisplayAble Points
 
 data SheetType
   = Bonus  { maxPoints :: Points }
@@ -52,36 +98,144 @@ data SheetType
   | Pass   { maxPoints, passingPoints :: Points }
   | NotGraded
   deriving (Show, Read, Eq)
+
+instance DisplayAble SheetType where
+  display (Bonus {..}) = tshow maxPoints <> " Bonuspunkte"
+  display (Normal{..}) = tshow maxPoints <> " Punkte"
+  display (Pass  {..}) = "Bestanden ab " <> tshow (pToI passingPoints) <> " von " <> tshow maxPoints
+  display (NotGraded)  = "Unbewertet"
+
 deriveJSON defaultOptions ''SheetType
-derivePersistFieldJSON "SheetType"
+derivePersistFieldJSON ''SheetType
+
+data SheetTypeSummary = SheetTypeSummary
+  { sumBonusPoints  :: Sum Points
+  , sumNormalPoints :: Sum Points
+  , numPassSheets   :: Sum Int
+  , numNotGraded    :: Sum Int
+  , achievedBonus   :: Maybe (Sum Points)
+  , achievedNormal  :: Maybe (Sum Points)
+  , achievedPasses  :: Maybe (Sum Int)
+  } deriving (Generic)
+
+instance Monoid SheetTypeSummary where
+  mempty = memptydefault
+  mappend = mappenddefault
+
+sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary
+sheetTypeSum (Bonus{..},  achieved) = mempty { sumBonusPoints = Sum maxPoints, achievedBonus = Sum <$> achieved }
+sheetTypeSum (Normal{..}, achieved) = mempty { sumNormalPoints = Sum maxPoints, achievedNormal = Sum <$> achieved }
+sheetTypeSum (Pass{..},   achieved) = mempty { numPassSheets = Sum 1, achievedPasses = Sum . bool 0 1 . (passingPoints <=) <$> achieved}
+sheetTypeSum (NotGraded,  _       ) = mempty { numNotGraded = Sum 1 }
+
 
 data SheetGroup
-  = Arbitrary { maxParticipants :: Int } -- Distinguish Limited/Arbitrary
+  = Arbitrary { maxParticipants :: Int }
   | RegisteredGroups
   | NoGroups
   deriving (Show, Read, Eq)
 deriveJSON defaultOptions ''SheetGroup
-derivePersistFieldJSON "SheetGroup"
+derivePersistFieldJSON ''SheetGroup
 
 data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 derivePersistField "SheetFileType"
 
+instance Universe SheetFileType where universe = universeDef
+instance Finite SheetFileType
+
 instance PathPiece SheetFileType where
   toPathPiece SheetExercise = "file"
   toPathPiece SheetHint     = "hint"
   toPathPiece SheetSolution = "solution"
   toPathPiece SheetMarking  = "marking"
-  fromPathPiece t =
-    lookup (CI.mk t) [(CI.mk $ toPathPiece ty,ty) | ty <- [minBound..maxBound]]
+  fromPathPiece = finiteFromPathPiece
+
+-- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
+instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
+  display SheetExercise = "Aufgabenstellung"
+  display SheetHint     = "Hinweise"
+  display SheetSolution = "Musterlösung"
+  display SheetMarking  = "Korrekturhinweise"
+
+-- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a)
+-- partitionFileType' = groupMap
+
+partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a
+partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs
+
+data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
+  deriving (Show, Read, Eq, Ord, Enum, Bounded)
+
+instance Universe SubmissionFileType where universe = universeDef
+instance Finite SubmissionFileType
+
+submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
+submissionFileTypeIsUpdate SubmissionOriginal  = False
+submissionFileTypeIsUpdate SubmissionCorrected = True
+
+isUpdateSubmissionFileType :: Bool -> SubmissionFileType
+isUpdateSubmissionFileType False = SubmissionOriginal
+isUpdateSubmissionFileType True  = SubmissionCorrected
+
+instance PathPiece SubmissionFileType where
+  toPathPiece SubmissionOriginal  = "original"
+  toPathPiece SubmissionCorrected = "corrected"
+  fromPathPiece = finiteFromPathPiece
+
+instance DisplayAble SubmissionFileType where
+  display SubmissionOriginal  = "Abgabe"
+  display SubmissionCorrected = "Korrektur"
+
+{-
+data DA = forall a . (DisplayAble a) => DA a
+
+instance DisplayAble DA where
+  display (DA x) = display x
+-}
+
+
+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"
 
-data Load = ByTutorial | ByProportion Rational
-  deriving (Show, Read, Eq)
-derivePersistField "Load"
+-- | Specify a corrector's workload
+data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational }
+    = Load { byTutorial :: Maybe Bool  -- ^ Just all from Tutorial, True if counting towards overall workload
+           , byProportion :: Rational  -- ^ workload proportion of all submission not assigned to tutorial leaders
+           }
+  deriving (Show, Read, Eq, Ord)
+
+deriveJSON defaultOptions ''Load
+derivePersistFieldJSON ''Load
+
+
+
+
+instance Semigroup Load where
+  (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
+    where
+      byTut''
+        | Nothing <- byTut  = byTut'
+        | Nothing <- byTut' = byTut
+        | Just a <- byTut
+        , Just b <- byTut'  = Just $ a || b
+
+instance Monoid Load where
+  mempty = Load Nothing 0
+  mappend = (<>)
+
+{- Use (is _ByTutorial) instead of this unneeded definition:
+  isByTutorial :: Load -> Bool
+  isByTutorial (ByTutorial {}) = True
+  isByTutorial _               = False
+-}
 
 data Season = Summer | Winter
   deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
@@ -98,6 +252,8 @@ seasonFromChar c
   where
     (~=) = (==) `on` CI.mk
 
+instance DisplayAble Season
+
 data TermIdentifier = TermIdentifier
   { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
   , season :: Season
@@ -107,25 +263,63 @@ data TermIdentifier = TermIdentifier
 -- from_TermId_to_TermIdentifier = unTermKey
 -- from_TermIdentifier_to_TermId = TermKey
 
---TODO: Enforce the number of digits within year, with parsing filling in the current leading digits? Goal: short urls
-termToText :: TermIdentifier -> Text
-termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show year
+shortened :: Iso' Integer Integer
+shortened = iso shorten expand
+  where
+    century = ($currentYear `div` 100) * 100
+    expand year
+      | 0 <= year
+      , year < 100 = let
+          options = [ expanded | offset <- [-1, 0, 1]
+                               , let century' = century + offset * 100
+                                     expanded = century' + year
+                               , $currentYear - 50 <= expanded
+                               , expanded < $currentYear + 50
+                               ]
+          in case options of
+               [unique] -> unique
+               failed   -> error $ "Could not expand year " ++ show year ++ ": " ++ show failed
+      | otherwise = year
+    shorten year
+      | $currentYear - 50 <= year
+      , year < $currentYear + 50 = year `mod` 100
+      | otherwise = year
 
+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 year <- readMaybe ys
+  , 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
+  where
+    seasonOffset
+      | Summer <- season = 0
+      | Winter <- season = 0.5
+
+termFromRational :: Rational -> TermIdentifier
+termFromRational n = TermIdentifier{..}
+  where
+    year = floor n
+    remainder = n - (fromInteger $ floor n)
+    season
+      | remainder == 0 = Summer
+      | otherwise      = Winter
+
 instance PersistField TermIdentifier where
-  toPersistValue = PersistText . termToText
-  fromPersistValue (PersistText t) = termFromText t
+  toPersistValue = PersistRational . termToRational
+  fromPersistValue (PersistRational t) = Right $ termFromRational t
   fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x
 
 instance PersistFieldSql TermIdentifier where
-  sqlType _ = SqlString
+  sqlType _ = SqlNumeric 5 1
 
 instance ToHttpApiData TermIdentifier where
   toUrlPiece = termToText
@@ -142,33 +336,120 @@ instance ToJSON TermIdentifier where
 
 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 = checkMMap (return . termFromText) termToText textField
-  -- TODO: this is too simple and inconvenient, use selector and year picker  
--} 
+    termField :: Field (HandlerT UniWorX IO) TermIdentifier
+    termField = checkMMap (return . termFromText) termToText textField
+   See Handler.Utils.Form.termsField and termActiveField
+-}
 
 
 withinTerm :: Day -> TermIdentifier -> Bool
 time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
-  where 
-    timeYear = fst3 $ toGregorian time      
-    termYear = year term 
-      
+  where
+    timeYear = fst3 $ toGregorian time
+    termYear = year term
+
 
 data StudyFieldType = FieldPrimary | FieldSecondary
   deriving (Eq, Ord, Enum, Show, Read, Bounded)
 derivePersistField "StudyFieldType"
 
-derivePersistField "UUID"
+instance PersistField UUID where
+  toPersistValue = PersistDbSpecific . toASCIIBytes
+  fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ fromText t
+  fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ fromASCIIBytes bs
+  fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ fromASCIIBytes bs
+  fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x
 
-instance PersistField Value where
-  toPersistValue = PersistDbSpecific . toStrict . encode
+instance PersistFieldSql UUID where
+  sqlType _ = SqlOther "uuid"
 
-  fromPersistValue (PersistDbSpecific t) = first pack . eitherDecode $ fromStrict t
-  fromPersistValue (PersistByteString t) = first pack . eitherDecode $ fromStrict t
-  fromPersistValue v = Left $ "JSON values must be converted from PersistDbSpecific (got: " ++ tshow v ++ ")"
+instance DisplayAble StudyFieldType
 
-instance PersistFieldSql Value where
-  sqlType _ = SqlOther "json"
+data Theme
+  = ThemeDefault
+  | ThemeLavender
+  | ThemeNeutralBlue
+  | ThemeAberdeenReds
+  | ThemeMossGreen
+  | ThemeSkyLove
+  deriving (Eq, Ord, Bounded, Enum, Show, Read)
+
+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])
+  fromPathPiece = finiteFromPathPiece
+
+$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
+
+derivePersistField "Theme"
+
+
+newtype ZIPArchiveName obj = ZIPArchiveName { unZIPArchiveName :: obj }
+  deriving (Show, Read, Eq)
+
+instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
+    fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip"
+    toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName
+
+newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
+  deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql, IsString)
+
+data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
+  deriving (Eq, Ord, Read, Show, Enum, Bounded)
+
+
+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
+
+instance Universe CorrectorState where universe = universeDef
+instance Finite CorrectorState
+
+instance PathPiece CorrectorState where
+  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
+
+
+derivePersistFieldJSON ''Value
+
+  
+-- Type synonyms
+
+type SchoolName      = CI Text
+type SchoolShorthand = CI Text
+type CourseName      = CI Text
+type CourseShorthand = CI Text
+type SheetName       = CI Text
+type UserEmail       = CI Text
+
+type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString

src/Model/Types/JSON.hs

@@ -0,0 +1,56 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
+
+module Model.Types.JSON
+  ( derivePersistFieldJSON
+  ) where
+
+import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
+import Data.List (foldl)
+import Database.Persist.Sql
+
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Text.Encoding as Text
+
+import qualified Data.Aeson as JSON
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Datatype
+
+
+derivePersistFieldJSON :: Name -> DecsQ
+derivePersistFieldJSON n = do
+  DatatypeInfo{..} <- reifyDatatype n
+  vars <- forM datatypeVars (const $ newName "a")
+  let t = foldl (\t n -> t `appT` varT n) (conT n) vars
+      iCxt
+        | null vars = cxt []
+        | otherwise = cxt [[t|ToJSON|] `appT` t, [t|FromJSON|] `appT` t]
+      sqlCxt
+        | null vars = cxt []
+        | otherwise = cxt [[t|PersistField|] `appT` t]
+  sequence
+    [ instanceD iCxt ([t|PersistField|] `appT` t)
+      [ funD (mkName "toPersistValue")
+        [ clause [] (normalB [e|PersistDbSpecific . LBS.toStrict . JSON.encode|]) []
+        ]
+      , funD (mkName "fromPersistValue")
+        [ do
+            bs <- newName "bs"
+            clause [[p|PersistDbSpecific $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) []
+        , do
+            bs <- newName "bs"
+            clause [[p|PersistByteString $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) []
+        , do
+            t <- newName "t"
+            clause [[p|PersistText $(varP t)|]] (normalB [e|first pack . JSON.eitherDecodeStrict' $ Text.encodeUtf8 $(varE t)|]) []
+        , clause [wildP] (normalB [e|Left "JSON values must be converted from PersistDbSpecific, PersistText, or PersistByteString"|]) []
+        ]
+      ]
+    , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
+      [ funD (mkName "sqlType")
+        [ clause [wildP] (normalB [e|SqlOther "json"|]) []
+        ]
+      ]
+    ]

src/Notifications.hs

@@ -1,82 +0,0 @@
-{-# LANGUAGE NoImplicitPrelude
-           , RecordWildCards
-           , TemplateHaskell
-           , OverloadedStrings
-           , FlexibleContexts
-           , ViewPatterns
-           , TypeFamilies
-           , DeriveGeneric
-           , DeriveDataTypeable
-  #-}
-
-module Notifications
-  ( handleNotifications
-  ) where
-
-import Import
-
-import Data.Conduit.TMChan
-import qualified Data.Conduit.List as C
-
-import Data.Aeson (fromJSON, Result(..))
-import Database.Persist.Sql (rawExecute, fromSqlKey)
-
-
-data NotificationQueueException = QNInvalid QueuedNotification
-                                | QNLocked QueuedNotificationId UUID UTCTime
-                                | QNNonexistant QueuedNotificationId
-  deriving (Read, Show, Eq, Generic, Typeable)
-
-instance Exception NotificationQueueException
-  
-
-handleNotifications :: UniWorX -> IO ()
-handleNotifications foundation@UniWorX{..} = unsafeHandler foundation . bracket_ logStart logStop . runConduit $ sourceTMChan appNotificationCtl .| handleNotifications'
-  where
-    logStart = $(logDebugS) "Notifications" "Started"
-    logStop = $(logDebugS) "Notifications" "Shutting down"
-
-handleNotifications' :: Sink NotificationCtl Handler ()
-handleNotifications' = C.mapM_ $ void . handleAny ($(logErrorS) "Notifications" . tshow) . handleCmd
-  where
-    handleQueueException :: MonadLogger m => NotificationQueueException -> m ()
-    handleQueueException (QNInvalid qn) = $(logWarnS) "Notifications" $ "Invalid QueuedNotification: " ++ tshow qn
-    handleQueueException (QNNonexistant qnId) = $(logInfoS) "Notifications" $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey qnId)
-    handleQueueException (QNLocked qnId lInstance lTime)  = $(logDebugS) "Notifications" $ "Saw locked QueuedNotification: " ++ tshow (qnId, lInstance, lTime)
-    
-    handleCmd NCtlFlush = void . fork . runDB . runConduit $ selectKeys [] [ Asc QueuedNotificationCreated ] .| C.mapM_ cmdSend
-    handleCmd (NCtlSend qnId) = handle handleQueueException . (`finally` qnUnlock qnId) $ do
-      qn@QueuedNotification{..} <- qnLock qnId
-
-      let
-        content :: Notification
-        Success content = fromJSON queuedNotificationContent
-      
-      $(logDebugS) "Notifications" $ "Would send: " <> tshow (queuedNotificationRecipient, content) -- FIXME
-
-      runDB $ delete qnId
-
-qnLock :: QueuedNotificationId -> Handler QueuedNotification
-qnLock qnId = runDB $ do
-  rawExecute "SET TRANSACTION ISOLATION LEVEL SERIALIZABLE" []
-  qn@QueuedNotification{..} <- maybe (throwM $ QNNonexistant qnId) return =<< get qnId
-  maybe (return ()) throwM $ QNLocked <$> pure qnId <*> queuedNotificationLockInstance <*> queuedNotificationLockTime
-  unless ((fromJSON queuedNotificationContent :: Result Notification) /= mempty) . throwM $ QNInvalid qn
-  instanceID <- getsYesod appInstanceID
-  now <- liftIO getCurrentTime
-  updateGet qnId [ QueuedNotificationLockInstance =. Just instanceID
-                 , QueuedNotificationLockTime =. Just now
-                 ]
-
-qnUnlock :: QueuedNotificationId -> Handler ()
-qnUnlock qnId = runDB $ update qnId [ QueuedNotificationLockInstance =. Nothing
-                                    , QueuedNotificationLockTime =. Nothing
-                                    ]
-
-
-cmdSend :: ( MonadHandler m
-           , HandlerSite m ~ UniWorX
-           ) => QueuedNotificationId -> m ()
-cmdSend (NCtlSend -> cmd) = do
-  chan <- getsYesod appNotificationCtl 
-  liftIO . atomically $ writeTMChan chan cmd

src/Settings.hs

@@ -3,6 +3,8 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE MultiWayIf        #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 -- | Settings are centralized, as much as possible, into this file. This
 -- includes database connection settings, static file locations, etc.
 -- In addition, you can configure a number of different aspects of Yesod
@@ -14,6 +16,8 @@ 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')
 import           Database.Persist.Postgresql (PostgresConf)
@@ -23,6 +27,19 @@ 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 hiding (MessageClass(..))
+import Control.Lens
+
+import Data.Maybe (fromJust)
+import qualified Data.Char as Char
+
+import Model
 
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
@@ -32,6 +49,8 @@ data AppSettings = AppSettings
     -- ^ Directory from which to serve static files.
     , appDatabaseConf           :: PostgresConf
     -- ^ Configuration settings for accessing the database.
+    , appLdapConf               :: Maybe LdapConf
+    -- ^ Configuration settings for accessing the LDAP-directory
     , appRoot                   :: Maybe Text
     -- ^ Base for all generated URLs. If @Nothing@, determined
     -- from the request headers.
@@ -43,11 +62,6 @@ data AppSettings = AppSettings
     -- ^ Get the IP address from the header when logging. Useful when sitting
     -- behind a reverse proxy.
 
-    , appLDAPURI                :: String
-    , appLDAPDN                 :: String
-    , appLDAPPw                 :: String
-    , appLDAPBaseName           :: Maybe String
-
     , appDetailedRequestLogging :: Bool
     -- ^ Use detailed request logging system
     , appShouldLogAll           :: Bool
@@ -58,21 +72,80 @@ data AppSettings = AppSettings
     -- ^ Assume that files in the static dir may change after compilation
     , appSkipCombining          :: Bool
     -- ^ Perform no stylesheet/script combining
-
-    , appDefaultFavourites :: Int
-    -- ^ Initial Value for remembered Favourites
-
-    -- Example app-specific configuration values.
-    , appCopyright              :: Text
-    -- ^ Copyright text to appear in the footer of the page
-    , appAnalytics              :: Maybe Text
-    -- ^ Google Analytics code
-    , appCryptoIDKeyFile        :: FilePath
-    , appInstanceIDFile         :: Maybe FilePath
-
     , appAuthDummyLogin         :: Bool
     -- ^ Indicate if auth dummy login should be enabled.
+    , appAllowDeprecated        :: Bool
+    -- ^ Indicate if deprecated routes are accessible for everyone
+    , appMinimumLogLevel        :: LogLevel
+
+    , appUserDefaults           :: UserDefaultConf
+    , appAuthPWHash             :: PWHashConf
+
+    , appCryptoIDKeyFile        :: FilePath
+    , appInstanceIDFile         :: Maybe FilePath
     }
+  
+data UserDefaultConf = UserDefaultConf
+  { userDefaultTheme :: Theme
+  , userDefaultMaxFavourites :: Int
+  , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
+  , userDefaultDownloadFiles :: Bool
+  }
+ 
+data PWHashConf = PWHashConf
+  { pwHashAlgorithm :: PWHashAlgorithm
+  , pwHashStrength :: Int
+  }
+
+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
+  , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
+  , ldapBase :: Ldap.Dn
+  , ldapScope :: Ldap.Scope
+  , ldapTimeout :: Int32
+  }
+ 
+deriveFromJSON defaultOptions ''Ldap.Scope
+deriveFromJSON defaultOptions
+  { fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel
+  } ''UserDefaultConf
+
+instance FromJSON LdapConf where
+    parseJSON = withObject "LdapConf" $ \o -> do
+        ldapTls <- o .:? "tls"
+        tlsSettings <- case ldapTls :: Maybe String of
+          Just spec
+            | spec == "insecure" -> return $ Just Ldap.insecureTlsSettings
+            | spec == "default"  -> return $ Just Ldap.defaultTlsSettings
+            | null spec          -> return Nothing
+          Nothing                -> return Nothing
+          _otherwise             -> fail "Could not parse LDAP TLSSettings"
+        ldapHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .: "host"
+        ldapPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port"
+        ldapDn <- Ldap.Dn <$> o .: "user"
+        ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .: "pass"
+        ldapBase <- Ldap.Dn <$> o .: "baseDN"
+        ldapScope <- o .: "scope"
+        ldapTimeout <- o .: "timeout"
+        return LdapConf{..}
+
+deriveFromJSON
+  defaultOptions
+    { constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level"
+    , sumEncoding = UntaggedValue
+    }
+  ''LogLevel
 
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
@@ -84,29 +157,30 @@ instance FromJSON AppSettings where
 #endif
         appStaticDir              <- o .: "static-dir"
         appDatabaseConf           <- o .: "database"
+        let nonEmptyHost LdapConf{..} = case ldapHost of
+              Ldap.Tls host _ -> not $ null host
+              Ldap.Plain host -> not $ null host
+        appLdapConf               <- assertM nonEmptyHost <$> o .:? "ldap"
         appRoot                   <- o .:? "approot"
         appHost                   <- fromString <$> o .: "host"
         appPort                   <- o .: "port"
         appIpFromHeader           <- o .: "ip-from-header"
 
-        ( appLDAPURI, appLDAPDN, appLDAPPw, appLDAPBaseName )
-          <- (=<< o .: "ldap") . withObject "LDAP" $ \obj -> (,,,) <$> obj .: "uri" <*> obj .: "dn" <*> obj .: "password" <*> obj .:? "basename"
-
         appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
         appShouldLogAll           <- o .:? "should-log-all"   .!= defaultDev
+        appMinimumLogLevel        <- o .:  "minimum-log-level"
         appReloadTemplates        <- o .:? "reload-templates" .!= defaultDev
         appMutableStatic          <- o .:? "mutable-static"   .!= defaultDev
         appSkipCombining          <- o .:? "skip-combining"   .!= defaultDev
+        appAuthDummyLogin         <- o .:? "auth-dummy-login" .!= defaultDev
+        appAllowDeprecated        <- o .:? "allow-deprecated" .!= defaultDev
 
-        appDefaultFavourites      <- o .:  "userDefaultFavourites"
+        appUserDefaults           <- o .:  "user-defaults"
+        appAuthPWHash             <- o .:  "auth-pw-hash"
 
-        appCopyright              <- o .:  "copyright"
-        appAnalytics              <- o .:? "analytics"
         appCryptoIDKeyFile        <- o .:  "cryptoid-keyfile"
         appInstanceIDFile         <- o .:? "instance-idfile"
 
-        appAuthDummyLogin         <- o .:? "auth-dummy-login"      .!= defaultDev
-
         return AppSettings {..}
 
 -- | Settings for 'widgetFile', such as which template languages to support and

src/Utils.hs

@@ -1,7 +1,13 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
 {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult
 
 module Utils
   ( module Utils
@@ -9,18 +15,93 @@ module Utils
 
 import ClassyPrelude.Yesod
 
+-- import Data.Double.Conversion.Text -- faster implementation for textPercent?
+import Data.Foldable as Fold hiding (length)
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
 import Utils.DB as Utils
-import Utils.Common 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)
 
+import Data.Char (isDigit)
+import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
+import Numeric (showFFloat)
+
+import Control.Lens
+import Data.Set (Set)
+import qualified Data.Set as Set
 import Data.Map (Map)
 import qualified Data.Map as Map
-import qualified Data.List as List
+-- import qualified Data.List as List
 
+import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Control.Monad.Catch
+
+
+import qualified Database.Esqueleto as E (Value, unValue)
+
+import Language.Haskell.TH
+import Instances.TH.Lift ()
+
+import Text.Shakespeare.Text (st)
+
+
+
+-----------
+-- Yesod --
+-----------
+
+newtype MsgRendererS site = MsgRenderer { render :: (forall msg. RenderMessage site msg => msg -> Text) }
+
+getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site)
+getMsgRenderer = do
+  mr <- getMessageRender
+  return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)
+
+
+instance Monad FormResult where
+  FormMissing        >>= _ = FormMissing
+  (FormFailure errs) >>= _ = FormFailure errs
+  (FormSuccess a)    >>= f = f a
+
+guardAuthResult :: MonadHandler m => AuthResult -> m ()
+guardAuthResult AuthenticationRequired = notAuthenticated
+guardAuthResult (Unauthorized t) = permissionDenied t
+guardAuthResult Authorized = return ()
+
+data UnsupportedAuthPredicate route = UnsupportedAuthPredicate String route
+  deriving (Eq, Ord, Typeable, Show)
+instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route)
+
+unsupportedAuthPredicate :: ExpQ
+unsupportedAuthPredicate = do
+  logFunc <- logErrorS
+  [e| \tag route -> do
+        $(return logFunc) "AccessControl" [st|"!#{tag}" used on route that doesn't support it: #{tshow route}|]
+        unauthorizedI (UnsupportedAuthPredicate tag route)
+    |]
+
+
+
+---------------------
+-- Text and String --
+---------------------
 
 tickmark :: IsString a => a
 tickmark = fromString "✔"
+-- Avoid annoying warnings:
+tickmarkS :: String
+tickmarkS = tickmark
+tickmarkT :: Text
+tickmarkT = tickmark
 
 text2Html :: Text -> Html
 text2Html = toHtml -- prevents ambiguous types
@@ -29,28 +110,327 @@ toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
   a -> WidgetT site m ()
 toWgt = toWidget . toHtml
 
+-- Convenience Functions to avoid type signatures:
 text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
                 Text -> WidgetT site m ()
 text2widget t = [whamlet|#{t}|]
 
+citext2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
+                (CI Text) -> WidgetT site m ()
+citext2widget t = [whamlet|#{CI.original t}|]
+
 str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
                 String -> WidgetT site m ()
 str2widget s = [whamlet|#{s}|]
 
+display2widget ::  (MonadBaseControl IO m, MonadThrow m, MonadIO m, DisplayAble a) =>
+                a -> WidgetT site m ()
+display2widget = text2widget . display
 
-withFragment :: ( Monad m
-                ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
+withFragment :: Monad m => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
 withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
 
+
+-- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production)
+{- (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)
+  default display :: Show a => a -> Text
+  display = pack . show
+
+instance DisplayAble Text where
+  display = id
+
+instance DisplayAble String where
+  display = pack
+
+instance DisplayAble Int
+instance DisplayAble Int64
+instance DisplayAble Integer
+
+instance DisplayAble Rational where
+  display r = showFFloat (Just 2) (rat2float r) ""
+      & pack
+      & dropWhileEnd ('0'==)
+      & dropWhileEnd ('.'==)
+    where
+      rat2float :: Rational -> Double
+      rat2float = fromRational
+
+instance DisplayAble a => DisplayAble (Maybe a) where
+  display Nothing  = ""
+  display (Just x) = display x
+
+instance DisplayAble a => DisplayAble (E.Value a) where
+  display = display . E.unValue
+
+instance DisplayAble a => DisplayAble (CI a) where
+  display = display . CI.original
+
+{- We do not want DisplayAble for every Show-Class:
+   We want to explicitly verify that the resulting text can be displayed to the User!
+   For example: UTCTime values were shown without proper format rendering!
+instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where -- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated)
+  display = pack . show
+-}
+
+textPercent :: Double -> Text -- slow, maybe use Data.Double.Conversion.Text.toFixed instead?
+textPercent x = lz <> (pack $ show rx) <> "%"
+ where
+   round' :: Double -> Int -- avoids annoying warning
+   round' = round
+   rx :: Double
+   rx = fromIntegral (round' $ 1000.0*x) / 10.0
+   lz = if rx < 10.0 then "0" else ""
+
+stepTextCounterCI :: CI Text -> CI Text -- find and increment rightmost-number, preserving leading zeroes
+stepTextCounterCI = CI.map stepTextCounter
+
+stepTextCounter :: Text -> Text -- find and increment rightmost-number, preserving leading zeroes
+stepTextCounter text
+    | (Just i) <- readMay number =
+        let iplus1 = tshow (succ i :: Int)
+            zeroip = justifyRight (length number) '0' iplus1
+        in  prefix <> zeroip <> suffix
+    | otherwise = text
+  where -- no splitWhile nor findEnd in Data.Text
+    suffix =                        takeWhileEnd (not . isDigit) text
+    number = takeWhileEnd isDigit $ dropWhileEnd (not . isDigit) text
+    prefix = dropWhileEnd isDigit $ dropWhileEnd (not . isDigit) text
+
+-- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo  Ue3bung00322 34 (H)"
+-- ["12",".ProMo  Ue","3","bung","00322"," ","34"," (H)"]
+
+
+------------
+-- Tuples --
+------------
+
+fst3 :: (a,b,c) -> a
+fst3 (x,_,_) = x
+snd3 :: (a,b,c) -> b
+snd3 (_,y,_) = y
+trd3 :: (a,b,c) -> c
+trd3 (_,_,z) = z
+
+-- Further projections are available via TemplateHaskell, defined in Utils.Common:
+-- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
+-- snd3 = $(projNI 3 2)
+
+
+
 -----------
--- Maybe --
+-- Lists --
 -----------
-whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
-whenIsJust (Just x) f = f x
-whenIsJust Nothing  _ = return ()
+
+-- notNull = not . null
+
+lastMaybe :: [a] -> Maybe a
+lastMaybe []    = Nothing
+lastMaybe [h]   = Just h
+lastMaybe (_:t) = lastMaybe t
+
+lastMaybe' :: [a] -> Maybe a
+lastMaybe' l = fmap snd $ l ^? _Snoc
+
+
+mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
+mergeAttrs = mergeAttrs' `on` sort
+  where
+    special = [ ("class", \v1 v2 -> v1 <> " " <> v2)
+              ]
+
+    mergeAttrs' (x1@(n1, v1):xs1) (x2@(n2, v2):xs2)
+      | Just merge <- lookup n1 special
+      , n2 == n1
+      = mergeAttrs' ((n1, merge v1 v2) : xs1) xs2
+      | Just _ <- lookup n1 special
+      , n1 < n2
+      = x2 : mergeAttrs' (x1:xs1) xs2
+      | otherwise = x1 : mergeAttrs' xs1 (x2:xs2)
+    mergeAttrs' [] xs2 = xs2
+    mergeAttrs' xs1 [] = xs1
 
 
 
 ----------
 -- Maps --
 ----------
+
+infixl 5 !!!
+
+
+(!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
+(!!!) m k = (fromMaybe mempty) $ Map.lookup k m
+
+groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
+groupMap l = Map.fromListWith mappend $ [(k, Set.singleton v) | (k,v) <- l]
+
+partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v
+partMap = Map.fromListWith mappend
+
+invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
+invertMap = groupMap . map swap . Map.toList
+
+
+
+-----------
+-- Maybe --
+-----------
+
+toMaybe :: Bool -> a -> Maybe a
+toMaybe True  = Just
+toMaybe False = const Nothing
+
+toNothing :: a -> Maybe b
+toNothing = const Nothing
+
+toNothingS :: String -> Maybe b
+toNothingS = const Nothing
+
+maybeAdd :: Num a => Maybe a -> Maybe a -> Maybe a -- treats Nothing as neutral/zero, unlike fmap
+maybeAdd (Just x) (Just y) = Just (x + y)
+maybeAdd Nothing y  = y
+maybeAdd x Nothing  = x
+
+maybeEmpty :: Monoid m => Maybe a -> (a -> m) -> m
+maybeEmpty (Just x) f = f x
+maybeEmpty Nothing  _ = mempty
+
+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
+
+catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
+catchIfMaybeT p act = catchIf p (lift act) (const mzero)
+
+mcons :: Maybe a -> [a] -> [a]
+mcons Nothing  xs = xs
+mcons (Just x) xs = x:xs
+
+newtype NTop a = NTop a -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
+
+instance Eq a  => Eq (NTop (Maybe a)) where
+  (NTop x) == (NTop y) = x == y
+
+instance Ord a => Ord (NTop (Maybe a)) where
+  compare (NTop Nothing)  (NTop Nothing) = EQ
+  compare (NTop Nothing)  _              = GT
+  compare _               (NTop Nothing) = LT
+  compare (NTop (Just x)) (NTop (Just y)) = compare x y
+
+
+
+------------
+-- 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 --
+---------------
+
+maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b
+maybeExceptT err act = lift act >>= maybe (throwE err) return
+
+maybeMExceptT :: Monad m => (m e) -> m (Maybe b) -> ExceptT e m b
+maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
+
+whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
+whenExceptT b err = when b $ throwE err
+
+whenMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
+whenMExceptT b err = when b $ lift err >>= throwE
+
+guardExceptT :: Monad m => Bool -> e -> ExceptT e m ()
+guardExceptT b err = unless b $ throwE err
+
+guardMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
+guardMExceptT b err = unless b $ lift err >>= throwE
+
+exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
+exceptT f g = either f g <=< runExceptT
+
+catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a
+catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
+
+
+
+------------
+-- Monads --
+------------
+
+shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a
+shortCircuitM sc mx my bop = do
+  x <- mx
+  case sc x of
+    True  -> return x
+    False -> bop <$> pure x <*> my
+
+
+guardM :: MonadPlus m => m Bool -> m ()
+guardM f = guard =<< f
+
+assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
+assertM f x = x >>= assertM' f
+
+assertM' :: MonadPlus m => (a -> Bool) -> a -> m a
+assertM' f x = x <$ guard (f x)
+
+-- Some Utility Functions from Agda.Utils.Monad
+-- | Monadic if-then-else.
+ifM :: Monad m => m Bool -> m a -> m a -> m a
+ifM c m m' =
+    do  b <- c
+        if b then m else m'
+
+-- | @ifNotM mc = ifM (not <$> mc)@
+ifNotM :: Monad m => m Bool -> m a -> m a -> m a
+ifNotM c = flip $ ifM c
+
+-- | Lazy monadic conjunction.
+and2M :: Monad m => m Bool -> m Bool -> m Bool
+and2M ma mb = ifM ma mb (return False)
+
+andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
+andM = Fold.foldr and2M (return True)
+
+allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
+allM xs f = andM $ fmap f xs
+
+-- | Lazy monadic disjunction.
+or2M :: Monad m => m Bool -> m Bool -> m Bool
+or2M ma mb = ifM ma (return True) mb
+
+orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
+orM = Fold.foldr or2M (return False)
+
+anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
+anyM xs f = orM $ fmap f xs

src/Utils/Common.hs

@@ -1,52 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE QuasiQuotes #-}
-
-module Utils.Common where
--- Common Utility Functions
-
-import Language.Haskell.TH
-
-
-------------
--- Tuples --
-------------
-
-fst3 :: (a,b,c) -> a
-fst3 (x,_,_) = x
-snd3 :: (a,b,c) -> b
-snd3 (_,y,_) = y
-trd3 :: (a,b,c) -> c
-trd3 (_,_,z) = z
-
-projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2)  --ghci -fth
--- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
-projNI n i = lamE [pat] rhs
-  where pat = tupP (map varP xs)
-        rhs = varE (xs !! (i - 1))
-        xs  = [ mkName $ "x" ++ show j | j <- [1..n] ]
-        
-        
----------------
--- Functions --
----------------
-
-permuteFun :: [Int] -> ExpQ -- generic permutation of function arguments, i.e. $(permuteFun [2,1]) == flip
-permuteFun perm = lamE pat rhs
-  where pat = map varP $ fn:xs
-        rhs = foldl appE (varE fn) $ map varE ps
---         rhs = appE (varE fn) (varE $ xs!!1)
-        ln  = length perm   
-        xs  = [ mkName $ "x" ++ show j | j <- [1..ln] ]
-        ps  = [ xs !! (j-1) | j <- perm ]
-        fn  = mkName "fn" 
-
-altFun :: [Int] -> ExpQ -- generic permutation/repetition of function arguments, i.e. $(permuteFun [2,1]) == flip
-altFun perm = lamE pat rhs
-  where pat = map varP $ fn:xs
-        rhs = foldl appE (varE fn) $ map varE ps
---         rhs = appE (varE fn) (varE $ xs!!1)        
-        mx  = maximum perm
-        xs  = [ mkName $ "x" ++ show j | j <- [1..mx] ]
-        ps  = [ xs !! (j-1) | j <- perm ]
-        fn  = mkName "fn" 
-        

src/Utils/DB.hs

@@ -10,11 +10,19 @@ import ClassyPrelude.Yesod
 import qualified Data.List as List
 import Data.Map (Map)
 import qualified Data.Map as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import qualified Database.Esqueleto as E
+-- import Database.Persist -- currently not needed here
 
-import Database.Persist
 
--- getKeyBy :: PersistEntity val => Unique val -> ReaderT backend0 m0 (Maybe (Entity val))
--- getKeyBy :: Unique a -> YesodDB site (Key a)
+
+emptyOrIn :: PersistField typ =>
+  E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)
+emptyOrIn criterion testSet
+  | Set.null testSet = E.val True
+  | otherwise        = criterion `E.in_` E.valList (Set.toList testSet)
+
 
 entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
 entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty
@@ -27,8 +35,15 @@ getKeyBy404 :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity
   => Unique record -> ReaderT backend m (Key record)
 getKeyBy404 = (fmap entityKey) . getBy404 -- TODO optimize this, so that DB does not deliver entire record!
 
+existsBy :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity record, PersistUniqueRead backend, MonadIO m)
+  => Unique record -> ReaderT backend m Bool
+existsBy = fmap isJust . getBy -- TODO optimize, so that DB does not deliver entire record
 
-myReplaceUnique
+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
        ,Eq (Unique record)
        ,PersistRecordBackend record backend

src/Utils/DateTime.hs

@@ -0,0 +1,65 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , QuasiQuotes
+           , StandaloneDeriving
+           , DeriveLift
+  #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Utils.DateTime
+  ( timeLocaleMap
+  , TimeLocale(..)
+  , currentYear
+  , module Data.Time.Zones
+  , module Data.Time.Zones.TH
+  ) where
+
+import ClassyPrelude.Yesod hiding (lift)
+import System.Locale.Read
+
+import Data.Time (TimeZone(..), TimeLocale(..))
+import Data.Time.Zones (TZ)
+import Data.Time.Zones.TH (includeSystemTZ)
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax (Lift(..))
+import Instances.TH.Lift ()
+
+deriving instance Lift TimeZone
+deriving instance Lift TimeLocale
+
+
+-- $(timeLocaleMap _) :: [Lang] -> TimeLocale
+timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
+              -> ExpQ
+timeLocaleMap [] = fail "Need at least one (language, locale)-pair"
+timeLocaleMap extra@((_, defLocale):_) = do
+  localeMap <- newName "localeMap"
+
+  let
+    localeMap' = funD localeMap $ map matchLang extra ++ [reduceLangList, defaultLang]
+
+    defaultLang :: ClauseQ
+    defaultLang =
+      clause [listP []] (normalB $ localeExp defLocale) []
+
+    reduceLangList :: ClauseQ
+    reduceLangList = do
+      ls <- newName "ls"
+      clause [[p|(_ : $(varP ls))|]] (normalB [e|$(varE localeMap) $(varE ls)|]) []
+
+    matchLang :: (Lang, String) -> ClauseQ
+    matchLang (lang, localeStr) = do
+      lang' <- newName "lang"
+      clause [[p|($(varP lang') : _)|]] (guardedB [(,) <$> normalG [e|$(varE lang') == lang|] <*> localeExp localeStr]) []
+
+    localeExp :: String -> ExpQ
+    localeExp = lift <=< runIO . getLocale . Just
+  
+  letE [localeMap'] (varE localeMap)
+
+currentYear :: ExpQ
+currentYear = do
+  now <- runIO getCurrentTime
+  let (year, _, _) = toGregorian $ utctDay now
+  [e|year|]

src/Utils/Form.hs

@@ -0,0 +1,218 @@
+{-# LANGUAGE NoImplicitPrelude
+           , TemplateHaskell
+           , ViewPatterns
+           , OverloadedStrings
+           , QuasiQuotes
+           , TemplateHaskell
+           , MultiParamTypeClasses
+           , TypeFamilies
+           , FlexibleContexts
+           , NamedFieldPuns
+           , ScopedTypeVariables
+#-}
+
+module Utils.Form where
+
+import ClassyPrelude.Yesod
+import Settings
+
+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
+
+-------------------
+-- Form Renderer --
+-------------------
+
+-- | Use this type to pass information to the form template
+data FormLayout = FormStandard
+
+renderAForm :: Monad m => FormLayout -> FormRender m a
+renderAForm formLayout aform fragment = do
+  (res, (($ []) -> views)) <- aFormToForm aform
+  let widget = $(widgetFile "widgets/form")
+  return (res, widget)
+
+--------------------
+-- Field Settings --
+--------------------
+
+fsl ::  Text -> FieldSettings site
+fsl lbl =
+  FieldSettings { fsLabel    = (SomeMessage lbl)
+                , fsTooltip  = Nothing
+                , fsId       = Nothing
+                , fsName     = Nothing
+                , fsAttrs    = []
+  }
+
+fslI :: RenderMessage site msg => msg -> FieldSettings site
+fslI lbl =
+  FieldSettings { fsLabel    = (SomeMessage lbl)
+                , fsTooltip  = Nothing
+                , fsId       = Nothing
+                , fsName     = Nothing
+                , fsAttrs    = []
+  }
+
+fslp ::  Text -> Text -> FieldSettings site
+fslp lbl placeholder =
+  FieldSettings { fsLabel    = (SomeMessage lbl)
+                , fsTooltip  = Nothing
+                , fsId       = Nothing
+                , fsName     = Nothing
+                , fsAttrs    = [("placeholder", placeholder)]
+  }
+
+fslpI :: RenderMessage site msg => msg -> Text -> FieldSettings site
+fslpI lbl placeholder =
+  FieldSettings { fsLabel    = (SomeMessage lbl)
+                , fsTooltip  = Nothing
+                , fsId       = Nothing
+                , fsName     = Nothing
+                , fsAttrs    = [("placeholder", placeholder)]
+  }
+
+addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
+addAttr attr valu fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
+  where
+    newAttrs :: [(Text,Text)] -> [(Text,Text)]
+    newAttrs [] = [(attr,valu)]
+    newAttrs (p@(a,v):t)
+      | attr==a   = (a,T.append valu $ cons ' ' v):t
+      | otherwise = p:(newAttrs t)
+
+addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
+addAttrs attr valus fs = fs { fsAttrs=newAttrs (fsAttrs fs) }
+  where
+    newAttrs :: [(Text,Text)] -> [(Text,Text)]
+    newAttrs [] = [(attr,T.intercalate " " valus)]
+    newAttrs (p@(a,v):t)
+      | attr==a   = (a,T.intercalate " " (v:valus)):t
+      | otherwise = p:(newAttrs t)
+
+addClass :: Text -> FieldSettings site -> FieldSettings site
+addClass = addAttr "class"
+
+addClasses :: [Text] -> FieldSettings site -> FieldSettings site
+addClasses = addAttrs "class"
+
+addName :: Text -> FieldSettings site -> FieldSettings site
+addName nm fs = fs { fsName = Just nm }
+
+addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
+addNameClass gName gClass fs = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
+
+addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
+addIdClass gId gClass fs = fs { fsId= Just gId, fsAttrs=("class",gClass):(fsAttrs fs) }
+
+
+setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated
+setClass fs c = fs { fsAttrs=("class",c):(fsAttrs fs) }
+
+setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
+setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass):(fsAttrs fs) }
+
+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 --
+------------------------------------------------
+
+data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrection | FIDcorrectionsUpload | FIDcorrectionUpload
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance PathPiece FormIdentifier where
+  fromPathPiece = readFromPathPiece
+  toPathPiece = showToPathPiece
+
+
+identForm :: (Monad m, PathPiece ident)
+          => ident -- ^ Form identification
+          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+          -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
+identForm = identifyForm . toPathPiece
+
+{- Hinweise zur Erinnerung:
+  - identForm primär, wenn es mehr als ein Formular pro Handler gibt
+  - nur einmal pro makeForm reicht
+-}
+
+----------------------------
+-- Buttons (new version ) --
+----------------------------
+
+data family ButtonCssClass site :: *
+
+bcc2txt :: Show (ButtonCssClass site) => ButtonCssClass site -> Text -- a Hack; maybe define Read/Show manually
+bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> (drop 2 $ show bcc))
+
+class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where
+  label :: a -> WidgetT site IO ()
+  label = toWidget . toPathPiece
+
+  cssClass :: a -> ButtonCssClass site
+
+data SubmitButton = BtnSubmit
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance PathPiece SubmitButton where
+  toPathPiece   = showToPathPiece
+  fromPathPiece = readFromPathPiece
+
+buttonField :: forall site a. (Button site a, Show (ButtonCssClass site)) => a -> Field (HandlerT site IO) a -- already validates that the correct button press was received (result only neccessary for combinedButtonField)
+buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
+  where
+    fieldEnctype = UrlEncoded
+
+    fieldView fid name attrs _val _ = let
+      cssClass' :: ButtonCssClass site
+      cssClass' = cssClass btn
+      in [whamlet|
+        <button .btn .#{bcc2txt cssClass'} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid}>^{label btn}
+      |]
+
+    fieldParse []    _ = return $ Right Nothing
+    fieldParse [str] _
+      | str == toPathPiece btn = return $ Right $ Just btn
+      | otherwise  = return $ Left "Wrong button value"
+    fieldParse _ _ = return $ Left "Multiple button values"
+
+combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
+combinedButtonField btns = traverse b2f btns
+  where
+    b2f b = aopt (buttonField b) "" Nothing
+
+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/Lens.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FunctionalDependencies #-}
+module Utils.Lens ( module Utils.Lens ) where
+
+import Import.NoFoundation
+import Control.Lens as Utils.Lens
+import Utils.Lens.TH
+
+import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
+
+_unValue :: Lens' (E.Value a) a
+_unValue f (E.Value a) = E.Value <$> f a
+
+_InnerJoinLeft :: Lens' (E.InnerJoin l r) l -- forall f. Functor f => (a -> f a) -> s -> f s
+_InnerJoinLeft  f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l
+
+_InnerJoinRight :: Lens' (E.InnerJoin l r) r
+_InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r
+
+
+makeLenses_ ''Entity
+
+makeLenses_ ''Course
+
+makeLenses_ ''SheetCorrector
+
+makeLenses_ ''SubmissionGroup
+
+-- makeClassy_ ''Load
+
+

src/Utils/Lens/TH.hs

@@ -0,0 +1,47 @@
+module Utils.Lens.TH where
+
+import Control.Lens
+import Control.Lens.Internal.FieldTH
+import Language.Haskell.TH
+
+-- import Control.Lens.Misc
+{-  NOTE: The code for lensRules_  and makeLenses_ was stolen from package lens-misc-0.0.2.0,
+    which was currently unavailable in our stack snapshot.
+    See https://github.com/louispan/lens-misc
+-}
+
+-- | A 'LensRules' used by 'makeLenses_'.
+lensRules_ :: LensRules
+lensRules_ = lensRules
+    & lensField .~ \_ _ n -> [TopName (mkName ('_':nameBase n))]
+
+-- | Build lenses (and traversals) with a sensible default configuration.
+-- Works the same as 'makeLenses' except that
+-- the resulting lens is also prefixed with an underscore.
+--
+-- /e.g./
+--
+-- @
+-- data FooBar
+--   = Foo { x, y :: 'Int' }
+--   | Bar { x :: 'Int' }
+-- 'makeLenses' ''FooBar
+-- @
+--
+-- will create
+--
+-- @
+-- _x :: 'Lens'' FooBar 'Int'
+-- _x f (Foo a b) = (\\a\' -> Foo a\' b) \<$\> f a
+-- _x f (Bar a)   = Bar \<$\> f a
+-- _y :: 'Traversal'' FooBar 'Int'
+-- _y f (Foo a b) = (\\b\' -> Foo a  b\') \<$\> f b
+-- _y _ c\@(Bar _) = pure c
+-- @
+--
+-- @
+-- 'makeLenses_' = 'makeLensesWith' 'lensRules_'
+-- @
+
+makeLenses_ :: Name -> DecsQ
+makeLenses_ = makeFieldOptics lensRules_

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

@@ -0,0 +1,51 @@
+{-# LANGUAGE NoImplicitPrelude
+  #-}
+
+module Utils.PathPiece
+  ( finiteFromPathPiece
+  , nullaryToPathPiece
+  , splitCamel
+  ) where
+
+import ClassyPrelude.Yesod
+
+import Language.Haskell.TH
+import qualified Language.Haskell.TH.Syntax as TH (Lift(..))
+import Data.Universe
+
+import qualified Data.Text as Text
+import qualified Data.Char as Char
+
+import Data.Monoid (Endo(..))
+
+finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a
+finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of
+  [x] -> Just x
+  _xs -> Nothing
+
+nullaryToPathPiece :: Name -> [Text -> Text] -> ExpQ
+nullaryToPathPiece nullaryType manglers = do
+  TyConI (DataD _ _ _ _ constructors _) <- reify nullaryType
+  helperName <- newName "helper"
+  let
+    toClause (NormalC cName []) = clause [conP cName []] (normalB . TH.lift . mangle $ nameBase cName) []
+    toClause con = fail $ "Unsupported constructor: " ++ show con
+    helperDec = funD helperName $ map toClause constructors
+  letE [helperDec] $ varE helperName
+  where
+    mangle = appEndo (foldMap Endo manglers) . Text.pack
+  
+splitCamel :: Textual t => t -> [t]
+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 (Char.isLower w) items (c:ws) cs
+      | sameCategory w c = helper hadChange items (c:ws) 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
+
+    sameCategory = (==) `on` Char.generalCategory

src/Utils/TH.hs

@@ -0,0 +1,78 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+module Utils.TH where
+-- Common Utility Functions that require TemplateHaskell
+
+-- import Data.Char
+
+import Language.Haskell.TH
+-- import Control.Monad
+-- import Control.Monad.Trans.Class
+-- import Control.Monad.Trans.Maybe
+-- import Control.Monad.Trans.Except
+
+------------
+-- Tuples --
+------------
+
+-- Alternatively uses lenses: "^. _3" projects the 3rd component of an n-tuple for any n >=3, requires import Control.Lens
+projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2)  --ghci -fth
+-- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
+projNI n i = lamE [pat] rhs
+  where pat = tupP (map varP xs)
+        rhs = varE (xs !! (i - 1))
+        xs  = [ mkName $ "x" ++ show j | j <- [1..n] ]
+        
+---------------
+-- Functions --
+---------------
+
+permuteFun :: [Int] -> ExpQ -- generic permutation of function arguments, i.e. $(permuteFun [2,1]) == flip
+permuteFun perm = lamE pat rhs
+  where pat = map varP $ fn:xs
+        rhs = foldl appE (varE fn) $ map varE ps
+--         rhs = appE (varE fn) (varE $ xs!!1)
+        ln  = length perm   
+        xs  = [ mkName $ "x" ++ show j | j <- [1..ln] ]
+        ps  = [ xs !! (j-1) | j <- perm ]
+        fn  = mkName "fn" 
+
+altFun :: [Int] -> ExpQ -- generic permutation/repetition of function arguments, i.e. $(permuteFun [2,1]) == flip
+altFun perm = lamE pat rhs
+  where pat = map varP $ fn:xs
+        rhs = foldl appE (varE fn) $ map varE ps
+--         rhs = appE (varE fn) (varE $ xs!!1)        
+        mx  = maximum perm
+        xs  = [ mkName $ "x" ++ show j | j <- [1..mx] ]
+        ps  = [ xs !! (j-1) | j <- perm ]
+        fn  = mkName "fn" 
+        
+
+
+-- Special Show-Instances for Themes
+deriveShowWith :: (String -> String) -> Name -> Q [Dec]
+deriveShowWith = deriveSimpleWith ''Show 'show
+
+-- deriveDisplayWith :: (String -> String) -> Name -> Q [Dec]
+-- deriveDisplayWith = deriveSimpleWith ''DisplayAble 'display
+
+deriveSimpleWith ::  Name -> Name -> (String -> String) -> Name -> Q [Dec]
+deriveSimpleWith cls fun strOp ty = do
+    (TyConI tyCon)  <- reify ty
+    (tyConName, cs) <- case tyCon of
+        DataD [] nm [] _ cs _ -> return (nm, cs)
+        _ -> fail "deriveShowTheme: tyCon must be a plain datatype enumeration"
+    let instanceT = conT cls `appT` conT tyConName
+    return <$> instanceD (return []) instanceT [genDecs cs]
+  where
+    genDecs :: [Con] -> Q Dec
+    genDecs cs = funD fun (map genClause cs)
+
+    genClause :: Con -> Q Clause
+    genClause (NormalC name []) =
+      let pats = [ConP name []]
+          body = NormalB $ LitE $ StringL $ strOp $ nameBase name
+      in return $ Clause pats body []
+    genClause _ = fail "deriveShowTheme: constructors not allowed to have arguments"
+

src/index.md

@@ -0,0 +1,98 @@
+Utils, Utils.*
+  : Hilfsfunktionionen _unabhängig von Foundation_
+  
+Utils
+  : Yesod Hilfsfunktionen und Instanzen, Text-HTML-Widget-Konvertierungen
+    (`DisplayAble`), Crud, `NTop`, Utility-Funktionen für `MonadPlus`, `Maybe`,
+    `MaybeT`, `Map`, und Attrs-Lists
+    
+Utils.TH
+  : Template Haskell code-generatoren von unabhängigen Hilfsfunktionen (`deriveSimpleWith`)
+  
+Utils.DB
+  : Derived persistent functions (`existsBy`, `getKeyBy404`, ...)
+  
+Utils.Form
+  : `renderAForm`, Field-Settings helper, `FormIdentifier`, `Button`-Klasse,
+    unabhängige konkrete Buttons
+    
+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
+  
+Utils.DateTime
+  : Template Haskell code-generatoren zum compile-time einbinden von Zeitzone
+    und `TimeLocale`
+  
+Handler.Utils, Handler.Utils.*
+  : Hilfsfunktionien, importieren `Import`
+  
+Handler.Utils
+  : `Handler.Utils.*`, Unsortierte _Foundation-abhängige_ Hilfsfunktionen
+  
+Handler.Utils.DateTime
+  : Nutzer-spezifisches `DateTime`-Formatieren
+
+Handler.Utils.Form
+  : Konkrete Buttons, spezielle Felder (inkl. Datei-Upload-Felder),
+    Optionslisten (`optionsPersistCryptoId`), `forced`-Felder (erzwungenes
+    Ergebnis, deaktiviertes Feld), `multiAction`
+    
+Handler.Utils.Rating
+  : `Rating` (kodiert eine Rating-Datei), Parsen und PrettyPrinten von
+    Rating-Dateien
+    
+Handler.Utils.Sheet
+  : `fetchSheet`
+  
+Handler.Utils.StudyFeatures
+  : Parsen von LDAP StudyFeatures-Strings
+  
+Handler.Utils.Submission
+  : `assignSubmissions`, `sinkSubmission` State-Maschinen die (bereits geparste)
+    ZIP-Archive auseinandernehmen und (in einer Transaction) in die Datenbank
+    speichern
+    
+Handler.Utils.Submission.TH
+  : Template Haskell zum parsen und einkompilieren von Dateiname-Blacklist für
+    `sinkSubmission`; Patterns in `config/submission-blacklist`
+    
+Handler.Utils.Table
+  : Hilfsfunktion zum direkten Benutzen von Colonnade (kein `dbTable`)
+  
+Handler.Utils.Table.Pagination
+  : Here be Dragons
+  
+    Paginated database-backed tables with support for sorting, filtering,
+    numbering, forms, further database-requests within cells
+    
+    Includes helper functions for mangling pagination-, sorting-, and filter-settings
+    
+    Includes helper functions for constructing common types of cells
+  
+Handler.Utils.Table.Pagination.Types
+  : `Sortable`-Headedness for colonnade
+
+Handler.Utils.Table.Cells
+  : extends dbTable with UniWorX specific functions, such as special courseCell
+
+Handler.Utils.Templates
+  : Modals
+  
+Handler.Utils.Zip
+  : Conduit-basiertes ZIP Parsen und Erstellen
+  
+Handler.Common
+  : Handler aus dem Scaffolding; Implementierungen von Handlern, die _jede
+    Website_ irgendwann braucht
+    
+CryptoID
+  : Definiert CryptoIDs für custom Typen (aus Model)
+  
+Model.Migration
+  : Manuelle Datenbank-Migration

stack.yaml

@@ -1,8 +1,5 @@
 flags: {}
 
-docker:
-  enable: false
-  image: uniworx
 nix:
   packages: []
   pure: false
@@ -16,14 +13,6 @@ packages:
       git: https://github.com/pngwjpgh/zip-stream.git
       commit: 9272bbed000928d500febad1cdc98d1da29d399e
     extra-dep: true
-  - location:
-      git: https://github.com/mlitchard/yesod-auth-ldap.git
-      commit: 69e08ef687ab96df3352ff4267562135453c6f02
-    extra-dep: true
-  - location:
-      git: https://github.com/mlitchard/authenticate-ldap.git
-      commit: cc2770024766a8fa29d3086688df60aaf65fb954
-    extra-dep: true
   - location:
       git: https://github.com/pngwjpgh/encoding.git
       commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
@@ -33,14 +22,18 @@ extra-deps:
   - colonnade-1.2.0
   - yesod-colonnade-1.2.0
 
+  - ldap-client-0.2.0
+
   - conduit-resumablesink-0.2
 
   - uuid-crypto-1.4.0.0
   - filepath-crypto-0.1.0.0
-  - cryptoids-0.5.0.0
+  - cryptoids-0.5.1.0
   - cryptoids-types-0.0.0
   - cryptoids-class-0.0.0
 
-  - LDAP-0.6.11
+  - system-locale-0.3.0.0
+
+  - persistent-2.7.3.1
 
 resolver: lts-10.5

start.sh

@@ -4,5 +4,18 @@ unset HOST
 export DETAILED_LOGGING=true
 export LOG_ALL=true
 export DUMMY_LOGIN=true
+export ALLOW_DEPRECATED=true
+export PWFILE=users.yml
 
-exec -- stack exec -- yesod devel
+move-back() {
+    mv -v .stack-work .stack-work-run
+    [[ -d .stack-work-ghci ]] && mv -v .stack-work-ghci .stack-work
+}
+
+if [[ -d .stack-work-run ]]; then
+    [[ -d .stack-work ]] && mv -v .stack-work .stack-work-ghci
+    mv -v .stack-work-run .stack-work
+    trap move-back EXIT
+fi
+
+stack exec -- yesod devel

static/css/flatpickr.css

@@ -0,0 +1,740 @@
+.flatpickr-calendar {
+  background: transparent;
+  opacity: 0;
+  display: none;
+  text-align: center;
+  visibility: hidden;
+  padding: 0;
+  -webkit-animation: none;
+          animation: none;
+  direction: ltr;
+  border: 0;
+  font-size: 14px;
+  line-height: 24px;
+  border-radius: 5px;
+  position: absolute;
+  width: 307.875px;
+  -webkit-box-sizing: border-box;
+          box-sizing: border-box;
+  -ms-touch-action: manipulation;
+      touch-action: manipulation;
+  background: #fff;
+  -webkit-box-shadow: 1px 0 0 #e6e6e6, -1px 0 0 #e6e6e6, 0 1px 0 #e6e6e6, 0 -1px 0 #e6e6e6, 0 3px 13px rgba(0,0,0,0.08);
+          box-shadow: 1px 0 0 #e6e6e6, -1px 0 0 #e6e6e6, 0 1px 0 #e6e6e6, 0 -1px 0 #e6e6e6, 0 3px 13px rgba(0,0,0,0.08);
+}
+.flatpickr-calendar.open,
+.flatpickr-calendar.inline {
+  opacity: 1;
+  max-height: 640px;
+  visibility: visible;
+}
+.flatpickr-calendar.open {
+  display: inline-block;
+  z-index: 99999;
+}
+.flatpickr-calendar.animate.open {
+  -webkit-animation: fpFadeInDown 300ms cubic-bezier(0.23, 1, 0.32, 1);
+          animation: fpFadeInDown 300ms cubic-bezier(0.23, 1, 0.32, 1);
+}
+.flatpickr-calendar.inline {
+  display: block;
+  position: relative;
+  top: 2px;
+}
+.flatpickr-calendar.static {
+  position: absolute;
+  top: calc(100% + 2px);
+}
+.flatpickr-calendar.static.open {
+  z-index: 999;
+  display: block;
+}
+.flatpickr-calendar.multiMonth .flatpickr-days .dayContainer:nth-child(n+1) .flatpickr-day.inRange:nth-child(7n+7) {
+  -webkit-box-shadow: none !important;
+          box-shadow: none !important;
+}
+.flatpickr-calendar.multiMonth .flatpickr-days .dayContainer:nth-child(n+2) .flatpickr-day.inRange:nth-child(7n+1) {
+  -webkit-box-shadow: -2px 0 0 #e6e6e6, 5px 0 0 #e6e6e6;
+          box-shadow: -2px 0 0 #e6e6e6, 5px 0 0 #e6e6e6;
+}
+.flatpickr-calendar .hasWeeks .dayContainer,
+.flatpickr-calendar .hasTime .dayContainer {
+  border-bottom: 0;
+  border-bottom-right-radius: 0;
+  border-bottom-left-radius: 0;
+}
+.flatpickr-calendar .hasWeeks .dayContainer {
+  border-left: 0;
+}
+.flatpickr-calendar.showTimeInput.hasTime .flatpickr-time {
+  height: 40px;
+  border-top: 1px solid #e6e6e6;
+}
+.flatpickr-calendar.noCalendar.hasTime .flatpickr-time {
+  height: auto;
+}
+.flatpickr-calendar:before,
+.flatpickr-calendar:after {
+  position: absolute;
+  display: block;
+  pointer-events: none;
+  border: solid transparent;
+  content: '';
+  height: 0;
+  width: 0;
+  left: 22px;
+}
+.flatpickr-calendar.rightMost:before,
+.flatpickr-calendar.rightMost:after {
+  left: auto;
+  right: 22px;
+}
+.flatpickr-calendar:before {
+  border-width: 5px;
+  margin: 0 -5px;
+}
+.flatpickr-calendar:after {
+  border-width: 4px;
+  margin: 0 -4px;
+}
+.flatpickr-calendar.arrowTop:before,
+.flatpickr-calendar.arrowTop:after {
+  bottom: 100%;
+}
+.flatpickr-calendar.arrowTop:before {
+  border-bottom-color: #e6e6e6;
+}
+.flatpickr-calendar.arrowTop:after {
+  border-bottom-color: #fff;
+}
+.flatpickr-calendar.arrowBottom:before,
+.flatpickr-calendar.arrowBottom:after {
+  top: 100%;
+}
+.flatpickr-calendar.arrowBottom:before {
+  border-top-color: #e6e6e6;
+}
+.flatpickr-calendar.arrowBottom:after {
+  border-top-color: #fff;
+}
+.flatpickr-calendar:focus {
+  outline: 0;
+}
+.flatpickr-wrapper {
+  position: relative;
+  display: inline-block;
+}
+.flatpickr-months {
+  display: -webkit-box;
+  display: -webkit-flex;
+  display: -ms-flexbox;
+  display: flex;
+}
+.flatpickr-months .flatpickr-month {
+  background: transparent;
+  color: rgba(0,0,0,0.9);
+  fill: rgba(0,0,0,0.9);
+  height: 28px;
+  line-height: 1;
+  text-align: center;
+  position: relative;
+  -webkit-user-select: none;
+     -moz-user-select: none;
+      -ms-user-select: none;
+          user-select: none;
+  overflow: hidden;
+  -webkit-box-flex: 1;
+  -webkit-flex: 1;
+      -ms-flex: 1;
+          flex: 1;
+}
+.flatpickr-months .flatpickr-prev-month,
+.flatpickr-months .flatpickr-next-month {
+  text-decoration: none;
+  cursor: pointer;
+  position: absolute;
+  top: 0px;
+  line-height: 16px;
+  height: 28px;
+  padding: 10px;
+  z-index: 3;
+}
+.flatpickr-months .flatpickr-prev-month.disabled,
+.flatpickr-months .flatpickr-next-month.disabled {
+  display: none;
+}
+.flatpickr-months .flatpickr-prev-month i,
+.flatpickr-months .flatpickr-next-month i {
+  position: relative;
+}
+.flatpickr-months .flatpickr-prev-month.flatpickr-prev-month,
+.flatpickr-months .flatpickr-next-month.flatpickr-prev-month {
+/*
+      /*rtl:begin:ignore*/
+/*
+      */
+  left: 0;
+/*
+      /*rtl:end:ignore*/
+/*
+      */
+}
+/*
+      /*rtl:begin:ignore*/
+/*
+      /*rtl:end:ignore*/
+.flatpickr-months .flatpickr-prev-month.flatpickr-next-month,
+.flatpickr-months .flatpickr-next-month.flatpickr-next-month {
+/*
+      /*rtl:begin:ignore*/
+/*
+      */
+  right: 0;
+/*
+      /*rtl:end:ignore*/
+/*
+      */
+}
+/*
+      /*rtl:begin:ignore*/
+/*
+      /*rtl:end:ignore*/
+.flatpickr-months .flatpickr-prev-month:hover,
+.flatpickr-months .flatpickr-next-month:hover {
+  color: #959ea9;
+}
+.flatpickr-months .flatpickr-prev-month:hover svg,
+.flatpickr-months .flatpickr-next-month:hover svg {
+  fill: #f64747;
+}
+.flatpickr-months .flatpickr-prev-month svg,
+.flatpickr-months .flatpickr-next-month svg {
+  width: 14px;
+  height: 14px;
+}
+.flatpickr-months .flatpickr-prev-month svg path,
+.flatpickr-months .flatpickr-next-month svg path {
+  -webkit-transition: fill 0.1s;
+  transition: fill 0.1s;
+  fill: inherit;
+}
+.numInputWrapper {
+  position: relative;
+  height: auto;
+}
+.numInputWrapper input,
+.numInputWrapper span {
+  display: inline-block;
+}
+.numInputWrapper input {
+  width: 100%;
+  min-width: auto !important;
+}
+.numInputWrapper input::-ms-clear {
+  display: none;
+}
+.numInputWrapper span {
+  position: absolute;
+  right: 0;
+  width: 14px;
+  padding: 0 4px 0 2px;
+  height: 50%;
+  line-height: 50%;
+  opacity: 0;
+  cursor: pointer;
+  border: 1px solid rgba(57,57,57,0.15);
+  -webkit-box-sizing: border-box;
+          box-sizing: border-box;
+}
+.numInputWrapper span:hover {
+  background: rgba(0,0,0,0.1);
+}
+.numInputWrapper span:active {
+  background: rgba(0,0,0,0.2);
+}
+.numInputWrapper span:after {
+  display: block;
+  content: "";
+  position: absolute;
+}
+.numInputWrapper span.arrowUp {
+  top: 0;
+  border-bottom: 0;
+}
+.numInputWrapper span.arrowUp:after {
+  border-left: 4px solid transparent;
+  border-right: 4px solid transparent;
+  border-bottom: 4px solid rgba(57,57,57,0.6);
+  top: 26%;
+}
+.numInputWrapper span.arrowDown {
+  top: 50%;
+}
+.numInputWrapper span.arrowDown:after {
+  border-left: 4px solid transparent;
+  border-right: 4px solid transparent;
+  border-top: 4px solid rgba(57,57,57,0.6);
+  top: 40%;
+}
+.numInputWrapper span svg {
+  width: inherit;
+  height: auto;
+}
+.numInputWrapper span svg path {
+  fill: rgba(0,0,0,0.5);
+}
+.numInputWrapper:hover {
+  background: rgba(0,0,0,0.05);
+}
+.numInputWrapper:hover span {
+  opacity: 1;
+}
+.flatpickr-current-month {
+  font-size: 135%;
+  line-height: inherit;
+  font-weight: 300;
+  color: inherit;
+  position: absolute;
+  width: 75%;
+  left: 12.5%;
+  padding: 6.16px 0 0 0;
+  line-height: 1;
+  height: 28px;
+  display: inline-block;
+  text-align: center;
+  -webkit-transform: translate3d(0px, 0px, 0px);
+          transform: translate3d(0px, 0px, 0px);
+}
+.flatpickr-current-month span.cur-month {
+  font-family: inherit;
+  font-weight: 700;
+  color: inherit;
+  display: inline-block;
+  margin-left: 0.5ch;
+  padding: 0;
+}
+.flatpickr-current-month span.cur-month:hover {
+  background: rgba(0,0,0,0.05);
+}
+.flatpickr-current-month .numInputWrapper {
+  width: 6ch;
+  width: 7ch\0;
+  display: inline-block;
+}
+.flatpickr-current-month .numInputWrapper span.arrowUp:after {
+  border-bottom-color: rgba(0,0,0,0.9);
+}
+.flatpickr-current-month .numInputWrapper span.arrowDown:after {
+  border-top-color: rgba(0,0,0,0.9);
+}
+.flatpickr-current-month input.cur-year {
+  background: transparent;
+  -webkit-box-sizing: border-box;
+          box-sizing: border-box;
+  color: inherit;
+  cursor: text;
+  padding: 0 0 0 0.5ch;
+  margin: 0;
+  display: inline-block;
+  font-size: inherit;
+  font-family: inherit;
+  font-weight: 300;
+  line-height: inherit;
+  height: auto;
+  border: 0;
+  border-radius: 0;
+  vertical-align: initial;
+}
+.flatpickr-current-month input.cur-year:focus {
+  outline: 0;
+}
+.flatpickr-current-month input.cur-year[disabled],
+.flatpickr-current-month input.cur-year[disabled]:hover {
+  font-size: 100%;
+  color: rgba(0,0,0,0.5);
+  background: transparent;
+  pointer-events: none;
+}
+.flatpickr-weekdays {
+  background: transparent;
+  text-align: center;
+  overflow: hidden;
+  width: 100%;
+  display: -webkit-box;
+  display: -webkit-flex;
+  display: -ms-flexbox;
+  display: flex;
+  -webkit-box-align: center;
+  -webkit-align-items: center;
+      -ms-flex-align: center;
+          align-items: center;
+  height: 28px;
+}
+.flatpickr-weekdays .flatpickr-weekdaycontainer {
+  display: -webkit-box;
+  display: -webkit-flex;
+  display: -ms-flexbox;
+  display: flex;
+  -webkit-box-flex: 1;
+  -webkit-flex: 1;
+      -ms-flex: 1;
+          flex: 1;
+}
+span.flatpickr-weekday {
+  cursor: default;
+  font-size: 90%;
+  background: transparent;
+  color: rgba(0,0,0,0.54);
+  line-height: 1;
+  margin: 0;
+  text-align: center;
+  display: block;
+  -webkit-box-flex: 1;
+  -webkit-flex: 1;
+      -ms-flex: 1;
+          flex: 1;
+  font-weight: bolder;
+}
+.dayContainer,
+.flatpickr-weeks {
+  padding: 1px 0 0 0;
+}
+.flatpickr-days {
+  position: relative;
+  overflow: hidden;
+  display: -webkit-box;
+  display: -webkit-flex;
+  display: -ms-flexbox;
+  display: flex;
+  -webkit-box-align: start;
+  -webkit-align-items: flex-start;
+      -ms-flex-align: start;
+          align-items: flex-start;
+  width: 307.875px;
+}
+.flatpickr-days:focus {
+  outline: 0;
+}
+.dayContainer {
+  padding: 0;
+  outline: 0;
+  text-align: left;
+  width: 307.875px;
+  min-width: 307.875px;
+  max-width: 307.875px;
+  -webkit-box-sizing: border-box;
+          box-sizing: border-box;
+  display: inline-block;
+  display: -ms-flexbox;
+  display: -webkit-box;
+  display: -webkit-flex;
+  display: flex;
+  -webkit-flex-wrap: wrap;
+          flex-wrap: wrap;
+  -ms-flex-wrap: wrap;
+  -ms-flex-pack: justify;
+  -webkit-justify-content: space-around;
+          justify-content: space-around;
+  -webkit-transform: translate3d(0px, 0px, 0px);
+          transform: translate3d(0px, 0px, 0px);
+  opacity: 1;
+}
+.dayContainer + .dayContainer {
+  -webkit-box-shadow: -1px 0 0 #e6e6e6;
+          box-shadow: -1px 0 0 #e6e6e6;
+}
+.flatpickr-day {
+  background: none;
+  border: 1px solid transparent;
+  border-radius: 150px;
+  -webkit-box-sizing: border-box;
+          box-sizing: border-box;
+  color: #393939;
+  cursor: pointer;
+  font-weight: 400;
+  width: 14.2857143%;
+  -webkit-flex-basis: 14.2857143%;
+      -ms-flex-preferred-size: 14.2857143%;
+          flex-basis: 14.2857143%;
+  max-width: 39px;
+  height: 39px;
+  line-height: 39px;
+  margin: 0;
+  display: inline-block;
+  position: relative;
+  -webkit-box-pack: center;
+  -webkit-justify-content: center;
+      -ms-flex-pack: center;
+          justify-content: center;
+  text-align: center;
+}
+.flatpickr-day.inRange,
+.flatpickr-day.prevMonthDay.inRange,
+.flatpickr-day.nextMonthDay.inRange,
+.flatpickr-day.today.inRange,
+.flatpickr-day.prevMonthDay.today.inRange,
+.flatpickr-day.nextMonthDay.today.inRange,
+.flatpickr-day:hover,
+.flatpickr-day.prevMonthDay:hover,
+.flatpickr-day.nextMonthDay:hover,
+.flatpickr-day:focus,
+.flatpickr-day.prevMonthDay:focus,
+.flatpickr-day.nextMonthDay:focus {
+  cursor: pointer;
+  outline: 0;
+  background: #e6e6e6;
+  border-color: #e6e6e6;
+}
+.flatpickr-day.today {
+  border-color: #959ea9;
+}
+.flatpickr-day.today:hover,
+.flatpickr-day.today:focus {
+  border-color: #959ea9;
+  background: #959ea9;
+  color: #fff;
+}
+.flatpickr-day.selected,
+.flatpickr-day.startRange,
+.flatpickr-day.endRange,
+.flatpickr-day.selected.inRange,
+.flatpickr-day.startRange.inRange,
+.flatpickr-day.endRange.inRange,
+.flatpickr-day.selected:focus,
+.flatpickr-day.startRange:focus,
+.flatpickr-day.endRange:focus,
+.flatpickr-day.selected:hover,
+.flatpickr-day.startRange:hover,
+.flatpickr-day.endRange:hover,
+.flatpickr-day.selected.prevMonthDay,
+.flatpickr-day.startRange.prevMonthDay,
+.flatpickr-day.endRange.prevMonthDay,
+.flatpickr-day.selected.nextMonthDay,
+.flatpickr-day.startRange.nextMonthDay,
+.flatpickr-day.endRange.nextMonthDay {
+  background: #569ff7;
+  -webkit-box-shadow: none;
+          box-shadow: none;
+  color: #fff;
+  border-color: #569ff7;
+}
+.flatpickr-day.selected.startRange,
+.flatpickr-day.startRange.startRange,
+.flatpickr-day.endRange.startRange {
+  border-radius: 50px 0 0 50px;
+}
+.flatpickr-day.selected.endRange,
+.flatpickr-day.startRange.endRange,
+.flatpickr-day.endRange.endRange {
+  border-radius: 0 50px 50px 0;
+}
+.flatpickr-day.selected.startRange + .endRange,
+.flatpickr-day.startRange.startRange + .endRange,
+.flatpickr-day.endRange.startRange + .endRange {
+  -webkit-box-shadow: -10px 0 0 #569ff7;
+          box-shadow: -10px 0 0 #569ff7;
+}
+.flatpickr-day.selected.startRange.endRange,
+.flatpickr-day.startRange.startRange.endRange,
+.flatpickr-day.endRange.startRange.endRange {
+  border-radius: 50px;
+}
+.flatpickr-day.inRange {
+  border-radius: 0;
+  -webkit-box-shadow: -5px 0 0 #e6e6e6, 5px 0 0 #e6e6e6;
+          box-shadow: -5px 0 0 #e6e6e6, 5px 0 0 #e6e6e6;
+}
+.flatpickr-day.disabled,
+.flatpickr-day.disabled:hover,
+.flatpickr-day.prevMonthDay,
+.flatpickr-day.nextMonthDay,
+.flatpickr-day.notAllowed,
+.flatpickr-day.notAllowed.prevMonthDay,
+.flatpickr-day.notAllowed.nextMonthDay {
+  color: rgba(57,57,57,0.3);
+  background: transparent;
+  border-color: transparent;
+  cursor: default;
+}
+.flatpickr-day.disabled,
+.flatpickr-day.disabled:hover {
+  cursor: not-allowed;
+  color: rgba(57,57,57,0.1);
+}
+.flatpickr-day.week.selected {
+  border-radius: 0;
+  -webkit-box-shadow: -5px 0 0 #569ff7, 5px 0 0 #569ff7;
+          box-shadow: -5px 0 0 #569ff7, 5px 0 0 #569ff7;
+}
+.flatpickr-day.hidden {
+  visibility: hidden;
+}
+.rangeMode .flatpickr-day {
+  margin-top: 1px;
+}
+.flatpickr-weekwrapper {
+  display: inline-block;
+  float: left;
+}
+.flatpickr-weekwrapper .flatpickr-weeks {
+  padding: 0 12px;
+  -webkit-box-shadow: 1px 0 0 #e6e6e6;
+          box-shadow: 1px 0 0 #e6e6e6;
+}
+.flatpickr-weekwrapper .flatpickr-weekday {
+  float: none;
+  width: 100%;
+  line-height: 28px;
+}
+.flatpickr-weekwrapper span.flatpickr-day,
+.flatpickr-weekwrapper span.flatpickr-day:hover {
+  display: block;
+  width: 100%;
+  max-width: none;
+  color: rgba(57,57,57,0.3);
+  background: transparent;
+  cursor: default;
+  border: none;
+}
+.flatpickr-innerContainer {
+  display: block;
+  display: -webkit-box;
+  display: -webkit-flex;
+  display: -ms-flexbox;
+  display: flex;
+  -webkit-box-sizing: border-box;
+          box-sizing: border-box;
+  overflow: hidden;
+}
+.flatpickr-rContainer {
+  display: inline-block;
+  padding: 0;
+  -webkit-box-sizing: border-box;
+          box-sizing: border-box;
+}
+.flatpickr-time {
+  text-align: center;
+  outline: 0;
+  display: block;
+  height: 0;
+  line-height: 40px;
+  max-height: 40px;
+  -webkit-box-sizing: border-box;
+          box-sizing: border-box;
+  overflow: hidden;
+  display: -webkit-box;
+  display: -webkit-flex;
+  display: -ms-flexbox;
+  display: flex;
+}
+.flatpickr-time:after {
+  content: "";
+  display: table;
+  clear: both;
+}
+.flatpickr-time .numInputWrapper {
+  -webkit-box-flex: 1;
+  -webkit-flex: 1;
+      -ms-flex: 1;
+          flex: 1;
+  width: 40%;
+  height: 40px;
+  float: left;
+}
+.flatpickr-time .numInputWrapper span.arrowUp:after {
+  border-bottom-color: #393939;
+}
+.flatpickr-time .numInputWrapper span.arrowDown:after {
+  border-top-color: #393939;
+}
+.flatpickr-time.hasSeconds .numInputWrapper {
+  width: 26%;
+}
+.flatpickr-time.time24hr .numInputWrapper {
+  width: 49%;
+}
+.flatpickr-time input {
+  background: transparent;
+  -webkit-box-shadow: none;
+          box-shadow: none;
+  border: 0;
+  border-radius: 0;
+  text-align: center;
+  margin: 0;
+  padding: 0;
+  height: inherit;
+  line-height: inherit;
+  cursor: pointer;
+  color: #393939;
+  font-size: 14px;
+  position: relative;
+  -webkit-box-sizing: border-box;
+          box-sizing: border-box;
+}
+.flatpickr-time input.flatpickr-hour {
+  font-weight: bold;
+}
+.flatpickr-time input.flatpickr-minute,
+.flatpickr-time input.flatpickr-second {
+  font-weight: 400;
+}
+.flatpickr-time input:focus {
+  outline: 0;
+  border: 0;
+}
+.flatpickr-time .flatpickr-time-separator,
+.flatpickr-time .flatpickr-am-pm {
+  height: inherit;
+  display: inline-block;
+  float: left;
+  line-height: inherit;
+  color: #393939;
+  font-weight: bold;
+  width: 2%;
+  -webkit-user-select: none;
+     -moz-user-select: none;
+      -ms-user-select: none;
+          user-select: none;
+  -webkit-align-self: center;
+      -ms-flex-item-align: center;
+          align-self: center;
+}
+.flatpickr-time .flatpickr-am-pm {
+  outline: 0;
+  width: 18%;
+  cursor: pointer;
+  text-align: center;
+  font-weight: 400;
+}
+.flatpickr-time .flatpickr-am-pm:hover,
+.flatpickr-time .flatpickr-am-pm:focus {
+  background: #f0f0f0;
+}
+.flatpickr-input[readonly] {
+  cursor: pointer;
+  min-width: auto;
+}
+@-webkit-keyframes fpFadeInDown {
+  from {
+    opacity: 0;
+    -webkit-transform: translate3d(0, -20px, 0);
+            transform: translate3d(0, -20px, 0);
+  }
+  to {
+    opacity: 1;
+    -webkit-transform: translate3d(0, 0, 0);
+            transform: translate3d(0, 0, 0);
+  }
+}
+@keyframes fpFadeInDown {
+  from {
+    opacity: 0;
+    -webkit-transform: translate3d(0, -20px, 0);
+            transform: translate3d(0, -20px, 0);
+  }
+  to {
+    opacity: 1;
+    -webkit-transform: translate3d(0, 0, 0);
+            transform: translate3d(0, 0, 0);
+  }
+}

static/css/fonts.css

@@ -1,9 +1,19 @@
-@font-face {
-  font-family: 'Glyphicons Halflings';
-  src: url('../fonts/glyphicons-halflings-regular.eot');
-  src: url('../fonts/glyphicons-halflings-regular.eot?#iefix') format('embedded-opentype'),
-       url('../fonts/glyphicons-halflings-regular.woff2') format('woff2'),
-       url('../fonts/glyphicons-halflings-regular.woff') format('woff'),
-       url('../fonts/glyphicons-halflings-regular.ttf') format('truetype'),
-       url('../fonts/glyphicons-halflings-regular.svg#glyphicons_halflingsregular') format('svg');
+/*!
+ * Font Awesome Free 5.1.0 by @fontawesome - https://fontawesome.com
+ * License - https://fontawesome.com/license (Icons: CC BY 4.0, Fonts: SIL OFL 1.1, Code: MIT License)
+ */
+ @font-face{
+  font-family:"Font Awesome 5 Free";
+  font-style:normal;
+  font-weight:900;
+  src:url(../fonts/fontawesome/fa-solid-900.eot);
+  src:url(../fonts/fontawesome/fa-solid-900.eot?#iefix) format("embedded-opentype"),
+      url(../fonts/fontawesome/fa-solid-900.woff2) format("woff2"),
+      url(../fonts/fontawesome/fa-solid-900.woff) format("woff"),
+      url(../fonts/fontawesome/fa-solid-900.ttf) format("truetype"),
+      url(../fonts/fontawesome/fa-solid-900.svg#fontawesome) format("svg");
+}
+.fa,.fas{
+  font-family:"Font Awesome 5 Free";
+  font-weight:900;
 }

static/css/icons.css

@@ -1,34 +0,0 @@
-.glyphicon {
-  position: relative;
-  display: inline-block;
-  width: 40px;
-  height: 40px;
-}
-.glyphicon::before {
-  position: absolute;
-  top: 50%;
-  left: 50%;
-  transform: translate(-50%, -50%);
-  font-family: 'Glyphicons Halflings';
-  -webkit-font-smoothing: antialiased;
-  -moz-osx-font-smoothing: grayscale;
-}
-
-.glyphicon--home::before {
-  content: '\e021';
-}
-.glyphicon--book::before {
-  content: '\e043';
-}
-.glyphicon--profile::before {
-  content: '\e019';
-}
-.glyphicon--user::before {
-  content: '\e008';
-}
-.glyphicon--login::before {
-  content: '\e161';
-}
-.glyphicon--logout::before {
-  content: '\e163';
-}

static/css/tabber.css

@@ -1,6 +1,6 @@
 .tab-group {
-  box-shadow: 0 0 0 18px white, 0 0 0 20px #b3b7c1;
-  margin-top: 40px;
+  border-top: 2px solid #dcdcdc;
+  padding-top: 30px;
 }
 
 .tab-group-openers {
@@ -22,21 +22,18 @@
   font-size: 16px;
   text-transform: uppercase;
   font-weight: 600;
-  transition: all .2s ease;
-  box-shadow: inset 0 -4px 4px rgba(0, 0, 0, 0.1);
-  border-top: 5px solid transparent;
+  transition: all .1s ease;
+  border-bottom: 5px solid rgba(100, 100, 100, 0.2);
 }
 .tab-opener:not(.tab-visible):hover {
   cursor: pointer;
   background-color: transparent;
   color: rgb(52, 48, 58);
-  box-shadow: none;
-  border-top-color: grey;
+  border-bottom-color: grey;
 }
 
 .tab-opener.tab-visible {
   background-color: transparent;
   color: rgb(52, 48, 58);
-  border-top-color: #5F98C2;
-  box-shadow: none;
+  border-bottom-color: #5F98C2;
 }

static/fonts/glyphicons-halflings-regular.svg

@@ -1,229 +0,0 @@
-<?xml version="1.0" standalone="no"?>
-<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd" >
-<svg xmlns="http://www.w3.org/2000/svg">
-<metadata></metadata>
-<defs>
-<font id="glyphicons_halflingsregular" horiz-adv-x="1200" >
-<font-face units-per-em="1200" ascent="960" descent="-240" />
-<missing-glyph horiz-adv-x="500" />
-<glyph />
-<glyph />
-<glyph unicode="&#xd;" />
-<glyph unicode=" " />
-<glyph unicode="*" d="M100 500v200h259l-183 183l141 141l183 -183v259h200v-259l183 183l141 -141l-183 -183h259v-200h-259l183 -183l-141 -141l-183 183v-259h-200v259l-183 -183l-141 141l183 183h-259z" />
-<glyph unicode="+" d="M0 400v300h400v400h300v-400h400v-300h-400v-400h-300v400h-400z" />
-<glyph unicode="&#xa0;" />
-<glyph unicode="&#x2000;" horiz-adv-x="652" />
-<glyph unicode="&#x2001;" horiz-adv-x="1304" />
-<glyph unicode="&#x2002;" horiz-adv-x="652" />
-<glyph unicode="&#x2003;" horiz-adv-x="1304" />
-<glyph unicode="&#x2004;" horiz-adv-x="434" />
-<glyph unicode="&#x2005;" horiz-adv-x="326" />
-<glyph unicode="&#x2006;" horiz-adv-x="217" />
-<glyph unicode="&#x2007;" horiz-adv-x="217" />
-<glyph unicode="&#x2008;" horiz-adv-x="163" />
-<glyph unicode="&#x2009;" horiz-adv-x="260" />
-<glyph unicode="&#x200a;" horiz-adv-x="72" />
-<glyph unicode="&#x202f;" horiz-adv-x="260" />
-<glyph unicode="&#x205f;" horiz-adv-x="326" />
-<glyph unicode="&#x20ac;" d="M100 500l100 100h113q0 47 5 100h-218l100 100h135q37 167 112 257q117 141 297 141q242 0 354 -189q60 -103 66 -209h-181q0 55 -25.5 99t-63.5 68t-75 36.5t-67 12.5q-24 0 -52.5 -10t-62.5 -32t-65.5 -67t-50.5 -107h379l-100 -100h-300q-6 -46 -6 -100h406l-100 -100 h-300q9 -74 33 -132t52.5 -91t62 -54.5t59 -29t46.5 -7.5q29 0 66 13t75 37t63.5 67.5t25.5 96.5h174q-31 -172 -128 -278q-107 -117 -274 -117q-205 0 -324 158q-36 46 -69 131.5t-45 205.5h-217z" />
-<glyph unicode="&#x2212;" d="M200 400h900v300h-900v-300z" />
-<glyph unicode="&#x25fc;" horiz-adv-x="500" d="M0 0z" />
-<glyph unicode="&#x2601;" d="M-14 494q0 -80 56.5 -137t135.5 -57h750q120 0 205 86.5t85 207.5t-85 207t-205 86q-46 0 -90 -14q-44 97 -134.5 156.5t-200.5 59.5q-152 0 -260 -107.5t-108 -260.5q0 -25 2 -37q-66 -14 -108.5 -67.5t-42.5 -122.5z" />
-<glyph unicode="&#x2709;" d="M0 100l400 400l200 -200l200 200l400 -400h-1200zM0 300v600l300 -300zM0 1100l600 -603l600 603h-1200zM900 600l300 300v-600z" />
-<glyph unicode="&#x270f;" d="M-13 -13l333 112l-223 223zM187 403l214 -214l614 614l-214 214zM887 1103l214 -214l99 92q13 13 13 32.5t-13 33.5l-153 153q-15 13 -33 13t-33 -13z" />
-<glyph unicode="&#xe001;" d="M0 1200h1200l-500 -550v-550h300v-100h-800v100h300v550z" />
-<glyph unicode="&#xe002;" d="M14 84q18 -55 86 -75.5t147 5.5q65 21 109 69t44 90v606l600 155v-521q-64 16 -138 -7q-79 -26 -122.5 -83t-25.5 -111q18 -55 86 -75.5t147 4.5q70 23 111.5 63.5t41.5 95.5v881q0 10 -7 15.5t-17 2.5l-752 -193q-10 -3 -17 -12.5t-7 -19.5v-689q-64 17 -138 -7 q-79 -25 -122.5 -82t-25.5 -112z" />
-<glyph unicode="&#xe003;" d="M23 693q0 200 142 342t342 142t342 -142t142 -342q0 -142 -78 -261l300 -300q7 -8 7 -18t-7 -18l-109 -109q-8 -7 -18 -7t-18 7l-300 300q-119 -78 -261 -78q-200 0 -342 142t-142 342zM176 693q0 -136 97 -233t234 -97t233.5 96.5t96.5 233.5t-96.5 233.5t-233.5 96.5 t-234 -97t-97 -233z" />
-<glyph unicode="&#xe005;" d="M100 784q0 64 28 123t73 100.5t104.5 64t119 20.5t120 -38.5t104.5 -104.5q48 69 109.5 105t121.5 38t118.5 -20.5t102.5 -64t71 -100.5t27 -123q0 -57 -33.5 -117.5t-94 -124.5t-126.5 -127.5t-150 -152.5t-146 -174q-62 85 -145.5 174t-149.5 152.5t-126.5 127.5 t-94 124.5t-33.5 117.5z" />
-<glyph unicode="&#xe006;" d="M-72 800h479l146 400h2l146 -400h472l-382 -278l145 -449l-384 275l-382 -275l146 447zM168 71l2 1z" />
-<glyph unicode="&#xe007;" d="M-72 800h479l146 400h2l146 -400h472l-382 -278l145 -449l-384 275l-382 -275l146 447zM168 71l2 1zM237 700l196 -142l-73 -226l192 140l195 -141l-74 229l193 140h-235l-77 211l-78 -211h-239z" />
-<glyph unicode="&#xe008;" d="M0 0v143l400 257v100q-37 0 -68.5 74.5t-31.5 125.5v200q0 124 88 212t212 88t212 -88t88 -212v-200q0 -51 -31.5 -125.5t-68.5 -74.5v-100l400 -257v-143h-1200z" />
-<glyph unicode="&#xe009;" d="M0 0v1100h1200v-1100h-1200zM100 100h100v100h-100v-100zM100 300h100v100h-100v-100zM100 500h100v100h-100v-100zM100 700h100v100h-100v-100zM100 900h100v100h-100v-100zM300 100h600v400h-600v-400zM300 600h600v400h-600v-400zM1000 100h100v100h-100v-100z M1000 300h100v100h-100v-100zM1000 500h100v100h-100v-100zM1000 700h100v100h-100v-100zM1000 900h100v100h-100v-100z" />
-<glyph unicode="&#xe010;" d="M0 50v400q0 21 14.5 35.5t35.5 14.5h400q21 0 35.5 -14.5t14.5 -35.5v-400q0 -21 -14.5 -35.5t-35.5 -14.5h-400q-21 0 -35.5 14.5t-14.5 35.5zM0 650v400q0 21 14.5 35.5t35.5 14.5h400q21 0 35.5 -14.5t14.5 -35.5v-400q0 -21 -14.5 -35.5t-35.5 -14.5h-400 q-21 0 -35.5 14.5t-14.5 35.5zM600 50v400q0 21 14.5 35.5t35.5 14.5h400q21 0 35.5 -14.5t14.5 -35.5v-400q0 -21 -14.5 -35.5t-35.5 -14.5h-400q-21 0 -35.5 14.5t-14.5 35.5zM600 650v400q0 21 14.5 35.5t35.5 14.5h400q21 0 35.5 -14.5t14.5 -35.5v-400 q0 -21 -14.5 -35.5t-35.5 -14.5h-400q-21 0 -35.5 14.5t-14.5 35.5z" />
-<glyph unicode="&#xe011;" d="M0 50v200q0 21 14.5 35.5t35.5 14.5h200q21 0 35.5 -14.5t14.5 -35.5v-200q0 -21 -14.5 -35.5t-35.5 -14.5h-200q-21 0 -35.5 14.5t-14.5 35.5zM0 450v200q0 21 14.5 35.5t35.5 14.5h200q21 0 35.5 -14.5t14.5 -35.5v-200q0 -21 -14.5 -35.5t-35.5 -14.5h-200 q-21 0 -35.5 14.5t-14.5 35.5zM0 850v200q0 21 14.5 35.5t35.5 14.5h200q21 0 35.5 -14.5t14.5 -35.5v-200q0 -21 -14.5 -35.5t-35.5 -14.5h-200q-21 0 -35.5 14.5t-14.5 35.5zM400 50v200q0 21 14.5 35.5t35.5 14.5h200q21 0 35.5 -14.5t14.5 -35.5v-200q0 -21 -14.5 -35.5 t-35.5 -14.5h-200q-21 0 -35.5 14.5t-14.5 35.5zM400 450v200q0 21 14.5 35.5t35.5 14.5h200q21 0 35.5 -14.5t14.5 -35.5v-200q0 -21 -14.5 -35.5t-35.5 -14.5h-200q-21 0 -35.5 14.5t-14.5 35.5zM400 850v200q0 21 14.5 35.5t35.5 14.5h200q21 0 35.5 -14.5t14.5 -35.5 v-200q0 -21 -14.5 -35.5t-35.5 -14.5h-200q-21 0 -35.5 14.5t-14.5 35.5zM800 50v200q0 21 14.5 35.5t35.5 14.5h200q21 0 35.5 -14.5t14.5 -35.5v-200q0 -21 -14.5 -35.5t-35.5 -14.5h-200q-21 0 -35.5 14.5t-14.5 35.5zM800 450v200q0 21 14.5 35.5t35.5 14.5h200 q21 0 35.5 -14.5t14.5 -35.5v-200q0 -21 -14.5 -35.5t-35.5 -14.5h-200q-21 0 -35.5 14.5t-14.5 35.5zM800 850v200q0 21 14.5 35.5t35.5 14.5h200q21 0 35.5 -14.5t14.5 -35.5v-200q0 -21 -14.5 -35.5t-35.5 -14.5h-200q-21 0 -35.5 14.5t-14.5 35.5z" />
-<glyph unicode="&#xe012;" d="M0 50v200q0 21 14.5 35.5t35.5 14.5h200q21 0 35.5 -14.5t14.5 -35.5v-200q0 -21 -14.5 -35.5t-35.5 -14.5h-200q-21 0 -35.5 14.5t-14.5 35.5zM0 450q0 -21 14.5 -35.5t35.5 -14.5h200q21 0 35.5 14.5t14.5 35.5v200q0 21 -14.5 35.5t-35.5 14.5h-200q-21 0 -35.5 -14.5 t-14.5 -35.5v-200zM0 850v200q0 21 14.5 35.5t35.5 14.5h200q21 0 35.5 -14.5t14.5 -35.5v-200q0 -21 -14.5 -35.5t-35.5 -14.5h-200q-21 0 -35.5 14.5t-14.5 35.5zM400 50v200q0 21 14.5 35.5t35.5 14.5h700q21 0 35.5 -14.5t14.5 -35.5v-200q0 -21 -14.5 -35.5 t-35.5 -14.5h-700q-21 0 -35.5 14.5t-14.5 35.5zM400 450v200q0 21 14.5 35.5t35.5 14.5h700q21 0 35.5 -14.5t14.5 -35.5v-200q0 -21 -14.5 -35.5t-35.5 -14.5h-700q-21 0 -35.5 14.5t-14.5 35.5zM400 850v200q0 21 14.5 35.5t35.5 14.5h700q21 0 35.5 -14.5t14.5 -35.5 v-200q0 -21 -14.5 -35.5t-35.5 -14.5h-700q-21 0 -35.5 14.5t-14.5 35.5z" />
-<glyph unicode="&#xe013;" d="M29 454l419 -420l818 820l-212 212l-607 -607l-206 207z" />
-<glyph unicode="&#xe014;" d="M106 318l282 282l-282 282l212 212l282 -282l282 282l212 -212l-282 -282l282 -282l-212 -212l-282 282l-282 -282z" />
-<glyph unicode="&#xe015;" d="M23 693q0 200 142 342t342 142t342 -142t142 -342q0 -142 -78 -261l300 -300q7 -8 7 -18t-7 -18l-109 -109q-8 -7 -18 -7t-18 7l-300 300q-119 -78 -261 -78q-200 0 -342 142t-142 342zM176 693q0 -136 97 -233t234 -97t233.5 96.5t96.5 233.5t-96.5 233.5t-233.5 96.5 t-234 -97t-97 -233zM300 600v200h100v100h200v-100h100v-200h-100v-100h-200v100h-100z" />
-<glyph unicode="&#xe016;" d="M23 694q0 200 142 342t342 142t342 -142t142 -342q0 -141 -78 -262l300 -299q7 -7 7 -18t-7 -18l-109 -109q-8 -8 -18 -8t-18 8l-300 300q-119 -78 -261 -78q-200 0 -342 142t-142 342zM176 694q0 -136 97 -233t234 -97t233.5 97t96.5 233t-96.5 233t-233.5 97t-234 -97 t-97 -233zM300 601h400v200h-400v-200z" />
-<glyph unicode="&#xe017;" d="M23 600q0 183 105 331t272 210v-166q-103 -55 -165 -155t-62 -220q0 -177 125 -302t302 -125t302 125t125 302q0 120 -62 220t-165 155v166q167 -62 272 -210t105 -331q0 -118 -45.5 -224.5t-123 -184t-184 -123t-224.5 -45.5t-224.5 45.5t-184 123t-123 184t-45.5 224.5 zM500 750q0 -21 14.5 -35.5t35.5 -14.5h100q21 0 35.5 14.5t14.5 35.5v400q0 21 -14.5 35.5t-35.5 14.5h-100q-21 0 -35.5 -14.5t-14.5 -35.5v-400z" />
-<glyph unicode="&#xe018;" d="M100 1h200v300h-200v-300zM400 1v500h200v-500h-200zM700 1v800h200v-800h-200zM1000 1v1200h200v-1200h-200z" />
-<glyph unicode="&#xe019;" d="M26 601q0 -33 6 -74l151 -38l2 -6q14 -49 38 -93l3 -5l-80 -134q45 -59 105 -105l133 81l5 -3q45 -26 94 -39l5 -2l38 -151q40 -5 74 -5q27 0 74 5l38 151l6 2q46 13 93 39l5 3l134 -81q56 44 104 105l-80 134l3 5q24 44 39 93l1 6l152 38q5 40 5 74q0 28 -5 73l-152 38 l-1 6q-16 51 -39 93l-3 5l80 134q-44 58 -104 105l-134 -81l-5 3q-45 25 -93 39l-6 1l-38 152q-40 5 -74 5q-27 0 -74 -5l-38 -152l-5 -1q-50 -14 -94 -39l-5 -3l-133 81q-59 -47 -105 -105l80 -134l-3 -5q-25 -47 -38 -93l-2 -6l-151 -38q-6 -48 -6 -73zM385 601 q0 88 63 151t152 63t152 -63t63 -151q0 -89 -63 -152t-152 -63t-152 63t-63 152z" />
-<glyph unicode="&#xe020;" d="M100 1025v50q0 10 7.5 17.5t17.5 7.5h275v100q0 41 29.5 70.5t70.5 29.5h300q41 0 70.5 -29.5t29.5 -70.5v-100h275q10 0 17.5 -7.5t7.5 -17.5v-50q0 -11 -7 -18t-18 -7h-1050q-11 0 -18 7t-7 18zM200 100v800h900v-800q0 -41 -29.5 -71t-70.5 -30h-700q-41 0 -70.5 30 t-29.5 71zM300 100h100v700h-100v-700zM500 100h100v700h-100v-700zM500 1100h300v100h-300v-100zM700 100h100v700h-100v-700zM900 100h100v700h-100v-700z" />
-<glyph unicode="&#xe021;" d="M1 601l656 644l644 -644h-200v-600h-300v400h-300v-400h-300v600h-200z" />
-<glyph unicode="&#xe022;" d="M100 25v1150q0 11 7 18t18 7h475v-500h400v-675q0 -11 -7 -18t-18 -7h-850q-11 0 -18 7t-7 18zM700 800v300l300 -300h-300z" />
-<glyph unicode="&#xe023;" d="M4 600q0 162 80 299t217 217t299 80t299 -80t217 -217t80 -299t-80 -299t-217 -217t-299 -80t-299 80t-217 217t-80 299zM186 600q0 -171 121.5 -292.5t292.5 -121.5t292.5 121.5t121.5 292.5t-121.5 292.5t-292.5 121.5t-292.5 -121.5t-121.5 -292.5zM500 500v400h100 v-300h200v-100h-300z" />
-<glyph unicode="&#xe024;" d="M-100 0l431 1200h209l-21 -300h162l-20 300h208l431 -1200h-538l-41 400h-242l-40 -400h-539zM488 500h224l-27 300h-170z" />
-<glyph unicode="&#xe025;" d="M0 0v400h490l-290 300h200v500h300v-500h200l-290 -300h490v-400h-1100zM813 200h175v100h-175v-100z" />
-<glyph unicode="&#xe026;" d="M1 600q0 122 47.5 233t127.5 191t191 127.5t233 47.5t233 -47.5t191 -127.5t127.5 -191t47.5 -233t-47.5 -233t-127.5 -191t-191 -127.5t-233 -47.5t-233 47.5t-191 127.5t-127.5 191t-47.5 233zM188 600q0 -170 121 -291t291 -121t291 121t121 291t-121 291t-291 121 t-291 -121t-121 -291zM350 600h150v300h200v-300h150l-250 -300z" />
-<glyph unicode="&#xe027;" d="M4 600q0 162 80 299t217 217t299 80t299 -80t217 -217t80 -299t-80 -299t-217 -217t-299 -80t-299 80t-217 217t-80 299zM186 600q0 -171 121.5 -292.5t292.5 -121.5t292.5 121.5t121.5 292.5t-121.5 292.5t-292.5 121.5t-292.5 -121.5t-121.5 -292.5zM350 600l250 300 l250 -300h-150v-300h-200v300h-150z" />
-<glyph unicode="&#xe028;" d="M0 25v475l200 700h800l199 -700l1 -475q0 -11 -7 -18t-18 -7h-1150q-11 0 -18 7t-7 18zM200 500h200l50 -200h300l50 200h200l-97 500h-606z" />
-<glyph unicode="&#xe029;" d="M4 600q0 162 80 299t217 217t299 80t299 -80t217 -217t80 -299t-80 -299t-217 -217t-299 -80t-299 80t-217 217t-80 299zM186 600q0 -172 121.5 -293t292.5 -121t292.5 121t121.5 293q0 171 -121.5 292.5t-292.5 121.5t-292.5 -121.5t-121.5 -292.5zM500 397v401 l297 -200z" />
-<glyph unicode="&#xe030;" d="M23 600q0 -118 45.5 -224.5t123 -184t184 -123t224.5 -45.5t224.5 45.5t184 123t123 184t45.5 224.5h-150q0 -177 -125 -302t-302 -125t-302 125t-125 302t125 302t302 125q136 0 246 -81l-146 -146h400v400l-145 -145q-157 122 -355 122q-118 0 -224.5 -45.5t-184 -123 t-123 -184t-45.5 -224.5z" />
-<glyph unicode="&#xe031;" d="M23 600q0 118 45.5 224.5t123 184t184 123t224.5 45.5q198 0 355 -122l145 145v-400h-400l147 147q-112 80 -247 80q-177 0 -302 -125t-125 -302h-150zM100 0v400h400l-147 -147q112 -80 247 -80q177 0 302 125t125 302h150q0 -118 -45.5 -224.5t-123 -184t-184 -123 t-224.5 -45.5q-198 0 -355 122z" />
-<glyph unicode="&#xe032;" d="M100 0h1100v1200h-1100v-1200zM200 100v900h900v-900h-900zM300 200v100h100v-100h-100zM300 400v100h100v-100h-100zM300 600v100h100v-100h-100zM300 800v100h100v-100h-100zM500 200h500v100h-500v-100zM500 400v100h500v-100h-500zM500 600v100h500v-100h-500z M500 800v100h500v-100h-500z" />
-<glyph unicode="&#xe033;" d="M0 100v600q0 41 29.5 70.5t70.5 29.5h100v200q0 82 59 141t141 59h300q82 0 141 -59t59 -141v-200h100q41 0 70.5 -29.5t29.5 -70.5v-600q0 -41 -29.5 -70.5t-70.5 -29.5h-900q-41 0 -70.5 29.5t-29.5 70.5zM400 800h300v150q0 21 -14.5 35.5t-35.5 14.5h-200 q-21 0 -35.5 -14.5t-14.5 -35.5v-150z" />
-<glyph unicode="&#xe034;" d="M100 0v1100h100v-1100h-100zM300 400q60 60 127.5 84t127.5 17.5t122 -23t119 -30t110 -11t103 42t91 120.5v500q-40 -81 -101.5 -115.5t-127.5 -29.5t-138 25t-139.5 40t-125.5 25t-103 -29.5t-65 -115.5v-500z" />
-<glyph unicode="&#xe035;" d="M0 275q0 -11 7 -18t18 -7h50q11 0 18 7t7 18v300q0 127 70.5 231.5t184.5 161.5t245 57t245 -57t184.5 -161.5t70.5 -231.5v-300q0 -11 7 -18t18 -7h50q11 0 18 7t7 18v300q0 116 -49.5 227t-131 192.5t-192.5 131t-227 49.5t-227 -49.5t-192.5 -131t-131 -192.5 t-49.5 -227v-300zM200 20v460q0 8 6 14t14 6h160q8 0 14 -6t6 -14v-460q0 -8 -6 -14t-14 -6h-160q-8 0 -14 6t-6 14zM800 20v460q0 8 6 14t14 6h160q8 0 14 -6t6 -14v-460q0 -8 -6 -14t-14 -6h-160q-8 0 -14 6t-6 14z" />
-<glyph unicode="&#xe036;" d="M0 400h300l300 -200v800l-300 -200h-300v-400zM688 459l141 141l-141 141l71 71l141 -141l141 141l71 -71l-141 -141l141 -141l-71 -71l-141 141l-141 -141z" />
-<glyph unicode="&#xe037;" d="M0 400h300l300 -200v800l-300 -200h-300v-400zM700 857l69 53q111 -135 111 -310q0 -169 -106 -302l-67 54q86 110 86 248q0 146 -93 257z" />
-<glyph unicode="&#xe038;" d="M0 401v400h300l300 200v-800l-300 200h-300zM702 858l69 53q111 -135 111 -310q0 -170 -106 -303l-67 55q86 110 86 248q0 145 -93 257zM889 951l7 -8q123 -151 123 -344q0 -189 -119 -339l-7 -8l81 -66l6 8q142 178 142 405q0 230 -144 408l-6 8z" />
-<glyph unicode="&#xe039;" d="M0 0h500v500h-200v100h-100v-100h-200v-500zM0 600h100v100h400v100h100v100h-100v300h-500v-600zM100 100v300h300v-300h-300zM100 800v300h300v-300h-300zM200 200v100h100v-100h-100zM200 900h100v100h-100v-100zM500 500v100h300v-300h200v-100h-100v-100h-200v100 h-100v100h100v200h-200zM600 0v100h100v-100h-100zM600 1000h100v-300h200v-300h300v200h-200v100h200v500h-600v-200zM800 800v300h300v-300h-300zM900 0v100h300v-100h-300zM900 900v100h100v-100h-100zM1100 200v100h100v-100h-100z" />
-<glyph unicode="&#xe040;" d="M0 200h100v1000h-100v-1000zM100 0v100h300v-100h-300zM200 200v1000h100v-1000h-100zM500 0v91h100v-91h-100zM500 200v1000h200v-1000h-200zM700 0v91h100v-91h-100zM800 200v1000h100v-1000h-100zM900 0v91h200v-91h-200zM1000 200v1000h200v-1000h-200z" />
-<glyph unicode="&#xe041;" d="M0 700l1 475q0 10 7.5 17.5t17.5 7.5h474l700 -700l-500 -500zM148 953q0 -42 29 -71q30 -30 71.5 -30t71.5 30q29 29 29 71t-29 71q-30 30 -71.5 30t-71.5 -30q-29 -29 -29 -71z" />
-<glyph unicode="&#xe042;" d="M1 700l1 475q0 11 7 18t18 7h474l700 -700l-500 -500zM148 953q0 -42 30 -71q29 -30 71 -30t71 30q30 29 30 71t-30 71q-29 30 -71 30t-71 -30q-30 -29 -30 -71zM701 1200h100l700 -700l-500 -500l-50 50l450 450z" />
-<glyph unicode="&#xe043;" d="M100 0v1025l175 175h925v-1000l-100 -100v1000h-750l-100 -100h750v-1000h-900z" />
-<glyph unicode="&#xe044;" d="M200 0l450 444l450 -443v1150q0 20 -14.5 35t-35.5 15h-800q-21 0 -35.5 -15t-14.5 -35v-1151z" />
-<glyph unicode="&#xe045;" d="M0 100v700h200l100 -200h600l100 200h200v-700h-200v200h-800v-200h-200zM253 829l40 -124h592l62 124l-94 346q-2 11 -10 18t-18 7h-450q-10 0 -18 -7t-10 -18zM281 24l38 152q2 10 11.5 17t19.5 7h500q10 0 19.5 -7t11.5 -17l38 -152q2 -10 -3.5 -17t-15.5 -7h-600 q-10 0 -15.5 7t-3.5 17z" />
-<glyph unicode="&#xe046;" d="M0 200q0 -41 29.5 -70.5t70.5 -29.5h1000q41 0 70.5 29.5t29.5 70.5v600q0 41 -29.5 70.5t-70.5 29.5h-150q-4 8 -11.5 21.5t-33 48t-53 61t-69 48t-83.5 21.5h-200q-41 0 -82 -20.5t-70 -50t-52 -59t-34 -50.5l-12 -20h-150q-41 0 -70.5 -29.5t-29.5 -70.5v-600z M356 500q0 100 72 172t172 72t172 -72t72 -172t-72 -172t-172 -72t-172 72t-72 172zM494 500q0 -44 31 -75t75 -31t75 31t31 75t-31 75t-75 31t-75 -31t-31 -75zM900 700v100h100v-100h-100z" />
-<glyph unicode="&#xe047;" d="M53 0h365v66q-41 0 -72 11t-49 38t1 71l92 234h391l82 -222q16 -45 -5.5 -88.5t-74.5 -43.5v-66h417v66q-34 1 -74 43q-18 19 -33 42t-21 37l-6 13l-385 998h-93l-399 -1006q-24 -48 -52 -75q-12 -12 -33 -25t-36 -20l-15 -7v-66zM416 521l178 457l46 -140l116 -317h-340 z" />
-<glyph unicode="&#xe048;" d="M100 0v89q41 7 70.5 32.5t29.5 65.5v827q0 28 -1 39.5t-5.5 26t-15.5 21t-29 14t-49 14.5v71l471 -1q120 0 213 -88t93 -228q0 -55 -11.5 -101.5t-28 -74t-33.5 -47.5t-28 -28l-12 -7q8 -3 21.5 -9t48 -31.5t60.5 -58t47.5 -91.5t21.5 -129q0 -84 -59 -156.5t-142 -111 t-162 -38.5h-500zM400 200h161q89 0 153 48.5t64 132.5q0 90 -62.5 154.5t-156.5 64.5h-159v-400zM400 700h139q76 0 130 61.5t54 138.5q0 82 -84 130.5t-239 48.5v-379z" />
-<glyph unicode="&#xe049;" d="M200 0v57q77 7 134.5 40.5t65.5 80.5l173 849q10 56 -10 74t-91 37q-6 1 -10.5 2.5t-9.5 2.5v57h425l2 -57q-33 -8 -62 -25.5t-46 -37t-29.5 -38t-17.5 -30.5l-5 -12l-128 -825q-10 -52 14 -82t95 -36v-57h-500z" />
-<glyph unicode="&#xe050;" d="M-75 200h75v800h-75l125 167l125 -167h-75v-800h75l-125 -167zM300 900v300h150h700h150v-300h-50q0 29 -8 48.5t-18.5 30t-33.5 15t-39.5 5.5t-50.5 1h-200v-850l100 -50v-100h-400v100l100 50v850h-200q-34 0 -50.5 -1t-40 -5.5t-33.5 -15t-18.5 -30t-8.5 -48.5h-49z " />
-<glyph unicode="&#xe051;" d="M33 51l167 125v-75h800v75l167 -125l-167 -125v75h-800v-75zM100 901v300h150h700h150v-300h-50q0 29 -8 48.5t-18 30t-33.5 15t-40 5.5t-50.5 1h-200v-650l100 -50v-100h-400v100l100 50v650h-200q-34 0 -50.5 -1t-39.5 -5.5t-33.5 -15t-18.5 -30t-8 -48.5h-50z" />
-<glyph unicode="&#xe052;" d="M0 50q0 -20 14.5 -35t35.5 -15h1100q21 0 35.5 15t14.5 35v100q0 21 -14.5 35.5t-35.5 14.5h-1100q-21 0 -35.5 -14.5t-14.5 -35.5v-100zM0 350q0 -20 14.5 -35t35.5 -15h800q21 0 35.5 15t14.5 35v100q0 21 -14.5 35.5t-35.5 14.5h-800q-21 0 -35.5 -14.5t-14.5 -35.5 v-100zM0 650q0 -20 14.5 -35t35.5 -15h1000q21 0 35.5 15t14.5 35v100q0 21 -14.5 35.5t-35.5 14.5h-1000q-21 0 -35.5 -14.5t-14.5 -35.5v-100zM0 950q0 -20 14.5 -35t35.5 -15h600q21 0 35.5 15t14.5 35v100q0 21 -14.5 35.5t-35.5 14.5h-600q-21 0 -35.5 -14.5 t-14.5 -35.5v-100z" />
-<glyph unicode="&#xe053;" d="M0 50q0 -20 14.5 -35t35.5 -15h1100q21 0 35.5 15t14.5 35v100q0 21 -14.5 35.5t-35.5 14.5h-1100q-21 0 -35.5 -14.5t-14.5 -35.5v-100zM0 650q0 -20 14.5 -35t35.5 -15h1100q21 0 35.5 15t14.5 35v100q0 21 -14.5 35.5t-35.5 14.5h-1100q-21 0 -35.5 -14.5t-14.5 -35.5 v-100zM200 350q0 -20 14.5 -35t35.5 -15h700q21 0 35.5 15t14.5 35v100q0 21 -14.5 35.5t-35.5 14.5h-700q-21 0 -35.5 -14.5t-14.5 -35.5v-100zM200 950q0 -20 14.5 -35t35.5 -15h700q21 0 35.5 15t14.5 35v100q0 21 -14.5 35.5t-35.5 14.5h-700q-21 0 -35.5 -14.5 t-14.5 -35.5v-100z" />
-<glyph unicode="&#xe054;" d="M0 50v100q0 21 14.5 35.5t35.5 14.5h1100q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-1100q-21 0 -35.5 15t-14.5 35zM100 650v100q0 21 14.5 35.5t35.5 14.5h1000q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-1000q-21 0 -35.5 15 t-14.5 35zM300 350v100q0 21 14.5 35.5t35.5 14.5h800q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-800q-21 0 -35.5 15t-14.5 35zM500 950v100q0 21 14.5 35.5t35.5 14.5h600q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-600 q-21 0 -35.5 15t-14.5 35z" />
-<glyph unicode="&#xe055;" d="M0 50v100q0 21 14.5 35.5t35.5 14.5h1100q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-1100q-21 0 -35.5 15t-14.5 35zM0 350v100q0 21 14.5 35.5t35.5 14.5h1100q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-1100q-21 0 -35.5 15 t-14.5 35zM0 650v100q0 21 14.5 35.5t35.5 14.5h1100q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-1100q-21 0 -35.5 15t-14.5 35zM0 950v100q0 21 14.5 35.5t35.5 14.5h1100q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-1100 q-21 0 -35.5 15t-14.5 35z" />
-<glyph unicode="&#xe056;" d="M0 50v100q0 21 14.5 35.5t35.5 14.5h100q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-100q-21 0 -35.5 15t-14.5 35zM0 350v100q0 21 14.5 35.5t35.5 14.5h100q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-100q-21 0 -35.5 15 t-14.5 35zM0 650v100q0 21 14.5 35.5t35.5 14.5h100q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-100q-21 0 -35.5 15t-14.5 35zM0 950v100q0 21 14.5 35.5t35.5 14.5h100q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-100q-21 0 -35.5 15 t-14.5 35zM300 50v100q0 21 14.5 35.5t35.5 14.5h800q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-800q-21 0 -35.5 15t-14.5 35zM300 350v100q0 21 14.5 35.5t35.5 14.5h800q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-800 q-21 0 -35.5 15t-14.5 35zM300 650v100q0 21 14.5 35.5t35.5 14.5h800q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15h-800q-21 0 -35.5 15t-14.5 35zM300 950v100q0 21 14.5 35.5t35.5 14.5h800q21 0 35.5 -14.5t14.5 -35.5v-100q0 -20 -14.5 -35t-35.5 -15 h-800q-21 0 -35.5 15t-14.5 35z" />
-<glyph unicode="&#xe057;" d="M-101 500v100h201v75l166 -125l-166 -125v75h-201zM300 0h100v1100h-100v-1100zM500 50q0 -20 14.5 -35t35.5 -15h600q20 0 35 15t15 35v100q0 21 -15 35.5t-35 14.5h-600q-21 0 -35.5 -14.5t-14.5 -35.5v-100zM500 350q0 -20 14.5 -35t35.5 -15h300q20 0 35 15t15 35 v100q0 21 -15 35.5t-35 14.5h-300q-21 0 -35.5 -14.5t-14.5 -35.5v-100zM500 650q0 -20 14.5 -35t35.5 -15h500q20 0 35 15t15 35v100q0 21 -15 35.5t-35 14.5h-500q-21 0 -35.5 -14.5t-14.5 -35.5v-100zM500 950q0 -20 14.5 -35t35.5 -15h100q20 0 35 15t15 35v100 q0 21 -15 35.5t-35 14.5h-100q-21 0 -35.5 -14.5t-14.5 -35.5v-100z" />
-<glyph unicode="&#xe058;" d="M1 50q0 -20 14.5 -35t35.5 -15h600q20 0 35 15t15 35v100q0 21 -15 35.5t-35 14.5h-600q-21 0 -35.5 -14.5t-14.5 -35.5v-100zM1 350q0 -20 14.5 -35t35.5 -15h300q20 0 35 15t15 35v100q0 21 -15 35.5t-35 14.5h-300q-21 0 -35.5 -14.5t-14.5 -35.5v-100zM1 650 q0 -20 14.5 -35t35.5 -15h500q20 0 35 15t15 35v100q0 21 -15 35.5t-35 14.5h-500q-21 0 -35.5 -14.5t-14.5 -35.5v-100zM1 950q0 -20 14.5 -35t35.5 -15h100q20 0 35 15t15 35v100q0 21 -15 35.5t-35 14.5h-100q-21 0 -35.5 -14.5t-14.5 -35.5v-100zM801 0v1100h100v-1100 h-100zM934 550l167 -125v75h200v100h-200v75z" />
-<glyph unicode="&#xe059;" d="M0 275v650q0 31 22 53t53 22h750q31 0 53 -22t22 -53v-650q0 -31 -22 -53t-53 -22h-750q-31 0 -53 22t-22 53zM900 600l300 300v-600z" />
-<glyph unicode="&#xe060;" d="M0 44v1012q0 18 13 31t31 13h1112q19 0 31.5 -13t12.5 -31v-1012q0 -18 -12.5 -31t-31.5 -13h-1112q-18 0 -31 13t-13 31zM100 263l247 182l298 -131l-74 156l293 318l236 -288v500h-1000v-737zM208 750q0 56 39 95t95 39t95 -39t39 -95t-39 -95t-95 -39t-95 39t-39 95z " />
-<glyph unicode="&#xe062;" d="M148 745q0 124 60.5 231.5t165 172t226.5 64.5q123 0 227 -63t164.5 -169.5t60.5 -229.5t-73 -272q-73 -114 -166.5 -237t-150.5 -189l-57 -66q-10 9 -27 26t-66.5 70.5t-96 109t-104 135.5t-100.5 155q-63 139 -63 262zM342 772q0 -107 75.5 -182.5t181.5 -75.5 q107 0 182.5 75.5t75.5 182.5t-75.5 182t-182.5 75t-182 -75.5t-75 -181.5z" />
-<glyph unicode="&#xe063;" d="M1 600q0 122 47.5 233t127.5 191t191 127.5t233 47.5t233 -47.5t191 -127.5t127.5 -191t47.5 -233t-47.5 -233t-127.5 -191t-191 -127.5t-233 -47.5t-233 47.5t-191 127.5t-127.5 191t-47.5 233zM173 600q0 -177 125.5 -302t301.5 -125v854q-176 0 -301.5 -125 t-125.5 -302z" />
-<glyph unicode="&#xe064;" d="M117 406q0 94 34 186t88.5 172.5t112 159t115 177t87.5 194.5q21 -71 57.5 -142.5t76 -130.5t83 -118.5t82 -117t70 -116t50 -125.5t18.5 -136q0 -89 -39 -165.5t-102 -126.5t-140 -79.5t-156 -33.5q-114 6 -211.5 53t-161.5 139t-64 210zM243 414q14 -82 59.5 -136 t136.5 -80l16 98q-7 6 -18 17t-34 48t-33 77q-15 73 -14 143.5t10 122.5l9 51q-92 -110 -119.5 -185t-12.5 -156z" />
-<glyph unicode="&#xe065;" d="M0 400v300q0 165 117.5 282.5t282.5 117.5q366 -6 397 -14l-186 -186h-311q-41 0 -70.5 -29.5t-29.5 -70.5v-500q0 -41 29.5 -70.5t70.5 -29.5h500q41 0 70.5 29.5t29.5 70.5v125l200 200v-225q0 -165 -117.5 -282.5t-282.5 -117.5h-300q-165 0 -282.5 117.5 t-117.5 282.5zM436 341l161 50l412 412l-114 113l-405 -405zM995 1015l113 -113l113 113l-21 85l-92 28z" />
-<glyph unicode="&#xe066;" d="M0 400v300q0 165 117.5 282.5t282.5 117.5h261l2 -80q-133 -32 -218 -120h-145q-41 0 -70.5 -29.5t-29.5 -70.5v-500q0 -41 29.5 -70.5t70.5 -29.5h500q41 0 70.5 29.5t29.5 70.5l200 153v-53q0 -165 -117.5 -282.5t-282.5 -117.5h-300q-165 0 -282.5 117.5t-117.5 282.5 zM423 524q30 38 81.5 64t103 35.5t99 14t77.5 3.5l29 -1v-209l360 324l-359 318v-216q-7 0 -19 -1t-48 -8t-69.5 -18.5t-76.5 -37t-76.5 -59t-62 -88t-39.5 -121.5z" />
-<glyph unicode="&#xe067;" d="M0 400v300q0 165 117.5 282.5t282.5 117.5h300q61 0 127 -23l-178 -177h-349q-41 0 -70.5 -29.5t-29.5 -70.5v-500q0 -41 29.5 -70.5t70.5 -29.5h500q41 0 70.5 29.5t29.5 70.5v69l200 200v-169q0 -165 -117.5 -282.5t-282.5 -117.5h-300q-165 0 -282.5 117.5 t-117.5 282.5zM342 632l283 -284l567 567l-137 137l-430 -431l-146 147z" />
-<glyph unicode="&#xe068;" d="M0 603l300 296v-198h200v200h-200l300 300l295 -300h-195v-200h200v198l300 -296l-300 -300v198h-200v-200h195l-295 -300l-300 300h200v200h-200v-198z" />
-<glyph unicode="&#xe069;" d="M200 50v1000q0 21 14.5 35.5t35.5 14.5h100q21 0 35.5 -14.5t14.5 -35.5v-437l500 487v-1100l-500 488v-438q0 -21 -14.5 -35.5t-35.5 -14.5h-100q-21 0 -35.5 14.5t-14.5 35.5z" />
-<glyph unicode="&#xe070;" d="M0 50v1000q0 21 14.5 35.5t35.5 14.5h100q21 0 35.5 -14.5t14.5 -35.5v-437l500 487v-487l500 487v-1100l-500 488v-488l-500 488v-438q0 -21 -14.5 -35.5t-35.5 -14.5h-100q-21 0 -35.5 14.5t-14.5 35.5z" />
-<glyph unicode="&#xe071;" d="M136 550l564 550v-487l500 487v-1100l-500 488v-488z" />
-<glyph unicode="&#xe072;" d="M200 0l900 550l-900 550v-1100z" />
-<glyph unicode="&#xe073;" d="M200 150q0 -21 14.5 -35.5t35.5 -14.5h200q21 0 35.5 14.5t14.5 35.5v800q0 21 -14.5 35.5t-35.5 14.5h-200q-21 0 -35.5 -14.5t-14.5 -35.5v-800zM600 150q0 -21 14.5 -35.5t35.5 -14.5h200q21 0 35.5 14.5t14.5 35.5v800q0 21 -14.5 35.5t-35.5 14.5h-200 q-21 0 -35.5 -14.5t-14.5 -35.5v-800z" />
-<glyph unicode="&#xe074;" d="M200 150q0 -20 14.5 -35t35.5 -15h800q21 0 35.5 15t14.5 35v800q0 21 -14.5 35.5t-35.5 14.5h-800q-21 0 -35.5 -14.5t-14.5 -35.5v-800z" />
-<glyph unicode="&#xe075;" d="M0 0v1100l500 -487v487l564 -550l-564 -550v488z" />
-<glyph unicode="&#xe076;" d="M0 0v1100l500 -487v487l500 -487v437q0 21 14.5 35.5t35.5 14.5h100q21 0 35.5 -14.5t14.5 -35.5v-1000q0 -21 -14.5 -35.5t-35.5 -14.5h-100q-21 0 -35.5 14.5t-14.5 35.5v438l-500 -488v488z" />
-<glyph unicode="&#xe077;" d="M300 0v1100l500 -487v437q0 21 14.5 35.5t35.5 14.5h100q21 0 35.5 -14.5t14.5 -35.5v-1000q0 -21 -14.5 -35.5t-35.5 -14.5h-100q-21 0 -35.5 14.5t-14.5 35.5v438z" />
-<glyph unicode="&#xe078;" d="M100 250v100q0 21 14.5 35.5t35.5 14.5h1000q21 0 35.5 -14.5t14.5 -35.5v-100q0 -21 -14.5 -35.5t-35.5 -14.5h-1000q-21 0 -35.5 14.5t-14.5 35.5zM100 500h1100l-550 564z" />
-<glyph unicode="&#xe079;" d="M185 599l592 -592l240 240l-353 353l353 353l-240 240z" />
-<glyph unicode="&#xe080;" d="M272 194l353 353l-353 353l241 240l572 -571l21 -22l-1 -1v-1l-592 -591z" />
-<glyph unicode="&#xe081;" d="M3 600q0 162 80 299.5t217.5 217.5t299.5 80t299.5 -80t217.5 -217.5t80 -299.5t-80 -299.5t-217.5 -217.5t-299.5 -80t-299.5 80t-217.5 217.5t-80 299.5zM300 500h200v-200h200v200h200v200h-200v200h-200v-200h-200v-200z" />
-<glyph unicode="&#xe082;" d="M3 600q0 162 80 299.5t217.5 217.5t299.5 80t299.5 -80t217.5 -217.5t80 -299.5t-80 -299.5t-217.5 -217.5t-299.5 -80t-299.5 80t-217.5 217.5t-80 299.5zM300 500h600v200h-600v-200z" />
-<glyph unicode="&#xe083;" d="M3 600q0 162 80 299.5t217.5 217.5t299.5 80t299.5 -80t217.5 -217.5t80 -299.5t-80 -299.5t-217.5 -217.5t-299.5 -80t-299.5 80t-217.5 217.5t-80 299.5zM246 459l213 -213l141 142l141 -142l213 213l-142 141l142 141l-213 212l-141 -141l-141 142l-212 -213l141 -141 z" />
-<glyph unicode="&#xe084;" d="M3 600q0 162 80 299.5t217.5 217.5t299.5 80t299.5 -80t217.5 -217.5t80 -299.5t-80 -299.5t-217.5 -217.5t-299.5 -80t-299.5 80t-217.5 217.5t-80 299.5zM270 551l276 -277l411 411l-175 174l-236 -236l-102 102z" />
-<glyph unicode="&#xe085;" d="M3 600q0 162 80 299.5t217.5 217.5t299.5 80t299.5 -80t217.5 -217.5t80 -299.5t-80 -299.5t-217.5 -217.5t-299.5 -80t-299.5 80t-217.5 217.5t-80 299.5zM364 700h143q4 0 11.5 -1t11 -1t6.5 3t3 9t1 11t3.5 8.5t3.5 6t5.5 4t6.5 2.5t9 1.5t9 0.5h11.5h12.5 q19 0 30 -10t11 -26q0 -22 -4 -28t-27 -22q-5 -1 -12.5 -3t-27 -13.5t-34 -27t-26.5 -46t-11 -68.5h200q5 3 14 8t31.5 25.5t39.5 45.5t31 69t14 94q0 51 -17.5 89t-42 58t-58.5 32t-58.5 15t-51.5 3q-50 0 -90.5 -12t-75 -38.5t-53.5 -74.5t-19 -114zM500 300h200v100h-200 v-100z" />
-<glyph unicode="&#xe086;" d="M3 600q0 162 80 299.5t217.5 217.5t299.5 80t299.5 -80t217.5 -217.5t80 -299.5t-80 -299.5t-217.5 -217.5t-299.5 -80t-299.5 80t-217.5 217.5t-80 299.5zM400 300h400v100h-100v300h-300v-100h100v-200h-100v-100zM500 800h200v100h-200v-100z" />
-<glyph unicode="&#xe087;" d="M0 500v200h195q31 125 98.5 199.5t206.5 100.5v200h200v-200q54 -20 113 -60t112.5 -105.5t71.5 -134.5h203v-200h-203q-25 -102 -116.5 -186t-180.5 -117v-197h-200v197q-140 27 -208 102.5t-98 200.5h-194zM290 500q24 -73 79.5 -127.5t130.5 -78.5v206h200v-206 q149 48 201 206h-201v200h200q-25 74 -75.5 127t-124.5 77v-204h-200v203q-75 -23 -130 -77t-79 -126h209v-200h-210z" />
-<glyph unicode="&#xe088;" d="M4 600q0 162 80 299t217 217t299 80t299 -80t217 -217t80 -299t-80 -299t-217 -217t-299 -80t-299 80t-217 217t-80 299zM186 600q0 -171 121.5 -292.5t292.5 -121.5t292.5 121.5t121.5 292.5t-121.5 292.5t-292.5 121.5t-292.5 -121.5t-121.5 -292.5zM356 465l135 135 l-135 135l109 109l135 -135l135 135l109 -109l-135 -135l135 -135l-109 -109l-135 135l-135 -135z" />
-<glyph unicode="&#xe089;" d="M4 600q0 162 80 299t217 217t299 80t299 -80t217 -217t80 -299t-80 -299t-217 -217t-299 -80t-299 80t-217 217t-80 299zM186 600q0 -171 121.5 -292.5t292.5 -121.5t292.5 121.5t121.5 292.5t-121.5 292.5t-292.5 121.5t-292.5 -121.5t-121.5 -292.5zM322 537l141 141 l87 -87l204 205l142 -142l-346 -345z" />
-<glyph unicode="&#xe090;" d="M4 600q0 162 80 299t217 217t299 80t299 -80t217 -217t80 -299t-80 -299t-217 -217t-299 -80t-299 80t-217 217t-80 299zM186 600q0 -115 62 -215l568 567q-100 62 -216 62q-171 0 -292.5 -121.5t-121.5 -292.5zM391 245q97 -59 209 -59q171 0 292.5 121.5t121.5 292.5 q0 112 -59 209z" />
-<glyph unicode="&#xe091;" d="M0 547l600 453v-300h600v-300h-600v-301z" />
-<glyph unicode="&#xe092;" d="M0 400v300h600v300l600 -453l-600 -448v301h-600z" />
-<glyph unicode="&#xe093;" d="M204 600l450 600l444 -600h-298v-600h-300v600h-296z" />
-<glyph unicode="&#xe094;" d="M104 600h296v600h300v-600h298l-449 -600z" />
-<glyph unicode="&#xe095;" d="M0 200q6 132 41 238.5t103.5 193t184 138t271.5 59.5v271l600 -453l-600 -448v301q-95 -2 -183 -20t-170 -52t-147 -92.5t-100 -135.5z" />
-<glyph unicode="&#xe096;" d="M0 0v400l129 -129l294 294l142 -142l-294 -294l129 -129h-400zM635 777l142 -142l294 294l129 -129v400h-400l129 -129z" />
-<glyph unicode="&#xe097;" d="M34 176l295 295l-129 129h400v-400l-129 130l-295 -295zM600 600v400l129 -129l295 295l142 -141l-295 -295l129 -130h-400z" />
-<glyph unicode="&#xe101;" d="M23 600q0 118 45.5 224.5t123 184t184 123t224.5 45.5t224.5 -45.5t184 -123t123 -184t45.5 -224.5t-45.5 -224.5t-123 -184t-184 -123t-224.5 -45.5t-224.5 45.5t-184 123t-123 184t-45.5 224.5zM456 851l58 -302q4 -20 21.5 -34.5t37.5 -14.5h54q20 0 37.5 14.5 t21.5 34.5l58 302q4 20 -8 34.5t-32 14.5h-207q-21 0 -33 -14.5t-8 -34.5zM500 300h200v100h-200v-100z" />
-<glyph unicode="&#xe102;" d="M0 800h100v-200h400v300h200v-300h400v200h100v100h-111q1 1 1 6.5t-1.5 15t-3.5 17.5l-34 172q-11 39 -41.5 63t-69.5 24q-32 0 -61 -17l-239 -144q-22 -13 -40 -35q-19 24 -40 36l-238 144q-33 18 -62 18q-39 0 -69.5 -23t-40.5 -61l-35 -177q-2 -8 -3 -18t-1 -15v-6 h-111v-100zM100 0h400v400h-400v-400zM200 900q-3 0 14 48t36 96l18 47l213 -191h-281zM700 0v400h400v-400h-400zM731 900l202 197q5 -12 12 -32.5t23 -64t25 -72t7 -28.5h-269z" />
-<glyph unicode="&#xe103;" d="M0 -22v143l216 193q-9 53 -13 83t-5.5 94t9 113t38.5 114t74 124q47 60 99.5 102.5t103 68t127.5 48t145.5 37.5t184.5 43.5t220 58.5q0 -189 -22 -343t-59 -258t-89 -181.5t-108.5 -120t-122 -68t-125.5 -30t-121.5 -1.5t-107.5 12.5t-87.5 17t-56.5 7.5l-99 -55z M238.5 300.5q19.5 -6.5 86.5 76.5q55 66 367 234q70 38 118.5 69.5t102 79t99 111.5t86.5 148q22 50 24 60t-6 19q-7 5 -17 5t-26.5 -14.5t-33.5 -39.5q-35 -51 -113.5 -108.5t-139.5 -89.5l-61 -32q-369 -197 -458 -401q-48 -111 -28.5 -117.5z" />
-<glyph unicode="&#xe104;" d="M111 408q0 -33 5 -63q9 -56 44 -119.5t105 -108.5q31 -21 64 -16t62 23.5t57 49.5t48 61.5t35 60.5q32 66 39 184.5t-13 157.5q79 -80 122 -164t26 -184q-5 -33 -20.5 -69.5t-37.5 -80.5q-10 -19 -14.5 -29t-12 -26t-9 -23.5t-3 -19t2.5 -15.5t11 -9.5t19.5 -5t30.5 2.5 t42 8q57 20 91 34t87.5 44.5t87 64t65.5 88.5t47 122q38 172 -44.5 341.5t-246.5 278.5q22 -44 43 -129q39 -159 -32 -154q-15 2 -33 9q-79 33 -120.5 100t-44 175.5t48.5 257.5q-13 -8 -34 -23.5t-72.5 -66.5t-88.5 -105.5t-60 -138t-8 -166.5q2 -12 8 -41.5t8 -43t6 -39.5 t3.5 -39.5t-1 -33.5t-6 -31.5t-13.5 -24t-21 -20.5t-31 -12q-38 -10 -67 13t-40.5 61.5t-15 81.5t10.5 75q-52 -46 -83.5 -101t-39 -107t-7.5 -85z" />
-<glyph unicode="&#xe105;" d="M-61 600l26 40q6 10 20 30t49 63.5t74.5 85.5t97 90t116.5 83.5t132.5 59t145.5 23.5t145.5 -23.5t132.5 -59t116.5 -83.5t97 -90t74.5 -85.5t49 -63.5t20 -30l26 -40l-26 -40q-6 -10 -20 -30t-49 -63.5t-74.5 -85.5t-97 -90t-116.5 -83.5t-132.5 -59t-145.5 -23.5 t-145.5 23.5t-132.5 59t-116.5 83.5t-97 90t-74.5 85.5t-49 63.5t-20 30zM120 600q7 -10 40.5 -58t56 -78.5t68 -77.5t87.5 -75t103 -49.5t125 -21.5t123.5 20t100.5 45.5t85.5 71.5t66.5 75.5t58 81.5t47 66q-1 1 -28.5 37.5t-42 55t-43.5 53t-57.5 63.5t-58.5 54 q49 -74 49 -163q0 -124 -88 -212t-212 -88t-212 88t-88 212q0 85 46 158q-102 -87 -226 -258zM377 656q49 -124 154 -191l105 105q-37 24 -75 72t-57 84l-20 36z" />
-<glyph unicode="&#xe106;" d="M-61 600l26 40q6 10 20 30t49 63.5t74.5 85.5t97 90t116.5 83.5t132.5 59t145.5 23.5q61 0 121 -17l37 142h148l-314 -1200h-148l37 143q-82 21 -165 71.5t-140 102t-109.5 112t-72 88.5t-29.5 43zM120 600q210 -282 393 -336l37 141q-107 18 -178.5 101.5t-71.5 193.5 q0 85 46 158q-102 -87 -226 -258zM377 656q49 -124 154 -191l47 47l23 87q-30 28 -59 69t-44 68l-14 26zM780 161l38 145q22 15 44.5 34t46 44t40.5 44t41 50.5t33.5 43.5t33 44t24.5 34q-97 127 -140 175l39 146q67 -54 131.5 -125.5t87.5 -103.5t36 -52l26 -40l-26 -40 q-7 -12 -25.5 -38t-63.5 -79.5t-95.5 -102.5t-124 -100t-146.5 -79z" />
-<glyph unicode="&#xe107;" d="M-97.5 34q13.5 -34 50.5 -34h1294q37 0 50.5 35.5t-7.5 67.5l-642 1056q-20 34 -48 36.5t-48 -29.5l-642 -1066q-21 -32 -7.5 -66zM155 200l445 723l445 -723h-345v100h-200v-100h-345zM500 600l100 -300l100 300v100h-200v-100z" />
-<glyph unicode="&#xe108;" d="M100 262v41q0 20 11 44.5t26 38.5l363 325v339q0 62 44 106t106 44t106 -44t44 -106v-339l363 -325q15 -14 26 -38.5t11 -44.5v-41q0 -20 -12 -26.5t-29 5.5l-359 249v-263q100 -91 100 -113v-64q0 -20 -13 -28.5t-32 0.5l-94 78h-222l-94 -78q-19 -9 -32 -0.5t-13 28.5 v64q0 22 100 113v263l-359 -249q-17 -12 -29 -5.5t-12 26.5z" />
-<glyph unicode="&#xe109;" d="M0 50q0 -20 14.5 -35t35.5 -15h1000q21 0 35.5 15t14.5 35v750h-1100v-750zM0 900h1100v150q0 21 -14.5 35.5t-35.5 14.5h-150v100h-100v-100h-500v100h-100v-100h-150q-21 0 -35.5 -14.5t-14.5 -35.5v-150zM100 100v100h100v-100h-100zM100 300v100h100v-100h-100z M100 500v100h100v-100h-100zM300 100v100h100v-100h-100zM300 300v100h100v-100h-100zM300 500v100h100v-100h-100zM500 100v100h100v-100h-100zM500 300v100h100v-100h-100zM500 500v100h100v-100h-100zM700 100v100h100v-100h-100zM700 300v100h100v-100h-100zM700 500 v100h100v-100h-100zM900 100v100h100v-100h-100zM900 300v100h100v-100h-100zM900 500v100h100v-100h-100z" />
-<glyph unicode="&#xe110;" d="M0 200v200h259l600 600h241v198l300 -295l-300 -300v197h-159l-600 -600h-341zM0 800h259l122 -122l141 142l-181 180h-341v-200zM678 381l141 142l122 -123h159v198l300 -295l-300 -300v197h-241z" />
-<glyph unicode="&#xe111;" d="M0 400v600q0 41 29.5 70.5t70.5 29.5h1000q41 0 70.5 -29.5t29.5 -70.5v-600q0 -41 -29.5 -70.5t-70.5 -29.5h-596l-304 -300v300h-100q-41 0 -70.5 29.5t-29.5 70.5z" />
-<glyph unicode="&#xe112;" d="M100 600v200h300v-250q0 -113 6 -145q17 -92 102 -117q39 -11 92 -11q37 0 66.5 5.5t50 15.5t36 24t24 31.5t14 37.5t7 42t2.5 45t0 47v25v250h300v-200q0 -42 -3 -83t-15 -104t-31.5 -116t-58 -109.5t-89 -96.5t-129 -65.5t-174.5 -25.5t-174.5 25.5t-129 65.5t-89 96.5 t-58 109.5t-31.5 116t-15 104t-3 83zM100 900v300h300v-300h-300zM800 900v300h300v-300h-300z" />
-<glyph unicode="&#xe113;" d="M-30 411l227 -227l352 353l353 -353l226 227l-578 579z" />
-<glyph unicode="&#xe114;" d="M70 797l580 -579l578 579l-226 227l-353 -353l-352 353z" />
-<glyph unicode="&#xe115;" d="M-198 700l299 283l300 -283h-203v-400h385l215 -200h-800v600h-196zM402 1000l215 -200h381v-400h-198l299 -283l299 283h-200v600h-796z" />
-<glyph unicode="&#xe116;" d="M18 939q-5 24 10 42q14 19 39 19h896l38 162q5 17 18.5 27.5t30.5 10.5h94q20 0 35 -14.5t15 -35.5t-15 -35.5t-35 -14.5h-54l-201 -961q-2 -4 -6 -10.5t-19 -17.5t-33 -11h-31v-50q0 -20 -14.5 -35t-35.5 -15t-35.5 15t-14.5 35v50h-300v-50q0 -20 -14.5 -35t-35.5 -15 t-35.5 15t-14.5 35v50h-50q-21 0 -35.5 15t-14.5 35q0 21 14.5 35.5t35.5 14.5h535l48 200h-633q-32 0 -54.5 21t-27.5 43z" />
-<glyph unicode="&#xe117;" d="M0 0v800h1200v-800h-1200zM0 900v100h200q0 41 29.5 70.5t70.5 29.5h300q41 0 70.5 -29.5t29.5 -70.5h500v-100h-1200z" />
-<glyph unicode="&#xe118;" d="M1 0l300 700h1200l-300 -700h-1200zM1 400v600h200q0 41 29.5 70.5t70.5 29.5h300q41 0 70.5 -29.5t29.5 -70.5h500v-200h-1000z" />
-<glyph unicode="&#xe119;" d="M302 300h198v600h-198l298 300l298 -300h-198v-600h198l-298 -300z" />
-<glyph unicode="&#xe120;" d="M0 600l300 298v-198h600v198l300 -298l-300 -297v197h-600v-197z" />
-<glyph unicode="&#xe121;" d="M0 100v100q0 41 29.5 70.5t70.5 29.5h1000q41 0 70.5 -29.5t29.5 -70.5v-100q0 -41 -29.5 -70.5t-70.5 -29.5h-1000q-41 0 -70.5 29.5t-29.5 70.5zM31 400l172 739q5 22 23 41.5t38 19.5h672q19 0 37.5 -22.5t23.5 -45.5l172 -732h-1138zM800 100h100v100h-100v-100z M1000 100h100v100h-100v-100z" />
-<glyph unicode="&#xe122;" d="M-101 600v50q0 24 25 49t50 38l25 13v-250l-11 5.5t-24 14t-30 21.5t-24 27.5t-11 31.5zM100 500v250v8v8v7t0.5 7t1.5 5.5t2 5t3 4t4.5 3.5t6 1.5t7.5 0.5h200l675 250v-850l-675 200h-38l47 -276q2 -12 -3 -17.5t-11 -6t-21 -0.5h-8h-83q-20 0 -34.5 14t-18.5 35 q-55 337 -55 351zM1100 200v850q0 21 14.5 35.5t35.5 14.5q20 0 35 -14.5t15 -35.5v-850q0 -20 -15 -35t-35 -15q-21 0 -35.5 15t-14.5 35z" />
-<glyph unicode="&#xe123;" d="M74 350q0 21 13.5 35.5t33.5 14.5h18l117 173l63 327q15 77 76 140t144 83l-18 32q-6 19 3 32t29 13h94q20 0 29 -10.5t3 -29.5q-18 -36 -18 -37q83 -19 144 -82.5t76 -140.5l63 -327l118 -173h17q20 0 33.5 -14.5t13.5 -35.5q0 -20 -13 -40t-31 -27q-8 -3 -23 -8.5 t-65 -20t-103 -25t-132.5 -19.5t-158.5 -9q-125 0 -245.5 20.5t-178.5 40.5l-58 20q-18 7 -31 27.5t-13 40.5zM497 110q12 -49 40 -79.5t63 -30.5t63 30.5t39 79.5q-48 -6 -102 -6t-103 6z" />
-<glyph unicode="&#xe124;" d="M21 445l233 -45l-78 -224l224 78l45 -233l155 179l155 -179l45 233l224 -78l-78 224l234 45l-180 155l180 156l-234 44l78 225l-224 -78l-45 233l-155 -180l-155 180l-45 -233l-224 78l78 -225l-233 -44l179 -156z" />
-<glyph unicode="&#xe125;" d="M0 200h200v600h-200v-600zM300 275q0 -75 100 -75h61q124 -100 139 -100h250q46 0 83 57l238 344q29 31 29 74v100q0 44 -30.5 84.5t-69.5 40.5h-328q28 118 28 125v150q0 44 -30.5 84.5t-69.5 40.5h-50q-27 0 -51 -20t-38 -48l-96 -198l-145 -196q-20 -26 -20 -63v-400z M400 300v375l150 213l100 212h50v-175l-50 -225h450v-125l-250 -375h-214l-136 100h-100z" />
-<glyph unicode="&#xe126;" d="M0 400v600h200v-600h-200zM300 525v400q0 75 100 75h61q124 100 139 100h250q46 0 83 -57l238 -344q29 -31 29 -74v-100q0 -44 -30.5 -84.5t-69.5 -40.5h-328q28 -118 28 -125v-150q0 -44 -30.5 -84.5t-69.5 -40.5h-50q-27 0 -51 20t-38 48l-96 198l-145 196 q-20 26 -20 63zM400 525l150 -212l100 -213h50v175l-50 225h450v125l-250 375h-214l-136 -100h-100v-375z" />
-<glyph unicode="&#xe127;" d="M8 200v600h200v-600h-200zM308 275v525q0 17 14 35.5t28 28.5l14 9l362 230q14 6 25 6q17 0 29 -12l109 -112q14 -14 14 -34q0 -18 -11 -32l-85 -121h302q85 0 138.5 -38t53.5 -110t-54.5 -111t-138.5 -39h-107l-130 -339q-7 -22 -20.5 -41.5t-28.5 -19.5h-341 q-7 0 -90 81t-83 94zM408 289l100 -89h293l131 339q6 21 19.5 41t28.5 20h203q16 0 25 15t9 36q0 20 -9 34.5t-25 14.5h-457h-6.5h-7.5t-6.5 0.5t-6 1t-5 1.5t-5.5 2.5t-4 4t-4 5.5q-5 12 -5 20q0 14 10 27l147 183l-86 83l-339 -236v-503z" />
-<glyph unicode="&#xe128;" d="M-101 651q0 72 54 110t139 38l302 -1l-85 121q-11 16 -11 32q0 21 14 34l109 113q13 12 29 12q11 0 25 -6l365 -230q7 -4 17 -10.5t26.5 -26t16.5 -36.5v-526q0 -13 -86 -93.5t-94 -80.5h-341q-16 0 -29.5 20t-19.5 41l-130 339h-107q-84 0 -139 39t-55 111zM-1 601h222 q15 0 28.5 -20.5t19.5 -40.5l131 -339h293l107 89v502l-343 237l-87 -83l145 -184q10 -11 10 -26q0 -11 -5 -20q-1 -3 -3.5 -5.5l-4 -4t-5 -2.5t-5.5 -1.5t-6.5 -1t-6.5 -0.5h-7.5h-6.5h-476v-100zM1000 201v600h200v-600h-200z" />
-<glyph unicode="&#xe129;" d="M97 719l230 -363q4 -6 10.5 -15.5t26 -25t36.5 -15.5h525q13 0 94 83t81 90v342q0 15 -20 28.5t-41 19.5l-339 131v106q0 84 -39 139t-111 55t-110 -53.5t-38 -138.5v-302l-121 84q-15 12 -33.5 11.5t-32.5 -13.5l-112 -110q-22 -22 -6 -53zM172 739l83 86l183 -146 q22 -18 47 -5q3 1 5.5 3.5l4 4t2.5 5t1.5 5.5t1 6.5t0.5 6.5v7.5v6.5v456q0 22 25 31t50 -0.5t25 -30.5v-202q0 -16 20 -29.5t41 -19.5l339 -130v-294l-89 -100h-503zM400 0v200h600v-200h-600z" />
-<glyph unicode="&#xe130;" d="M2 585q-16 -31 6 -53l112 -110q13 -13 32 -13.5t34 10.5l121 85q0 -51 -0.5 -153.5t-0.5 -148.5q0 -84 38.5 -138t110.5 -54t111 55t39 139v106l339 131q20 6 40.5 19.5t20.5 28.5v342q0 7 -81 90t-94 83h-525q-17 0 -35.5 -14t-28.5 -28l-10 -15zM77 565l236 339h503 l89 -100v-294l-340 -130q-20 -6 -40 -20t-20 -29v-202q0 -22 -25 -31t-50 0t-25 31v456v14.5t-1.5 11.5t-5 12t-9.5 7q-24 13 -46 -5l-184 -146zM305 1104v200h600v-200h-600z" />
-<glyph unicode="&#xe131;" d="M5 597q0 122 47.5 232.5t127.5 190.5t190.5 127.5t232.5 47.5q162 0 299.5 -80t217.5 -218t80 -300t-80 -299.5t-217.5 -217.5t-299.5 -80t-300 80t-218 217.5t-80 299.5zM298 701l2 -201h300l-2 -194l402 294l-402 298v-197h-300z" />
-<glyph unicode="&#xe132;" d="M0 597q0 122 47.5 232.5t127.5 190.5t190.5 127.5t231.5 47.5q122 0 232.5 -47.5t190.5 -127.5t127.5 -190.5t47.5 -232.5q0 -162 -80 -299.5t-218 -217.5t-300 -80t-299.5 80t-217.5 217.5t-80 299.5zM200 600l402 -294l-2 194h300l2 201h-300v197z" />
-<glyph unicode="&#xe133;" d="M5 597q0 122 47.5 232.5t127.5 190.5t190.5 127.5t232.5 47.5q162 0 299.5 -80t217.5 -218t80 -300t-80 -299.5t-217.5 -217.5t-299.5 -80t-300 80t-218 217.5t-80 299.5zM300 600h200v-300h200v300h200l-300 400z" />
-<glyph unicode="&#xe134;" d="M5 597q0 122 47.5 232.5t127.5 190.5t190.5 127.5t232.5 47.5q162 0 299.5 -80t217.5 -218t80 -300t-80 -299.5t-217.5 -217.5t-299.5 -80t-300 80t-218 217.5t-80 299.5zM300 600l300 -400l300 400h-200v300h-200v-300h-200z" />
-<glyph unicode="&#xe135;" d="M5 597q0 122 47.5 232.5t127.5 190.5t190.5 127.5t232.5 47.5q121 0 231.5 -47.5t190.5 -127.5t127.5 -190.5t47.5 -232.5q0 -162 -80 -299.5t-217.5 -217.5t-299.5 -80t-300 80t-218 217.5t-80 299.5zM254 780q-8 -33 5.5 -92.5t7.5 -87.5q0 -9 17 -44t16 -60 q12 0 23 -5.5t23 -15t20 -13.5q24 -12 108 -42q22 -8 53 -31.5t59.5 -38.5t57.5 -11q8 -18 -15 -55t-20 -57q42 -71 87 -80q0 -6 -3 -15.5t-3.5 -14.5t4.5 -17q104 -3 221 112q30 29 47 47t34.5 49t20.5 62q-14 9 -37 9.5t-36 7.5q-14 7 -49 15t-52 19q-9 0 -39.5 -0.5 t-46.5 -1.5t-39 -6.5t-39 -16.5q-50 -35 -66 -12q-4 2 -3.5 25.5t0.5 25.5q-6 13 -26.5 17t-24.5 7q2 22 -2 41t-16.5 28t-38.5 -20q-23 -25 -42 4q-19 28 -8 58q6 16 22 22q6 -1 26 -1.5t33.5 -4t19.5 -13.5q12 -19 32 -37.5t34 -27.5l14 -8q0 3 9.5 39.5t5.5 57.5 q-4 23 14.5 44.5t22.5 31.5q5 14 10 35t8.5 31t15.5 22.5t34 21.5q-6 18 10 37q8 0 23.5 -1.5t24.5 -1.5t20.5 4.5t20.5 15.5q-10 23 -30.5 42.5t-38 30t-49 26.5t-43.5 23q11 39 2 44q31 -13 58 -14.5t39 3.5l11 4q7 36 -16.5 53.5t-64.5 28.5t-56 23q-19 -3 -37 0 q-15 -12 -36.5 -21t-34.5 -12t-44 -8t-39 -6q-15 -3 -45.5 0.5t-45.5 -2.5q-21 -7 -52 -26.5t-34 -34.5q-3 -11 6.5 -22.5t8.5 -18.5q-3 -34 -27.5 -90.5t-29.5 -79.5zM518 916q3 12 16 30t16 25q10 -10 18.5 -10t14 6t14.5 14.5t16 12.5q0 -24 17 -66.5t17 -43.5 q-9 2 -31 5t-36 5t-32 8t-30 14zM692 1003h1h-1z" />
-<glyph unicode="&#xe136;" d="M0 164.5q0 21.5 15 37.5l600 599q-33 101 6 201.5t135 154.5q164 92 306 -9l-259 -138l145 -232l251 126q13 -175 -151 -267q-123 -70 -253 -23l-596 -596q-15 -16 -36.5 -16t-36.5 16l-111 110q-15 15 -15 36.5z" />
-<glyph unicode="&#xe137;" horiz-adv-x="1220" d="M0 196v100q0 41 29.5 70.5t70.5 29.5h1000q41 0 70.5 -29.5t29.5 -70.5v-100q0 -41 -29.5 -70.5t-70.5 -29.5h-1000q-41 0 -70.5 29.5t-29.5 70.5zM0 596v100q0 41 29.5 70.5t70.5 29.5h1000q41 0 70.5 -29.5t29.5 -70.5v-100q0 -41 -29.5 -70.5t-70.5 -29.5h-1000 q-41 0 -70.5 29.5t-29.5 70.5zM0 996v100q0 41 29.5 70.5t70.5 29.5h1000q41 0 70.5 -29.5t29.5 -70.5v-100q0 -41 -29.5 -70.5t-70.5 -29.5h-1000q-41 0 -70.5 29.5t-29.5 70.5zM600 596h500v100h-500v-100zM800 196h300v100h-300v-100zM900 996h200v100h-200v-100z" />
-<glyph unicode="&#xe138;" d="M100 1100v100h1000v-100h-1000zM150 1000h900l-350 -500v-300l-200 -200v500z" />
-<glyph unicode="&#xe139;" d="M0 200v200h1200v-200q0 -41 -29.5 -70.5t-70.5 -29.5h-1000q-41 0 -70.5 29.5t-29.5 70.5zM0 500v400q0 41 29.5 70.5t70.5 29.5h300v100q0 41 29.5 70.5t70.5 29.5h200q41 0 70.5 -29.5t29.5 -70.5v-100h300q41 0 70.5 -29.5t29.5 -70.5v-400h-500v100h-200v-100h-500z M500 1000h200v100h-200v-100z" />
-<glyph unicode="&#xe140;" d="M0 0v400l129 -129l200 200l142 -142l-200 -200l129 -129h-400zM0 800l129 129l200 -200l142 142l-200 200l129 129h-400v-400zM729 329l142 142l200 -200l129 129v-400h-400l129 129zM729 871l200 200l-129 129h400v-400l-129 129l-200 -200z" />
-<glyph unicode="&#xe141;" d="M0 596q0 162 80 299t217 217t299 80t299 -80t217 -217t80 -299t-80 -299t-217 -217t-299 -80t-299 80t-217 217t-80 299zM182 596q0 -172 121.5 -293t292.5 -121t292.5 121t121.5 293q0 171 -121.5 292.5t-292.5 121.5t-292.5 -121.5t-121.5 -292.5zM291 655 q0 23 15.5 38.5t38.5 15.5t39 -16t16 -38q0 -23 -16 -39t-39 -16q-22 0 -38 16t-16 39zM400 850q0 22 16 38.5t39 16.5q22 0 38 -16t16 -39t-16 -39t-38 -16q-23 0 -39 16.5t-16 38.5zM514 609q0 32 20.5 56.5t51.5 29.5l122 126l1 1q-9 14 -9 28q0 22 16 38.5t39 16.5 q22 0 38 -16t16 -39t-16 -39t-38 -16q-14 0 -29 10l-55 -145q17 -22 17 -51q0 -36 -25.5 -61.5t-61.5 -25.5t-61.5 25.5t-25.5 61.5zM800 655q0 22 16 38t39 16t38.5 -15.5t15.5 -38.5t-16 -39t-38 -16q-23 0 -39 16t-16 39z" />
-<glyph unicode="&#xe142;" d="M-40 375q-13 -95 35 -173q35 -57 94 -89t129 -32q63 0 119 28q33 16 65 40.5t52.5 45.5t59.5 64q40 44 57 61l394 394q35 35 47 84t-3 96q-27 87 -117 104q-20 2 -29 2q-46 0 -78.5 -16.5t-67.5 -51.5l-389 -396l-7 -7l69 -67l377 373q20 22 39 38q23 23 50 23 q38 0 53 -36q16 -39 -20 -75l-547 -547q-52 -52 -125 -52q-55 0 -100 33t-54 96q-5 35 2.5 66t31.5 63t42 50t56 54q24 21 44 41l348 348q52 52 82.5 79.5t84 54t107.5 26.5q25 0 48 -4q95 -17 154 -94.5t51 -175.5q-7 -101 -98 -192l-252 -249l-253 -256l7 -7l69 -60 l517 511q67 67 95 157t11 183q-16 87 -67 154t-130 103q-69 33 -152 33q-107 0 -197 -55q-40 -24 -111 -95l-512 -512q-68 -68 -81 -163z" />
-<glyph unicode="&#xe143;" d="M80 784q0 131 98.5 229.5t230.5 98.5q143 0 241 -129q103 129 246 129q129 0 226 -98.5t97 -229.5q0 -46 -17.5 -91t-61 -99t-77 -89.5t-104.5 -105.5q-197 -191 -293 -322l-17 -23l-16 23q-43 58 -100 122.5t-92 99.5t-101 100q-71 70 -104.5 105.5t-77 89.5t-61 99 t-17.5 91zM250 784q0 -27 30.5 -70t61.5 -75.5t95 -94.5l22 -22q93 -90 190 -201q82 92 195 203l12 12q64 62 97.5 97t64.5 79t31 72q0 71 -48 119.5t-105 48.5q-74 0 -132 -83l-118 -171l-114 174q-51 80 -123 80q-60 0 -109.5 -49.5t-49.5 -118.5z" />
-<glyph unicode="&#xe144;" d="M57 353q0 -95 66 -159l141 -142q68 -66 159 -66q93 0 159 66l283 283q66 66 66 159t-66 159l-141 141q-8 9 -19 17l-105 -105l212 -212l-389 -389l-247 248l95 95l-18 18q-46 45 -75 101l-55 -55q-66 -66 -66 -159zM269 706q0 -93 66 -159l141 -141q7 -7 19 -17l105 105 l-212 212l389 389l247 -247l-95 -96l18 -17q47 -49 77 -100l29 29q35 35 62.5 88t27.5 96q0 93 -66 159l-141 141q-66 66 -159 66q-95 0 -159 -66l-283 -283q-66 -64 -66 -159z" />
-<glyph unicode="&#xe145;" d="M200 100v953q0 21 30 46t81 48t129 38t163 15t162 -15t127 -38t79 -48t29 -46v-953q0 -41 -29.5 -70.5t-70.5 -29.5h-600q-41 0 -70.5 29.5t-29.5 70.5zM300 300h600v700h-600v-700zM496 150q0 -43 30.5 -73.5t73.5 -30.5t73.5 30.5t30.5 73.5t-30.5 73.5t-73.5 30.5 t-73.5 -30.5t-30.5 -73.5z" />
-<glyph unicode="&#xe146;" d="M0 0l303 380l207 208l-210 212h300l267 279l-35 36q-15 14 -15 35t15 35q14 15 35 15t35 -15l283 -282q15 -15 15 -36t-15 -35q-14 -15 -35 -15t-35 15l-36 35l-279 -267v-300l-212 210l-208 -207z" />
-<glyph unicode="&#xe148;" d="M295 433h139q5 -77 48.5 -126.5t117.5 -64.5v335q-6 1 -15.5 4t-11.5 3q-46 14 -79 26.5t-72 36t-62.5 52t-40 72.5t-16.5 99q0 92 44 159.5t109 101t144 40.5v78h100v-79q38 -4 72.5 -13.5t75.5 -31.5t71 -53.5t51.5 -84t24.5 -118.5h-159q-8 72 -35 109.5t-101 50.5 v-307l64 -14q34 -7 64 -16.5t70 -31.5t67.5 -52t47.5 -80.5t20 -112.5q0 -139 -89 -224t-244 -96v-77h-100v78q-152 17 -237 104q-40 40 -52.5 93.5t-15.5 139.5zM466 889q0 -29 8 -51t16.5 -34t29.5 -22.5t31 -13.5t38 -10q7 -2 11 -3v274q-61 -8 -97.5 -37.5t-36.5 -102.5 zM700 237q170 18 170 151q0 64 -44 99.5t-126 60.5v-311z" />
-<glyph unicode="&#xe149;" d="M100 600v100h166q-24 49 -44 104q-10 26 -14.5 55.5t-3 72.5t25 90t68.5 87q97 88 263 88q129 0 230 -89t101 -208h-153q0 52 -34 89.5t-74 51.5t-76 14q-37 0 -79 -14.5t-62 -35.5q-41 -44 -41 -101q0 -28 16.5 -69.5t28 -62.5t41.5 -72h241v-100h-197q8 -50 -2.5 -115 t-31.5 -94q-41 -59 -99 -113q35 11 84 18t70 7q33 1 103 -16t103 -17q76 0 136 30l50 -147q-41 -25 -80.5 -36.5t-59 -13t-61.5 -1.5q-23 0 -128 33t-155 29q-39 -4 -82 -17t-66 -25l-24 -11l-55 145l16.5 11t15.5 10t13.5 9.5t14.5 12t14.5 14t17.5 18.5q48 55 54 126.5 t-30 142.5h-221z" />
-<glyph unicode="&#xe150;" d="M2 300l298 -300l298 300h-198v900h-200v-900h-198zM602 900l298 300l298 -300h-198v-900h-200v900h-198z" />
-<glyph unicode="&#xe151;" d="M2 300h198v900h200v-900h198l-298 -300zM700 0v200h100v-100h200v-100h-300zM700 400v100h300v-200h-99v-100h-100v100h99v100h-200zM700 700v500h300v-500h-100v100h-100v-100h-100zM801 900h100v200h-100v-200z" />
-<glyph unicode="&#xe152;" d="M2 300h198v900h200v-900h198l-298 -300zM700 0v500h300v-500h-100v100h-100v-100h-100zM700 700v200h100v-100h200v-100h-300zM700 1100v100h300v-200h-99v-100h-100v100h99v100h-200zM801 200h100v200h-100v-200z" />
-<glyph unicode="&#xe153;" d="M2 300l298 -300l298 300h-198v900h-200v-900h-198zM800 100v400h300v-500h-100v100h-200zM800 1100v100h200v-500h-100v400h-100zM901 200h100v200h-100v-200z" />
-<glyph unicode="&#xe154;" d="M2 300l298 -300l298 300h-198v900h-200v-900h-198zM800 400v100h200v-500h-100v400h-100zM800 800v400h300v-500h-100v100h-200zM901 900h100v200h-100v-200z" />
-<glyph unicode="&#xe155;" d="M2 300l298 -300l298 300h-198v900h-200v-900h-198zM700 100v200h500v-200h-500zM700 400v200h400v-200h-400zM700 700v200h300v-200h-300zM700 1000v200h200v-200h-200z" />
-<glyph unicode="&#xe156;" d="M2 300l298 -300l298 300h-198v900h-200v-900h-198zM700 100v200h200v-200h-200zM700 400v200h300v-200h-300zM700 700v200h400v-200h-400zM700 1000v200h500v-200h-500z" />
-<glyph unicode="&#xe157;" d="M0 400v300q0 165 117.5 282.5t282.5 117.5h300q162 0 281 -118.5t119 -281.5v-300q0 -165 -118.5 -282.5t-281.5 -117.5h-300q-165 0 -282.5 117.5t-117.5 282.5zM200 300q0 -41 29.5 -70.5t70.5 -29.5h500q41 0 70.5 29.5t29.5 70.5v500q0 41 -29.5 70.5t-70.5 29.5 h-500q-41 0 -70.5 -29.5t-29.5 -70.5v-500z" />
-<glyph unicode="&#xe158;" d="M0 400v300q0 163 119 281.5t281 118.5h300q165 0 282.5 -117.5t117.5 -282.5v-300q0 -165 -117.5 -282.5t-282.5 -117.5h-300q-163 0 -281.5 117.5t-118.5 282.5zM200 300q0 -41 29.5 -70.5t70.5 -29.5h500q41 0 70.5 29.5t29.5 70.5v500q0 41 -29.5 70.5t-70.5 29.5 h-500q-41 0 -70.5 -29.5t-29.5 -70.5v-500zM400 300l333 250l-333 250v-500z" />
-<glyph unicode="&#xe159;" d="M0 400v300q0 163 117.5 281.5t282.5 118.5h300q163 0 281.5 -119t118.5 -281v-300q0 -165 -117.5 -282.5t-282.5 -117.5h-300q-165 0 -282.5 117.5t-117.5 282.5zM200 300q0 -41 29.5 -70.5t70.5 -29.5h500q41 0 70.5 29.5t29.5 70.5v500q0 41 -29.5 70.5t-70.5 29.5 h-500q-41 0 -70.5 -29.5t-29.5 -70.5v-500zM300 700l250 -333l250 333h-500z" />
-<glyph unicode="&#xe160;" d="M0 400v300q0 165 117.5 282.5t282.5 117.5h300q165 0 282.5 -117.5t117.5 -282.5v-300q0 -162 -118.5 -281t-281.5 -119h-300q-165 0 -282.5 118.5t-117.5 281.5zM200 300q0 -41 29.5 -70.5t70.5 -29.5h500q41 0 70.5 29.5t29.5 70.5v500q0 41 -29.5 70.5t-70.5 29.5 h-500q-41 0 -70.5 -29.5t-29.5 -70.5v-500zM300 400h500l-250 333z" />
-<glyph unicode="&#xe161;" d="M0 400v300h300v200l400 -350l-400 -350v200h-300zM500 0v200h500q41 0 70.5 29.5t29.5 70.5v500q0 41 -29.5 70.5t-70.5 29.5h-500v200h400q165 0 282.5 -117.5t117.5 -282.5v-300q0 -165 -117.5 -282.5t-282.5 -117.5h-400z" />
-<glyph unicode="&#xe162;" d="M217 519q8 -19 31 -19h302q-155 -438 -160 -458q-5 -21 4 -32l9 -8h9q14 0 26 15q11 13 274.5 321.5t264.5 308.5q14 19 5 36q-8 17 -31 17l-301 -1q1 4 78 219.5t79 227.5q2 15 -5 27l-9 9h-9q-15 0 -25 -16q-4 -6 -98 -111.5t-228.5 -257t-209.5 -237.5q-16 -19 -6 -41 z" />
-<glyph unicode="&#xe163;" d="M0 400q0 -165 117.5 -282.5t282.5 -117.5h300q47 0 100 15v185h-500q-41 0 -70.5 29.5t-29.5 70.5v500q0 41 29.5 70.5t70.5 29.5h500v185q-14 4 -114 7.5t-193 5.5l-93 2q-165 0 -282.5 -117.5t-117.5 -282.5v-300zM600 400v300h300v200l400 -350l-400 -350v200h-300z " />
-<glyph unicode="&#xe164;" d="M0 400q0 -165 117.5 -282.5t282.5 -117.5h300q163 0 281.5 117.5t118.5 282.5v98l-78 73l-122 -123v-148q0 -41 -29.5 -70.5t-70.5 -29.5h-500q-41 0 -70.5 29.5t-29.5 70.5v500q0 41 29.5 70.5t70.5 29.5h156l118 122l-74 78h-100q-165 0 -282.5 -117.5t-117.5 -282.5 v-300zM496 709l353 342l-149 149h500v-500l-149 149l-342 -353z" />
-<glyph unicode="&#xe165;" d="M4 600q0 162 80 299t217 217t299 80t299 -80t217 -217t80 -299t-80 -299t-217 -217t-299 -80t-299 80t-217 217t-80 299zM186 600q0 -171 121.5 -292.5t292.5 -121.5t292.5 121.5t121.5 292.5t-121.5 292.5t-292.5 121.5t-292.5 -121.5t-121.5 -292.5zM406 600 q0 80 57 137t137 57t137 -57t57 -137t-57 -137t-137 -57t-137 57t-57 137z" />
-<glyph unicode="&#xe166;" d="M0 0v275q0 11 7 18t18 7h1048q11 0 19 -7.5t8 -17.5v-275h-1100zM100 800l445 -500l450 500h-295v400h-300v-400h-300zM900 150h100v50h-100v-50z" />
-<glyph unicode="&#xe167;" d="M0 0v275q0 11 7 18t18 7h1048q11 0 19 -7.5t8 -17.5v-275h-1100zM100 700h300v-300h300v300h295l-445 500zM900 150h100v50h-100v-50z" />
-<glyph unicode="&#xe168;" d="M0 0v275q0 11 7 18t18 7h1048q11 0 19 -7.5t8 -17.5v-275h-1100zM100 705l305 -305l596 596l-154 155l-442 -442l-150 151zM900 150h100v50h-100v-50z" />
-<glyph unicode="&#xe169;" d="M0 0v275q0 11 7 18t18 7h1048q11 0 19 -7.5t8 -17.5v-275h-1100zM100 988l97 -98l212 213l-97 97zM200 400l697 1l3 699l-250 -239l-149 149l-212 -212l149 -149zM900 150h100v50h-100v-50z" />
-<glyph unicode="&#xe170;" d="M0 0v275q0 11 7 18t18 7h1048q11 0 19 -7.5t8 -17.5v-275h-1100zM200 612l212 -212l98 97l-213 212zM300 1200l239 -250l-149 -149l212 -212l149 148l249 -237l-1 697zM900 150h100v50h-100v-50z" />
-<glyph unicode="&#xe171;" d="M23 415l1177 784v-1079l-475 272l-310 -393v416h-392zM494 210l672 938l-672 -712v-226z" />
-<glyph unicode="&#xe172;" d="M0 150v1000q0 20 14.5 35t35.5 15h250v-300h500v300h100l200 -200v-850q0 -21 -15 -35.5t-35 -14.5h-150v400h-700v-400h-150q-21 0 -35.5 14.5t-14.5 35.5zM600 1000h100v200h-100v-200z" />
-<glyph unicode="&#xe173;" d="M0 150v1000q0 20 14.5 35t35.5 15h250v-300h500v300h100l200 -200v-218l-276 -275l-120 120l-126 -127h-378v-400h-150q-21 0 -35.5 14.5t-14.5 35.5zM581 306l123 123l120 -120l353 352l123 -123l-475 -476zM600 1000h100v200h-100v-200z" />
-<glyph unicode="&#xe174;" d="M0 150v1000q0 20 14.5 35t35.5 15h250v-300h500v300h100l200 -200v-269l-103 -103l-170 170l-298 -298h-329v-400h-150q-21 0 -35.5 14.5t-14.5 35.5zM600 1000h100v200h-100v-200zM700 133l170 170l-170 170l127 127l170 -170l170 170l127 -128l-170 -169l170 -170 l-127 -127l-170 170l-170 -170z" />
-<glyph unicode="&#xe175;" d="M0 150v1000q0 20 14.5 35t35.5 15h250v-300h500v300h100l200 -200v-300h-400v-200h-500v-400h-150q-21 0 -35.5 14.5t-14.5 35.5zM600 300l300 -300l300 300h-200v300h-200v-300h-200zM600 1000v200h100v-200h-100z" />
-<glyph unicode="&#xe176;" d="M0 150v1000q0 20 14.5 35t35.5 15h250v-300h500v300h100l200 -200v-402l-200 200l-298 -298h-402v-400h-150q-21 0 -35.5 14.5t-14.5 35.5zM600 300h200v-300h200v300h200l-300 300zM600 1000v200h100v-200h-100z" />
-<glyph unicode="&#xe177;" d="M0 250q0 -21 14.5 -35.5t35.5 -14.5h1100q21 0 35.5 14.5t14.5 35.5v550h-1200v-550zM0 900h1200v150q0 21 -14.5 35.5t-35.5 14.5h-1100q-21 0 -35.5 -14.5t-14.5 -35.5v-150zM100 300v200h400v-200h-400z" />
-<glyph unicode="&#xe178;" d="M0 400l300 298v-198h400v-200h-400v-198zM100 800v200h100v-200h-100zM300 800v200h100v-200h-100zM500 800v200h400v198l300 -298l-300 -298v198h-400zM800 300v200h100v-200h-100zM1000 300h100v200h-100v-200z" />
-<glyph unicode="&#xe179;" d="M100 700v400l50 100l50 -100v-300h100v300l50 100l50 -100v-300h100v300l50 100l50 -100v-400l-100 -203v-447q0 -21 -14.5 -35.5t-35.5 -14.5h-200q-21 0 -35.5 14.5t-14.5 35.5v447zM800 597q0 -29 10.5 -55.5t25 -43t29 -28.5t25.5 -18l10 -5v-397q0 -21 14.5 -35.5 t35.5 -14.5h200q21 0 35.5 14.5t14.5 35.5v1106q0 31 -18 40.5t-44 -7.5l-276 -116q-25 -17 -43.5 -51.5t-18.5 -65.5v-359z" />
-<glyph unicode="&#xe180;" d="M100 0h400v56q-75 0 -87.5 6t-12.5 44v394h500v-394q0 -38 -12.5 -44t-87.5 -6v-56h400v56q-4 0 -11 0.5t-24 3t-30 7t-24 15t-11 24.5v888q0 22 25 34.5t50 13.5l25 2v56h-400v-56q75 0 87.5 -6t12.5 -44v-394h-500v394q0 38 12.5 44t87.5 6v56h-400v-56q4 0 11 -0.5 t24 -3t30 -7t24 -15t11 -24.5v-888q0 -22 -25 -34.5t-50 -13.5l-25 -2v-56z" />
-<glyph unicode="&#xe181;" d="M0 300q0 -41 29.5 -70.5t70.5 -29.5h300q41 0 70.5 29.5t29.5 70.5v500q0 41 -29.5 70.5t-70.5 29.5h-300q-41 0 -70.5 -29.5t-29.5 -70.5v-500zM100 100h400l200 200h105l295 98v-298h-425l-100 -100h-375zM100 300v200h300v-200h-300zM100 600v200h300v-200h-300z M100 1000h400l200 -200v-98l295 98h105v200h-425l-100 100h-375zM700 402v163l400 133v-163z" />
-<glyph unicode="&#xe182;" d="M16.5 974.5q0.5 -21.5 16 -90t46.5 -140t104 -177.5t175 -208q103 -103 207.5 -176t180 -103.5t137 -47t92.5 -16.5l31 1l163 162q17 18 13.5 41t-22.5 37l-192 136q-19 14 -45 12t-42 -19l-118 -118q-142 101 -268 227t-227 268l118 118q17 17 20 41.5t-11 44.5 l-139 194q-14 19 -36.5 22t-40.5 -14l-162 -162q-1 -11 -0.5 -32.5z" />
-<glyph unicode="&#xe183;" d="M0 50v212q0 20 10.5 45.5t24.5 39.5l365 303v50q0 4 1 10.5t12 22.5t30 28.5t60 23t97 10.5t97 -10t60 -23.5t30 -27.5t12 -24l1 -10v-50l365 -303q14 -14 24.5 -39.5t10.5 -45.5v-212q0 -21 -14.5 -35.5t-35.5 -14.5h-1100q-20 0 -35 14.5t-15 35.5zM0 712 q0 -21 14.5 -33.5t34.5 -8.5l202 33q20 4 34.5 21t14.5 38v146q141 24 300 24t300 -24v-146q0 -21 14.5 -38t34.5 -21l202 -33q20 -4 34.5 8.5t14.5 33.5v200q-6 8 -19 20.5t-63 45t-112 57t-171 45t-235 20.5q-92 0 -175 -10.5t-141.5 -27t-108.5 -36.5t-81.5 -40 t-53.5 -36.5t-31 -27.5l-9 -10v-200z" />
-<glyph unicode="&#xe184;" d="M100 0v100h1100v-100h-1100zM175 200h950l-125 150v250l100 100v400h-100v-200h-100v200h-200v-200h-100v200h-200v-200h-100v200h-100v-400l100 -100v-250z" />
-<glyph unicode="&#xe185;" d="M100 0h300v400q0 41 -29.5 70.5t-70.5 29.5h-100q-41 0 -70.5 -29.5t-29.5 -70.5v-400zM500 0v1000q0 41 29.5 70.5t70.5 29.5h100q41 0 70.5 -29.5t29.5 -70.5v-1000h-300zM900 0v700q0 41 29.5 70.5t70.5 29.5h100q41 0 70.5 -29.5t29.5 -70.5v-700h-300z" />
-<glyph unicode="&#xe186;" d="M-100 300v500q0 124 88 212t212 88h700q124 0 212 -88t88 -212v-500q0 -124 -88 -212t-212 -88h-700q-124 0 -212 88t-88 212zM100 200h900v700h-900v-700zM200 300h300v300h-200v100h200v100h-300v-300h200v-100h-200v-100zM600 300h200v100h100v300h-100v100h-200v-500 zM700 400v300h100v-300h-100z" />
-<glyph unicode="&#xe187;" d="M-100 300v500q0 124 88 212t212 88h700q124 0 212 -88t88 -212v-500q0 -124 -88 -212t-212 -88h-700q-124 0 -212 88t-88 212zM100 200h900v700h-900v-700zM200 300h100v200h100v-200h100v500h-100v-200h-100v200h-100v-500zM600 300h200v100h100v300h-100v100h-200v-500 zM700 400v300h100v-300h-100z" />
-<glyph unicode="&#xe188;" d="M-100 300v500q0 124 88 212t212 88h700q124 0 212 -88t88 -212v-500q0 -124 -88 -212t-212 -88h-700q-124 0 -212 88t-88 212zM100 200h900v700h-900v-700zM200 300h300v100h-200v300h200v100h-300v-500zM600 300h300v100h-200v300h200v100h-300v-500z" />
-<glyph unicode="&#xe189;" d="M-100 300v500q0 124 88 212t212 88h700q124 0 212 -88t88 -212v-500q0 -124 -88 -212t-212 -88h-700q-124 0 -212 88t-88 212zM100 200h900v700h-900v-700zM200 550l300 -150v300zM600 400l300 150l-300 150v-300z" />
-<glyph unicode="&#xe190;" d="M-100 300v500q0 124 88 212t212 88h700q124 0 212 -88t88 -212v-500q0 -124 -88 -212t-212 -88h-700q-124 0 -212 88t-88 212zM100 200h900v700h-900v-700zM200 300v500h700v-500h-700zM300 400h130q41 0 68 42t27 107t-28.5 108t-66.5 43h-130v-300zM575 549 q0 -65 27 -107t68 -42h130v300h-130q-38 0 -66.5 -43t-28.5 -108z" />
-<glyph unicode="&#xe191;" d="M-100 300v500q0 124 88 212t212 88h700q124 0 212 -88t88 -212v-500q0 -124 -88 -212t-212 -88h-700q-124 0 -212 88t-88 212zM100 200h900v700h-900v-700zM200 300h300v300h-200v100h200v100h-300v-300h200v-100h-200v-100zM601 300h100v100h-100v-100zM700 700h100 v-400h100v500h-200v-100z" />
-<glyph unicode="&#xe192;" d="M-100 300v500q0 124 88 212t212 88h700q124 0 212 -88t88 -212v-500q0 -124 -88 -212t-212 -88h-700q-124 0 -212 88t-88 212zM100 200h900v700h-900v-700zM200 300h300v400h-200v100h-100v-500zM301 400v200h100v-200h-100zM601 300h100v100h-100v-100zM700 700h100 v-400h100v500h-200v-100z" />
-<glyph unicode="&#xe193;" d="M-100 300v500q0 124 88 212t212 88h700q124 0 212 -88t88 -212v-500q0 -124 -88 -212t-212 -88h-700q-124 0 -212 88t-88 212zM100 200h900v700h-900v-700zM200 700v100h300v-300h-99v-100h-100v100h99v200h-200zM201 300v100h100v-100h-100zM601 300v100h100v-100h-100z M700 700v100h200v-500h-100v400h-100z" />
-<glyph unicode="&#xe194;" d="M4 600q0 162 80 299t217 217t299 80t299 -80t217 -217t80 -299t-80 -299t-217 -217t-299 -80t-299 80t-217 217t-80 299zM186 600q0 -171 121.5 -292.5t292.5 -121.5t292.5 121.5t121.5 292.5t-121.5 292.5t-292.5 121.5t-292.5 -121.5t-121.5 -292.5zM400 500v200 l100 100h300v-100h-300v-200h300v-100h-300z" />
-<glyph unicode="&#xe195;" d="M0 600q0 162 80 299t217 217t299 80t299 -80t217 -217t80 -299t-80 -299t-217 -217t-299 -80t-299 80t-217 217t-80 299zM182 600q0 -171 121.5 -292.5t292.5 -121.5t292.5 121.5t121.5 292.5t-121.5 292.5t-292.5 121.5t-292.5 -121.5t-121.5 -292.5zM400 400v400h300 l100 -100v-100h-100v100h-200v-100h200v-100h-200v-100h-100zM700 400v100h100v-100h-100z" />
-<glyph unicode="&#xe197;" d="M-14 494q0 -80 56.5 -137t135.5 -57h222v300h400v-300h128q120 0 205 86.5t85 207.5t-85 207t-205 86q-46 0 -90 -14q-44 97 -134.5 156.5t-200.5 59.5q-152 0 -260 -107.5t-108 -260.5q0 -25 2 -37q-66 -14 -108.5 -67.5t-42.5 -122.5zM300 200h200v300h200v-300h200 l-300 -300z" />
-<glyph unicode="&#xe198;" d="M-14 494q0 -80 56.5 -137t135.5 -57h8l414 414l403 -403q94 26 154.5 104.5t60.5 178.5q0 120 -85 206.5t-205 86.5q-46 0 -90 -14q-44 97 -134.5 156.5t-200.5 59.5q-152 0 -260 -107.5t-108 -260.5q0 -25 2 -37q-66 -14 -108.5 -67.5t-42.5 -122.5zM300 200l300 300 l300 -300h-200v-300h-200v300h-200z" />
-<glyph unicode="&#xe199;" d="M100 200h400v-155l-75 -45h350l-75 45v155h400l-270 300h170l-270 300h170l-300 333l-300 -333h170l-270 -300h170z" />
-<glyph unicode="&#xe200;" d="M121 700q0 -53 28.5 -97t75.5 -65q-4 -16 -4 -38q0 -74 52.5 -126.5t126.5 -52.5q56 0 100 30v-306l-75 -45h350l-75 45v306q46 -30 100 -30q74 0 126.5 52.5t52.5 126.5q0 24 -9 55q50 32 79.5 83t29.5 112q0 90 -61.5 155.5t-150.5 71.5q-26 89 -99.5 145.5 t-167.5 56.5q-116 0 -197.5 -81.5t-81.5 -197.5q0 -4 1 -11.5t1 -11.5q-14 2 -23 2q-74 0 -126.5 -52.5t-52.5 -126.5z" />
-</font>
-</defs></svg> 

static/js/tabber.js

@@ -80,9 +80,11 @@
 
     };
 
-    // apply plugin to all available tab-groups
-    $('.tab-group').each(function(i, t) {
-      $(t).tabgroup();
-    })
+    // apply plugin to all available tab-groups if on wide screen
+    if (window.innerWidth > 768) {
+      $('.tab-group').each(function(i, t) {
+        $(t).tabgroup();
+      });
+    }
   });
 })($);

templates/adminTest.hamlet

@@ -0,0 +1,41 @@
+<div .container>
+  <h1>Uni2work - Admin Demopage
+
+  <p data-tooltip="Solch ein Tooltip kann mit dem <em>data-tooltip</em> Attribut erzeugt werden. Funktioniert aber nur in Block-Elementen die einen sinnvollen Wrapper haben.">
+    Diese interne Seite dient lediglich zum Testen diverser Funktionalitäten
+    und zur Demonstration der verschiedenen Hilfsfunktionen/Module.
+
+    Der Handler sollte jeweils aktuelle Beispiele für alle möglichen Funktionalitäten enthalten, so dass man immer weiß, wo man nachschlagen kann.
+
+
+<div .container.js-show-hide>
+  <h2 .js-show-hide__toggle>Teilweise funktionierende Abschnitte
+
+  <ul .js-show-hide__target>
+    <li .list-group-item>
+      <a href=@{UsersR}>Benutzer Verwaltung
+
+    <li .list-group-item>
+      <a href=@{TermShowR}>Semester Verwaltung
+      <a href=@{TermEditR}>Neues Semester anlegen
+
+    <li .list-group-item>
+      <a href=@{CourseNewR}>Kurse anlegen
+
+<hr>
+<div .container>
+  <h2>Funktionen zum Testen
+
+  <ul>
+    <li>
+      Knopf-Test:
+        <form .form-inline method=post action=@{AdminTestR} enctype=#{btnEnctype}>
+          ^{btnWdgt}
+    <li><br>
+      Modals:
+      ^{modal ".toggler1" Nothing}
+      <a href=@{UsersR} .btn.toggler1>Klick mich für Ajax-Test
+        <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/correction-user.hamlet

@@ -0,0 +1,39 @@
+<div .scrolltable>
+  <table .table .table--striped .table--hover .table--vertical>
+    <tr .table__row>
+      <th .table__th>_{MsgSubmission}
+      <td .table__td>#{display cid}
+    $maybe Entity _ User{..} <- corrector
+      <tr .table__row>
+        <th .table__th>_{MsgRatingBy}
+        <td .table__td>#{display userDisplayName}
+    $maybe time <- submissionRatingTime
+      <tr .table__row>
+        <th .table__th>_{MsgRatingTime}
+        <td .table__td>^{formatTimeW SelFormatDateTime time}
+    $maybe points <- submissionRatingPoints
+      $case sheetType
+        $of Bonus{..}
+          <tr .table__row>
+            <th .table__th>_{MsgAchievedBonusPoints}
+            <td .table__td>_{MsgAchievedOf points maxPoints}
+        $of Normal{..}
+          <tr .table__row>
+            <th .table__th>_{MsgAchievedNormalPoints}
+            <td .table__td>_{MsgAchievedOf points maxPoints}
+        $of Pass{..}
+          <tr .table__row>
+            <th .table__th>_{MsgPassedResult}
+            <td .table__td>
+              $if points >= passingPoints
+                _{MsgPassed}
+              $else
+                _{MsgNotPassed}
+          <tr .table__row>
+            <th .table__th>_{MsgAchievedPassPoints}
+            <td .table__td>_{MsgPassAchievedOf points passingPoints maxPoints}
+        $of NotGraded
+    $maybe comment <- ratingComment
+      <tr .table__row>
+        <th .table__th>_{MsgRatingComment}
+        <td .table__td style="white-space: pre;">#{comment}

templates/correction.hamlet

@@ -0,0 +1,11 @@
+^{userCorrection}
+
+<hr>
+  
+<form method=post enctype=#{corrEncoding}>
+  ^{corrForm}
+
+<hr>
+  
+<form method=post enctype=#{uploadEncoding}>
+  ^{uploadForm}

templates/corrections-upload.hamlet

@@ -0,0 +1,2 @@
+<form method=POST enctype=#{uploadEncoding}>
+  ^{upload}