fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into 'live'

Browse Source 
Master

Closes #164, #163, #162, #158, #77, #117, #159, #120, #151, #142, and #113

See merge request !71
This commit is contained in:
Gregor Kleen 2018-09-06 16:13:15 +02:00
commit 2afdb7e55b
56 changed files with 2054 additions and 1216 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.gitignore vendored
View File

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

4
ChangeLog.md
View File

@ -1,3 +1,7 @@
* Version 06.08.2016
Einführung einer Option, ob Dateien automatisch heruntergeladen werden sollen
* Version 01.08.2018 * Version 01.08.2018
Verbesserter Campus-Login Verbesserter Campus-Login

56
config/settings.yml
View File

@ -1,29 +1,26 @@
# Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable. # 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 # 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" static-dir: "_env:STATIC_DIR:static"
host: "_env:HOST:*4" # any IPv4 host 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" 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" 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"
auth-pwfile: "_env:PWFILE:"
allow-deprecated: "_env:ALLOW_DEPRECATED:false"
# Optional values with the following production defaults. # Optional values with the following production defaults.
# In development, they default to the inverse. # In development, they default to true.
#
detailed-logging: "_env:DETAILED_LOGGING:false"
should-log-all: "_env:LOG_ALL:false"
# reload-templates: false # reload-templates: false
# mutable-static: false # mutable-static: false
# skip-combining: false # skip-combining: false
auth-dummy-login: "_env:DUMMY_LOGIN:false"
auth-pwfile: "_env:PWFILE:"
allow-deprecated: "_env:ALLOW_DEPRECATED: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: database:
user: "_env:PGUSER:uniworx" user: "_env:PGUSER:uniworx"
@ -35,22 +32,21 @@ database:
poolsize: "_env:PGPOOLSIZE:10" poolsize: "_env:PGPOOLSIZE:10"
ldap: ldap:
host: "_env:LDAPHOST:" host: "_env:LDAPHOST:"
tls: "_env:LDAPTLS:" tls: "_env:LDAPTLS:"
port: "_env:LDAPPORT:389" port: "_env:LDAPPORT:389"
user: "_env:LDAPUSER:" user: "_env:LDAPUSER:"
pass: "_env:LDAPPASS:" pass: "_env:LDAPPASS:"
baseDN: "_env:LDAPBASE:" baseDN: "_env:LDAPBASE:"
scope: "_env:LDAPSCOPE:WholeSubtree" scope: "_env:LDAPSCOPE:WholeSubtree"
timeout: "_env:LDAPTIMEOUT:5" timeout: "_env:LDAPTIMEOUT:5"
default-favourites: 12 user-defaults:
default-theme: Default favourites: 12
default-date-time-format: "%a %d %b %Y %R" theme: Default
default-date-format: "%d.%m.%Y" date-time-format: "%a %d %b %Y %R"
default-time-format: "%R" date-format: "%d.%m.%Y"
time-format: "%R"
download-files: false
cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf" cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf"
copyright: ©Institute for Informatics, LMU Munich
#analytics: UA-YOURCODE

4
config/submission-blacklist
View File

@ -8,5 +8,5 @@ $# Ignoriere rekursiv alle Ordner __MACOSX und ihren Inhalt
**/__MACOSX/* **/__MACOSX/*
**/__MACOSX/**/* **/__MACOSX/**/*
$# Ignoriere rekursiv alle Dateien .DS_Store $# Ignoriere rekursiv alle Dateien .DS_Store (Mac OS)
**/.DS_Store **/.DS_Store

85
db.hs
View File

@ -18,16 +18,20 @@ import System.Console.GetOpt
import System.Exit (exitWith, ExitCode(..)) import System.Exit (exitWith, ExitCode(..))
import System.IO (hPutStrLn, stderr) import System.IO (hPutStrLn, stderr)
import qualified Data.ByteString as BS
import Data.Time import Data.Time
data DBAction = DBClear data DBAction = DBClear
| DBMigrate
| DBFill | DBFill
argsDescr :: [OptDescr DBAction] argsDescr :: [OptDescr DBAction]
argsDescr = argsDescr =
[ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user" [ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user"
, Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data" , Option ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration"
, Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data"
] ]
@ -36,19 +40,26 @@ main = do
args <- map unpack <$> getArgs args <- map unpack <$> getArgs
case getOpt Permute argsDescr args of case getOpt Permute argsDescr args of
(acts@(_:_), [], []) -> forM_ acts $ \case (acts@(_:_), [], []) -> forM_ acts $ \case
DBClear -> runStderrLoggingT $ do -- We don't use `db` here, since we do /not/ want any migrations to run, yet DBClear -> runStderrLoggingT $ do -- We don't use `db` here, since we do /not/ want any migrations to run, yet
settings <- liftIO getAppDevSettings settings <- liftIO getAppDevSettings
withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do
rawExecute "drop owned by current_user;" [] rawExecute "drop owned by current_user;" []
DBFill -> db $ fillDb DBMigrate -> db $ return ()
DBFill -> db $ fillDb
(_, _, errs) -> do (_, _, errs) -> do
forM_ errs $ hPutStrLn stderr forM_ errs $ hPutStrLn stderr
hPutStrLn stderr $ usageInfo "db.hs" argsDescr hPutStrLn stderr $ usageInfo "db.hs" argsDescr
exitWith $ ExitFailure 2 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 :: DB ()
fillDb = do fillDb = do
AppSettings{..} <- getsYesod appSettings AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod appSettings
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let let
summer2017 = TermIdentifier 2017 Summer summer2017 = TermIdentifier 2017 Summer
@ -61,10 +72,11 @@ fillDb = do
, userEmail = "G.Kleen@campus.lmu.de" , userEmail = "G.Kleen@campus.lmu.de"
, userDisplayName = "Gregor Kleen" , userDisplayName = "Gregor Kleen"
, userMaxFavourites = 6 , userMaxFavourites = 6
, userTheme = Default , userTheme = ThemeDefault
, userDateTimeFormat = appDefaultDateTimeFormat , userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = appDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = appDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
} }
fhamann <- insert User fhamann <- insert User
{ userPlugin = "LDAP" { userPlugin = "LDAP"
@ -72,11 +84,12 @@ fillDb = do
, userMatrikelnummer = Nothing , userMatrikelnummer = Nothing
, userEmail = "felix.hamann@campus.lmu.de" , userEmail = "felix.hamann@campus.lmu.de"
, userDisplayName = "Felix Hamann" , userDisplayName = "Felix Hamann"
, userMaxFavourites = appDefaultMaxFavourites , userMaxFavourites = userDefaultMaxFavourites
, userTheme = Default , userTheme = ThemeDefault
, userDateTimeFormat = appDefaultDateTimeFormat , userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = appDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = appDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
} }
jost <- insert User jost <- insert User
{ userPlugin = "LDAP" { userPlugin = "LDAP"
@ -85,10 +98,11 @@ fillDb = do
, userEmail = "jost@tcs.ifi.lmu.de" , userEmail = "jost@tcs.ifi.lmu.de"
, userDisplayName = "Steffen Jost" , userDisplayName = "Steffen Jost"
, userMaxFavourites = 14 , userMaxFavourites = 14
, userTheme = MossGreen , userTheme = ThemeMossGreen
, userDateTimeFormat = appDefaultDateTimeFormat , userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = appDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = appDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
} }
void . insert $ User void . insert $ User
{ userPlugin = "LDAP" { userPlugin = "LDAP"
@ -97,10 +111,11 @@ fillDb = do
, userEmail = "max@campus.lmu.de" , userEmail = "max@campus.lmu.de"
, userDisplayName = "Max Musterstudent" , userDisplayName = "Max Musterstudent"
, userMaxFavourites = 7 , userMaxFavourites = 7
, userTheme = AberdeenReds , userTheme = ThemeAberdeenReds
, userDateTimeFormat = appDefaultDateTimeFormat , userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = appDefaultDateFormat , userDateFormat = userDefaultDateFormat
, userTimeFormat = appDefaultTimeFormat , userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
} }
void . insert $ Term void . insert $ Term
{ termName = summer2017 { termName = summer2017
@ -229,10 +244,10 @@ fillDb = do
, courseDescription = Nothing , courseDescription = Nothing
, courseLinkExternal = Nothing , courseLinkExternal = Nothing
, courseShorthand = "ProMo" , courseShorthand = "ProMo"
, courseTerm = TermKey summer2017 , courseTerm = TermKey summer2018
, courseSchool = ifi , courseSchool = ifi
, courseCapacity = Just 50 , courseCapacity = Just 50
, courseRegisterFrom = Nothing , courseRegisterFrom = Just now
, courseRegisterTo = Nothing , courseRegisterTo = Nothing
, courseDeregisterUntil = Nothing , courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing , courseRegisterSecret = Nothing
@ -241,6 +256,28 @@ fillDb = do
insert_ $ CourseEdit jost now pmo insert_ $ CourseEdit jost now pmo
void . insert $ DegreeCourse pmo sdBsc sdInf void . insert $ DegreeCourse pmo sdBsc sdInf
void . insert $ Lecturer jost pmo 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
, 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 -- datenbanksysteme
dbs <- insert Course dbs <- insert Course
{ courseName = "Datenbanksysteme" { courseName = "Datenbanksysteme"

13
ghci.sh
View File

@ -5,4 +5,15 @@ export DETAILED_LOGGING=true
export LOG_ALL=true export LOG_ALL=true
export DUMMY_LOGIN=true export DUMMY_LOGIN=true
exec -- stack ghci --flag uniworx:dev --flag uniworx:library-only 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

53
messages/uniworx/de.msg
View File

@ -38,16 +38,18 @@ CourseRegisterOk: Sie wurden angemeldet
CourseDeregisterOk: Sie wurden abgemeldet CourseDeregisterOk: Sie wurden abgemeldet
CourseSecretWrong: Falsches Kennwort CourseSecretWrong: Falsches Kennwort
CourseSecret: Zugangspasswort CourseSecret: Zugangspasswort
CourseNewOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt. CourseNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich erstellt.
CourseEditOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich geändert. CourseEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich geändert.
CourseNewDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. CourseNewDupShort tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
CourseEditDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. CourseEditDupShort tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
FFSheetName: Name FFSheetName: Name
TermCourseListHeading tid@TermId: Kursübersicht #{display tid} TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{display school}
CourseListTitle: Alle Kurse CourseListTitle: Alle Kurse
TermCourseListTitle tid@TermId: Kurse #{display tid} TermCourseListTitle tid@TermId: Kurse #{display tid}
TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{display school}
CourseNewHeading: Neuen Kurs anlegen CourseNewHeading: Neuen Kurs anlegen
CourseEditHeading tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} editieren CourseEditHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} editieren
CourseEditTitle: Kurs editieren/anlegen CourseEditTitle: Kurs editieren/anlegen
CourseMembers: Teilnehmer CourseMembers: Teilnehmer
CourseMembersCount num@Int64: #{display num} CourseMembersCount num@Int64: #{display num}
@ -59,7 +61,8 @@ CourseHomepage: Homepage
CourseShorthand: Kürzel CourseShorthand: Kürzel
CourseShorthandUnique: Muss innerhalb des Semesters eindeutig sein CourseShorthandUnique: Muss innerhalb des Semesters eindeutig sein
CourseSemester: Semester CourseSemester: Semester
CourseSchool: Fachbereich CourseSchool: Institut
CourseSchoolShort: Fach
CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt
CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich
CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein
@ -67,17 +70,17 @@ CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
Sheet: Blatt Sheet: Blatt
SheetList tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Übersicht Übungsblätter SheetList tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Übersicht Übungsblätter
SheetNewHeading tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Neues Übungsblatt anlegen SheetNewHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Neues Übungsblatt anlegen
SheetNewOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{courseShortHand} erfolgreich erstellt. SheetNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{display ssh}-#{courseShortHand} erfolgreich erstellt.
SheetTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName} SheetTitle tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
SheetTitleNew tid@TermId courseShortHand@CourseShorthand : #{display tid}-#{courseShortHand}: Neues Übungsblatt SheetTitleNew tid@TermId ssh@SchoolId courseShortHand@CourseShorthand : #{display tid}-#{display ssh}-#{courseShortHand}: Neues Übungsblatt
SheetEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName} editieren SheetEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} editieren
SheetEditOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{courseShortHand} wurde gespeichert. SheetEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde gespeichert.
SheetNameDup tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{courseShortHand}. SheetNameDup tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{courseShortHand}.
SheetDelHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{courseShortHand} herauslöschen? SheetDelHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} herauslöschen?
SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben. 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 courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht. SheetDelOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht.
SheetExercise: Aufgabenstellung SheetExercise: Aufgabenstellung
SheetHint: Hinweis SheetHint: Hinweis
@ -110,12 +113,12 @@ Deadline: Abgabe
Done: Eingereicht Done: Eingereicht
Submission: Abgabenummer Submission: Abgabenummer
SubmissionsCourse tid@TermId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{courseShortHand} SubmissionsCourse tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{display ssh}-#{courseShortHand}
SubmissionsSheet sheetName@SheetName: Abgaben für Blatt #{sheetName} SubmissionsSheet sheetName@SheetName: Abgaben für #{sheetName}
SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt. SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
SubmissionEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen SubmissionEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
CorrectionHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{courseShortHand} #{sheetName}: Korrektur CorrectionHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Korrektur
SubmissionMember g@Int: Mitabgebende(r) ##{display g} SubmissionMember g@Int: Mitabgebende(r) ##{display g}
SubmissionArchive: Zip-Archiv der Abgabedatei(en) SubmissionArchive: Zip-Archiv der Abgabedatei(en)
SubmissionFile: Datei zur Abgabe SubmissionFile: Datei zur Abgabe
@ -155,10 +158,11 @@ TooManyParticipants: Es wurden zu viele Mitabgebende angegeben
AddCorrector: Zusätzlicher Korrektor AddCorrector: Zusätzlicher Korrektor
CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
SheetCorrectorsTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{courseShortHand} #{sheetName} SheetCorrectorsTitle tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
CountTutProp: Tutorien zählen gegen Proportion CountTutProp: Tutorien zählen gegen Proportion
Corrector: Korrektor Corrector: Korrektor
Correctors: Korrektoren Correctors: Korrektoren
CorState: Status
CorByTut: Nach Tutorium CorByTut: Nach Tutorium
CorProportion: Anteil CorProportion: Anteil
DeleteRow: Zeile entfernen DeleteRow: Zeile entfernen
@ -247,9 +251,12 @@ UserListTitle: Komprehensive Benutzerliste
DateTimeFormat: Datums- und Uhrzeitformat DateTimeFormat: Datums- und Uhrzeitformat
DateFormat: Datumsformat DateFormat: Datumsformat
TimeFormat: Uhrzeitformat 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 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 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 LastEdits: Letzte Änderungen
EditedBy name@Text time@Text: Durch #{name} um #{time} EditedBy name@Text time@Text: Durch #{name} um #{time}
@ -260,3 +267,7 @@ SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe
LDAPLoginTitle: Campus-Login LDAPLoginTitle: Campus-Login
DummyLoginTitle: Development-Login DummyLoginTitle: Development-Login
CorrectorNormal: Normal
CorrectorMissing: Abwesend
CorrectorExcused: Entschuldigt

9
models
View File

@ -9,6 +9,7 @@ User json
dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'"
dateFormat DateTimeFormat "default='%d.%m.%Y'" dateFormat DateTimeFormat "default='%d.%m.%Y'"
timeFormat DateTimeFormat "default='%R'" timeFormat DateTimeFormat "default='%R'"
downloadFiles Bool default=false
UniqueAuthentication plugin ident UniqueAuthentication plugin ident
UniqueEmail email UniqueEmail email
deriving Show deriving Show
@ -51,7 +52,8 @@ School json
name (CI Text) name (CI Text)
shorthand (CI Text) shorthand (CI Text)
UniqueSchool name UniqueSchool name
UniqueSchoolShorthand shorthand UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
Primary shorthand -- newtype Key School = School { unSchoolKey :: SchoolShorthand }
deriving Eq deriving Eq
DegreeCourse json DegreeCourse json
course CourseId course CourseId
@ -72,8 +74,8 @@ Course
deregisterUntil UTCTime Maybe deregisterUntil UTCTime Maybe
registerSecret Text Maybe -- Falls ein Passwort erforderlich ist registerSecret Text Maybe -- Falls ein Passwort erforderlich ist
materialFree Bool materialFree Bool
CourseTermShort term shorthand TermSchoolCourseShort term school shorthand
CourseTermName term name TermSchoolCourseName term school name
CourseEdit CourseEdit
user UserId user UserId
time UTCTime time UTCTime
@ -114,6 +116,7 @@ SheetCorrector
user UserId user UserId
sheet SheetId sheet SheetId
load Load load Load
state CorrectorState default='CorrectorNormal'
UniqueSheetCorrector user sheet UniqueSheetCorrector user sheet
deriving Show Eq Ord deriving Show Eq Ord
SheetFile SheetFile

6
package.yaml
View File

@ -20,7 +20,7 @@ dependencies:
- classy-prelude-conduit >=0.10.2 - classy-prelude-conduit >=0.10.2
- bytestring >=0.9 && <0.11 - bytestring >=0.9 && <0.11
- text >=0.11 && <2.0 - text >=0.11 && <2.0
- persistent >=2.0 && <2.8 - persistent >=2.7.2 && <2.8
- persistent-postgresql >=2.1.1 && <2.8 - persistent-postgresql >=2.1.1 && <2.8
- persistent-template >=2.0 && <2.8 - persistent-template >=2.0 && <2.8
- template-haskell - template-haskell
@ -88,6 +88,10 @@ dependencies:
- Glob - Glob
- ldap-client - ldap-client
- connection - connection
- universe
- universe-base
- random-shuffle
- th-abstraction
# The library contains all of our application code. The executable # The library contains all of our application code. The executable
# defined below is just a thin wrapper. # defined below is just a thin wrapper.

4
routes
View File

@ -46,11 +46,13 @@
/terms/edit TermEditR GET POST /terms/edit TermEditR GET POST
/terms/#TermId/edit TermEditExistR GET /terms/#TermId/edit TermEditExistR GET
!/terms/#TermId TermCourseListR GET !free !/terms/#TermId TermCourseListR GET !free
!/terms/#TermId/#SchoolId TermSchoolCourseListR GET !free
-- For Pattern Synonyms see Foundation -- For Pattern Synonyms see Foundation
/course/ CourseListR GET !free /course/ CourseListR GET !free
!/course/new CourseNewR GET POST !lecturer !/course/new CourseNewR GET POST !lecturer
/course/#TermId/#CourseShorthand CourseR !lecturer: /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
/ CShowR GET !free / CShowR GET !free
/register CRegisterR POST !timeANDcapacity /register CRegisterR POST !timeANDcapacity
/edit CEditR GET POST /edit CEditR GET POST

2
src/Application.hs
View File

@ -98,7 +98,7 @@ makeFoundation appSettings@(AppSettings{..}) = do
(pgPoolSize appDatabaseConf) (pgPoolSize appDatabaseConf)
-- Perform database migration using our application's logging settings. -- Perform database migration using our application's logging settings.
runLoggingT (runSqlPool (runMigration $ migrateAll) pool) logFunc runLoggingT (runSqlPool migrateAll pool) logFunc
-- Return the foundation -- Return the foundation
return $ mkFoundation pool return $ mkFoundation pool

20
src/CryptoID.hs
View File

@ -27,35 +27,17 @@ import System.FilePath.Cryptographic.ImplicitNamespace
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.UUID.Types -- import Data.UUID.Types
import Web.PathPieces import Web.PathPieces
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
instance PathPiece UUID where
fromPathPiece = 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
-- Generates CryptoUUID... and CryptoFileName... Datatypes -- Generates CryptoUUID... and CryptoFileName... Datatypes
decCryptoIDs [ ''SubmissionId decCryptoIDs [ ''SubmissionId
, ''FileId , ''FileId
, ''UserId , ''UserId
, ''CourseId
] ]
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where

56
src/Data/CaseInsensitive/Instances.hs Normal file
View File

@ -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

291
src/Foundation.hs
View File

@ -97,6 +97,8 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission
instance DisplayAble TermId where instance DisplayAble TermId where
display = termToText . unTermKey display = termToText . unTermKey
instance DisplayAble SchoolId where
display = CI.original . unSchoolKey
-- infixl 9 :$: -- infixl 9 :$:
-- pattern a :$: b = a b -- pattern a :$: b = a b
@ -124,8 +126,8 @@ data UniWorX = UniWorX
-- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules -- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules
-- --
-- This function also generates the following type synonyms: -- This function also generates the following type synonyms:
-- type Handler = HandlerT UniWorX IO -- type Handler x = HandlerT UniWorX IO x
-- type Widget = WidgetT UniWorX IO () -- type Widget = WidgetT UniWorX IO ()
mkYesodData "UniWorX" $(parseRoutesFile "routes") mkYesodData "UniWorX" $(parseRoutesFile "routes")
-- | Convenient Type Synonyms: -- | Convenient Type Synonyms:
@ -134,11 +136,11 @@ type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
type MsgRenderer = MsgRendererS UniWorX -- see Utils type MsgRenderer = MsgRendererS UniWorX -- see Utils
-- Pattern Synonyms for convenience -- Pattern Synonyms for convenience
pattern CSheetR tid csh shn ptn pattern CSheetR tid ssh csh shn ptn
= CourseR tid csh (SheetR shn ptn) = CourseR tid ssh csh (SheetR shn ptn)
pattern CSubmissionR tid csh shn cid ptn pattern CSubmissionR tid ssh csh shn cid ptn
= CSheetR tid csh shn (SubmissionR cid ptn) = CSheetR tid ssh csh shn (SubmissionR cid ptn)
-- Menus and Favourites -- Menus and Favourites
data MenuItem = MenuItem data MenuItem = MenuItem
@ -159,7 +161,7 @@ data MenuTypes -- Semantische Rolle:
| NavbarRight { menuItem :: MenuItem } -- Generell, nahezu immer sichtbar | NavbarRight { menuItem :: MenuItem } -- Generell, nahezu immer sichtbar
| NavbarSecondary { menuItem :: MenuItem } -- Generell, nahezu immer sichtbar | NavbarSecondary { menuItem :: MenuItem } -- Generell, nahezu immer sichtbar
| PageActionPrime { menuItem :: MenuItem } -- Seitenspezifische Aktion, häufig | PageActionPrime { menuItem :: MenuItem } -- Seitenspezifische Aktion, häufig
| PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten | PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten (nicht im MouseOver enthalten, immer hinten gelistet)
-- Messages -- Messages
mkMessage "UniWorX" "messages/uniworx" "de" mkMessage "UniWorX" "messages/uniworx" "de"
@ -196,6 +198,13 @@ instance RenderMessage UniWorX SheetFileType where
SheetMarking -> renderMessage' MsgSheetMarking SheetMarking -> renderMessage' MsgSheetMarking
where renderMessage' = renderMessage foundation ls where renderMessage' = renderMessage foundation ls
instance RenderMessage UniWorX CorrectorState where
renderMessage foundation ls = \case
CorrectorNormal -> renderMessage' MsgCorrectorNormal
CorrectorMissing -> renderMessage' MsgCorrectorMissing
CorrectorExcused -> renderMessage' MsgCorrectorExcused
where renderMessage' = renderMessage foundation ls
instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route) renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
@ -260,12 +269,13 @@ falseAP = APPure . const . const $ Unauthorized . ($ MsgUnauthorized) . render <
adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes) adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes)
adminAP = APDB $ \route _ -> case route of adminAP = APDB $ \route _ -> case route of
-- Courses: access only to school admins -- Courses: access only to school admins
CourseR tid csh _ -> exceptT return return $ do CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64)) return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
@ -288,12 +298,13 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
return $ bool (Unauthorized "Deprecated Route") Authorized allow return $ bool (Unauthorized "Deprecated Route") Authorized allow
) )
,("lecturer", APDB $ \route _ -> case route of ,("lecturer", APDB $ \route _ -> case route of
CourseR tid csh _ -> exceptT return return $ do CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64)) return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer) guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
@ -314,18 +325,18 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
resMap :: Map CourseId (Set SheetId) resMap :: Map CourseId (Set SheetId)
resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
case route of case route of
CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
Submission{..} <- MaybeT . lift $ get sid Submission{..} <- MaybeT . lift $ get sid
guard $ maybe False (== authId) submissionRatingBy guard $ maybe False (== authId) submissionRatingBy
return Authorized return Authorized
CSheetR tid csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
return Authorized return Authorized
CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
guard $ cid `Set.member` Map.keysSet resMap guard $ cid `Set.member` Map.keysSet resMap
return Authorized return Authorized
_ -> do _ -> do
@ -333,8 +344,8 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
return Authorized return Authorized
) )
,("time", APDB $ \route _ -> case route of ,("time", APDB $ \route _ -> case route of
CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
cTime <- liftIO getCurrentTime cTime <- liftIO getCurrentTime
let let
@ -352,18 +363,9 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
_ -> return () _ -> return ()
return Authorized return Authorized
let started = sheetActiveFrom <= cTime || NTop sheetVisibleFrom <= (NTop $ Just cTime)
case subRoute of
SFileR SheetExercise _ -> guard started
SFileR SheetMarking _ -> mzero -- only for correctors and lecturers
SubmissionNewR -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
SubmissionR _ _ -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
_ -> guard started
return Authorized
CourseR tid csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
cTime <- (NTop . Just) <$> liftIO getCurrentTime cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop courseRegisterFrom <= cTime guard $ NTop courseRegisterFrom <= cTime
&& NTop courseRegisterTo >= cTime && NTop courseRegisterTo >= cTime
@ -372,12 +374,13 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
r -> $unsupportedAuthPredicate "time" r r -> $unsupportedAuthPredicate "time" r
) )
,("registered", APDB $ \route _ -> case route of ,("registered", APDB $ \route _ -> case route of
CourseR tid csh _ -> exceptT return return $ do CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64)) return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
@ -385,22 +388,22 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
r -> $unsupportedAuthPredicate "registered" r r -> $unsupportedAuthPredicate "registered" r
) )
,("capacity", APDB $ \route _ -> case route of ,("capacity", APDB $ \route _ -> case route of
CourseR tid csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
guard $ NTop courseCapacity > NTop (Just registered) guard $ NTop courseCapacity > NTop (Just registered)
return Authorized return Authorized
r -> $unsupportedAuthPredicate "capacity" r r -> $unsupportedAuthPredicate "capacity" r
) )
,("materials", APDB $ \route _ -> case route of ,("materials", APDB $ \route _ -> case route of
CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
guard courseMaterialFree guard courseMaterialFree
return Authorized return Authorized
r -> $unsupportedAuthPredicate "materials" r r -> $unsupportedAuthPredicate "materials" r
) )
,("owner", APDB $ \route _ -> case route of ,("owner", APDB $ \route _ -> case route of
CSubmissionR _ _ _ cID _ -> exceptT return return $ do CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
@ -408,7 +411,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
r -> $unsupportedAuthPredicate "owner" r r -> $unsupportedAuthPredicate "owner" r
) )
,("rated", APDB $ \route _ -> case route of ,("rated", APDB $ \route _ -> case route of
CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
sub <- MaybeT $ get sid sub <- MaybeT $ get sid
guard $ submissionRatingDone sub guard $ submissionRatingDone sub
@ -478,14 +481,14 @@ instance Yesod UniWorX where
updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
route <- MaybeT getCurrentRoute route <- MaybeT getCurrentRoute
case route of -- update Course Favourites here case route of -- update Course Favourites here
CourseR tid csh _ -> do CourseR tid ssh csh _ -> do
void . lift . runDB . runMaybeT $ do void . lift . runDB . runMaybeT $ do
guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid csh CShowR) False guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False
$logDebugS "updateFavourites" "Updating favourites" $logDebugS "updateFavourites" "Updating favourites"
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
uid <- MaybeT $ liftHandlerT maybeAuthId uid <- MaybeT $ liftHandlerT maybeAuthId
cid <- MaybeT . getKeyBy $ CourseTermShort tid csh cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
user <- MaybeT $ get uid user <- MaybeT $ get uid
let courseFavourite = CourseFavourite uid now cid let courseFavourite = CourseFavourite uid now cid
@ -515,6 +518,7 @@ instance Yesod UniWorX where
defaultLayout widget = do defaultLayout widget = do
master <- getYesod master <- getYesod
let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master
mmsgs <- getMessages mmsgs <- getMessages
mcurrentRoute <- getCurrentRoute mcurrentRoute <- getCurrentRoute
@ -525,19 +529,17 @@ instance Yesod UniWorX where
-- let isParent :: Route UniWorX -> Bool -- let isParent :: Route UniWorX -> Bool
-- isParent r = r == (fst parents) -- isParent r = r == (fst parents)
let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute
let
menu = defaultLinks ++ maybe [] pageActions mcurrentRoute
menuTypes <- filterM (menuItemAccessCallback . menuItem) menu menuTypes <- filterM (menuItemAccessCallback . menuItem) menu
isAuth <- isJust <$> maybeAuthId isAuth <- isJust <$> maybeAuthId
-- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?! -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?!
(favourites',show -> currentTheme) <- do (favourites', currentTheme) <- do
muid <- maybeAuthPair muid <- maybeAuthPair
case muid of case muid of
Nothing -> return ([],Default) Nothing -> return ([],userDefaultTheme)
(Just (uid,user)) -> do (Just (uid,user)) -> do
favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do
E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse)
@ -547,7 +549,7 @@ instance Yesod UniWorX where
return (favs, userTheme user) return (favs, userTheme user)
favourites <- forM favourites' $ \(Entity _ c@Course{..}) favourites <- forM favourites' $ \(Entity _ c@Course{..})
-> let -> let
courseRoute = CourseR courseTerm courseShorthand CShowR courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute) in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
@ -577,10 +579,11 @@ instance Yesod UniWorX where
breadcrumbs :: Widget breadcrumbs :: Widget
breadcrumbs = $(widgetFile "widgets/breadcrumbs") breadcrumbs = $(widgetFile "widgets/breadcrumbs")
pageactionprime :: Widget pageactionprime :: Widget
pageactionprime = $(widgetFile "widgets/pageactionprime") pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now
-- functions to determine if there are page-actions -- functions to determine if there are page-actions (primary or secondary)
isPageActionPrime :: MenuTypes -> Bool isPageActionPrime :: MenuTypes -> Bool
isPageActionPrime (PageActionPrime _) = True isPageActionPrime (PageActionPrime _) = True
isPageActionPrime (PageActionSecondary _) = True
isPageActionPrime _ = False isPageActionPrime _ = False
hasPageActions :: Bool hasPageActions :: Bool
hasPageActions = any isPageActionPrime menuTypes hasPageActions = any isPageActionPrime menuTypes
@ -644,10 +647,7 @@ instance Yesod UniWorX where
-- What messages should be logged. The following includes all messages when -- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production. -- in development, and warnings and errors in production.
shouldLog app _source level = shouldLog app _source level = appShouldLogAll (appSettings app) || level >= appMinimumLogLevel (appSettings app)
appShouldLogAll (appSettings app)
|| level == LevelWarn
|| level == LevelError
makeLogger = return . appLogger makeLogger = return . appLogger
@ -670,27 +670,29 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid) breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid)
breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR) breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR)
breadcrumb (TermSchoolCourseListR tid ssh) = return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid)
breadcrumb CourseListR = return ("Kurse" , Just HomeR) breadcrumb CourseListR = return ("Kurse" , Just HomeR)
breadcrumb CourseNewR = return ("Neu" , Just CourseListR) breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
breadcrumb (CourseR tid csh CShowR) = return (CI.original csh, Just $ TermCourseListR tid) breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ TermSchoolCourseListR tid ssh)
-- (CourseR tid csh CRegisterR) -- is POST only -- (CourseR tid ssh csh CRegisterR) -- is POST only
breadcrumb (CourseR tid csh CEditR) = return ("Editieren", Just $ CourseR tid csh CShowR) breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren", Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid csh CShowR) breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid csh SheetListR) = return ("Übungen" , Just $ CourseR tid csh CShowR) breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR) breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR)
breadcrumb (CSheetR tid csh shn SShowR) = return (CI.original shn, Just $ CourseR tid csh SheetListR) breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSubmissionR tid csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSubmissionR tid ssh csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
-- (CSubmissionR tid csh shn _ SubArchiveR) -- just for Download -- (CSubmissionR tid ssh csh shn _ SubArchiveR) -- just for Download
breadcrumb (CSubmissionR tid csh shn cid CorrectionR) = return ("Korrektur", Just $ CSubmissionR tid csh shn cid SubShowR) breadcrumb (CSubmissionR tid ssh csh shn cid CorrectionR) = return ("Korrektur", Just $ CSubmissionR tid ssh csh shn cid SubShowR)
-- (CSubmissionR tid csh shn _ SubDownloadR) -- just for Download -- (CSubmissionR tid ssh csh shn _ SubDownloadR) -- just for Download
breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid ssh csh shn SShowR)
-- (CSheetR tid csh shn SFileR) -- just for Downloads -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads
-- Others -- Others
breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR) breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR)
breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR) breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR)
@ -769,6 +771,7 @@ defaultLinks = -- Define the menu items of the header.
} }
] ]
pageActions :: Route UniWorX -> [MenuTypes] pageActions :: Route UniWorX -> [MenuTypes]
{- {-
Icons: https://fontawesome.com/icons?d=gallery Icons: https://fontawesome.com/icons?d=gallery
@ -830,22 +833,22 @@ pageActions (CourseListR) =
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CourseR tid csh CShowR) = pageActions (CourseR tid ssh csh CShowR) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Kurs Editieren" { menuItemLabel = "Kurs Editieren"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh CEditR , menuItemRoute = CourseR tid ssh csh CEditR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , PageActionPrime $ MenuItem
{ menuItemLabel = "Übungsblätter" { menuItemLabel = "Übungsblätter"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh SheetListR , menuItemRoute = CourseR tid ssh csh SheetListR
, menuItemAccessCallback' = do --TODO always show for lecturer , menuItemAccessCallback' = do --TODO always show for lecturer
let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid csh shn SShowR) False) let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False)
muid <- maybeAuthId muid <- maybeAuthId
(sheets,lecturer) <- runDB $ do (sheets,lecturer) <- runDB $ do
cid <- getKeyBy404 $ CourseTermShort tid csh cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom] sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
lecturer <- case muid of lecturer <- case muid of
Nothing -> return False Nothing -> return False
@ -856,29 +859,29 @@ pageActions (CourseR tid csh CShowR) =
, PageActionPrime $ MenuItem , PageActionPrime $ MenuItem
{ menuItemLabel = "Abgaben" { menuItemLabel = "Abgaben"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh CCorrectionsR , menuItemRoute = CourseR tid ssh csh CCorrectionsR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionSecondary $ MenuItem , PageActionSecondary $ MenuItem
{ menuItemLabel = "Neues Übungsblatt anlegen" { menuItemLabel = "Neues Übungsblatt anlegen"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh SheetNewR , menuItemRoute = CourseR tid ssh csh SheetNewR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CourseR tid csh SheetListR) = pageActions (CourseR tid ssh csh SheetListR) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Neues Übungsblatt anlegen" { menuItemLabel = "Neues Übungsblatt anlegen"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh SheetNewR , menuItemRoute = CourseR tid ssh csh SheetNewR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CSheetR tid csh shn SShowR) = pageActions (CSheetR tid ssh csh shn SShowR) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Abgabe anlegen" { menuItemLabel = "Abgabe anlegen"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SubmissionNewR , menuItemRoute = CSheetR tid ssh csh shn SubmissionNewR
, menuItemAccessCallback' = runDB . maybeT (return False) $ do , menuItemAccessCallback' = runDB . maybeT (return False) $ do
uid <- MaybeT $ liftHandlerT maybeAuthId uid <- MaybeT $ liftHandlerT maybeAuthId
submissions <- lift $ submissionList tid csh shn uid submissions <- lift $ submissionList tid csh shn uid
@ -888,7 +891,7 @@ pageActions (CSheetR tid csh shn SShowR) =
, PageActionPrime $ MenuItem , PageActionPrime $ MenuItem
{ menuItemLabel = "Abgabe ansehen" { menuItemLabel = "Abgabe ansehen"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SubmissionOwnR , menuItemRoute = CSheetR tid ssh csh shn SubmissionOwnR
, menuItemAccessCallback' = runDB . maybeT (return False) $ do , menuItemAccessCallback' = runDB . maybeT (return False) $ do
uid <- MaybeT $ liftHandlerT maybeAuthId uid <- MaybeT $ liftHandlerT maybeAuthId
submissions <- lift $ submissionList tid csh shn uid submissions <- lift $ submissionList tid csh shn uid
@ -898,35 +901,49 @@ pageActions (CSheetR tid csh shn SShowR) =
, PageActionPrime $ MenuItem , PageActionPrime $ MenuItem
{ menuItemLabel = "Korrektoren" { menuItemLabel = "Korrektoren"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SCorrR , menuItemRoute = CSheetR tid ssh csh shn SCorrR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , PageActionPrime $ MenuItem
{ menuItemLabel = "Abgaben" { menuItemLabel = "Abgaben"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SSubsR , menuItemRoute = CSheetR tid ssh csh shn SSubsR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , PageActionPrime $ MenuItem
{ menuItemLabel = "Blatt Editieren" { menuItemLabel = "Blatt Editieren"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SEditR , menuItemRoute = CSheetR tid ssh csh shn SEditR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CSubmissionR tid csh shn cid SubShowR) = pageActions (CSheetR tid ssh csh shn SSubsR) =
[ PageActionPrime $ MenuItem
{ menuItemLabel = "Korrektoren"
, menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SCorrR
, menuItemAccessCallback' = return True
}
]
pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Korrektur" { menuItemLabel = "Korrektur"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSubmissionR tid csh shn cid CorrectionR , menuItemRoute = CSubmissionR tid ssh csh shn cid CorrectionR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CSheetR tid csh shn SCorrR) = pageActions (CSheetR tid ssh csh shn SCorrR) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Abgaben" { menuItemLabel = "Abgaben"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SSubsR , menuItemRoute = CSheetR tid ssh csh shn SSubsR
, menuItemAccessCallback' = return True
}
, PageActionSecondary $ MenuItem
{ menuItemLabel = "Edit " <> (CI.original shn)
, menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SEditR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
@ -973,45 +990,49 @@ pageHeading (TermEditExistR tid)
= Just $ i18nHeading $ MsgTermEditTid tid = Just $ i18nHeading $ MsgTermEditTid tid
pageHeading (TermCourseListR tid) pageHeading (TermCourseListR tid)
= Just . i18nHeading . MsgTermCourseListHeading $ tid = Just . i18nHeading . MsgTermCourseListHeading $ tid
pageHeading (TermSchoolCourseListR tid ssh)
= Just $ do
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
i18nHeading $ MsgTermSchoolCourseListHeading tid school
pageHeading (CourseListR) pageHeading (CourseListR)
= Just $ i18nHeading $ MsgCourseListTitle = Just $ i18nHeading $ MsgCourseListTitle
pageHeading CourseNewR pageHeading CourseNewR
= Just $ i18nHeading MsgCourseNewHeading = Just $ i18nHeading MsgCourseNewHeading
pageHeading (CourseR tid csh CShowR) pageHeading (CourseR tid ssh csh CShowR)
= Just $ do = Just $ do
Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ CourseTermShort tid csh Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
toWidget courseName toWidget courseName
-- (CourseR tid csh CRegisterR) -- just for POST -- (CourseR tid csh CRegisterR) -- just for POST
pageHeading (CourseR tid csh CEditR) pageHeading (CourseR tid ssh csh CEditR)
= Just $ i18nHeading $ MsgCourseEditHeading tid csh = Just $ i18nHeading $ MsgCourseEditHeading tid ssh csh
pageHeading (CourseR tid csh CCorrectionsR) pageHeading (CourseR tid ssh csh CCorrectionsR)
= Just $ i18nHeading $ MsgSubmissionsCourse tid csh = Just $ i18nHeading $ MsgSubmissionsCourse tid ssh csh
pageHeading (CourseR tid csh SheetListR) pageHeading (CourseR tid ssh csh SheetListR)
= Just $ i18nHeading $ MsgSheetList tid csh = Just $ i18nHeading $ MsgSheetList tid ssh csh
pageHeading (CourseR tid csh SheetNewR) pageHeading (CourseR tid ssh csh SheetNewR)
= Just $ i18nHeading $ MsgSheetNewHeading tid csh = Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh
pageHeading (CSheetR tid csh shn SShowR) pageHeading (CSheetR tid ssh csh shn SShowR)
= Just $ i18nHeading $ MsgSheetTitle tid csh shn = Just $ i18nHeading $ MsgSheetTitle tid ssh csh shn
pageHeading (CSheetR tid csh shn SEditR) pageHeading (CSheetR tid ssh csh shn SEditR)
= Just $ i18nHeading $ MsgSheetEditHead tid csh shn = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn
pageHeading (CSheetR tid csh shn SDelR) pageHeading (CSheetR tid ssh csh shn SDelR)
= Just $ i18nHeading $ MsgSheetDelHead tid csh shn = Just $ i18nHeading $ MsgSheetDelHead tid ssh csh shn
pageHeading (CSheetR tid csh shn SSubsR) pageHeading (CSheetR tid ssh csh shn SSubsR)
= Just $ i18nHeading $ MsgSubmissionsSheet shn = Just $ i18nHeading $ MsgSubmissionsSheet shn
pageHeading (CSheetR tid csh shn SubmissionNewR) pageHeading (CSheetR tid ssh csh shn SubmissionNewR)
= Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
pageHeading (CSheetR tid csh shn SubmissionOwnR) pageHeading (CSheetR tid ssh csh shn SubmissionOwnR)
= Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
pageHeading (CSubmissionR tid csh shn _ SubShowR) -- TODO: Rethink this one! pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one!
= Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
-- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download -- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download
pageHeading (CSubmissionR tid csh shn cid CorrectionR) pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR)
= Just $ i18nHeading $ MsgCorrectionHead tid csh shn cid = Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid
-- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download -- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download
pageHeading (CSheetR tid csh shn SCorrR) pageHeading (CSheetR tid ssh csh shn SCorrR)
= Just $ i18nHeading $ MsgCorrectorsHead shn = Just $ i18nHeading $ MsgCorrectorsHead shn
-- (CSheetR tid csh shn SFileR) -- just for Downloads -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads
pageHeading CorrectionsR pageHeading CorrectionsR
= Just $ i18nHeading MsgCorrectionsTitle = Just $ i18nHeading MsgCorrectionsTitle
@ -1026,6 +1047,7 @@ pageHeading _
routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)] routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)]
routeNormalizers = routeNormalizers =
[ normalizeRender [ normalizeRender
, ncSchool
, ncCourse , ncCourse
, ncSheet , ncSheet
] ]
@ -1046,17 +1068,25 @@ routeNormalizers =
$logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|] $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
tell $ Any True tell $ Any True
| otherwise = return () | otherwise = return ()
ncSchool = maybeOrig $ \route -> do
TermSchoolCourseListR tid ssh <- return route
let schoolShort :: SchoolShorthand
schoolShort = unSchoolKey ssh
Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
(hasChanged `on` unSchoolKey)ssh ssh'
return $ TermSchoolCourseListR tid ssh'
ncCourse = maybeOrig $ \route -> do ncCourse = maybeOrig $ \route -> do
CourseR tid csh subRoute <- return route CourseR tid ssh csh subRoute <- return route
Entity _ Course{..} <- MaybeT . lift . getBy $ CourseTermShort tid csh Entity _ Course{..} <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
hasChanged csh courseShorthand hasChanged csh courseShorthand
return $ CourseR tid courseShorthand subRoute (hasChanged `on` unSchoolKey) ssh courseSchool
return $ CourseR tid courseSchool courseShorthand subRoute
ncSheet = maybeOrig $ \route -> do ncSheet = maybeOrig $ \route -> do
CSheetR tid csh shn subRoute <- return route CSheetR tid ssh csh shn subRoute <- return route
Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
hasChanged shn sheetName hasChanged shn sheetName
return $ CSheetR tid csh sheetName subRoute return $ CSheetR tid ssh csh sheetName subRoute
-- How to run database actions. -- How to run database actions.
@ -1120,7 +1150,7 @@ instance YesodAuth UniWorX where
acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
$logDebugS "auth" $ tshow Creds{..} $logDebugS "auth" $ tshow Creds{..}
AppSettings{..} <- getsYesod appSettings AppSettings{ appUserDefaults = UserDefaultConf{..}, ..} <- getsYesod appSettings
flip catches excHandlers $ case appLdapConf of flip catches excHandlers $ case appLdapConf of
Just ldapConf -> fmap (either id id) . runExceptT $ do Just ldapConf -> fmap (either id id) . runExceptT $ do
@ -1154,12 +1184,15 @@ instance YesodAuth UniWorX where
-> throwError $ ServerError "Could not decode user matriculation" -> throwError $ ServerError "Could not decode user matriculation"
let let
userMaxFavourites = appDefaultMaxFavourites newUser = User
userTheme = appDefaultTheme { userMaxFavourites = userDefaultMaxFavourites
userDateTimeFormat = appDefaultDateTimeFormat , userTheme = userDefaultTheme
userDateFormat = appDefaultDateFormat , userDateTimeFormat = userDefaultDateTimeFormat
userTimeFormat = appDefaultTimeFormat , userDateFormat = userDefaultDateFormat
newUser = User{..} , userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, ..
}
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
, UserDisplayName =. userDisplayName , UserDisplayName =. userDisplayName
, UserEmail =. userEmail , UserEmail =. userEmail

80
src/Handler/Corrections.hs
View File

@ -86,33 +86,36 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse) colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(_, _, course, _, _) } -> $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
let tid = course ^. _3 let csh = course ^. _2
csh = course ^. _2 tid = course ^. _3
in anchorCell (CourseR tid csh CShowR) [whamlet|#{display csh}|] ssh = course ^. _4
in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|]
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSheet = sortable (Just "sheet") (i18nCell MsgSheet) colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
$ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } ->
let tid = course ^. _3 let csh = course ^. _2
csh = course ^. _2 tid = course ^. _3
ssh = course ^. _4
shn = sheetName $ entityVal sheet shn = sheetName $ entityVal sheet
in anchorCell (CSheetR tid csh shn SShowR) [whamlet|#{display shn}|] in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|]
colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
DBRow{ dbrOutput = (_, _, _, Nothing, _) } -> cell mempty DBRow{ dbrOutput = (_, _, _, Nothing , _) } -> cell mempty
DBRow{ dbrOutput = (_, _, _, Just corr, _) } -> textCell . display . userDisplayName $ entityVal corr DBRow{ dbrOutput = (_, _, _, Just corr, _) } -> textCell . display . userDisplayName $ entityVal corr
colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
$ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } ->
let tid = course ^. _3 let csh = course ^. _2
csh = course ^. _2 tid = course ^. _3
ssh = course ^. _4
shn = sheetName $ entityVal sheet shn = sheetName $ entityVal sheet
mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice
mkRoute = do mkRoute = do
cid <- mkCid cid <- mkCid
return $ CSubmissionR tid csh shn cid SubShowR return $ CSubmissionR tid ssh csh shn cid SubShowR
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
@ -125,12 +128,13 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp
colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } -> colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } ->
let tid = course ^. _3 let csh = course ^. _2
csh = course ^. _2 tid = course ^. _3
ssh = course ^. _4
-- shn = sheetName -- shn = sheetName
mkRoute = do mkRoute = do
cid <- encrypt subId cid <- encrypt subId
return $ CSubmissionR tid csh sheetName cid CorrectionR return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
in anchorCellM mkRoute $(widgetFile "widgets/rating") in anchorCellM mkRoute $(widgetFile "widgets/rating")
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)) 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))
@ -340,10 +344,10 @@ postCorrectionsR = do
[ downloadAction [ downloadAction
] ]
getCCorrectionsR, postCCorrectionsR :: TermId -> CourseShorthand -> Handler TypedContent getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
getCCorrectionsR = postCCorrectionsR getCCorrectionsR = postCCorrectionsR
postCCorrectionsR tid csh = do postCCorrectionsR tid ssh csh = do
Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
let whereClause = courseIs cid let whereClause = courseIs cid
colonnade = mconcat colonnade = mconcat
[ colSelect [ colSelect
@ -360,10 +364,10 @@ postCCorrectionsR tid csh = do
, assignAction (Left cid) , assignAction (Left cid)
] ]
getSSubsR, postSSubsR :: TermId -> CourseShorthand -> SheetName -> Handler TypedContent getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
getSSubsR = postSSubsR getSSubsR = postSSubsR
postSSubsR tid csh shn = do postSSubsR tid ssh csh shn = do
shid <- runDB $ fetchSheetId tid csh shn shid <- runDB $ fetchSheetId tid ssh csh shn
let whereClause = sheetIs shid let whereClause = sheetIs shid
colonnade = mconcat colonnade = mconcat
[ colSelect [ colSelect
@ -380,26 +384,26 @@ postSSubsR tid csh shn = do
, autoAssignAction shid , autoAssignAction shid
] ]
correctionData tid csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do 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 $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ course E.^. CourseTerm E.==. E.val tid
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.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. sheet E.^. SheetName E.==. E.val shn
E.&&. submission E.^. SubmissionId E.==. E.val sub E.&&. submission E.^. SubmissionId E.==. E.val sub
return (course, sheet, submission, corrector) return (course, sheet, submission, corrector)
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getCorrectionR tid csh shn cid = do getCorrectionR tid ssh csh shn cid = do
mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True
bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid csh shn cid bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid
postCorrectionR tid csh shn cid = do postCorrectionR tid ssh csh shn cid = do
sub <- decrypt cid sub <- decrypt cid
results <- runDB $ correctionData tid csh shn sub results <- runDB $ correctionData tid ssh csh shn sub
case results of case results of
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do
@ -424,14 +428,14 @@ postCorrectionR tid csh shn cid = do
let rated = isJust $ void ratingPoints <|> void ratingComment let rated = isJust $ void ratingPoints <|> void ratingComment
update sub [ SubmissionRatingBy =. (uid <$ guard rated) update sub [ SubmissionRatingBy =. (uid <$ guard rated)
, SubmissionRatingTime =. (now <$ guard rated) , SubmissionRatingTime =. (now <$ guard rated)
, SubmissionRatingPoints =. ratingPoints , SubmissionRatingPoints =. ratingPoints
, SubmissionRatingComment =. ratingComment , SubmissionRatingComment =. ratingComment
] ]
addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated
redirect $ CSubmissionR tid csh shn cid CorrectionR redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
case uploadResult of case uploadResult of
FormMissing -> return () FormMissing -> return ()
@ -442,16 +446,16 @@ postCorrectionR tid csh shn cid = do
runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
addMessageI "success" MsgRatingFilesUpdated addMessageI "success" MsgRatingFilesUpdated
redirect $ CSubmissionR tid csh shn cid CorrectionR redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
defaultLayout $ do defaultLayout $ do
let userCorrection = $(widgetFile "correction-user") let userCorrection = $(widgetFile "correction-user")
$(widgetFile "correction") $(widgetFile "correction")
_ -> notFound _ -> notFound
getCorrectionUserR tid csh shn cid = do getCorrectionUserR tid ssh csh shn cid = do
sub <- decrypt cid sub <- decrypt cid
results <- runDB $ correctionData tid csh shn sub results <- runDB $ correctionData tid ssh csh shn sub
case results of case results of
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do

149
src/Handler/Course.hs
View File

@ -39,13 +39,13 @@ type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School)
colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse) colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
anchorCell (CourseR courseTerm courseShorthand CShowR) anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
[whamlet|#{display courseName}|] [whamlet|#{display courseName}|]
colCourseDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCourseDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) colCourseDescr = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
( anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseName}|] ) ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseName}|] )
( case courseDescription of ( case courseDescription of
Nothing -> mempty Nothing -> mempty
(Just descr) -> cell [whamlet| <span style="float:right"> ^{modalStatic descr} |] (Just descr) -> cell [whamlet| <span style="float:right"> ^{modalStatic descr} |]
@ -61,12 +61,12 @@ colDescription = sortable Nothing (i18nCell MsgCourseDescription)
colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseShorthand}|] anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort) colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
( anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseShorthand}|] ) ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
( case courseDescription of ( case courseDescription of
Nothing -> mempty Nothing -> mempty
(Just descr) -> cell (Just descr) -> cell
@ -80,13 +80,13 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
$ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
cell [whamlet|#{display schoolName}|] anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|]
colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchool) colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
$ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
cell [whamlet|#{display schoolShorthand}|] anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|]
colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
@ -187,7 +187,7 @@ getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
whereClause = const $ E.val True whereClause = const $ E.val True
validator = def validator = def
& defaultSorting [("course", SortAsc), ("term", SortDesc)] & defaultSorting [("course", SortAsc), ("term", SortDesc)]
coursesTable <- makeCourseTable whereClause colonnade validator ((), coursesTable) <- makeCourseTable whereClause colonnade validator
defaultLayout $ do defaultLayout $ do
setTitleI MsgCourseListTitle setTitleI MsgCourseListTitle
[whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO
@ -201,6 +201,30 @@ getTermCurrentR = do
(Just (maximum -> tid)) -> -- getTermCourseListR tid (Just (maximum -> tid)) -> -- getTermCourseListR tid
redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc. 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 :: TermId -> Handler Html
getTermCourseListR tid = do getTermCourseListR tid = do
void . runDB $ get404 tid -- Just ensure the term exists void . runDB $ get404 tid -- Just ensure the term exists
@ -217,18 +241,18 @@ getTermCourseListR tid = do
whereClause = \(course, _, _) -> course E.^. CourseTerm E.==. E.val tid whereClause = \(course, _, _) -> course E.^. CourseTerm E.==. E.val tid
validator = def validator = def
& defaultSorting [("cshort", SortAsc)] & defaultSorting [("cshort", SortAsc)]
coursesTable <- makeCourseTable whereClause colonnade validator ((), coursesTable) <- makeCourseTable whereClause colonnade validator
defaultLayout $ do defaultLayout $ do
setTitleI . MsgTermCourseListTitle $ tid setTitleI . MsgTermCourseListTitle $ tid
$(widgetFile "courses") $(widgetFile "courses")
getCShowR :: TermId -> CourseShorthand -> Handler Html getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid csh = do getCShowR tid ssh csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
(courseEnt,(schoolMB,participants,registered)) <- runDB $ do (courseEnt,(schoolMB,participants,registered)) <- runDB $ do
courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
dependent <- (,,) dependent <- (,,)
<$> get (courseSchool course) -- join <$> get (courseSchool course) -- join -- just fetch full school name here
<*> count [CourseParticipantCourse ==. cid] -- join <*> count [CourseParticipantCourse ==. cid] -- join
<*> (case mbAid of -- TODO: Someone please refactor this late-night mess here! <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
Nothing -> return False Nothing -> return False
@ -238,7 +262,7 @@ getCShowR tid csh = do
return $ (courseEnt,dependent) return $ (courseEnt,dependent)
let course = entityVal courseEnt let course = entityVal courseEnt
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid csh CRegisterR) True registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
defaultLayout $ do defaultLayout $ do
@ -258,11 +282,11 @@ registerForm registered msecret extra = do
return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
postCRegisterR :: TermId -> CourseShorthand -> Handler Html postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCRegisterR tid csh = do postCRegisterR tid ssh csh = do
aid <- requireAuthId aid <- requireAuthId
(cid, course, registered) <- runDB $ do (cid, course, registered) <- runDB $ do
(Entity cid course) <- getBy404 $ CourseTermShort tid csh (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
registered <- isJust <$> (getBy $ UniqueParticipant aid cid) registered <- isJust <$> (getBy $ UniqueParticipant aid cid)
return (cid, course, registered) return (cid, course, registered)
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
@ -277,7 +301,7 @@ postCRegisterR tid csh = do
when (isJust regOk) $ addMessageI "success" MsgCourseRegisterOk when (isJust regOk) $ addMessageI "success" MsgCourseRegisterOk
| otherwise -> addMessageI "danger" MsgCourseSecretWrong | otherwise -> addMessageI "danger" MsgCourseSecretWrong
(_other) -> return () -- TODO check this! (_other) -> return () -- TODO check this!
redirect $ CourseR tid csh CShowR redirect $ CourseR tid ssh csh CShowR
getCourseNewR :: Handler Html getCourseNewR :: Handler Html
getCourseNewR = do getCourseNewR = do
@ -287,14 +311,14 @@ getCourseNewR = do
postCourseNewR :: Handler Html postCourseNewR :: Handler Html
postCourseNewR = courseEditHandler False Nothing postCourseNewR = courseEditHandler False Nothing
getCEditR :: TermId -> CourseShorthand -> Handler Html getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCEditR tid csh = do getCEditR tid ssh csh = do
course <- runDB $ getBy $ CourseTermShort tid csh course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
courseEditHandler True course courseEditHandler True course
postCEditR :: TermId -> CourseShorthand -> Handler Html postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCEditR tid csh = do postCEditR tid ssh csh = do
course <- runDB $ getBy $ CourseTermShort tid csh course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
courseEditHandler False course courseEditHandler False course
@ -311,12 +335,14 @@ courseDeleteHandler = undefined
courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html
courseEditHandler isGet course = do courseEditHandler isGet course = do
$logDebug "€€€€€€ courseEditHandler started"
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm ((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm
case result of case result of
(FormSuccess res@( (FormSuccess res@(
CourseForm { cfCourseId = Nothing CourseForm { cfCourseId = Nothing
, cfShort = csh , cfShort = csh
, cfSchool = ssh
, cfTerm = tid , cfTerm = tid
})) -> do -- create new course })) -> do -- create new course
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
@ -339,17 +365,17 @@ courseEditHandler isGet course = do
runDB $ do runDB $ do
insert_ $ CourseEdit aid now cid insert_ $ CourseEdit aid now cid
insert_ $ Lecturer aid cid insert_ $ Lecturer aid cid
addMessageI "info" $ MsgCourseNewOk tid csh addMessageI "info" $ MsgCourseNewOk tid ssh csh
redirect $ TermCourseListR tid redirect $ TermCourseListR tid
Nothing -> Nothing ->
addMessageI "danger" $ MsgCourseNewDupShort tid csh addMessageI "danger" $ MsgCourseNewDupShort tid ssh csh
(FormSuccess res@( (FormSuccess res@(
CourseForm { cfCourseId = Just cID CourseForm { cfCourseId = Just cid
, cfShort = csh , cfShort = csh
, cfSchool = ssh
, cfTerm = tid , cfTerm = tid
})) -> do -- edit existing course })) -> do -- edit existing course
cid <- decrypt cID
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
-- addMessage "debug" [shamlet| #{show res}|] -- addMessage "debug" [shamlet| #{show res}|]
success <- runDB $ do success <- runDB $ do
@ -373,12 +399,12 @@ courseEditHandler isGet course = do
} }
) )
case updOkay of case updOkay of
(Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid csh) $> False (Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid ssh csh) $> False
Nothing -> do Nothing -> do
insert_ $ CourseEdit aid now cid insert_ $ CourseEdit aid now cid
addMessageI "success" $ MsgCourseEditOk tid csh addMessageI "success" $ MsgCourseEditOk tid ssh csh
return True return True
when success $ redirect $ CourseR tid csh CShowR when success $ redirect $ CourseR tid ssh csh CShowR
(FormFailure _) -> addMessageI "warning" MsgInvalidInput (FormFailure _) -> addMessageI "warning" MsgInvalidInput
(FormMissing) -> return () (FormMissing) -> return ()
@ -389,7 +415,7 @@ courseEditHandler isGet course = do
data CourseForm = CourseForm data CourseForm = CourseForm
{ cfCourseId :: Maybe CryptoUUIDCourse { cfCourseId :: Maybe CourseId
, cfName :: CourseName , cfName :: CourseName
, cfDesc :: Maybe Html , cfDesc :: Maybe Html
, cfLink :: Maybe Text , cfLink :: Maybe Text
@ -406,9 +432,8 @@ data CourseForm = CourseForm
courseToForm :: MonadCrypto m => Entity Course -> m CourseForm courseToForm :: MonadCrypto m => Entity Course -> m CourseForm
courseToForm (Entity cid Course{..}) = do courseToForm (Entity cid Course{..}) = do
cfCourseId <- Just <$> encrypt cid
return $ CourseForm return $ CourseForm
{ cfCourseId { cfCourseId = Just cid
, cfName = courseName , cfName = courseName
, cfDesc = courseDescription , cfDesc = courseDescription
, cfLink = courseLinkExternal , cfLink = courseLinkExternal
@ -425,40 +450,35 @@ courseToForm (Entity cid Course{..}) = do
newCourseForm :: Maybe CourseForm -> Form CourseForm newCourseForm :: Maybe CourseForm -> Form CourseForm
newCourseForm template = identForm FIDcourse $ \html -> do newCourseForm template = identForm FIDcourse $ \html -> do
-- mopt hiddenField userSchools <- liftHandlerT . runDB $ do
-- cidKey <- getsYesod appCryptoIDKey userId <- liftHandlerT requireAuthId
-- courseId <- runMaybeT $ do (fmap concat . sequence)
-- cid <- cfCourseId template [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
-- UUID.encrypt cidKey cid , map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] []
]
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
-- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work? <$> pure (cfCourseId =<< template)
<$> aopt hiddenField "courseId" (cfCourseId <$> template) <*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template)
<*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template)
<*> aopt htmlField (fslI MsgCourseDescription <*> aopt htmlField (fslI MsgCourseDescription
& setTooltip MsgCourseDescriptionTip) (cfDesc <$> template) & setTooltip MsgCourseDescriptionTip) (cfDesc <$> template)
<*> aopt urlField (fslI MsgCourseHomepage) (cfLink <$> template) <*> aopt urlField (fslI MsgCourseHomepage) (cfLink <$> template)
<*> areq (ciField textField) (fslI MsgCourseShorthand <*> areq (ciField textField) (fslI MsgCourseShorthand
-- & addAttr "disabled" "disabled" -- & addAttr "disabled" "disabled"
& setTooltip MsgCourseShorthandUnique) & setTooltip MsgCourseShorthandUnique)
(cfShort <$> template) (cfShort <$> template)
<*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template) <*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template)
<*> areq schoolField (fslI MsgCourseSchool) (cfSchool <$> template) <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
<*> aopt (natField "Kapazität") (fslI MsgCourseCapacity <*> aopt (natField "Kapazität") (fslI MsgCourseCapacity
& setTooltip MsgCourseCapacityTip & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template)
) (cfCapacity <$> template) <*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette"
<*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette" & setTooltip MsgCourseSecretTip) (cfSecret <$> template)
& setTooltip MsgCourseSecretTip) <*> areq checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template)
(cfSecret <$> template) <*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum"
<*> areq checkBoxField (fslI MsgMaterialFree)(cfMatFree <$> template) & setTooltip MsgCourseRegisterFromTip) (cfRegFrom <$> template)
<*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum" <*> aopt utcTimeField (fslpI MsgRegisterTo "Datum"
& setTooltip MsgCourseRegisterFromTip) & setTooltip MsgCourseRegisterToTip) (cfRegTo <$> template)
(cfRegFrom <$> template) <*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum"
<*> aopt utcTimeField (fslpI MsgRegisterTo "Datum" & setTooltip MsgCourseDeregisterUntilTip) (cfDeRegUntil <$> template)
& setTooltip MsgCourseRegisterToTip)
(cfRegTo <$> template)
<*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum"
& setTooltip MsgCourseDeregisterUntilTip)
(cfDeRegUntil <$> template)
<* submitButton <* submitButton
return $ case result of return $ case result of
FormSuccess courseResult FormSuccess courseResult
@ -476,9 +496,6 @@ newCourseForm template = identForm FIDcourse $ \html -> do
|] |]
) )
_ -> (result, widget) _ -> (result, widget)
-- where
-- cid :: Maybe CourseId
-- cid = join $ cfCourseId <$> template
validateCourse :: CourseForm -> [Text] validateCourse :: CourseForm -> [Text]

12
src/Handler/CryptoIDDispatch.hs
View File

@ -38,23 +38,23 @@ instance CryptoRoute UUID SubmissionId where
cryptoIDRoute _ (CryptoID -> cID) = do cryptoIDRoute _ (CryptoID -> cID) = do
(smid :: SubmissionId) <- decrypt cID (smid :: SubmissionId) <- decrypt cID
cID' <- encrypt smid cID' <- encrypt smid
(tid,csh,shn) <- runDB $ do (tid,ssh,csh,shn) <- runDB $ do
shid <- submissionSheet <$> get404 smid shid <- submissionSheet <$> get404 smid
Sheet{..} <- get404 shid Sheet{..} <- get404 shid
Course{..} <- get404 sheetCourse Course{..} <- get404 sheetCourse
return (courseTerm, courseShorthand, sheetName) return (courseTerm, courseSchool, courseShorthand, sheetName)
return $ CSubmissionR tid csh shn cID' SubShowR return $ CSubmissionR tid ssh csh shn cID' SubShowR
instance CryptoRoute (CI FilePath) SubmissionId where instance CryptoRoute (CI FilePath) SubmissionId where
cryptoIDRoute _ ciphertext cryptoIDRoute _ ciphertext
| Just cID <- fromPathPiece . Text.pack $ CI.original ciphertext = do | Just cID <- fromPathPiece . Text.pack $ CI.original ciphertext = do
smid <- decrypt cID smid <- decrypt cID
(tid,csh,shn) <- runDB $ do (tid,ssh,csh,shn) <- runDB $ do
shid <- submissionSheet <$> get404 smid shid <- submissionSheet <$> get404 smid
Sheet{..} <- get404 shid Sheet{..} <- get404 shid
Course{..} <- get404 sheetCourse Course{..} <- get404 sheetCourse
return (courseTerm, courseShorthand, sheetName) return (courseTerm, courseSchool, courseShorthand, sheetName)
return $ CSubmissionR tid csh shn cID SubShowR return $ CSubmissionR tid ssh csh shn cID SubShowR
| otherwise = notFound | otherwise = notFound
instance CryptoRoute UUID UserId where instance CryptoRoute UUID UserId where

62
src/Handler/Home.hs
View File

@ -22,12 +22,12 @@ import Data.Time hiding (formatTime)
-- import Web.PathPieces (showToPathPiece, readFromPathPiece) -- import Web.PathPieces (showToPathPiece, readFromPathPiece)
import Control.Lens -- import Control.Lens
import Colonnade hiding (fromMaybe, singleton) -- import Colonnade hiding (fromMaybe, singleton)
-- import Yesod.Colonnade -- import Yesod.Colonnade
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Text.Shakespeare.Text -- import Text.Shakespeare.Text
import Development.GitRev import Development.GitRev
@ -55,29 +55,31 @@ getHomeR = do
homeAnonymous :: Handler Html homeAnonymous :: Handler Html
homeAnonymous = do homeAnonymous = do
cTime <- liftIO getCurrentTime cTime <- liftIO getCurrentTime
let fTime = addUTCTime (offCourseDeadlines * nominalDay) cTime
let tableData :: E.SqlExpr (Entity Course) let tableData :: E.SqlExpr (Entity Course)
-> E.SqlQuery (E.SqlExpr (Entity Course)) -> E.SqlQuery (E.SqlExpr (Entity Course))
tableData course = do tableData course = do
E.where_ $ (E.not_ $ E.isNothing $ course E.^. CourseRegisterFrom) -- TODO: do this with isAuthorized in dbtProj 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.&&. (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime))
E.&&. ((E.isNothing $ course E.^. CourseRegisterTo) E.&&. ((E.isNothing $ course E.^. CourseRegisterTo)
E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime))) E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
return course return course
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (WidgetT UniWorX IO) ()) colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
colonnade = mconcat colonnade = mconcat
[ -- dbRow [ -- dbRow
sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
let tid = courseTerm course
csh = courseShorthand course
cell [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
, sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
textCell $ display $ courseTerm course textCell $ display $ courseTerm course
, sortable (Just "school") (textCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
textCell $ display $ courseSchool course
, sortable (Just "course") (textCell 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") (textCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> , sortable (Just "deadline") (textCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
] ]
courseTable <- dbTable def $ DBTable ((), courseTable) <- dbTable def $ DBTable
{ dbtSQLQuery = tableData { dbtSQLQuery = tableData
, dbtColonnade = colonnade , dbtColonnade = colonnade
, dbtProj = return , dbtProj = return
@ -85,6 +87,9 @@ homeAnonymous = do
[ ( "term" [ ( "term"
, SortColumn $ \(course) -> course E.^. CourseTerm , SortColumn $ \(course) -> course E.^. CourseTerm
) )
, ( "school"
, SortColumn $ \(course) -> course E.^. CourseSchool
)
, ( "course" , ( "course"
, SortColumn $ \(course) -> course E.^. CourseShorthand , SortColumn $ \(course) -> course E.^. CourseShorthand
) )
@ -116,6 +121,7 @@ homeUser uid = do
-- (E.SqlExpr (Entity Course ))) -- (E.SqlExpr (Entity Course )))
-- (E.SqlExpr (Entity Sheet )) -- (E.SqlExpr (Entity Sheet ))
_ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term)) _ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
, E.SqlExpr (E.Value SchoolId)
, E.SqlExpr (E.Value CourseShorthand) , E.SqlExpr (E.Value CourseShorthand)
, E.SqlExpr (E.Value SheetName) , E.SqlExpr (E.Value SheetName)
, E.SqlExpr (E.Value UTCTime) , E.SqlExpr (E.Value UTCTime)
@ -132,6 +138,7 @@ homeUser uid = do
-- E.limit nrSheetDeadlines -- arbitrary limits are not intuitive -- E.limit nrSheetDeadlines -- arbitrary limits are not intuitive
return return
( course E.^. CourseTerm ( course E.^. CourseTerm
, course E.^. CourseSchool
, course E.^. CourseShorthand , course E.^. CourseShorthand
, sheet E.^. SheetName , sheet E.^. SheetName
, sheet E.^. SheetActiveTo , sheet E.^. SheetActiveTo
@ -139,38 +146,45 @@ homeUser uid = do
) )
colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term) colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term)
, E.Value SchoolId
, E.Value CourseShorthand , E.Value CourseShorthand
, E.Value SheetName , E.Value SheetName
, E.Value UTCTime , E.Value UTCTime
, E.Value (Maybe SubmissionId) , E.Value (Maybe SubmissionId)
)) ))
(DBCell (WidgetT UniWorX IO) ()) (DBCell (HandlerT UniWorX IO) ())
colonnade = mconcat colonnade = mconcat
[ -- dbRow [ -- dbRow
sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _, _) } -> -- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } ->
anchorCell (CourseR tid csh CShowR) (toWidget $ display csh) sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } ->
, sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid, _,_,_,_) } ->
textCell $ display tid textCell $ display tid
, sortable (Just "sheet") (textCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, _) } -> , sortable (Just "school") (textCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } ->
anchorCell (CSheetR tid csh shn SShowR) (toWidget $ display shn) textCell $ display ssh
, sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline, _) } -> , sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } ->
anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh)
, sortable (Just "sheet") (textCell 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") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
cell $ formatTime SelFormatDateTime deadline >>= toWidget cell $ formatTime SelFormatDateTime deadline >>= toWidget
, sortable (Just "done") (textCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, E.Value mbsid) }) -> , sortable (Just "done") (textCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) }) ->
case mbsid of case mbsid of
Nothing -> mempty Nothing -> mempty
(Just sid) -> anchorCellM (CSubmissionR tid csh shn <$> encrypt sid <*> pure SubShowR) (Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
tickmark tickmark
] ]
let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)] let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
sheetTable <- dbTable validator $ DBTable ((), sheetTable) <- dbTable validator $ DBTable
{ dbtSQLQuery = tableData { dbtSQLQuery = tableData
, dbtColonnade = colonnade , dbtColonnade = colonnade
, dbtProj = \dbRow@DBRow{ dbrOutput = (E.Value tid, E.Value csh, E.Value shn, _, _) } , dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
-> dbRow <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh shn SShowR) False) -> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "term" [ ( "term"
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm
) )
, ( "school"
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseSchool
)
, ( "course" , ( "course"
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseShorthand , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
) )

105
src/Handler/Profile.hs
View File

@ -1,21 +1,25 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
module Handler.Profile where module Handler.Profile where
import Import import Import
import Handler.Utils import Handler.Utils
import Utils.Lens
-- import Colonnade hiding (fromMaybe, singleton) -- import Colonnade hiding (fromMaybe, singleton)
-- import Yesod.Colonnade -- import Yesod.Colonnade
import qualified Data.Map as Map
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Database.Esqueleto ((^.)) -- import Database.Esqueleto ((^.))
@ -25,19 +29,23 @@ data SettingsForm = SettingsForm
, stgDateTime :: DateTimeFormat , stgDateTime :: DateTimeFormat
, stgDate :: DateTimeFormat , stgDate :: DateTimeFormat
, stgTime :: DateTimeFormat , stgTime :: DateTimeFormat
, stgDownloadFiles :: Bool
} }
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
makeSettingForm template = identForm FIDsettings $ \html -> do makeSettingForm template = identForm FIDsettings $ \html -> do
let themeList = [(display t,t) | t <- allThemes] let themeList = [Option (display t) t (toPathPiece t) | t <- universeF]
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm (result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
<$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
(fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template) (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
<*> areq (selectFieldList themeList) <*> areq (selectField . return $ mkOptionList themeList)
(fslpI MsgTheme "theme-select" ) (stgTheme <$> template) -- TODO: pass theme-select as id-attribute or similar. (fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template)
<*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template)
<*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
<*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
<*> areq checkBoxField (fslI MsgDownloadFiles
& setTooltip MsgDownloadFilesTip
) (stgDownloadFiles <$> template)
<* submitButton <* submitButton
return (result, widget) -- no validation required here return (result, widget) -- no validation required here
@ -52,6 +60,7 @@ getProfileR = do
, stgDateTime = userDateTimeFormat , stgDateTime = userDateTimeFormat
, stgDate = userDateFormat , stgDate = userDateFormat
, stgTime = userTimeFormat , stgTime = userTimeFormat
, stgDownloadFiles = userDownloadFiles
} }
((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate
case res of case res of
@ -62,6 +71,7 @@ getProfileR = do
, UserDateTimeFormat =. stgDateTime , UserDateTimeFormat =. stgDateTime
, UserDateFormat =. stgDate , UserDateFormat =. stgDate
, UserTimeFormat =. stgTime , UserTimeFormat =. stgTime
, UserDownloadFiles =. stgDownloadFiles
] ]
when (stgMaxFavourties < userMaxFavourites) $ do when (stgMaxFavourties < userMaxFavourites) $ do
-- prune Favourites to user-defined size -- prune Favourites to user-defined size
@ -79,45 +89,45 @@ getProfileR = do
(admin_rights,lecturer_rights,lecture_owner,lecture_corrector,participant,studies) <- runDB $ (,,,,,) <$> (admin_rights,lecturer_rights,lecture_owner,lecture_corrector,participant,studies) <- runDB $ (,,,,,) <$>
(E.select $ E.from $ \(adright `E.InnerJoin` school) -> do (E.select $ E.from $ \(adright `E.InnerJoin` school) -> do
E.where_ $ adright ^. UserAdminUser E.==. E.val uid E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
E.on $ adright ^. UserAdminSchool E.==. school ^. SchoolId E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
return (school ^. SchoolShorthand) return (school E.^. SchoolShorthand)
) )
<*> <*>
(E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do (E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
E.where_ $ lecright ^. UserLecturerUser E.==. E.val uid E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
E.on $ lecright ^. UserLecturerSchool E.==. school ^. SchoolId E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
return (school ^. SchoolShorthand) return (school E.^. SchoolShorthand)
) )
<*> <*>
(E.select $ E.from $ \(lecturer `E.InnerJoin` course) -> do (E.select $ E.from $ \(lecturer `E.InnerJoin` course) -> do
E.where_ $ lecturer ^. LecturerUser E.==. E.val uid E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
E.on $ lecturer ^. LecturerCourse E.==. course ^. CourseId E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
return (course ^. CourseShorthand, course ^. CourseTerm) return (course E.^. CourseTerm, course E.^.CourseSchool, course E.^. CourseShorthand)
) )
<*> <*>
(E.select $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do (E.select $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet ^. SheetCourse E.==. course ^. CourseId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet ^. SheetId E.==. corrector ^. SheetCorrectorSheet E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ corrector ^. SheetCorrectorUser E.==. E.val uid E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
return (course ^. CourseShorthand, course ^. CourseTerm) return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
) )
<*> <*>
(E.select $ E.from $ \(participant `E.InnerJoin` course) -> do (E.select $ E.from $ \(participant `E.InnerJoin` course) -> do
E.where_ $ participant ^. CourseParticipantUser E.==. E.val uid E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
E.on $ participant ^. CourseParticipantCourse E.==. course ^. CourseId E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
return (course ^. CourseShorthand, course ^. CourseTerm, participant ^. CourseParticipantRegistration) return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, participant E.^. CourseParticipantRegistration)
) )
<*> <*>
(E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do (E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.where_ $ studyfeat ^. StudyFeaturesUser E.==. E.val uid E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.on $ studyfeat ^. StudyFeaturesField E.==. studyterms ^. StudyTermsId E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat ^. StudyFeaturesDegree E.==. studydegree ^. StudyDegreeId E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
return (studydegree ^. StudyDegreeName return (studydegree E.^. StudyDegreeName
,studyterms ^. StudyTermsName ,studyterms E.^. StudyTermsName
,studyfeat ^. StudyFeaturesType ,studyfeat E.^. StudyFeaturesType
,studyfeat ^. StudyFeaturesSemester) ,studyfeat E.^. StudyFeaturesSemester)
) )
let formText = Just MsgSettings let formText = Just MsgSettings
actionUrl = ProfileR actionUrl = ProfileR
@ -133,11 +143,48 @@ postProfileR = do
getProfileR getProfileR
getProfileDataR :: Handler Html getProfileDataR :: Handler Html
getProfileDataR = do getProfileDataR = do
(uid, User{..}) <- requireAuthPair (uid, User{..}) <- requireAuthPair
-- mr <- getMessageRender -- mr <- getMessageRender
-- Tabelle mit eigenen Kursen
-- Tabelle mit allen Teilnehmer: Kurs (link), Datum
courseTable <- do
let -- should be inlined
-- courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, Entity CourseParticipant)) (DBCell m a)
courseCol = sortable (Just "course") (i18nCell MsgCourse) $ do -- (->) a Monad
Course{..} <- view $ _dbrOutput . _1 . _entityVal -- view == ^.
-- "preview _left" in order to match Either (result is Maybe)
return $ anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
(citext2widget courseName)
--courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant)))
-- -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity CourseParticipant))
courseData = \(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)
dbTableWidget' def $ DBTable
{ dbtIdent = "courseMembership" :: Text
, dbtSQLQuery = courseData
, dbtColonnade = mconcat
[ courseCol
]
, dbtProj = return
, dbtSorting = Map.fromList
[ ( "course"
, SortColumn $ \(course `E.InnerJoin` _) -> course E.^. CourseName )
]
, dbtFilter = mempty
, dbtStyle = def
}
-- Tabelle mit allen Abgaben und Abgabe-Gruppen
-- Tabelle mit allen Korrektor-Aufgaben
-- Tabelle mit allen Tutorials
-- Tabelle mit allen Klausuren und Noten
defaultLayout $ do defaultLayout $ do
$(widgetFile "profileData") $(widgetFile "profileData")
$(widgetFile "dsgvDisclaimer") $(widgetFile "dsgvDisclaimer")

212
src/Handler/Sheet.hs
View File

@ -21,31 +21,31 @@ import Import
import System.FilePath (takeFileName) import System.FilePath (takeFileName)
import Handler.Utils import Handler.Utils
import Handler.Utils.Zip -- import Handler.Utils.Zip
-- import Data.Time -- import Data.Time
import qualified Data.Text as T -- import qualified Data.Text as T
-- import Data.Function ((&)) -- import Data.Function ((&))
-- --
import Colonnade hiding (fromMaybe, singleton, bool) -- import Colonnade hiding (fromMaybe, singleton, bool)
import qualified Yesod.Colonnade as Yesod import qualified Yesod.Colonnade as Yesod
import Text.Blaze (text) import Text.Blaze (text)
-- --
import qualified Data.UUID.Cryptographic as UUID -- import qualified Data.UUID.Cryptographic as UUID
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import Data.CaseInsensitive (CI) -- import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto as E import qualified Database.Esqueleto 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.Writer (MonadWriter(..), execWriterT)
import Control.Monad.Trans.RWS.Lazy (RWST, local) -- import Control.Monad.Trans.RWS.Lazy (RWST, local)
import qualified Text.Email.Validate as Email -- import qualified Text.Email.Validate as Email
import qualified Data.List as List -- import qualified Data.List as List
import Network.Mime import Network.Mime
@ -56,8 +56,10 @@ import qualified Data.Map as Map
import Data.Map (Map, (!), (!?)) import Data.Map (Map, (!), (!?))
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Monoid (Sum(..))
import Control.Lens import Control.Lens
import Utils.Lens -- import Utils.Lens
instance Eq (Unique Sheet) where instance Eq (Unique Sheet) where
@ -132,17 +134,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
FormSuccess sheetResult FormSuccess sheetResult
| errorMsgs <- validateSheet mr sheetResult | errorMsgs <- validateSheet mr sheetResult
, not $ null errorMsgs -> , not $ null errorMsgs ->
(FormFailure errorMsgs, (FormFailure errorMsgs, widget)
[whamlet|
<div class="alert alert-danger">
<div class="alert__content">
<h4> Fehler:
<ul>
$forall errmsg <- errorMsgs
<li> #{errmsg}
^{widget}
|]
)
_ -> (result, widget) _ -> (result, widget)
where where
validateSheet :: MsgRenderer -> SheetForm -> [Text] validateSheet :: MsgRenderer -> SheetForm -> [Text]
@ -154,24 +146,24 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
, ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly) , ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly)
] ] ] ]
getSheetListR :: TermId -> CourseShorthand -> Handler Html getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetListR tid csh = do getSheetListR tid ssh csh = do
muid <- maybeAuthId muid <- maybeAuthId
Entity cid _ <- runDB . getBy404 $ CourseTermShort tid csh Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
let let
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 :: 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 sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
let sheetEdit = E.sub_select . E.from $ \sheetEdit -> do let sheetEdit = E.sub_select . E.from $ \sheetEdit' -> do
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId E.where_ $ sheetEdit' E.^. SheetEditSheet E.==. sheet E.^. SheetId
return . E.max_ $ sheetEdit E.^. SheetEditTime return . E.max_ $ sheetEdit' E.^. SheetEditTime
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return (sheet, sheetEdit, submission) return (sheet, sheetEdit, submission)
sheetCol = widgetColonnade . mconcat $ sheetCol = widgetColonnade . mconcat $
[ sortable (Just "name") (i18nCell MsgSheet) [ sortable (Just "name") (i18nCell MsgSheet)
$ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid csh sheetName SShowR) (toWidget sheetName) $ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
, sortable (Just "last-edit") (i18nCell MsgLastEdit) , sortable (Just "last-edit") (i18nCell MsgLastEdit)
$ \(_, E.Value mEditTime, _) -> case mEditTime of $ \(_, E.Value mEditTime, _) -> case mEditTime of
Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget
@ -188,9 +180,9 @@ getSheetListR tid csh = do
(Just (Entity sid Submission{..})) -> (Just (Entity sid Submission{..})) ->
let mkCid = encrypt sid -- TODO: executed twice let mkCid = encrypt sid -- TODO: executed twice
mkRoute = do mkRoute = do
cid <- mkCid cid' <- mkCid
return $ CSubmissionR tid csh sheetName cid SubShowR return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
, sortable (Just "rating") (i18nCell MsgRating) , sortable (Just "rating") (i18nCell MsgRating)
$ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
Nothing -> mempty Nothing -> mempty
@ -198,8 +190,9 @@ getSheetListR tid csh = do
let mkCid = encrypt sid let mkCid = encrypt sid
mkRoute = do mkRoute = do
cid <- mkCid cid <- mkCid
return $ CSubmissionR tid csh sheetName cid CorrectionR return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
in anchorCellM mkRoute $(widgetFile "widgets/rating") protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating")
in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints)))
, sortable Nothing -- (Just "percent") , sortable Nothing -- (Just "percent")
(i18nCell MsgRatingPercent) (i18nCell MsgRatingPercent)
$ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of
@ -214,11 +207,11 @@ getSheetListR tid csh = do
] ]
psValidator = def psValidator = def
& defaultSorting [("submission-since", SortAsc)] & defaultSorting [("submission-since", SortAsc)]
table <- dbTable psValidator $ DBTable (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable
{ dbtSQLQuery = sheetData { dbtSQLQuery = sheetData
, dbtColonnade = sheetCol , dbtColonnade = sheetCol
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) } , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) }
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh sheetName SShowR) False) -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False)
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "name" [ ( "name"
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
@ -248,27 +241,14 @@ getSheetListR tid csh = do
, dbtStyle = def , dbtStyle = def
, dbtIdent = "sheets" :: Text , dbtIdent = "sheets" :: Text
} }
cTime <- Just <$> liftIO getCurrentTime -- TODO: HACK - remove me and the 2 next TODOs, see issue #142
rawStats <- runDB $ do -- compute the values of the table once again, since dbTable does not provide a list of raw values for summation/statistics
E.select $ E.from $ \(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
E.&&. (E.not_ $ E.isNothing $ sheet E.^. SheetVisibleFrom) -- TODO see above #142
E.&&. sheet E.^. SheetVisibleFrom E.<=. E.val cTime -- TODO see above #142
return $ (sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
let sheetTypeSummary = foldl' sumSheetTypes emptySheetTypeSummary
$ map (\(st,mp) -> (E.unValue st, join $ E.unValue mp)) rawStats
defaultLayout $ do defaultLayout $ do
$(widgetFile "sheetList") $(widgetFile "sheetList")
$(widgetFile "widgets/sheetTypeSummary") $(widgetFile "widgets/sheetTypeSummary")
-- Show single sheet -- Show single sheet
getSShowR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSShowR tid csh shn = do getSShowR tid ssh csh shn = do
entSheet <- runDB $ fetchSheet tid csh shn entSheet <- runDB $ fetchSheet tid ssh csh shn
let sheet = entityVal entSheet let sheet = entityVal entSheet
sid = entityKey entSheet sid = entityKey entSheet
-- without Colonnade -- without Colonnade
@ -281,7 +261,7 @@ getSShowR tid csh shn = do
-- E.where_ (sheet E.^. SheetId E.==. E.val sid ) -- E.where_ (sheet E.^. SheetId E.==. E.val sid )
-- -- return desired columns -- -- return desired columns
-- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) -- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
-- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid csh (SheetFileR shn fType fName),modified)) fileNameTypes -- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes
-- with Colonnade -- with Colonnade
let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do
@ -295,17 +275,17 @@ getSShowR tid csh shn = do
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
let colonnadeFiles = widgetColonnade $ mconcat let colonnadeFiles = widgetColonnade $ mconcat
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> stringCell ftype [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> stringCell ftype
, sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName)) , sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid ssh csh shn (SFileR fType fName))
(\(E.Value fName,_,_) -> str2widget fName) (\(E.Value fName,_,_) -> str2widget fName)
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
] ]
let psValidator = def let psValidator = def
& defaultSorting [("type", SortAsc), ("path", SortAsc)] & defaultSorting [("type", SortAsc), ("path", SortAsc)]
fileTable <- dbTable psValidator $ DBTable ((), fileTable) <- dbTable psValidator $ DBTable
{ dbtSQLQuery = fileData { dbtSQLQuery = fileData
, dbtColonnade = colonnadeFiles , dbtColonnade = colonnadeFiles
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh shn $ SFileR fType fName) False) -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
, dbtStyle = def , dbtStyle = def
, dbtFilter = Map.empty , dbtFilter = Map.empty
, dbtIdent = "files" :: Text , dbtIdent = "files" :: Text
@ -329,19 +309,19 @@ getSShowR tid csh shn = do
when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $ when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $
maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSheetTitle tid csh shn setTitleI $ MsgSheetTitle tid ssh csh shn
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
$(widgetFile "sheetShow") $(widgetFile "sheetShow")
getSFileR :: TermId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
getSFileR tid csh shn typ title = do getSFileR tid ssh csh shn typ title = do
results <- runDB $ E.select $ E.from $ results <- runDB $ E.select $ E.from $
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other -- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
-- filter to requested file -- filter to requested file
@ -349,7 +329,8 @@ getSFileR tid csh shn typ title = do
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ ) E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
E.&&. (sheet E.^. SheetName E.==. E.val shn ) E.&&. (sheet E.^. SheetName E.==. E.val shn )
E.&&. (course E.^. CourseShorthand E.==. E.val csh ) E.&&. (course E.^. CourseShorthand E.==. E.val csh )
E.&&. (course E.^. CourseTerm E.==. E.val tid ) E.&&. (course E.^. CourseSchool E.==. E.val ssh )
E.&&. (course E.^. CourseTerm E.==. E.val tid )
) )
-- return desired columns -- return desired columns
return $ (file E.^. FileTitle, file E.^. FileContent) return $ (file E.^. FileTitle, file E.^. FileContent)
@ -357,7 +338,8 @@ getSFileR tid csh shn typ title = do
case results of case results of
[(E.Value fileTitle, E.Value fileContent)] [(E.Value fileTitle, E.Value fileContent)]
| Just fileContent' <- fileContent -> do | Just fileContent' <- fileContent -> do
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] whenM downloadFiles $
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
| otherwise -> sendResponseStatus noContent204 () | otherwise -> sendResponseStatus noContent204 ()
[] -> notFound [] -> notFound
@ -365,21 +347,21 @@ getSFileR tid csh shn typ title = do
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found." error "Multiple matching files found."
getSheetNewR :: TermId -> CourseShorthand -> Handler Html getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetNewR tid csh = do getSheetNewR tid ssh csh = do
let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
insertUnique $ newSheet insertUnique $ newSheet
handleSheetEdit tid csh Nothing template action handleSheetEdit tid ssh csh Nothing template action
postSheetNewR :: TermId -> CourseShorthand -> Handler Html postSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postSheetNewR = getSheetNewR postSheetNewR = getSheetNewR
getSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSEditR tid csh shn = do getSEditR tid ssh csh shn = do
(sheetEnt, sheetFileIds) <- runDB $ do (sheetEnt, sheetFileIds) <- runDB $ do
ent <- fetchSheet tid csh shn ent <- fetchSheet tid ssh csh shn
fti <- getFtIdMap $ entityKey ent fti <- getFtIdMap $ entityKey ent
return (ent, fti) return (ent, fti)
let sid = entityKey sheetEnt let sid = entityKey sheetEnt
@ -405,13 +387,13 @@ getSEditR tid csh shn = do
case replaceRes of case replaceRes of
Nothing -> return $ Just sid Nothing -> return $ Just sid
(Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here (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
postSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSEditR = getSEditR postSEditR = getSEditR
handleSheetEdit :: TermId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
handleSheetEdit tid csh msId template dbAction = do handleSheetEdit tid ssh csh msId template dbAction = do
let mbshn = sfName <$> template let mbshn = sfName <$> template
aid <- requireAuthId aid <- requireAuthId
((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template
@ -419,7 +401,7 @@ handleSheetEdit tid csh msId template dbAction = do
(FormSuccess SheetForm{..}) -> do (FormSuccess SheetForm{..}) -> do
saveOkay <- runDB $ do saveOkay <- runDB $ do
actTime <- liftIO getCurrentTime actTime <- liftIO getCurrentTime
cid <- getKeyBy404 $ CourseTermShort tid csh cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
let newSheet = Sheet let newSheet = Sheet
{ sheetCourse = cid { sheetCourse = cid
, sheetName = sfName , sheetName = sfName
@ -435,51 +417,53 @@ handleSheetEdit tid csh msId template dbAction = do
} }
mbsid <- dbAction newSheet mbsid <- dbAction newSheet
case mbsid of case mbsid of
Nothing -> False <$ addMessageI "danger" (MsgSheetNameDup tid csh sfName) Nothing -> False <$ addMessageI "danger" (MsgSheetNameDup tid ssh csh sfName)
(Just sid) -> do -- save files in DB: (Just sid) -> do -- save files in DB:
whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise
whenIsJust sfHintF $ insertSheetFile' sid SheetHint whenIsJust sfHintF $ insertSheetFile' sid SheetHint
whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution
whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking
insert_ $ SheetEdit aid actTime sid insert_ $ SheetEdit aid actTime sid
addMessageI "info" $ MsgSheetEditOk tid csh sfName addMessageI "info" $ MsgSheetEditOk tid ssh csh sfName
return True return True
when saveOkay $ redirect $ CSheetR tid csh sfName SShowR -- redirect must happen outside of runDB when saveOkay $ redirect $ case msId of
Just _ -> CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
Nothing -> CSheetR tid ssh csh sfName SCorrR
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
_ -> return () _ -> return ()
let pageTitle = maybe (MsgSheetTitleNew tid csh) let pageTitle = maybe (MsgSheetTitleNew tid ssh csh)
(MsgSheetTitle tid csh) mbshn (MsgSheetTitle tid ssh csh) mbshn
-- let formTitle = pageTitle -- no longer used in template -- let formTitle = pageTitle -- no longer used in template
let formText = Nothing :: Maybe UniWorXMessage let formText = Nothing :: Maybe UniWorXMessage
actionUrl <- fromMaybe (CourseR tid csh SheetNewR) <$> getCurrentRoute actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute
defaultLayout $ do defaultLayout $ do
setTitleI pageTitle setTitleI pageTitle
$(widgetFile "formPageI18n") $(widgetFile "formPageI18n")
getSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSDelR tid csh shn = do getSDelR tid ssh csh shn = do
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
case result of case result of
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh shn SShowR (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid ssh csh shn SShowR
(FormSuccess BtnDelete) -> do (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!!! -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
addMessageI "info" $ MsgSheetDelOk tid csh shn addMessageI "info" $ MsgSheetDelOk tid ssh csh shn
redirect $ CourseR tid csh SheetListR redirect $ CourseR tid ssh csh SheetListR
_other -> do _other -> do
submissionno <- runDB $ do submissionno <- runDB $ do
sid <- fetchSheetId tid csh shn sid <- fetchSheetId tid ssh csh shn
count [SubmissionSheet ==. sid] count [SubmissionSheet ==. sid]
let formTitle = MsgSheetDelHead tid csh shn let formTitle = MsgSheetDelHead tid ssh csh shn
let formText = Just $ MsgSheetDelText submissionno let formText = Just $ MsgSheetDelText submissionno
let actionUrl = CSheetR tid csh shn SDelR let actionUrl = CSheetR tid ssh csh shn SDelR
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSheetTitle tid csh shn setTitleI $ MsgSheetTitle tid ssh csh shn
$(widgetFile "formPageI18n") $(widgetFile "formPageI18n")
postSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSDelR = getSDelR postSDelR = getSDelR
@ -511,11 +495,11 @@ insertSheetFile' sid ftype fs = do
data CorrectorForm = CorrectorForm data CorrectorForm = CorrectorForm
{ cfUserId :: UserId { cfUserId :: UserId
, cfUserName :: Text , cfUserName :: Text
, cfResult :: FormResult Load , cfResult :: FormResult (CorrectorState, Load)
, cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX , cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX
} }
type Loads = Map UserId Load type Loads = Map UserId (CorrectorState, Load)
defaultLoads :: SheetId -> DB Loads defaultLoads :: SheetId -> DB Loads
-- ^ Generate `Loads` in such a way that minimal editing is required -- ^ Generate `Loads` in such a way that minimal editing is required
@ -535,10 +519,10 @@ defaultLoads shid = do
E.orderBy [E.desc creationTime] E.orderBy [E.desc creationTime]
return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad) return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
where where
toMap :: [(E.Value UserId, E.Value Load)] -> Loads toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load 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 :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
@ -553,19 +537,19 @@ correctorForm shid = do
formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser]) formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
let let
currentLoads :: DB Loads currentLoads :: DB Loads
currentLoads = Map.fromList . map (\(Entity _ SheetCorrector{..}) -> (sheetCorrectorUser, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] [] currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
(defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
loads' <- fmap (Map.fromList [(uid, mempty) | uid <- formCIDs] `Map.union`) $ if loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
| Map.null currentLoads' | Map.null currentLoads'
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warning" MsgCorrectorsDefaulted) , null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warning" MsgCorrectorsDefaulted)
| otherwise -> return $ Map.fromList (map (, mempty) formCIDs) `Map.union` currentLoads' | 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') 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) let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions)
didDelete = any (flip Set.member deletions) formCIDs didDelete = any (flip Set.member deletions) formCIDs
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads' (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads'
let let
tutorField :: Field Handler [UserEmail] tutorField :: Field Handler [UserEmail]
tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
@ -595,7 +579,7 @@ correctorForm shid = do
case mUid of case mUid of
Nothing -> loads'' <$ addMessageI "error" (MsgEMailUnknown email) Nothing -> loads'' <$ addMessageI "error" (MsgEMailUnknown email)
Just uid Just uid
| not (Map.member uid loads') -> return $ Map.insert uid mempty loads'' | not (Map.member uid loads') -> return $ Map.insert uid (CorrectorNormal, mempty) loads''
| otherwise -> loads'' <$ addMessageI "warning" (MsgCorrectorExists email) | otherwise -> loads'' <$ addMessageI "warning" (MsgCorrectorExists email)
FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs
_ -> return loads'' _ -> return loads''
@ -607,8 +591,8 @@ correctorForm shid = do
return $ (user E.^. UserId, user E.^. UserDisplayName) return $ (user E.^. UserId, user E.^. UserDisplayName)
let let
constructFields :: (UserId, Text, Load) -> MForm Handler CorrectorForm constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm
constructFields (uid, uname, Load{..}) = do constructFields (uid, uname, (state, Load{..})) = do
cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser
let let
fs name = "" fs name = ""
@ -616,12 +600,13 @@ correctorForm shid = do
} }
rationalField = convertField toRational fromRational doubleField rationalField = convertField toRational fromRational doubleField
(stateRes, cfViewState) <- mreq (selectField $ optionsFinite id) (fs "state") (Just state)
(byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial) (byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
(propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion) (propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
(_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False) (_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
let let
cfResult :: FormResult Load cfResult :: FormResult (CorrectorState, Load)
cfResult = Load <$> tutRes' <*> propRes cfResult = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
tutRes' tutRes'
| FormSuccess True <- byTutRes = Just <$> countTutRes | FormSuccess True <- byTutRes = Just <$> countTutRes
| otherwise = Nothing <$ byTutRes | otherwise = Nothing <$ byTutRes
@ -638,6 +623,7 @@ correctorForm shid = do
let let
corrColonnade = mconcat corrColonnade = mconcat
[ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName [ 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 MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut
, headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp , headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp
, headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel , headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel
@ -646,7 +632,7 @@ correctorForm shid = do
| FormSuccess (Just es) <- addTutRes | FormSuccess (Just es) <- addTutRes
, not $ null es = FormMissing , not $ null es = FormMissing
| didDelete = FormMissing | didDelete = FormMissing
| otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> cfResult | otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> (snd <$> cfResult) <*> (fst <$> cfResult)
| CorrectorForm{..} <- corrData | CorrectorForm{..} <- corrData
] ]
idField CorrectorForm{..} = do idField CorrectorForm{..} = do
@ -678,10 +664,10 @@ correctorForm shid = do
-- Eingabebox für Korrektor hinzufügen -- Eingabebox für Korrektor hinzufügen
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
getSCorrR, postSCorrR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSCorrR = getSCorrR postSCorrR = getSCorrR
getSCorrR tid csh shn = do getSCorrR tid ssh csh shn = do
Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
@ -694,10 +680,10 @@ getSCorrR tid csh shn = do
FormMissing -> return () FormMissing -> return ()
let let
-- formTitle = MsgSheetCorrectorsTitle tid csh shn -- formTitle = MsgSheetCorrectorsTitle tid ssh csh shn
formText = Nothing :: Maybe (SomeMessage UniWorX) formText = Nothing :: Maybe (SomeMessage UniWorX)
actionUrl = CSheetR tid csh shn SCorrR actionUrl = CSheetR tid ssh csh shn SCorrR
-- actionUrl = CSheetR tid csh shn SShowR -- actionUrl = CSheetR tid ssh csh shn SShowR
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSheetCorrectorsTitle tid csh shn setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn
$(widgetFile "formPageI18n") $(widgetFile "formPageI18n")

57
src/Handler/Submission.hs
View File

@ -78,20 +78,20 @@ makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $
aforced' f fs (Just (Just v)) = Just <$> aforced f fs v aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary" aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary"
getSubmissionNewR, postSubmissionNewR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSubmissionNewR = postSubmissionNewR getSubmissionNewR = postSubmissionNewR
postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn NewSubmission
getSubShowR, postSubShowR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getSubShowR = postSubShowR getSubShowR = postSubShowR
postSubShowR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ ExistingSubmission cid
getSubmissionOwnR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSubmissionOwnR tid csh shn = do getSubmissionOwnR tid ssh csh shn = do
authId <- requireAuthId authId <- requireAuthId
sid <- runDB $ do sid <- runDB $ do
shid <- fetchSheetId tid csh shn shid <- fetchSheetId tid ssh csh shn
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId
@ -101,14 +101,14 @@ getSubmissionOwnR tid csh shn = do
((E.Value sid):_) -> return sid ((E.Value sid):_) -> return sid
[] -> notFound [] -> notFound
cID <- encrypt sid cID <- encrypt sid
redirect $ CSubmissionR tid csh shn cID SubShowR redirect $ CSubmissionR tid ssh csh shn cID SubShowR
submissionHelper :: TermId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
submissionHelper tid csh shn (SubmissionMode mcid) = do submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
uid <- requireAuthId uid <- requireAuthId
msmid <- traverse decrypt mcid msmid <- traverse decrypt mcid
(Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do (Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do
sheet@(Entity shid Sheet{..}) <- fetchSheet tid csh shn sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
case msmid of case msmid of
Nothing -> do Nothing -> do
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
@ -139,9 +139,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
(E.Value smid:_) -> do (E.Value smid:_) -> do
cID <- encrypt smid cID <- encrypt smid
addMessageI "info" $ MsgSubmissionAlreadyExists addMessageI "info" $ MsgSubmissionAlreadyExists
redirect $ CSubmissionR tid csh shn cID SubShowR redirect $ CSubmissionR tid ssh csh shn cID SubShowR
(Just smid) -> do (Just smid) -> do
void $ submissionMatchesSheet tid csh shn (fromJust mcid) void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
shid' <- submissionSheet <$> get404 smid shid' <- submissionSheet <$> get404 smid
-- fetch buddies from current submission -- fetch buddies from current submission
@ -239,14 +239,14 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
_other -> return Nothing _other -> return Nothing
case mCID of case mCID of
Just cID -> redirect $ CSubmissionR tid csh shn cID SubShowR Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR
Nothing -> return () Nothing -> return ()
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
maySubmit <- (== Authorized) <$> isAuthorized actionUrl True maySubmit <- (== Authorized) <$> isAuthorized actionUrl True
-- Maybe construct a table to display uploaded archive files -- Maybe construct a table to display uploaded archive files
let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ()) let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (HandlerT UniWorX IO) ())
colonnadeFiles cid = mconcat colonnadeFiles cid = mconcat
[ sortable (Just "path") (textCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let [ sortable (Just "path") (textCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let
Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr) Just fileTitle' = fileTitle . entityVal . snd <$> (mOrig <|> mCorr)
@ -254,13 +254,13 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr
Just isFile = origIsFile <|> corrIsFile Just isFile = origIsFile <|> corrIsFile
in if in if
| Just True <- origIsFile -> anchorCell (CSubmissionR tid csh shn cid $ SubDownloadR SubmissionOriginal fileTitle') | Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle')
([whamlet|#{fileTitle'}|]) ([whamlet|#{fileTitle'}|])
| otherwise -> textCell $ bool (<> "/") id isFile fileTitle' | otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
, sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of , sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of
Nothing -> cell mempty Nothing -> cell mempty
Just (_, Entity _ File{..}) Just (_, Entity _ File{..})
| isJust fileContent -> anchorCell (CSubmissionR tid csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) | isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle)
([whamlet|_{MsgFileCorrected}|]) ([whamlet|_{MsgFileCorrected}|])
| otherwise -> textCell MsgFileCorrected | otherwise -> textCell MsgFileCorrected
, sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let , sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let
@ -299,22 +299,22 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
] ]
, dbtFilter = [] , dbtFilter = []
} }
mFileTable <- traverse (dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSubmissionEditHead tid csh shn setTitleI $ MsgSubmissionEditHead tid ssh csh shn
$(widgetFile "submission") $(widgetFile "submission")
getSubDownloadR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
runDB $ do runDB $ do
submissionID <- submissionMatchesSheet tid csh shn cID submissionID <- submissionMatchesSheet tid ssh csh shn cID
isRating <- maybe False (== submissionID) <$> isRatingFile path isRating <- maybe False (== submissionID) <$> isRatingFile path
when (isUpdate || isRating) $ when (isUpdate || isRating) $
guardAuthResult =<< evalAccessDB (CSubmissionR tid csh shn cID CorrectionR) False guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
case isRating of case isRating of
True True
@ -335,17 +335,18 @@ getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path =
let fileName = Text.pack $ takeFileName path let fileName = Text.pack $ takeFileName path
case results of case results of
[Entity _ File{ fileContent = Just c, fileTitle }] -> do [Entity _ File{ fileContent = Just c, fileTitle }] -> do
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] whenM downloadFiles $
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c) return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
[Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 () [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
other -> do other -> do
$logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found." error "Multiple matching files found."
getSubArchiveR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
when (sfType == SubmissionCorrected) $ when (sfType == SubmissionCorrected) $
guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False
let filename let filename
| SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType
@ -353,7 +354,7 @@ getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|] addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
respondSourceDB "application/zip" $ do respondSourceDB "application/zip" $ do
submissionID <- lift $ submissionMatchesSheet tid csh shn cID submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
rating <- lift $ getRating submissionID rating <- lift $ getRating submissionID
let let

35
src/Handler/Term.hs
View File

@ -17,11 +17,40 @@ import Handler.Utils
-- import qualified Data.Text as T -- import qualified Data.Text as T
import Yesod.Form.Bootstrap3 import Yesod.Form.Bootstrap3
-- import Colonnade hiding (bool)
import Colonnade hiding (bool)
import qualified Database.Esqueleto as E 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 :: Handler TypedContent
getTermShowR = do getTermShowR = do
-- terms <- runDB $ selectList [] [Desc TermStart] -- terms <- runDB $ selectList [] [Desc TermStart]
@ -78,7 +107,7 @@ getTermShowR = do
-- #{termToText termName} -- #{termToText termName}
-- |] -- |]
-- ] -- ]
table <- dbTable def $ DBTable ((), table) <- dbTable def $ DBTable
{ dbtSQLQuery = termData { dbtSQLQuery = termData
, dbtColonnade = colonnadeTerms , dbtColonnade = colonnadeTerms
, dbtProj = return . dbrOutput , dbtProj = return . dbrOutput

58
src/Handler/Users.hs
View File

@ -4,7 +4,7 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
module Handler.Users where module Handler.Users where
@ -12,6 +12,8 @@ import Import
-- import Data.Text -- import Data.Text
import Handler.Utils import Handler.Utils
import Utils.Lens
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
@ -29,7 +31,7 @@ hijackUserForm uid csrf = do
getUsersR :: Handler Html getUsersR :: Handler Html
getUsersR = do getUsersR = do
let let
colonnadeUsers = dbColonnade . mconcat $ dbtColonnade = dbColonnade . mconcat $
[ dbRow [ dbRow
, sortable (Just "display-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM , sortable (Just "display-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
(AdminUserR <$> encrypt uid) (AdminUserR <$> encrypt uid)
@ -40,32 +42,28 @@ getUsersR = do
-- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
-- (AdminUserR <$> encrypt uid) -- (AdminUserR <$> encrypt uid)
-- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
, sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> mempty , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
{ dbCellContents = do schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do
schools <- E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool
E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid E.orderBy [E.asc $ school E.^. SchoolShorthand]
E.orderBy [E.asc $ school E.^. SchoolShorthand] return $ school E.^. SchoolShorthand
return $ school E.^. SchoolShorthand return [whamlet|
return [whamlet| <ul .list--inline .list--comma-separated>
<ul .list--inline .list--comma-separated> $forall (E.Value sh) <- schools
$forall (E.Value sh) <- schools <li>#{sh}
<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
, sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> mempty E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool
{ dbCellContents = do E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
schools <- E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do E.orderBy [E.asc $ school E.^. SchoolShorthand]
E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool return $ school E.^. SchoolShorthand
E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid return [whamlet|
E.orderBy [E.asc $ school E.^. SchoolShorthand] <ul .list--inline .list--comma-separated>
return $ school E.^. SchoolShorthand $forall (E.Value sh) <- schools
return [whamlet| <li>#{sh}
<ul .list--inline .list--comma-separated> |]
$forall (E.Value sh) <- schools
<li>#{sh}
|]
}
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
(hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm uid (hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm uid
cID <- encrypt uid cID <- encrypt uid
@ -77,9 +75,9 @@ getUsersR = do
psValidator = def psValidator = def
& defaultSorting [("display-name", SortAsc)] & defaultSorting [("display-name", SortAsc)]
userList <- dbTable psValidator $ DBTable ((), userList) <- dbTable psValidator $ DBTable
{ dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User)) { dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
, dbtColonnade = colonnadeUsers , dbtColonnade
, dbtProj = return , dbtProj = return
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "display-name" [ ( "display-name"

14
src/Handler/Utils.hs
View File

@ -2,16 +2,16 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
module Handler.Utils module Handler.Utils
( module Handler.Utils ( module Handler.Utils
) where ) where
import Import
import Handler.Utils.DateTime as Handler.Utils import Handler.Utils.DateTime as Handler.Utils
import Handler.Utils.Term as Handler.Utils
import Handler.Utils.Form as Handler.Utils import Handler.Utils.Form as Handler.Utils
import Handler.Utils.Table as Handler.Utils import Handler.Utils.Table as Handler.Utils
import Handler.Utils.Table.Pagination as Handler.Utils import Handler.Utils.Table.Pagination as Handler.Utils
@ -21,3 +21,13 @@ import Handler.Utils.Rating as Handler.Utils hiding (extractRatings)
import Handler.Utils.Submission as Handler.Utils import Handler.Utils.Submission as Handler.Utils
import Handler.Utils.Sheet as Handler.Utils import Handler.Utils.Sheet as Handler.Utils
import Handler.Utils.Templates 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

8
src/Handler/Utils/DateTime.hs
View File

@ -57,7 +57,7 @@ getTimeLocale = getTimeLocale' <$> languages
getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
getDateTimeFormat sel = do getDateTimeFormat sel = do
mauth <- liftHandlerT maybeAuth mauth <- liftHandlerT maybeAuth
AppSettings{..} <- getsYesod appSettings AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
let let
fmt fmt
| Just (Entity _ User{..}) <- mauth | Just (Entity _ User{..}) <- mauth
@ -67,9 +67,9 @@ getDateTimeFormat sel = do
SelFormatTime -> userTimeFormat SelFormatTime -> userTimeFormat
| otherwise | otherwise
= case sel of = case sel of
SelFormatDateTime -> appDefaultDateTimeFormat SelFormatDateTime -> userDefaultDateTimeFormat
SelFormatDate -> appDefaultDateFormat SelFormatDate -> userDefaultDateFormat
SelFormatTime -> appDefaultTimeFormat SelFormatTime -> userDefaultTimeFormat
return fmt return fmt
validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat

55
src/Handler/Utils/Form.hs
View File

@ -218,17 +218,36 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific) sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific)
return . fromRational $ round (sci * 100) % 100 return . fromRational $ round (sci * 100) % 100
--termField: see Utils.Term
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
schoolField :: Field Handler SchoolId schoolField :: Field Handler SchoolId
schoolField = selectField schools schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName
where
schools = optionsPersistKey [] [Asc SchoolName] schoolName
schoolEntField :: Field Handler (Entity School) schoolFieldEnt :: Field Handler (Entity School)
schoolEntField = selectField schools schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
where
schools = optionsPersist [] [Asc SchoolName] schoolName schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
zipFileField :: Bool -- ^ Unpack zips? zipFileField :: Bool -- ^ Unpack zips?
-> Field Handler (Source Handler File) -> Field Handler (Source Handler File)
@ -354,7 +373,7 @@ utcTimeField = Field
readTime t = readTime t =
case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
(Just (LTUUnique time _)) -> Right time (Just (LTUUnique time _)) -> Right time
(Just (LTUNone time _)) -> Right time -- FIXME: Should this be an error, too? (Just (LTUNone _ _)) -> Left MsgIllDefinedUTCTime
(Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime (Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime
Nothing -> Left MsgInvalidDateTimeFormat Nothing -> Left MsgInvalidDateTimeFormat
@ -376,17 +395,29 @@ optionsPersistCryptoId :: forall site backend a msg.
=> [Filter a] => [Filter a]
-> [SelectOpt a] -> [SelectOpt a]
-> (a -> msg) -> (a -> msg)
-> HandlerT site IO (OptionList (Key a)) -> HandlerT site IO (OptionList (Entity a))
optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
mr <- getMessageRender mr <- getMessageRender
pairs <- runDB $ selectList filts ords pairs <- runDB $ selectList filts ords
cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e 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) { optionDisplay = mr (toDisplay value)
, optionInternalValue = key , optionInternalValue = e
, optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a)) , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
}) cPairs }) 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) mforced :: (site ~ HandlerSite m, MonadHandler m)
=> Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site) => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
mforced Field{..} FieldSettings{..} val = do mforced Field{..} FieldSettings{..} val = do

25
src/Handler/Utils/Sheet.hs
View File

@ -24,29 +24,30 @@ fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
, PersistQueryRead backend, PersistUniqueRead backend , PersistQueryRead backend, PersistUniqueRead backend
) )
=> (E.SqlExpr (Entity Sheet) -> b) => (E.SqlExpr (Entity Sheet) -> b)
-> TermId -> CourseShorthand -> SheetName -> ReaderT backend m a -> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a
fetchSheetAux prj tid csh shn = fetchSheetAux prj tid ssh csh shn =
let cachId = encodeUtf8 $ tshow (tid,csh,shn) let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn)
in cachedBy cachId $ do in cachedBy cachId $ do
-- Mit Yesod: -- Mit Yesod:
-- cid <- getKeyBy404 $ CourseTermShort tid csh -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-- getBy404 $ CourseSheet cid shn -- getBy404 $ CourseSheet cid shn
-- Mit Esqueleto: -- Mit Esqueleto:
sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. sheet E.^. SheetName E.==. E.val shn
return $ prj sheet return $ prj sheet
case sheetList of case sheetList of
[sheet] -> return sheet [sheet] -> return sheet
_other -> notFound _other -> notFound
fetchSheet :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet) fetchSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet)
fetchSheet = fetchSheetAux id fetchSheet = fetchSheetAux id
fetchSheetId :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet) fetchSheetId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet)
fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid ssh cid shn
fetchSheetIdCourseId :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course) fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
fetchSheetIdCourseId tid cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid cid shn fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid ssh cid shn

149
src/Handler/Utils/Submission.hs
View File

@ -25,6 +25,7 @@ module Handler.Utils.Submission
) where ) where
import Import hiding ((.=), joinPath) import Import hiding ((.=), joinPath)
import Prelude (lcm)
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
import Control.Lens import Control.Lens
@ -32,9 +33,10 @@ import Control.Lens.Extras (is)
import Utils.Lens import Utils.Lens
import Control.Monad.State hiding (forM_, mapM_,foldM) import Control.Monad.State hiding (forM_, mapM_,foldM)
import Control.Monad.Writer (MonadWriter(..)) import Control.Monad.Writer (MonadWriter(..), execWriterT)
import Control.Monad.RWS.Lazy (RWST) import Control.Monad.RWS.Lazy (RWST)
import qualified Control.Monad.Random as Rand import qualified Control.Monad.Random as Rand
import qualified System.Random.Shuffle as Rand (shuffleM)
import Data.Maybe import Data.Maybe
@ -45,11 +47,12 @@ import Data.Map (Map, (!?))
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Ratio
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Data.Monoid (Monoid, Any(..)) import Data.Monoid (Monoid, Any(..), Sum(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Handler.Utils.Rating hiding (extractRatings) import Handler.Utils.Rating hiding (extractRatings)
@ -84,46 +87,128 @@ assignSubmissions :: SheetId -- ^ Sheet do distribute to correction
, Set SubmissionId -- ^ unassigend submissions (no tutors by load) , Set SubmissionId -- ^ unassigend submissions (no tutors by load)
) )
assignSubmissions sid restriction = do assignSubmissions sid restriction = do
correctors <- selectList [SheetCorrectorSheet ==. sid] [] Sheet{..} <- getJust sid
let corrsGroup = filter hasTutorialLoad correctors -- needed as List within Esqueleto correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] []
let corrsProp = filter hasPositiveLoad correctors let
let countsToLoad' :: UserId -> Bool byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ]
countsToLoad' uid = -- refactor by simply using Map.(!) corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto
fromMaybe (error "Called `countsToLoad'` on entity not element of `corrsGroup`") $ corrsProp = filter hasPositiveLoad correctors
Map.lookup uid loadMap countsToLoad' :: UserId -> Bool
loadMap :: Map UserId Bool countsToLoad' uid = Map.findWithDefault True uid loadMap
loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsGroup] loadMap :: Map UserId Bool
loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsTutorial]
subs <- E.select . E.from $ \(submission `E.LeftOuterJoin` user) -> do 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 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 -- 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.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do
E.on (tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial) E.on (tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial)
E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser) E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser)
E.where_ (tutorial E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsGroup)) E.where_ (tutorial E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial))
return $ tutorial E.^. TutorialTutor return $ tutorial E.^. TutorialTutor
E.on $ user E.?. UserId `E.in_` E.justList tutors E.on $ tutor E.?. UserId `E.in_` E.justList tutors
E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid
E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction) E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction)
E.orderBy [E.rand] -- randomize for fair tutor distribution return (submission E.^. SubmissionId, tutor)
return (submission E.^. SubmissionId, user) -- , listToMaybe tutors)
queue <- liftIO . Rand.evalRandIO . sequence . repeat $ Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp] let subTutor' :: Map SubmissionId (Set UserId)
subTutor' = Map.fromListWith Set.union $ currentSubs
& mapped._2 %~ maybe Set.empty Set.singleton
& mapped._2 %~ Set.mapMonotonic entityKey
& mapped._1 %~ E.unValue
let subTutor' :: Map SubmissionId (Maybe UserId) prevSubs <- E.select . E.from $ \((sheet `E.InnerJoin` sheetCorrector) `E.LeftOuterJoin` submission) -> do
subTutor' = Map.fromListWith (<|>) $ map (over (_2.traverse) entityKey . over _1 E.unValue) subs 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))
subTutor <- fmap fst . flip execStateT (Map.empty, queue) . forM_ (Map.toList subTutor') $ \case let
(smid, Just tutid) -> do 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 _1 %= Map.insert smid tutid
when (any ((== tutid) . sheetCorrectorUser . entityVal) corrsProp && countsToLoad' tutid) $ _3 . at tutid %= assertM' (> 0) . maybe (-1) pred
when countsToLoad $
_2 %= List.delete (Just tutid) _2 %= List.delete (Just tutid)
(smid, Nothing) -> do
(q:qs) <- use _2 maximumDeficit :: (MonadState (_a, _b, Map UserId Integer) m, MonadIO m) => m (Maybe UserId)
_2 .= qs maximumDeficit = do
case q of transposed <- uses _3 invertMap
Just q -> _1 %= Map.insert smid q traverse (liftIO . Rand.evalRandIO . Rand.uniform . snd) (Map.lookupMax transposed)
Nothing -> return () -- NOTE: throwM NoCorrectorsByProportion
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
forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [SubmissionRatingBy =. Just tutid] forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [SubmissionRatingBy =. Just tutid]
@ -466,7 +551,7 @@ sinkMultiSubmission userId isUpdate = do
Submission{..} <- get404 sId Submission{..} <- get404 sId
Sheet{..} <- get404 submissionSheet Sheet{..} <- get404 submissionSheet
Course{..} <- get404 sheetCourse Course{..} <- get404 sheetCourse
guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseSchool courseShorthand sheetName cID CorrectionR) True
return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate
sink' <- lift $ yield val ++$$ sink sink' <- lift $ yield val ++$$ sink
case sink' of case sink' of
@ -514,10 +599,10 @@ sinkMultiSubmission userId isUpdate = do
handleCryptoID _ = return Nothing handleCryptoID _ = return Nothing
submissionMatchesSheet :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId submissionMatchesSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId
submissionMatchesSheet tid csh shn cid = do submissionMatchesSheet tid ssh csh shn cid = do
sid <- decrypt cid sid <- decrypt cid
shid <- fetchSheetId tid csh shn shid <- fetchSheetId tid ssh csh shn
Submission{..} <- get404 sid Submission{..} <- get404 sid
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet] when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
return sid return sid

236
src/Handler/Utils/Table/Pagination.hs
View File

@ -21,7 +21,7 @@
module Handler.Utils.Table.Pagination module Handler.Utils.Table.Pagination
( SortColumn(..), SortDirection(..) ( SortColumn(..), SortDirection(..)
, FilterColumn(..), IsFilterColumn , FilterColumn(..), IsFilterColumn
, DBRow(..) , DBRow(..), HasDBRow(..)
, DBStyle(..), DBEmptyStyle(..) , DBStyle(..), DBEmptyStyle(..)
, DBTable(..), IsDBTable(..), DBCell(..) , DBTable(..), IsDBTable(..), DBCell(..)
, cellAttrs, cellContents , cellAttrs, cellContents
@ -31,6 +31,7 @@ module Handler.Utils.Table.Pagination
, restrictFilter, restrictSorting , restrictFilter, restrictSorting
, ToSortable(..), Sortable(..), sortable , ToSortable(..), Sortable(..), sortable
, dbTable , dbTable
, dbTableWidget, dbTableWidget'
, widgetColonnade, formColonnade, dbColonnade , widgetColonnade, formColonnade, dbColonnade
, cell, textCell, stringCell, i18nCell , cell, textCell, stringCell, i18nCell
, anchorCell, anchorCell', anchorCellM , anchorCell, anchorCell', anchorCellM
@ -40,6 +41,7 @@ module Handler.Utils.Table.Pagination
, dbRow, dbSelect , dbRow, dbSelect
, (&) , (&)
, module Control.Monad.Trans.Maybe , module Control.Monad.Trans.Maybe
, module Colonnade
) where ) where
import Handler.Utils.Table.Pagination.Types import Handler.Utils.Table.Pagination.Types
@ -124,12 +126,51 @@ instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, Mon
| Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is | Just i' <- fromPathPiece i = go (acc `mappend` singleton i', is') is
| otherwise = go (acc, is' . (i:)) is | otherwise = go (acc, is' . (i:)) is
data PaginationSettings = PaginationSettings
{ psSorting :: [(CI Text, SortDirection)]
, psFilter :: Map (CI Text) [Text]
, psLimit :: Int64
, psPage :: Int64
, psShortcircuit :: Bool
}
makeClassy_ ''PaginationSettings
instance Default PaginationSettings where
def = PaginationSettings
{ psSorting = []
, psFilter = Map.empty
, psLimit = 50
, psPage = 0
, psShortcircuit = False
}
data PaginationInput = PaginationInput
{ piSorting :: Maybe [(CI Text, SortDirection)]
, piFilter :: Maybe (Map (CI Text) [Text])
, piLimit :: Maybe Int64
, piPage :: Maybe Int64
, piShortcircuit :: Bool
}
makeClassy_ ''PaginationInput
piIsUnset :: PaginationInput -> Bool
piIsUnset PaginationInput{..} = and
[ isNothing piSorting
, isNothing piFilter
, isNothing piLimit
, isNothing piPage
, not piShortcircuit
]
data DBRow r = DBRow data DBRow r = DBRow
{ dbrOutput :: r { dbrOutput :: r
, dbrIndex, dbrCount :: Int64 , dbrIndex, dbrCount :: Int64
} deriving (Show, Read, Eq, Ord) } deriving (Show, Read, Eq, Ord)
makeClassy_ ''DBRow
instance Functor DBRow where instance Functor DBRow where
fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. } fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. }
@ -139,6 +180,50 @@ instance Foldable DBRow where
instance Traversable DBRow where instance Traversable DBRow where
traverse f DBRow{..} = DBRow <$> f dbrOutput <*> pure dbrIndex <*> pure dbrCount 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 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 }
data DBEmptyStyle = DBESNoHeading | DBESHeading data DBEmptyStyle = DBESNoHeading | DBESHeading
deriving (Enum, Bounded, Ord, Eq, Show, Read) deriving (Enum, Bounded, Ord, Eq, Show, Read)
@ -173,82 +258,6 @@ data DBTable m x = forall a r r' h i t.
, dbtIdent :: i , dbtIdent :: i
} }
data PaginationSettings = PaginationSettings
{ psSorting :: [(CI Text, SortDirection)]
, psFilter :: Map (CI Text) [Text]
, psLimit :: Int64
, psPage :: Int64
, psShortcircuit :: Bool
}
instance Default PaginationSettings where
def = PaginationSettings
{ psSorting = []
, psFilter = Map.empty
, psLimit = 50
, psPage = 0
, psShortcircuit = False
}
data PaginationInput = PaginationInput
{ piSorting :: Maybe [(CI Text, SortDirection)]
, piFilter :: Maybe (Map (CI Text) [Text])
, piLimit :: Maybe Int64
, piPage :: Maybe Int64
, piShortcircuit :: Bool
}
piIsUnset :: PaginationInput -> Bool
piIsUnset PaginationInput{..} = and
[ isNothing piSorting
, isNothing piFilter
, isNothing piLimit
, isNothing piPage
, not piShortcircuit
]
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 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 g
where
g dbTable Nothing = over _2 (\s -> s { psFilter }) $ f dbTable Nothing
g dbTable x = f dbTable x
defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x
defaultSorting psSorting (runPSValidator -> f) = PSValidator g
where
g dbTable Nothing = over _2 (\s -> s { psSorting }) $ f dbTable Nothing
g dbTable x = f dbTable x
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 }
class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) (x :: *) where class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) (x :: *) where
type DBResult m x :: * type DBResult m x :: *
-- type DBResult' m x :: * -- type DBResult' m x :: *
@ -257,8 +266,8 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget) 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 :: 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 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) 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) 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 :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
@ -267,46 +276,46 @@ cellAttrs = dbCell . _1
cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget) cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
cellContents = dbCell . _2 cellContents = dbCell . _2
instance IsDBTable (WidgetT UniWorX IO) () where instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where
type DBResult (WidgetT UniWorX IO) () = Widget type DBResult (HandlerT UniWorX IO) x = (x, Widget)
-- type DBResult' (WidgetT UniWorX IO) () = () -- type DBResult' (WidgetT UniWorX IO) () = ()
data DBCell (WidgetT UniWorX IO) () = WidgetCell data DBCell (HandlerT UniWorX IO) x = WidgetCell
{ wgtCellAttrs :: [(Text, Text)] { wgtCellAttrs :: [(Text, Text)]
, wgtCellContents :: Widget , wgtCellContents :: WriterT x (HandlerT UniWorX IO) Widget
} }
dbCell = iso dbCell = iso
(\WidgetCell{..} -> (wgtCellAttrs, return wgtCellContents)) (\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents))
(\(attrs, mkWidget) -> WidgetCell attrs . join . fmap fst $ runWriterT mkWidget) (\(attrs, mkWidget) -> WidgetCell attrs mkWidget)
-- dbWidget Proxy Proxy = iso (, ()) $ view _1 -- dbWidget Proxy Proxy = iso (, ()) $ view _1
dbWidget _ = return dbWidget _ = return . snd
dbHandler _ f x = return $ f x dbHandler _ f = return . over _2 f
runDBTable = return . join . fmap (view _2) runDBTable act = liftHandlerT act
instance Monoid (DBCell (WidgetT UniWorX IO) ()) where instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where
mempty = WidgetCell mempty mempty mempty = WidgetCell mempty $ return mempty
(WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend c c') (WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c')
instance IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) () where instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where
type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) () = Widget type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget)
data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) () = DBCell data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBCell
{ dbCellAttrs :: [(Text, Text)] { dbCellAttrs :: [(Text, Text)]
, dbCellContents :: ReaderT SqlBackend (HandlerT UniWorX IO) Widget , dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerT UniWorX IO)) Widget
} }
dbCell = iso dbCell = iso
(\DBCell{..} -> (dbCellAttrs, lift dbCellContents)) (\DBCell{..} -> (dbCellAttrs, dbCellContents))
(\(attrs, mkWidget) -> DBCell attrs . fmap fst $ runWriterT mkWidget) (\(attrs, mkWidget) -> DBCell attrs mkWidget)
dbWidget _ = return dbWidget _ = return . snd
dbHandler _ f x = return $ f x dbHandler _ f = return . over _2 f
-- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget) -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget)
runDBTable = fmap snd . mapReaderT liftHandlerT runDBTable = mapReaderT liftHandlerT
instance Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ()) where instance Monoid x => Monoid (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) where
mempty = DBCell mempty $ return mempty mempty = DBCell mempty $ return mempty
(DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c') (DBCell a c) `mappend` (DBCell a' c') = DBCell (mappend a a') (mappend <$> c <*> c')
@ -368,7 +377,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
psResult <- runInputGetResult $ PaginationInput psResult <- runInputGetResult $ PaginationInput
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting") <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
<*> ((\m -> m <$ guard (not $ Map.null m)) . Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter) <*> ((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 "pagesize")
<*> iopt intField (wIdent "page") <*> iopt intField (wIdent "page")
<*> ireq checkBoxField (wIdent "table-only") <*> ireq checkBoxField (wIdent "table-only")
@ -448,11 +457,16 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
setParam :: Text -> Maybe Text -> QueryText -> QueryText setParam :: Text -> Maybe Text -> QueryText -> QueryText
setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ] setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
--- DBCell utility functions dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x
-> Handler (DBResult (HandlerT UniWorX IO) x)
dbTableWidget = dbTable
widgetColonnade :: Headedness h dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> Handler Widget
=> Colonnade h r (DBCell (WidgetT UniWorX IO) ()) dbTableWidget' = fmap (fmap snd) . dbTable
-> Colonnade h r (DBCell (WidgetT UniWorX IO) ())
widgetColonnade :: (Headedness h, Monoid x)
=> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
-> Colonnade h r (DBCell (HandlerT UniWorX IO) x)
widgetColonnade = id widgetColonnade = id
formColonnade :: (Headedness h, Monoid a) formColonnade :: (Headedness h, Monoid a)
@ -460,11 +474,14 @@ 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 formColonnade = id
dbColonnade :: Headedness h dbColonnade :: (Headedness h, Monoid x)
=> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ()) => Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
-> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ()) -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
dbColonnade = id dbColonnade = id
--- DBCell utility functions
cell :: IsDBTable m a => Widget -> DBCell m a cell :: IsDBTable m a => Widget -> DBCell m a
cell wgt = dbCell # ([], return wgt) cell wgt = dbCell # ([], return wgt)
@ -523,6 +540,7 @@ formCell genIndex genForm input = FormCell
return (DBFormResult . Map.singleton i . (input,) <$> edit, w) return (DBFormResult . Map.singleton i . (input,) <$> edit, w)
} }
-- Predefined colonnades -- Predefined colonnades
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a) dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)

59
src/Handler/Utils/Term.hs
View File

@ -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."
)
] ]

6
src/Import/NoFoundation.hs
View File

@ -3,8 +3,10 @@ module Import.NoFoundation
( module Import ( module Import
) where ) where
import ClassyPrelude.Yesod as Import hiding (formatTime) import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON)
import Model as Import import Model as Import
import Model.Types.JSON as Import
import Model.Migration as Import
import Settings as Import import Settings as Import
import Settings.StaticFiles as Import import Settings.StaticFiles as Import
import Yesod.Auth as Import import Yesod.Auth as Import
@ -21,3 +23,5 @@ 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 Text.Shakespeare.Text as Import hiding (text, stext)
import Data.Universe as Import

10
src/Model.hs
View File

@ -18,30 +18,24 @@ module Model
import ClassyPrelude.Yesod import ClassyPrelude.Yesod
import Database.Persist.Quasi import Database.Persist.Quasi
import Database.Persist.Postgresql (migrateEnableExtension)
import Database.Persist.Sql (Migration)
-- import Data.Time -- import Data.Time
-- import Data.ByteString -- import Data.ByteString
import Model.Types import Model.Types
import Data.Aeson.TH import Data.Aeson.TH
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import Data.CaseInsensitive.Instances ()
-- You can define all of your database entities in the entities file. -- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities -- You can find more information on persistent and how to declare entities
-- at: -- at:
-- http://www.yesodweb.com/book/persistent/ -- 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") $(persistFileWith lowerCaseSettings "models")
-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
deriving instance Eq (Unique Course) deriving instance Eq (Unique Course)
migrateAll :: Migration
migrateAll = do
migrateEnableExtension "citext"
migrateAll'
data PWEntry = PWEntry data PWEntry = PWEntry
{ pwUser :: User { pwUser :: User
, pwHash :: Text , pwHash :: Text

163
src/Model/Migration.hs Normal file
View File

@ -0,0 +1,163 @@
{-# 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 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 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);
|]
)
]
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

92
src/Model/Migration/Version.hs Normal file
View File

@ -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"

205
src/Model/Types.hs
View File

@ -8,7 +8,7 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-- # LANGUAGE ExistentialQuantification #-} -- for DA type {-- # LANGUAGE ExistentialQuantification #-} -- for DA type
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
module Model.Types where module Model.Types where
@ -16,37 +16,65 @@ import ClassyPrelude
import Utils import Utils
import Control.Lens import Control.Lens
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Map as Map
import Data.Fixed 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.Class
import Database.Persist.Sql import Database.Persist.Sql
import Web.HttpApiData import Web.HttpApiData
import Web.PathPieces
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text import qualified Data.Text.Lens as Text
import Text.Read (readMaybe,readsPrec)
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Data.CaseInsensitive.Instances ()
import Yesod.Core.Dispatch (PathPiece(..)) import Yesod.Core.Dispatch (PathPiece(..))
import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..)) import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
import Data.Aeson.TH (deriveJSON, defaultOptions) import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..))
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Text.Shakespeare.I18N (ToMessage(..), RenderMessage(..))
import Text.Blaze (ToMarkup(..)) instance PathPiece UUID where
import Yesod.Core.Widget (ToWidget(..)) 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 type Points = Centi
@ -74,32 +102,27 @@ instance DisplayAble SheetType where
display (NotGraded) = "Unbewertet" display (NotGraded) = "Unbewertet"
deriveJSON defaultOptions ''SheetType deriveJSON defaultOptions ''SheetType
derivePersistFieldJSON "SheetType" derivePersistFieldJSON ''SheetType
data SheetTypeSummary = SheetTypeSummary data SheetTypeSummary = SheetTypeSummary
{ sumBonusPoints :: Points { sumBonusPoints :: Sum Points
, sumNormalPoints :: Points , sumNormalPoints :: Sum Points
, numPassSheets :: Int , numPassSheets :: Sum Int
, numNotGraded :: Int , numNotGraded :: Sum Int
, achievedBonus :: Maybe Points , achievedBonus :: Maybe (Sum Points)
, achievedNormal :: Maybe Points , achievedNormal :: Maybe (Sum Points)
, achievedPasses :: Maybe Int , achievedPasses :: Maybe (Sum Int)
} } deriving (Generic)
instance Monoid SheetTypeSummary where
mempty = memptydefault
mappend = mappenddefault
emptySheetTypeSummary :: SheetTypeSummary sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary
emptySheetTypeSummary = SheetTypeSummary 0 0 0 0 Nothing Nothing Nothing sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum maxPoints, achievedBonus = Sum <$> achieved }
sheetTypeSum (Normal{..}, achieved) = mempty { sumNormalPoints = Sum maxPoints, achievedNormal = Sum <$> achieved }
-- TODO: refactor with lenses! sheetTypeSum (Pass{..}, achieved) = mempty { numPassSheets = Sum 1, achievedPasses = Sum . bool 0 1 . (passingPoints <=) <$> achieved}
sumSheetTypes :: SheetTypeSummary -> (SheetType, Maybe Points) -> SheetTypeSummary sheetTypeSum (NotGraded, _ ) = mempty { numNotGraded = Sum 1 }
sumSheetTypes sts@(SheetTypeSummary {..}) (Bonus {..}, achieved)
= sts{ sumBonusPoints =sumBonusPoints +maxPoints, achievedBonus = maybeAdd achievedBonus achieved }
sumSheetTypes sts@(SheetTypeSummary {..}) (Normal {..}, achieved)
= sts{ sumNormalPoints=sumNormalPoints+maxPoints, achievedNormal = maybeAdd achievedNormal achieved }
sumSheetTypes sts@(SheetTypeSummary {..}) (Pass {..}, achieved)
= sts{ numPassSheets=numPassSheets+1, achievedPasses = maybeAdd achievedPasses (bool 0 1 <$> (passingPoints <=) <$> achieved) }
sumSheetTypes sts@(SheetTypeSummary {..}) (NotGraded, _achieved)
= sts{ numNotGraded=numNotGraded+1 }
data SheetGroup data SheetGroup
@ -108,21 +131,21 @@ data SheetGroup
| NoGroups | NoGroups
deriving (Show, Read, Eq) deriving (Show, Read, Eq)
deriveJSON defaultOptions ''SheetGroup deriveJSON defaultOptions ''SheetGroup
derivePersistFieldJSON "SheetGroup" derivePersistFieldJSON ''SheetGroup
enumFromPathPiece :: (PathPiece a, Enum a, Bounded a) => Text -> Maybe a
enumFromPathPiece t = lookup (CI.mk t) [(CI.mk $ toPathPiece ty,ty) | ty <- [minBound..maxBound]]
data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
deriving (Show, Read, Eq, Ord, Enum, Bounded) deriving (Show, Read, Eq, Ord, Enum, Bounded)
derivePersistField "SheetFileType" derivePersistField "SheetFileType"
instance Universe SheetFileType where universe = universeDef
instance Finite SheetFileType
instance PathPiece SheetFileType where instance PathPiece SheetFileType where
toPathPiece SheetExercise = "file" toPathPiece SheetExercise = "file"
toPathPiece SheetHint = "hint" toPathPiece SheetHint = "hint"
toPathPiece SheetSolution = "solution" toPathPiece SheetSolution = "solution"
toPathPiece SheetMarking = "marking" toPathPiece SheetMarking = "marking"
fromPathPiece = enumFromPathPiece fromPathPiece = finiteFromPathPiece
-- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType) -- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
@ -135,22 +158,14 @@ instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instan
-- partitionFileType' = groupMap -- partitionFileType' = groupMap
partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a
partitionFileType fts = partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs
let (se,sh,ss,sm) = foldl' switchft (Set.empty,Set.empty,Set.empty,Set.empty) fts
in \case SheetExercise -> se
SheetHint -> sh
SheetSolution -> ss
SheetMarking -> sm
where
switchft :: Ord a => (Set a, Set a, Set a, Set a) -> (SheetFileType,a) -> (Set a, Set a, Set a, Set a)
switchft (se,sh,ss,sm) (SheetExercise,x) = (Set.insert x se, sh, ss, sm)
switchft (se,sh,ss,sm) (SheetHint ,x) = (se, Set.insert x sh, ss, sm)
switchft (se,sh,ss,sm) (SheetSolution,x) = (se, sh, Set.insert x ss, sm)
switchft (se,sh,ss,sm) (SheetMarking ,x) = (se, sh, ss, Set.insert x sm)
data SubmissionFileType = SubmissionOriginal | SubmissionCorrected data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
deriving (Show, Read, Eq, Ord, Enum, Bounded) deriving (Show, Read, Eq, Ord, Enum, Bounded)
instance Universe SubmissionFileType where universe = universeDef
instance Finite SubmissionFileType
submissionFileTypeIsUpdate :: SubmissionFileType -> Bool submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
submissionFileTypeIsUpdate SubmissionOriginal = False submissionFileTypeIsUpdate SubmissionOriginal = False
submissionFileTypeIsUpdate SubmissionCorrected = True submissionFileTypeIsUpdate SubmissionCorrected = True
@ -162,7 +177,7 @@ isUpdateSubmissionFileType True = SubmissionCorrected
instance PathPiece SubmissionFileType where instance PathPiece SubmissionFileType where
toPathPiece SubmissionOriginal = "original" toPathPiece SubmissionOriginal = "original"
toPathPiece SubmissionCorrected = "corrected" toPathPiece SubmissionCorrected = "corrected"
fromPathPiece = enumFromPathPiece fromPathPiece = finiteFromPathPiece
instance DisplayAble SubmissionFileType where instance DisplayAble SubmissionFileType where
display SubmissionOriginal = "Abgabe" display SubmissionOriginal = "Abgabe"
@ -322,36 +337,27 @@ data StudyFieldType = FieldPrimary | FieldSecondary
deriving (Eq, Ord, Enum, Show, Read, Bounded) deriving (Eq, Ord, Enum, Show, Read, Bounded)
derivePersistField "StudyFieldType" derivePersistField "StudyFieldType"
data Theme
= ThemeDefault
| ThemeLavender
| ThemeNeutralBlue
| ThemeAberdeenReds
| ThemeMossGreen
| ThemeSkyLove
deriving (Eq, Ord, Bounded, Enum, Show, Read)
-- Skins / Themes deriveJSON defaultOptions
data Theme --Simply add Themes to this type only. CamelCase will be converted to "-lower" { constructorTagModifier = fromJust . stripPrefix "Theme"
= Default } ''Theme
| Lavender
| NeutralBlue
| AberdeenReds -- e.g. turned into "theme--aberdeen-reds"
| MossGreen
| SkyLove
deriving (Eq,Ord,Bounded,Enum)
$(deriveJSON defaultOptions ''Theme) instance Universe Theme where universe = universeDef
$(deriveShowWith uncamel ''Theme) -- show for internal use in css/js instance Finite Theme
$(deriveSimpleWith ''DisplayAble 'display camelSpace ''Theme) -- display to display at user
allThemes :: [Theme] instance PathPiece Theme where
allThemes = [minBound..maxBound] toPathPiece = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
fromPathPiece = finiteFromPathPiece
readTheme :: Map String Theme $(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
readTheme = Map.fromList [ (show t,t) | t <- allThemes ]
instance Read Theme where -- generic Read-Instance for Show/Bounded
readsPrec _ s
| (Just t) <- (Map.lookup s readTheme) = [(t,"")]
| otherwise = [(Default,"")] -- read shall always succeed
{-
instance Default Theme where
def = Default
-}
derivePersistField "Theme" derivePersistField "Theme"
@ -370,41 +376,28 @@ data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
deriving (Eq, Ord, Read, Show, Enum, Bounded) deriving (Eq, Ord, Read, Show, Enum, Bounded)
instance PersistField (CI Text) where data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText deriving (Eq, Ord, Read, Show, Enum, Bounded)
fromPersistValue (PersistDbSpecific bs) = Right . CI.mk $ Text.decodeUtf8 bs
fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
instance PersistField (CI String) where deriveJSON defaultOptions
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 . pack $ CI.original ciText { constructorTagModifier = fromJust . stripPrefix "Corrector"
fromPersistValue (PersistDbSpecific bs) = Right . CI.mk . unpack $ Text.decodeUtf8 bs } ''CorrectorState
fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
instance PersistFieldSql (CI Text) where
sqlType _ = SqlOther "citext"
instance ToJSON a => ToJSON (CI a) where instance Universe CorrectorState where universe = universeDef
toJSON = toJSON . CI.original instance Finite CorrectorState
instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where instance PathPiece CorrectorState where
parseJSON = fmap CI.mk . parseJSON toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
fromPathPiece = finiteFromPathPiece
instance ToMessage a => ToMessage (CI a) where derivePersistField "CorrectorState"
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
-- Type synonyms -- Type synonyms
type SheetName = CI Text type SchoolName = CI Text
type SchoolShorthand = CI Text
type CourseName = CI Text
type CourseShorthand = CI Text type CourseShorthand = CI Text
type CourseName = CI Text type SheetName = CI Text
type UserEmail = CI Text type UserEmail = CI Text

56
src/Model/Types/JSON.hs Normal file
View File

@ -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"|]) []
]
]
]

72
src/Settings.hs
View File

@ -31,6 +31,12 @@ import qualified Data.Text.Encoding as Text
import qualified Ldap.Client as Ldap import qualified Ldap.Client as Ldap
import Utils
import Control.Lens
import Data.Maybe (fromJust)
import qualified Data.Char as Char
import Model import Model
-- | Runtime settings to configure this application. These settings can be -- | Runtime settings to configure this application. These settings can be
@ -42,6 +48,7 @@ data AppSettings = AppSettings
, appDatabaseConf :: PostgresConf , appDatabaseConf :: PostgresConf
-- ^ Configuration settings for accessing the database. -- ^ Configuration settings for accessing the database.
, appLdapConf :: Maybe LdapConf , appLdapConf :: Maybe LdapConf
-- ^ Configuration settings for accessing the LDAP-directory
, appRoot :: Maybe Text , appRoot :: Maybe Text
-- ^ Base for all generated URLs. If @Nothing@, determined -- ^ Base for all generated URLs. If @Nothing@, determined
-- from the request headers. -- from the request headers.
@ -63,29 +70,37 @@ data AppSettings = AppSettings
-- ^ Assume that files in the static dir may change after compilation -- ^ Assume that files in the static dir may change after compilation
, appSkipCombining :: Bool , appSkipCombining :: Bool
-- ^ Perform no stylesheet/script combining -- ^ Perform no stylesheet/script combining
, appDefaultTheme :: Theme
, appDefaultMaxFavourites :: Int
, appDefaultDateTimeFormat :: DateTimeFormat
, appDefaultDateFormat :: DateTimeFormat
, appDefaultTimeFormat :: DateTimeFormat
-- 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
, appAuthDummyLogin :: Bool , appAuthDummyLogin :: Bool
-- ^ Indicate if auth dummy login should be enabled. -- ^ Indicate if auth dummy login should be enabled.
, appAuthPWFile :: Maybe FilePath
-- ^ If set authenticate against a local password file
, appAllowDeprecated :: Bool , appAllowDeprecated :: Bool
-- ^ Indicate if deprecated routes are accessible for everyone -- ^ Indicate if deprecated routes are accessible for everyone
, appAuthPWFile :: Maybe FilePath
-- ^ If set authenticate against a local password file
, appMinimumLogLevel :: LogLevel
, appUserDefaults :: UserDefaultConf
, appCryptoIDKeyFile :: FilePath
} }
data UserDefaultConf = UserDefaultConf
{ userDefaultTheme :: Theme
, userDefaultMaxFavourites :: Int
, userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
, userDefaultDownloadFiles :: Bool
}
instance FromJSON UserDefaultConf where
parseJSON = withObject "UserDefaultConf" $ \o -> do
userDefaultTheme <- o .: "theme"
userDefaultMaxFavourites <- o .: "favourites"
userDefaultDateTimeFormat <- o .: "date-time-format"
userDefaultDateFormat <- o .: "date-format"
userDefaultTimeFormat <- o .: "time-format"
userDefaultDownloadFiles <- o .: "download-files"
return UserDefaultConf{..}
data LdapConf = LdapConf data LdapConf = LdapConf
{ ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber { ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber
, ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
@ -115,6 +130,13 @@ instance FromJSON LdapConf where
ldapTimeout <- o .: "timeout" ldapTimeout <- o .: "timeout"
return LdapConf{..} return LdapConf{..}
deriveFromJSON
defaultOptions
{ constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level"
, sumEncoding = UntaggedValue
}
''LogLevel
instance FromJSON AppSettings where instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do parseJSON = withObject "AppSettings" $ \o -> do
let defaultDev = let defaultDev =
@ -128,7 +150,7 @@ instance FromJSON AppSettings where
let nonEmptyHost LdapConf{..} = case ldapHost of let nonEmptyHost LdapConf{..} = case ldapHost of
Ldap.Tls host _ -> not $ null host Ldap.Tls host _ -> not $ null host
Ldap.Plain host -> not $ null host Ldap.Plain host -> not $ null host
appLdapConf <- (>>= (\c -> c <$ guard (nonEmptyHost c))) <$> o .:? "ldap" appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap"
appRoot <- o .:? "approot" appRoot <- o .:? "approot"
appHost <- fromString <$> o .: "host" appHost <- fromString <$> o .: "host"
appPort <- o .: "port" appPort <- o .: "port"
@ -136,24 +158,18 @@ instance FromJSON AppSettings where
appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
appShouldLogAll <- o .:? "should-log-all" .!= defaultDev appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
appMinimumLogLevel <- o .: "minimum-log-level"
appReloadTemplates <- o .:? "reload-templates" .!= defaultDev appReloadTemplates <- o .:? "reload-templates" .!= defaultDev
appMutableStatic <- o .:? "mutable-static" .!= defaultDev appMutableStatic <- o .:? "mutable-static" .!= defaultDev
appSkipCombining <- o .:? "skip-combining" .!= defaultDev appSkipCombining <- o .:? "skip-combining" .!= defaultDev
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
appAuthPWFile <- assertM (not . null) <$> o .:? "auth-pwfile"
appDefaultMaxFavourites <- o .: "default-favourites" appUserDefaults <- o .: "user-defaults"
appDefaultTheme <- o .: "default-theme"
appDefaultDateTimeFormat <- o .: "default-date-time-format"
appDefaultDateFormat <- o .: "default-date-format"
appDefaultTimeFormat <- o .: "default-time-format"
appCopyright <- o .: "copyright"
appAnalytics <- o .:? "analytics"
appCryptoIDKeyFile <- o .: "cryptoid-keyfile" appCryptoIDKeyFile <- o .: "cryptoid-keyfile"
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
appAuthPWFile <- ((\f -> f <$ guard (not $ null f)) =<<) <$> o .:? "auth-pwfile"
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
return AppSettings {..} return AppSettings {..}
-- | Settings for 'widgetFile', such as which template languages to support and -- | Settings for 'widgetFile', such as which template languages to support and

42
src/Utils.hs
View File

@ -15,16 +15,15 @@ module Utils
import ClassyPrelude.Yesod import ClassyPrelude.Yesod
-- import Data.Double.Conversion.Text -- faster implementation for textPercent? -- import Data.Double.Conversion.Text -- faster implementation for textPercent?
import Data.List (foldl)
import Data.Foldable as Fold import Data.Foldable as Fold
import qualified Data.Char as Char
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Utils.DB as Utils import Utils.DB as Utils
import Utils.Common as Utils import Utils.TH as Utils
import Utils.DateTime as Utils import Utils.DateTime as Utils
import Utils.PathPiece as Utils
import Text.Blaze (Markup, ToMarkup) import Text.Blaze (Markup, ToMarkup)
@ -87,6 +86,11 @@ unsupportedAuthPredicate = do
tickmark :: IsString a => a tickmark :: IsString a => a
tickmark = fromString "✔" tickmark = fromString "✔"
-- Avoid annoying warnings:
tickmarkS :: String
tickmarkS = tickmark
tickmarkT :: Text
tickmarkT = tickmark
text2Html :: Text -> Html text2Html :: Text -> Html
text2Html = toHtml -- prevents ambiguous types text2Html = toHtml -- prevents ambiguous types
@ -95,10 +99,15 @@ toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
a -> WidgetT site m () a -> WidgetT site m ()
toWgt = toWidget . toHtml toWgt = toWidget . toHtml
-- Convenience Functions to avoid type signatures:
text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
Text -> WidgetT site m () Text -> WidgetT site m ()
text2widget t = [whamlet|#{t}|] 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) => str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) =>
String -> WidgetT site m () String -> WidgetT site m ()
str2widget s = [whamlet|#{s}|] str2widget s = [whamlet|#{s}|]
@ -109,24 +118,6 @@ withFragment :: ( Monad m
withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget) withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
uncamel :: String -> String -- "Model.Theme.CamelCaseThing" -> "camel-case-thing"
uncamel = ("theme-" ++) . reverse . foldl helper []
where
helper _ '.' = []
helper acc c
| Char.isSpace c = acc
| Char.isUpper c = Char.toLower c : '-' : acc
| otherwise = c : acc
camelSpace :: String -> String -- "Model.Theme.CamelCaseThing" -> "Camel Case Thing"
camelSpace = reverse . foldl helper []
where
helper _ '.' = []
helper acc c
| Char.isSpace c = acc
| Char.isUpper c = c : ' ' : acc
| otherwise = c : acc
-- Convert anything to Text, and I don't care how -- Convert anything to Text, and I don't care how
class DisplayAble a where class DisplayAble a where
display :: a -> Text display :: a -> Text
@ -216,6 +207,9 @@ groupMap l = Map.fromListWith mappend $ [(k, Set.singleton v) | (k,v) <- l]
partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v
partMap = Map.fromListWith mappend partMap = Map.fromListWith mappend
invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k)
invertMap = groupMap . map swap . Map.toList
----------- -----------
-- Maybe -- -- Maybe --
----------- -----------
@ -302,6 +296,12 @@ shortCircuitM sc mx my op = do
guardM :: MonadPlus m => m Bool -> m () guardM :: MonadPlus m => m Bool -> m ()
guardM f = guard =<< f 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 -- Some Utility Functions from Agda.Utils.Monad
-- | Monadic if-then-else. -- | Monadic if-then-else.
ifM :: Monad m => m Bool -> m a -> m a -> m a ifM :: Monad m => m Bool -> m a -> m a -> m a

51
src/Utils/PathPiece.hs Normal file
View File

@ -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 :: Text -> [Text]
splitCamel = map Text.pack . reverse . helper (error "hasChange undefined at start of string") [] "" . Text.unpack
where
helper hadChange words thisWord [] = reverse thisWord : words
helper hadChange words [] (c:cs) = helper True words [c] cs
helper hadChange words ws@(w:ws') (c:cs)
| sameCategory w c
, null ws' = helper False words (c:ws) cs
| sameCategory w c = helper hadChange words (c:ws) cs
| null ws' = helper True words (c:ws) cs
| not hadChange = helper True (reverse ws':words) [c,w] cs
| otherwise = helper True (reverse ws:words) [c] cs
sameCategory = (==) `on` Char.generalCategory

7
src/Utils/Common.hs → src/Utils/TH.hs
View File

@ -1,7 +1,7 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
module Utils.Common where module Utils.TH where
-- Common Utility Functions that require TemplateHaskell -- Common Utility Functions that require TemplateHaskell
-- import Data.Char -- import Data.Char
@ -17,13 +17,14 @@ import Language.Haskell.TH
------------ ------------
-- Alternatively uses lenses: "^. _3" projects the 3rd component of an n-tuple for any n >=3, requires import Control.Lens -- 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 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) -- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
projNI n i = lamE [pat] rhs projNI n i = lamE [pat] rhs
where pat = tupP (map varP xs) where pat = tupP (map varP xs)
rhs = varE (xs !! (i - 1)) rhs = varE (xs !! (i - 1))
xs = [ mkName $ "x" ++ show j | j <- [1..n] ] xs = [ mkName $ "x" ++ show j | j <- [1..n] ]
-}
--------------- ---------------
-- Functions -- -- Functions --
@ -73,7 +74,7 @@ deriveSimpleWith cls fun strOp ty = do
genClause :: Con -> Q Clause genClause :: Con -> Q Clause
genClause (NormalC name []) = genClause (NormalC name []) =
let pats = [ConP name []] let pats = [ConP name []]
body = NormalB $ LitE $ StringL $ strOp $ show $ name body = NormalB $ LitE $ StringL $ strOp $ nameBase name
in return $ Clause pats body [] in return $ Clause pats body []
genClause _ = fail "deriveShowTheme: constructors not allowed to have arguments" genClause _ = fail "deriveShowTheme: constructors not allowed to have arguments"

92
src/index.md Normal file
View File

@ -0,0 +1,92 @@
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.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.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

2
stack.yaml
View File

@ -34,4 +34,6 @@ extra-deps:
- system-locale-0.3.0.0 - system-locale-0.3.0.0
- persistent-2.7.3.1
resolver: lts-10.5 resolver: lts-10.5

13
start.sh
View File

@ -7,4 +7,15 @@ export DUMMY_LOGIN=true
export ALLOW_DEPRECATED=true export ALLOW_DEPRECATED=true
export PWFILE=users.yml 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

4
templates/course.hamlet
View File

@ -6,7 +6,7 @@
<div> <div>
#{schoolName school} #{schoolName school}
$maybe descr <- courseDescription course $maybe descr <- courseDescription course
<dt .deflist__dt>Beschreibung <dt .deflist__dt>_{MsgCourseDescription}
<dd .deflist__dd> <dd .deflist__dd>
<div> <div>
#{descr} #{descr}
@ -33,7 +33,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
<dt .deflist__dt> <dt .deflist__dt>
<dd .deflist__dd> <dd .deflist__dd>
<div .course__registration> <div .course__registration>
<form method=post action=@{CourseR tid csh CRegisterR} enctype=#{regEnctype}> <form method=post action=@{CourseR tid ssh csh CRegisterR} enctype=#{regEnctype}>
$# regWidget is defined through templates/widgets/registerForm $# regWidget is defined through templates/widgets/registerForm
^{regWidget} ^{regWidget}
<dt .deflist__dt> <dt .deflist__dt>

14
templates/default-layout-wrapper.hamlet
View File

@ -39,21 +39,9 @@ $newline never
} }
<body .no-js .#{currentTheme} :isAuth:.logged-in> <body .no-js .theme--#{toPathPiece currentTheme} :isAuth:.logged-in>
<!-- removes no-js class from body if client supports javascript --> <!-- removes no-js class from body if client supports javascript -->
<script> <script>
document.body.classList.remove('no-js'); document.body.classList.remove('no-js');
^{pageBody pc} ^{pageBody pc}
$maybe analytics <- appAnalytics $ appSettings master
<script>
if(!window.location.href.match(/localhost/)){
(function(i,s,o,g,r,a,m){i['GoogleAnalyticsObject']=r;i[r]=i[r]||function(){
(i[r].q=i[r].q||[]).push(arguments)},i[r].l=1*new Date();a=s.createElement(o),
m=s.getElementsByTagName(o)[0];a.async=1;a.src=g;m.parentNode.insertBefore(a,m)
})(window,document,'script','https://www.google-analytics.com/analytics.js','ga');
ga('create', '#{analytics}', 'auto');
ga('send', 'pageview');
}

14
templates/profile.hamlet
View File

@ -27,16 +27,16 @@
<dt .deflist__dt> Eigene Kurse <dt .deflist__dt> Eigene Kurse
<dd .deflist__dd> <dd .deflist__dd>
<ul .list-ul> <ul .list-ul>
$forall (E.Value csh, E.Value tid) <- lecture_owner $forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_owner
<li .list-ul__item> <li .list-ul__item>
<a href=@{CourseR tid csh CShowR}>#{display tid} - #{csh} <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
$if not $ null lecture_corrector $if not $ null lecture_corrector
<dt .deflist__dt> Korrektor <dt .deflist__dt> Korrektor
<dd .deflist__dd> <dd .deflist__dd>
<ul .list-ul> <ul .list-ul>
$forall (E.Value csh, E.Value tid) <- lecture_corrector $forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_corrector
<li .list-ul__item> <li .list-ul__item>
<a href=@{CourseR tid csh CShowR}>#{display tid} - #{csh} <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
$if not $ null studies $if not $ null studies
<dt .deflist__dt> Studiengänge <dt .deflist__dt> Studiengänge
<dd .deflist__dd> <dd .deflist__dd>
@ -59,10 +59,10 @@
<dt .deflist__dt> Teilnehmer <dt .deflist__dt> Teilnehmer
<dd .deflist__dd> <dd .deflist__dd>
<dl .deflist> <dl .deflist>
$forall (E.Value csh, E.Value tid, regSince) <- participant $forall (E.Value tid, E.Value ssh, E.Value csh, regSince) <- participant
<dt .deflist__dt> <dt .deflist__dt>
<a href=@{CourseR tid csh CShowR}>#{display tid} - #{csh} <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
<dd .deflist__dd> <dd .deflist__dd>
seit #{display regSince} seit #{display regSince}
^{settingsForm} ^{settingsForm}

6
templates/profile.julius
View File

@ -1,6 +1,6 @@
document.addEventListener('DOMContentLoaded', function () { document.addEventListener('DOMContentLoaded', function () {
var themeSelector = document.querySelector('[placeholder="theme-select"]'); var themeSelector = document.querySelector('#theme-select');
themeSelector.addEventListener('change', function() { themeSelector.addEventListener('change', function() {
// get rid of old themes on body // get rid of old themes on body
var options = Array.from(themeSelector.options) var options = Array.from(themeSelector.options)
@ -8,10 +8,10 @@ document.addEventListener('DOMContentLoaded', function () {
document.body.classList.remove(optionToTheme(option)); document.body.classList.remove(optionToTheme(option));
}); });
// add newly selected theme // add newly selected theme
document.body.classList.add(optionToTheme(themeSelector.options[themeSelector.value - 1])); document.body.classList.add(optionToTheme(themeSelector.selectedOptions[0]));
}); });
function optionToTheme(option) { function optionToTheme(option) {
return optionValue = 'theme--' + option.innerText.toLowerCase().trim().replace(/\s/g, '-'); return optionValue = 'theme--' + option.value;
} }
}); });

7
templates/profileData.hamlet
View File

@ -8,6 +8,11 @@
<em> TODO: Hier alle Daten in Tabellen anzeigen! <em> TODO: Hier alle Daten in Tabellen anzeigen!
<div .container>
<h2> Kursanmeldungen
<div .container>
^{courseTable}
<h2> <h2>
<em> TODO: Knopf zum Löschen aller Daten erstellen <em> TODO: Knopf zum Löschen aller Daten erstellen
@ -19,7 +24,7 @@
Alle Daten des Systems werden nach Abschluss des Testbetriebs von Uni2work Alle Daten des Systems werden nach Abschluss des Testbetriebs von Uni2work
unwiderruflich gelöscht werden! (Voraussichtlich ein paar Wochen vor Beginn des Wintersemesters 18/19, spätestens aber im Dezember 2018.) unwiderruflich gelöscht werden! (Voraussichtlich ein paar Wochen vor Beginn des Wintersemesters 18/19, spätestens aber im Dezember 2018.)
<li> <li>
Nicht aufgeführt sind Zeitstempel mit Benutzerinformationen, z.B. bei der Editierung und Korrekturen von Übungen, Übungsgruppenleiterschaft, Raumbuchungen, etc. Nicht aufgeführt sind Zeitstempel mit Benutzerinformationen, z.B. bei der Editierung und Korrektur von Übungen, Übungsgruppenleiterschaft, Raumbuchungen, etc.
<li> <li>
Benutzerdaten bleiben so lange gespeichert, bis ein Institutsadministrator über die Exmatrikulation informiert wurde. Dann wird der Account gelöscht. Benutzerdaten bleiben so lange gespeichert, bis ein Institutsadministrator über die Exmatrikulation informiert wurde. Dann wird der Account gelöscht.
Abgaben/Bonuspunkte werden unwiderruflich gelöscht. Abgaben/Bonuspunkte werden unwiderruflich gelöscht.

4
templates/submission.hamlet
View File

@ -1,8 +1,8 @@
$maybe cID <- mcid $maybe cID <- mcid
<section> <section>
<h2> <h2>
<a href=@{CSubmissionR tid csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))}>Archiv <a href=@{CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))}>Archiv
(<a href=@{CSubmissionR tid csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))}>Original</a>) (<a href=@{CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))}>Original</a>)
$if not (null lastEdits) $if not (null lastEdits)
<h3>_{MsgLastEdits} <h3>_{MsgLastEdits}
<ul> <ul>

8
templates/widgets/pageactionprime.hamlet
View File

@ -4,7 +4,13 @@ $if hasPageActions
<ul .pagenav__list> <ul .pagenav__list>
$forall menuType <- menuTypes $forall menuType <- menuTypes
$case menuType $case menuType
$of PageActionPrime (MenuItem label mIcon route _) $of PageActionPrime (MenuItem label _mIcon route _callback)
<li .pagenav__list-item>
<a .pagenav__link-wrapper href=@{route}>#{label}
$of _
$forall menuType <- menuTypes
$case menuType
$of PageActionSecondary (MenuItem label _mIcon route _callback)
<li .pagenav__list-item> <li .pagenav__list-item>
<a .pagenav__link-wrapper href=@{route}>#{label} <a .pagenav__link-wrapper href=@{route}>#{label}
$of _ $of _

2
templates/widgets/rating.hamlet
View File

@ -13,4 +13,4 @@ $maybe points <- submissionRatingPoints
$else $else
_{MsgNotPassed} _{MsgNotPassed}
$of NotGraded $of NotGraded
#{show tickmark} #{display tickmarkS}

26
templates/widgets/sheetTypeSummary.hamlet
View File

@ -1,23 +1,23 @@
<div> <div>
$if 0 < sumNormalPoints sheetTypeSummary $if 0 < getSum sumNormalPoints
Gesamtpunktzahl #{display (sumNormalPoints sheetTypeSummary)} Gesamtpunktzahl #{display (getSum sumNormalPoints)}
$maybe nPts <- (maybeAdd (achievedNormal sheetTypeSummary) (achievedBonus sheetTypeSummary)) $maybe nPts <- (maybeAdd (getSum <$> achievedNormal) (getSum <$> achievedBonus))
\ davon #{display nPts} erreicht \ davon #{display nPts} erreicht
$maybe bPts <- achievedBonus sheetTypeSummary $maybe bPts <- getSum <$> achievedBonus
\ (inklusive #{display bPts} # \ (inklusive #{display bPts} #
$if 0 < sumBonusPoints sheetTypeSummary $if 0 < getSum sumBonusPoints
von #{display $ sumBonusPoints sheetTypeSummary} erreichbaren # von #{display $ getSum sumBonusPoints} erreichbaren #
Bonuspunkten) Bonuspunkten)
\ #{textPercent $ realToFrac $ nPts / (sumNormalPoints sheetTypeSummary)} \ #{textPercent $ realToFrac $ nPts / (getSum sumNormalPoints)}
<div> <div>
$if 0 < numPassSheets sheetTypeSummary $if 0 < getSum numPassSheets
Blätter zum Bestehen: #{display (numPassSheets sheetTypeSummary)} Blätter zum Bestehen: #{display (getSum numPassSheets)}
$maybe passed <- achievedPasses sheetTypeSummary $maybe passed <- getSum <$> achievedPasses
\ davon #{display (achievedPasses sheetTypeSummary)} bestanden. \ davon #{display passed} bestanden.
<div> <div>
$if 0 < numNotGraded sheetTypeSummary $if 0 < getSum numNotGraded
Unbewertet: #{display (numNotGraded sheetTypeSummary)} Blätter Unbewertet: #{display (getSum numNotGraded)} Blätter

25
testdata/H10-2.hs vendored Normal file
View File

@ -0,0 +1,25 @@
{- Übung H10-2 zur Vorlesung "Programmierung und Modellierung"
Lehrstuhl für theoretische Informatik, LMU München
Steffen Jost, Leah Neukirchen
-}
import Control.Monad
chainAction1 :: Monad m => a -> [(a -> m a)] -> m a
chainAction1 = undefined -- !!! TODO !!!
chainAction2 :: Monad m => a -> [(a -> m a)] -> m a
chainAction2 = undefined -- !!! TODO !!!
chainAction3 :: Monad m => a-> [(a -> m a)] -> m a
chainAction3 = undefined -- !!! TODO !!!
tellOp :: (Show a, Show b) => (a -> b) -> a -> IO b
tellOp f x = let fx = f x in do
putStrLn $ (show x) ++ " -> " ++ (show fx)
return fx
test1 :: [Int -> IO Int]
test1 = map tellOp [(*3),(+1),(`mod` 7),(+5),(*2)]

84
testdata/H10-3.hs vendored Normal file
View File

@ -0,0 +1,84 @@
{- Übung H10-3 zur Vorlesung "Programmierung und Modellierung"
Lehrstuhl für theoretische Informatik, LMU München
Steffen Jost, Leah Neukirchen
Bitte nur die Zeilen mit
error "TODO" -- TODO: Ihre Aufgabe !!!
bearbeiten.
(Sie dürfen an diesen Stellen auch beliebig
viele neue Zeilen einfügen.)
Entweder mit ghc kompilieren und ausführen oder
einfach in ghci laden und main auswerten.
-}
import Control.Monad.Trans.State
type Wetter = String
data Welt = Welt { zeit :: Int, wetter :: Wetter }
deriving Show
main =
let startState = Welt { zeit=0, wetter="Regen" }
(result,finalState) = runState actions startState
in do
putStrLn "Zustand Welt bei Start ist: "
print startState
putStrLn "Zustand Welt bei Ende ist: "
print finalState
putStrLn "Ergebnis der Aktion ist: "
print result
actions :: State Welt [(String,Int)]
actions = do
tick
tick
tick
tick
wetter1 <- swapWetter "Sonne"
zeit1 <- gets zeit
let r1 = (wetter1, zeit1)
tick
tick
wetter2 <- swapWetter "Sturm"
zeit2 <- zeit <$> get
let r2 = (wetter2, zeit2)
tick
return [r1,r2]
--- !!! NUR AB HIER BEARBEITEN !!!
tick :: State Welt ()
tick =
error "TODO: tick noch nicht implementiert!" -- TODO: Ihre Aufgabe !!!
swapWetter :: Wetter -> State Welt Wetter
swapWetter =
error "TODO: swapWetter noch nicht implementiert!" -- TODO: Ihre Aufgabe !!!

BIN
testdata/ProMo_Uebung10.pdf vendored Normal file
View File

Binary file not shown.

343
uniworx.sublime-workspace
View File

@ -23,7 +23,7 @@
"file": "src/Application.hs", "file": "src/Application.hs",
"settings": "settings":
{ {
"buffer_size": 7271, "buffer_size": 8177,
"line_ending": "Unix" "line_ending": "Unix"
} }
}, },
@ -31,7 +31,7 @@
"file": "src/Foundation.hs", "file": "src/Foundation.hs",
"settings": "settings":
{ {
"buffer_size": 11626, "buffer_size": 55270,
"encoding": "UTF-8", "encoding": "UTF-8",
"line_ending": "Unix" "line_ending": "Unix"
} }
@ -40,27 +40,7 @@
"file": "src/Import.hs", "file": "src/Import.hs",
"settings": "settings":
{ {
"buffer_size": 125, "buffer_size": 126,
"line_ending": "Unix"
}
},
{
"file": "src/Model.hs",
"settings":
{
"buffer_size": 886,
"line_ending": "Unix"
}
},
{
"contents": "{-# LANGUAGE RecordWildCards #-}\n{-# LANGUAGE PatternGuards #-}\n{-# LANGUAGE TemplateHaskell #-}\n{-# LANGUAGE NoImplicitPrelude #-}\n{-# LANGUAGE OverloadedStrings #-}\n{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}\nmodule Model.Types where\n\nimport ClassyPrelude\n\nimport Database.Persist.TH\nimport Database.Persist.Class\nimport Database.Persist.Sql\n\nimport Web.HttpApiData\n\nimport Data.Text (Text)\nimport qualified Data.Text as Text\n\nimport Text.Read (readMaybe)\n\n-- import Data.CaseInsensitive (CI)\nimport qualified Data.CaseInsensitive as CI\n\nimport Yesod.Core.Dispatch (PathPiece(..))\nimport Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))\n\nimport GHC.Generics (Generic)\nimport Data.Typeable (Typeable)\n\n\ndata SheetType = Regular | Bonus | Extra \n deriving (Show, Read, Eq, Ord, Enum, Bounded) \nderivePersistField \"SheetType\"\n\ndata ExamStatus = Attended | NoShow | Voided\n deriving (Show, Read, Eq, Ord, Enum, Bounded) \nderivePersistField \"ExamStatus\"\n\n\ndata Season = Summer | Winter\n deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)\n\nseasonToChar :: Season -> Char\nseasonToChar Summer = 'S'\nseasonToChar Winter = 'W'\n\nseasonFromChar :: Char -> Either Text Season\nseasonFromChar c\n | c ~= 'S' = Right Summer\n | c ~= 'W' = Right Winter\n | otherwise = Left $ \"Invalid season character: ‘\" <> tshow c <> \"’\"\n where\n (~=) = (==) `on` CI.mk\n\ndata TermIdentifier = TermIdentifier\n { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'\n , season :: Season\n } deriving (Show, Read, Eq, Ord, Generic, Typeable)\n\ntermToText :: TermIdentifier -> Text\ntermToText TermIdentifier{..} = Text.pack $ seasonToChar season : show year\n\ntermFromText :: Text -> Either Text TermIdentifier\ntermFromText t\n | (s:ys) <- Text.unpack t\n , Just year <- readMaybe ys\n , Right season <- seasonFromChar s\n = Right TermIdentifier{..}\n | otherwise = Left $ \"Invalid TermIdentifier: “\" <> t <> \"”\"\n\ninstance PersistField TermIdentifier where\n toPersistValue = PersistText . termToText\n fromPersistValue (PersistText t) = termFromText t\n fromPersistValue x = Left $ \"Expected TermIdentifier, received: \" <> tshow x\n\ninstance PersistFieldSql TermIdentifier where\n sqlType _ = SqlString\n\ninstance ToHttpApiData TermIdentifier where\n toUrlPiece = termToText\n\ninstance FromHttpApiData TermIdentifier where\n parseUrlPiece = termFromText\n\ninstance PathPiece TermIdentifier where\n fromPathPiece = either (const Nothing) Just . termFromText\n toPathPiece = termToText\n\ninstance ToJSON TermIdentifier where\n toJSON = String . termToText\n\ninstance FromJSON TermIdentifier where\n parseJSON = withText \"Term\" $ either (fail . Text.unpack) return . termFromText\n\ninstance Class Data where\n func = \n",
"file": "src/Model/Types.hs",
"file_size": 2724,
"file_write_time": 131516115030281923,
"settings":
{
"buffer_size": 2753,
"encoding": "UTF-8",
"line_ending": "Unix" "line_ending": "Unix"
} }
}, },
@ -68,7 +48,7 @@
"file": "src/Settings.hs", "file": "src/Settings.hs",
"settings": "settings":
{ {
"buffer_size": 5994, "buffer_size": 9044,
"line_ending": "Unix" "line_ending": "Unix"
} }
}, },
@ -84,25 +64,7 @@
"file": "src/Handler/Home.hs", "file": "src/Handler/Home.hs",
"settings": "settings":
{ {
"buffer_size": 2324, "buffer_size": 11101,
"line_ending": "Unix"
}
},
{
"file": "src/Handler/Assist.hs",
"settings":
{
"buffer_size": 2858,
"encoding": "UTF-8",
"line_ending": "Unix"
}
},
{
"file": "templates/newcourse.hamlet",
"settings":
{
"buffer_size": 606,
"encoding": "UTF-8",
"line_ending": "Unix" "line_ending": "Unix"
} }
}, },
@ -110,7 +72,7 @@
"file": "src/Handler/Profile.hs", "file": "src/Handler/Profile.hs",
"settings": "settings":
{ {
"buffer_size": 411, "buffer_size": 6956,
"line_ending": "Unix" "line_ending": "Unix"
} }
}, },
@ -118,7 +80,7 @@
"file": "models", "file": "models",
"settings": "settings":
{ {
"buffer_size": 4388, "buffer_size": 6708,
"encoding": "UTF-8", "encoding": "UTF-8",
"line_ending": "Unix" "line_ending": "Unix"
} }
@ -127,7 +89,24 @@
"file": "stack.yaml", "file": "stack.yaml",
"settings": "settings":
{ {
"buffer_size": 2233, "buffer_size": 706,
"line_ending": "Unix"
}
},
{
"file": "src/Model.hs",
"settings":
{
"buffer_size": 1432,
"line_ending": "Unix"
}
},
{
"file": "src/Model/Types.hs",
"settings":
{
"buffer_size": 13229,
"encoding": "UTF-8",
"line_ending": "Unix" "line_ending": "Unix"
} }
} }
@ -166,11 +145,13 @@
}, },
"file_history": "file_history":
[ [
"/home/jost/programming/Haskell/Yesod/uniworx/templates/newcourse.hamlet",
"/home/jost/programming/Haskell/Yesod/uniworx/src/Handler/Assist.hs",
"/home/jost/programming/Haskell/Yesod/uniworx/src/Handler/Comment.hs" "/home/jost/programming/Haskell/Yesod/uniworx/src/Handler/Comment.hs"
], ],
"find": "find":
{ {
"height": 52.0 "height": 35.2588147037
}, },
"find_in_files": "find_in_files":
{ {
@ -210,7 +191,7 @@
"groups": "groups":
[ [
{ {
"selected": 8, "selected": 10,
"sheets": "sheets":
[ [
{ {
@ -219,7 +200,7 @@
"semi_transient": false, "semi_transient": false,
"settings": "settings":
{ {
"buffer_size": 7271, "buffer_size": 8177,
"regions": "regions":
{ {
}, },
@ -240,7 +221,7 @@
"translation.y": 0.0, "translation.y": 0.0,
"zoom_level": 1.0 "zoom_level": 1.0
}, },
"stack_index": 12, "stack_index": 10,
"type": "text" "type": "text"
}, },
{ {
@ -249,15 +230,15 @@
"semi_transient": false, "semi_transient": false,
"settings": "settings":
{ {
"buffer_size": 11626, "buffer_size": 55270,
"regions": "regions":
{ {
}, },
"selection": "selection":
[ [
[ [
9330, 0,
9330 0
] ]
], ],
"settings": "settings":
@ -267,10 +248,10 @@
"translate_tabs_to_spaces": true "translate_tabs_to_spaces": true
}, },
"translation.x": 0.0, "translation.x": 0.0,
"translation.y": 5125.0, "translation.y": 5125.28132033,
"zoom_level": 1.0 "zoom_level": 1.0
}, },
"stack_index": 6, "stack_index": 5,
"type": "text" "type": "text"
}, },
{ {
@ -279,7 +260,7 @@
"semi_transient": false, "semi_transient": false,
"settings": "settings":
{ {
"buffer_size": 125, "buffer_size": 126,
"regions": "regions":
{ {
}, },
@ -298,82 +279,24 @@
"translation.y": 0.0, "translation.y": 0.0,
"zoom_level": 1.0 "zoom_level": 1.0
}, },
"stack_index": 5,
"type": "text"
},
{
"buffer": 3,
"file": "src/Model.hs",
"semi_transient": false,
"settings":
{
"buffer_size": 886,
"regions":
{
},
"selection":
[
[
0,
0
]
],
"settings":
{
"syntax": "Packages/Haskell/Haskell.sublime-syntax"
},
"translation.x": 0.0,
"translation.y": 0.0,
"zoom_level": 1.0
},
"stack_index": 2,
"type": "text"
},
{
"buffer": 4,
"file": "src/Model/Types.hs",
"semi_transient": false,
"settings":
{
"buffer_size": 2753,
"regions":
{
},
"selection":
[
[
2726,
2731
]
],
"settings":
{
"syntax": "Packages/Haskell/Haskell.sublime-syntax",
"tab_size": 2,
"translate_tabs_to_spaces": true
},
"translation.x": 0.0,
"translation.y": 1380.0,
"zoom_level": 1.0
},
"stack_index": 1, "stack_index": 1,
"type": "text" "type": "text"
}, },
{ {
"buffer": 5, "buffer": 3,
"file": "src/Settings.hs", "file": "src/Settings.hs",
"semi_transient": false, "semi_transient": false,
"settings": "settings":
{ {
"buffer_size": 5994, "buffer_size": 9044,
"regions": "regions":
{ {
}, },
"selection": "selection":
[ [
[ [
104, 0,
104 0
] ]
], ],
"settings": "settings":
@ -386,11 +309,11 @@
"translation.y": 0.0, "translation.y": 0.0,
"zoom_level": 1.0 "zoom_level": 1.0
}, },
"stack_index": 11, "stack_index": 9,
"type": "text" "type": "text"
}, },
{ {
"buffer": 6, "buffer": 4,
"file": "src/Handler/Common.hs", "file": "src/Handler/Common.hs",
"semi_transient": false, "semi_transient": false,
"settings": "settings":
@ -414,24 +337,24 @@
"translation.y": 0.0, "translation.y": 0.0,
"zoom_level": 1.0 "zoom_level": 1.0
}, },
"stack_index": 10, "stack_index": 8,
"type": "text" "type": "text"
}, },
{ {
"buffer": 7, "buffer": 5,
"file": "src/Handler/Home.hs", "file": "src/Handler/Home.hs",
"semi_transient": false, "semi_transient": false,
"settings": "settings":
{ {
"buffer_size": 2324, "buffer_size": 11101,
"regions": "regions":
{ {
}, },
"selection": "selection":
[ [
[ [
404, 0,
404 0
] ]
], ],
"settings": "settings":
@ -441,49 +364,47 @@
"translate_tabs_to_spaces": true "translate_tabs_to_spaces": true
}, },
"translation.x": 0.0, "translation.x": 0.0,
"translation.y": 138.0, "translation.y": 138.034508627,
"zoom_level": 1.0 "zoom_level": 1.0
}, },
"stack_index": 7, "stack_index": 3,
"type": "text" "type": "text"
}, },
{ {
"buffer": 8, "buffer": 6,
"file": "src/Handler/Assist.hs", "file": "src/Handler/Profile.hs",
"semi_transient": false, "semi_transient": false,
"settings": "settings":
{ {
"buffer_size": 2858, "buffer_size": 6956,
"regions": "regions":
{ {
}, },
"selection": "selection":
[ [
[ [
454, 0,
454 0
] ]
], ],
"settings": "settings":
{ {
"syntax": "Packages/Haskell/Haskell.sublime-syntax", "syntax": "Packages/Haskell/Haskell.sublime-syntax"
"tab_size": 4,
"translate_tabs_to_spaces": true
}, },
"translation.x": 0.0, "translation.x": 0.0,
"translation.y": 0.0, "translation.y": 0.0,
"zoom_level": 1.0 "zoom_level": 1.0
}, },
"stack_index": 0, "stack_index": 6,
"type": "text" "type": "text"
}, },
{ {
"buffer": 9, "buffer": 7,
"file": "templates/newcourse.hamlet", "file": "models",
"semi_transient": false, "semi_transient": false,
"settings": "settings":
{ {
"buffer_size": 606, "buffer_size": 6708,
"regions": "regions":
{ {
}, },
@ -497,89 +418,31 @@
"settings": "settings":
{ {
"syntax": "Packages/Text/Plain text.tmLanguage", "syntax": "Packages/Text/Plain text.tmLanguage",
"tab_size": 4, "tab_size": 2,
"translate_tabs_to_spaces": true "translate_tabs_to_spaces": true
}, },
"translation.x": 0.0, "translation.x": 0.0,
"translation.y": 0.0, "translation.y": 138.034508627,
"zoom_level": 1.0 "zoom_level": 1.0
}, },
"stack_index": 4, "stack_index": 4,
"type": "text" "type": "text"
}, },
{ {
"buffer": 10, "buffer": 8,
"file": "src/Handler/Profile.hs",
"semi_transient": false,
"settings":
{
"buffer_size": 411,
"regions":
{
},
"selection":
[
[
213,
213
]
],
"settings":
{
"syntax": "Packages/Haskell/Haskell.sublime-syntax"
},
"translation.x": 0.0,
"translation.y": 0.0,
"zoom_level": 1.0
},
"stack_index": 8,
"type": "text"
},
{
"buffer": 11,
"file": "models",
"semi_transient": false,
"settings":
{
"buffer_size": 4388,
"regions":
{
},
"selection":
[
[
747,
747
]
],
"settings":
{
"syntax": "Packages/Text/Plain text.tmLanguage",
"tab_size": 2,
"translate_tabs_to_spaces": true
},
"translation.x": 0.0,
"translation.y": 138.0,
"zoom_level": 1.0
},
"stack_index": 3,
"type": "text"
},
{
"buffer": 12,
"file": "stack.yaml", "file": "stack.yaml",
"semi_transient": false, "semi_transient": false,
"settings": "settings":
{ {
"buffer_size": 2233, "buffer_size": 706,
"regions": "regions":
{ {
}, },
"selection": "selection":
[ [
[ [
663, 0,
663 0
] ]
], ],
"settings": "settings":
@ -590,7 +453,65 @@
"translation.y": 0.0, "translation.y": 0.0,
"zoom_level": 1.0 "zoom_level": 1.0
}, },
"stack_index": 9, "stack_index": 7,
"type": "text"
},
{
"buffer": 9,
"file": "src/Model.hs",
"semi_transient": false,
"settings":
{
"buffer_size": 1432,
"regions":
{
},
"selection":
[
[
0,
0
]
],
"settings":
{
"syntax": "Packages/Haskell/Haskell.sublime-syntax"
},
"translation.x": 0.0,
"translation.y": 0.0,
"zoom_level": 1.0
},
"stack_index": 2,
"type": "text"
},
{
"buffer": 10,
"file": "src/Model/Types.hs",
"semi_transient": false,
"settings":
{
"buffer_size": 13229,
"regions":
{
},
"selection":
[
[
0,
0
]
],
"settings":
{
"syntax": "Packages/Haskell/Haskell.sublime-syntax",
"tab_size": 2,
"translate_tabs_to_spaces": true
},
"translation.x": 0.0,
"translation.y": 1380.34508627,
"zoom_level": 1.0
},
"stack_index": 0,
"type": "text" "type": "text"
} }
] ]
@ -598,7 +519,7 @@
], ],
"incremental_find": "incremental_find":
{ {
"height": 33.0 "height": 35.2588147037
}, },
"input": "input":
{ {
@ -635,7 +556,7 @@
"project": "uniworx.sublime-project", "project": "uniworx.sublime-project",
"replace": "replace":
{ {
"height": 61.0 "height": 63.0157539385
}, },
"save_all_on_build": true, "save_all_on_build": true,
"select_file": "select_file":
@ -688,6 +609,15 @@
"selected_group": 0, "selected_group": 0,
"settings": "settings":
{ {
"last_automatic_layout":
[
[
0,
0,
1,
1
]
]
}, },
"show_minimap": true, "show_minimap": true,
"show_open_files": false, "show_open_files": false,
@ -697,5 +627,6 @@
"status_bar_visible": true, "status_bar_visible": true,
"template_settings": "template_settings":
{ {
"max_columns": 2
} }
} }