diff --git a/.gitignore b/.gitignore index 9abd44d27..c37cbe326 100644 --- a/.gitignore +++ b/.gitignore @@ -29,3 +29,6 @@ uniworx.nix src/Handler/Assist.bak src/Handler/Course.SnapCustom.hs *.orig +.stack-work-* +.directory +tags diff --git a/ChangeLog.md b/ChangeLog.md index c0392847e..e8491a064 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ + * Version 06.08.2016 + + Einführung einer Option, ob Dateien automatisch heruntergeladen werden sollen + * Version 01.08.2018 Verbesserter Campus-Login diff --git a/config/settings.yml b/config/settings.yml index 1b0913f6f..72965a276 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -1,29 +1,26 @@ # Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable. # See https://github.com/yesodweb/yesod/wiki/Configuration#overriding-configuration-values-with-environment-variables +# NB: If you need a numeric value (e.g. 123) to parse as a String, wrap it in single quotes (e.g. "_env:PGPASS:'123'") +# See https://github.com/yesodweb/yesod/wiki/Configuration#parsing-numeric-values-as-strings static-dir: "_env:STATIC_DIR:static" host: "_env:HOST:*4" # any IPv4 host -port: "_env:PORT:3000" # NB: The port `yesod devel` uses is distinct from this value. Set the `yesod devel` port from the command line. +port: "_env:PORT:3000" ip-from-header: "_env:IP_FROM_HEADER:false" - -# Default behavior: determine the application root from the request headers. -# Uncomment to set an explicit approot approot: "_env:APPROOT:http://localhost:3000" +detailed-logging: "_env:DETAILED_LOGGING:false" +should-log-all: "_env:LOG_ALL:false" +minimum-log-level: "_env:LOGLEVEL:warn" +auth-dummy-login: "_env:DUMMY_LOGIN:false" +auth-pwfile: "_env:PWFILE:" +allow-deprecated: "_env:ALLOW_DEPRECATED:false" + # Optional values with the following production defaults. -# In development, they default to the inverse. -# -detailed-logging: "_env:DETAILED_LOGGING:false" -should-log-all: "_env:LOG_ALL:false" +# In development, they default to true. # reload-templates: false # mutable-static: false # skip-combining: false -auth-dummy-login: "_env:DUMMY_LOGIN:false" -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: user: "_env:PGUSER:uniworx" @@ -35,22 +32,21 @@ database: poolsize: "_env:PGPOOLSIZE:10" ldap: - host: "_env:LDAPHOST:" - tls: "_env:LDAPTLS:" - port: "_env:LDAPPORT:389" - user: "_env:LDAPUSER:" - pass: "_env:LDAPPASS:" - baseDN: "_env:LDAPBASE:" - scope: "_env:LDAPSCOPE:WholeSubtree" - timeout: "_env:LDAPTIMEOUT:5" + host: "_env:LDAPHOST:" + tls: "_env:LDAPTLS:" + port: "_env:LDAPPORT:389" + user: "_env:LDAPUSER:" + pass: "_env:LDAPPASS:" + baseDN: "_env:LDAPBASE:" + scope: "_env:LDAPSCOPE:WholeSubtree" + timeout: "_env:LDAPTIMEOUT:5" -default-favourites: 12 -default-theme: Default -default-date-time-format: "%a %d %b %Y %R" -default-date-format: "%d.%m.%Y" -default-time-format: "%R" +user-defaults: + favourites: 12 + theme: Default + date-time-format: "%a %d %b %Y %R" + date-format: "%d.%m.%Y" + time-format: "%R" + download-files: false cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf" - -copyright: ©Institute for Informatics, LMU Munich -#analytics: UA-YOURCODE diff --git a/config/submission-blacklist b/config/submission-blacklist index 1027b869b..ad2a62ccf 100644 --- a/config/submission-blacklist +++ b/config/submission-blacklist @@ -8,5 +8,5 @@ $# Ignoriere rekursiv alle Ordner __MACOSX und ihren Inhalt **/__MACOSX/* **/__MACOSX/**/* -$# Ignoriere rekursiv alle Dateien .DS_Store -**/.DS_Store \ No newline at end of file +$# Ignoriere rekursiv alle Dateien .DS_Store (Mac OS) +**/.DS_Store diff --git a/db.hs b/db.hs index 6db5f2188..0c254a588 100755 --- a/db.hs +++ b/db.hs @@ -18,16 +18,20 @@ import System.Console.GetOpt import System.Exit (exitWith, ExitCode(..)) import System.IO (hPutStrLn, stderr) +import qualified Data.ByteString as BS + import Data.Time data DBAction = DBClear + | DBMigrate | DBFill argsDescr :: [OptDescr DBAction] argsDescr = - [ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user" - , Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data" + [ Option ['c'] ["clear"] (NoArg DBClear) "Delete everything accessable by the current database user" + , Option ['m'] ["migrate"] (NoArg DBMigrate) "Perform database migration" + , Option ['f'] ["fill"] (NoArg DBFill) "Fill database with example data" ] @@ -36,19 +40,26 @@ main = do args <- map unpack <$> getArgs case getOpt Permute argsDescr args of (acts@(_:_), [], []) -> forM_ acts $ \case - DBClear -> runStderrLoggingT $ do -- We don't use `db` here, since we do /not/ want any migrations to run, yet + DBClear -> runStderrLoggingT $ do -- We don't use `db` here, since we do /not/ want any migrations to run, yet settings <- liftIO getAppDevSettings withPostgresqlConn (pgConnStr $ appDatabaseConf settings) . runSqlConn $ do rawExecute "drop owned by current_user;" [] - DBFill -> db $ fillDb + DBMigrate -> db $ return () + DBFill -> db $ fillDb (_, _, errs) -> do forM_ errs $ hPutStrLn stderr hPutStrLn stderr $ usageInfo "db.hs" argsDescr exitWith $ ExitFailure 2 +insertFile :: FilePath -> DB FileId +insertFile fileTitle = do + fileContent <- liftIO $ Just <$> BS.readFile ("testdata/" <> fileTitle) + fileModified <- liftIO getCurrentTime + insert File{..} + fillDb :: DB () fillDb = do - AppSettings{..} <- getsYesod appSettings + AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod appSettings now <- liftIO getCurrentTime let summer2017 = TermIdentifier 2017 Summer @@ -61,10 +72,11 @@ fillDb = do , userEmail = "G.Kleen@campus.lmu.de" , userDisplayName = "Gregor Kleen" , userMaxFavourites = 6 - , userTheme = Default - , userDateTimeFormat = appDefaultDateTimeFormat - , userDateFormat = appDefaultDateFormat - , userTimeFormat = appDefaultTimeFormat + , userTheme = ThemeDefault + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles } fhamann <- insert User { userPlugin = "LDAP" @@ -72,11 +84,12 @@ fillDb = do , userMatrikelnummer = Nothing , userEmail = "felix.hamann@campus.lmu.de" , userDisplayName = "Felix Hamann" - , userMaxFavourites = appDefaultMaxFavourites - , userTheme = Default - , userDateTimeFormat = appDefaultDateTimeFormat - , userDateFormat = appDefaultDateFormat - , userTimeFormat = appDefaultTimeFormat + , userMaxFavourites = userDefaultMaxFavourites + , userTheme = ThemeDefault + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles } jost <- insert User { userPlugin = "LDAP" @@ -85,10 +98,11 @@ fillDb = do , userEmail = "jost@tcs.ifi.lmu.de" , userDisplayName = "Steffen Jost" , userMaxFavourites = 14 - , userTheme = MossGreen - , userDateTimeFormat = appDefaultDateTimeFormat - , userDateFormat = appDefaultDateFormat - , userTimeFormat = appDefaultTimeFormat + , userTheme = ThemeMossGreen + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles } void . insert $ User { userPlugin = "LDAP" @@ -97,10 +111,11 @@ fillDb = do , userEmail = "max@campus.lmu.de" , userDisplayName = "Max Musterstudent" , userMaxFavourites = 7 - , userTheme = AberdeenReds - , userDateTimeFormat = appDefaultDateTimeFormat - , userDateFormat = appDefaultDateFormat - , userTimeFormat = appDefaultTimeFormat + , userTheme = ThemeAberdeenReds + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles } void . insert $ Term { termName = summer2017 @@ -229,10 +244,10 @@ fillDb = do , courseDescription = Nothing , courseLinkExternal = Nothing , courseShorthand = "ProMo" - , courseTerm = TermKey summer2017 + , courseTerm = TermKey summer2018 , courseSchool = ifi , courseCapacity = Just 50 - , courseRegisterFrom = Nothing + , courseRegisterFrom = Just now , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing , courseRegisterSecret = Nothing @@ -241,6 +256,28 @@ fillDb = do insert_ $ CourseEdit jost now pmo void . insert $ DegreeCourse pmo sdBsc sdInf void . insert $ Lecturer jost pmo + sh1 <- insert Sheet + { sheetCourse = pmo + , sheetName = "Blatt 1" + , sheetDescription = Nothing + , sheetType = Normal 6 + , sheetGrouping = Arbitrary 3 + , sheetMarkingText = Nothing + , sheetVisibleFrom = Just now + , sheetActiveFrom = now + , sheetActiveTo = (14 * nominalDay) `addUTCTime` now + , sheetHintFrom = Nothing + , sheetSolutionFrom = Nothing + } + void . insert $ SheetEdit jost now sh1 + void . insert $ SheetCorrector jost sh1 (Load (Just True) 0) CorrectorNormal + void . insert $ SheetCorrector gkleen sh1 (Load (Just True) 1) CorrectorNormal + h102 <- insertFile "H10-2.hs" + h103 <- insertFile "H10-3.hs" + pdf10 <- insertFile "ProMo_Uebung10.pdf" + void . insert $ SheetFile sh1 h102 SheetHint + void . insert $ SheetFile sh1 h103 SheetSolution + void . insert $ SheetFile sh1 pdf10 SheetExercise -- datenbanksysteme dbs <- insert Course { courseName = "Datenbanksysteme" diff --git a/ghci.sh b/ghci.sh index 64adc58eb..5139c7c72 100755 --- a/ghci.sh +++ b/ghci.sh @@ -5,4 +5,15 @@ export DETAILED_LOGGING=true export LOG_ALL=true export DUMMY_LOGIN=true -exec -- stack ghci --flag uniworx:dev --flag uniworx:library-only +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 diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 89626f375..f68710517 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -38,16 +38,18 @@ CourseRegisterOk: Sie wurden angemeldet CourseDeregisterOk: Sie wurden abgemeldet CourseSecretWrong: Falsches Kennwort CourseSecret: Zugangspasswort -CourseNewOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt. -CourseEditOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{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. -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. +CourseNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich erstellt. +CourseEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich geändert. +CourseNewDupShort tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. +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 TermCourseListHeading tid@TermId: Kursübersicht #{display tid} +TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{display school} CourseListTitle: Alle Kurse TermCourseListTitle tid@TermId: Kurse #{display tid} +TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{display school} CourseNewHeading: Neuen Kurs anlegen -CourseEditHeading tid@TermId 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 CourseMembers: Teilnehmer CourseMembersCount num@Int64: #{display num} @@ -59,7 +61,8 @@ CourseHomepage: Homepage CourseShorthand: Kürzel CourseShorthandUnique: Muss innerhalb des Semesters eindeutig sein CourseSemester: Semester -CourseSchool: Fachbereich +CourseSchool: Institut +CourseSchoolShort: Fach CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein @@ -67,17 +70,17 @@ CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein Sheet: Blatt -SheetList tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Übersicht Übungsblätter -SheetNewHeading tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Neues Übungsblatt anlegen -SheetNewOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{courseShortHand} erfolgreich erstellt. -SheetTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName} -SheetTitleNew tid@TermId courseShortHand@CourseShorthand : #{display tid}-#{courseShortHand}: Neues Übungsblatt -SheetEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName} editieren -SheetEditOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{courseShortHand} wurde gespeichert. -SheetNameDup tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{courseShortHand}. -SheetDelHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{courseShortHand} herauslöschen? +SheetList tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Übersicht Übungsblätter +SheetNewHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Neues Übungsblatt anlegen +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 ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} +SheetTitleNew tid@TermId ssh@SchoolId courseShortHand@CourseShorthand : #{display tid}-#{display ssh}-#{courseShortHand}: Neues Übungsblatt +SheetEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} editieren +SheetEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde gespeichert. +SheetNameDup tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{courseShortHand}. +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. -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 SheetHint: Hinweis @@ -110,12 +113,12 @@ Deadline: Abgabe Done: Eingereicht Submission: Abgabenummer -SubmissionsCourse tid@TermId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{courseShortHand} -SubmissionsSheet sheetName@SheetName: Abgaben für Blatt #{sheetName} +SubmissionsCourse tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{display ssh}-#{courseShortHand} +SubmissionsSheet sheetName@SheetName: Abgaben für #{sheetName} SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt. SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. -SubmissionEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen -CorrectionHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{courseShortHand} #{sheetName}: Korrektur +SubmissionEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen +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} SubmissionArchive: Zip-Archiv der Abgabedatei(en) SubmissionFile: Datei zur Abgabe @@ -155,10 +158,11 @@ TooManyParticipants: Es wurden zu viele Mitabgebende angegeben AddCorrector: Zusätzlicher Korrektor 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 Corrector: Korrektor Correctors: Korrektoren +CorState: Status CorByTut: Nach Tutorium CorProportion: Anteil DeleteRow: Zeile entfernen @@ -247,9 +251,12 @@ UserListTitle: Komprehensive Benutzerliste DateTimeFormat: Datums- und Uhrzeitformat DateFormat: Datumsformat TimeFormat: Uhrzeitformat +DownloadFiles: Dateien automatisch herunterladen +DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden). InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren +IllDefinedUTCTime: Der angegebene Zeitpunkt lässt sich nicht zu UTC konvertieren LastEdits: Letzte Änderungen EditedBy name@Text time@Text: Durch #{name} um #{time} @@ -260,3 +267,7 @@ SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe LDAPLoginTitle: Campus-Login DummyLoginTitle: Development-Login + +CorrectorNormal: Normal +CorrectorMissing: Abwesend +CorrectorExcused: Entschuldigt diff --git a/models b/models index e68c47c43..c3cb175bf 100644 --- a/models +++ b/models @@ -9,6 +9,7 @@ User json dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" dateFormat DateTimeFormat "default='%d.%m.%Y'" timeFormat DateTimeFormat "default='%R'" + downloadFiles Bool default=false UniqueAuthentication plugin ident UniqueEmail email deriving Show @@ -51,7 +52,8 @@ School json name (CI Text) shorthand (CI Text) UniqueSchool name - UniqueSchoolShorthand shorthand + UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text + Primary shorthand -- newtype Key School = School { unSchoolKey :: SchoolShorthand } deriving Eq DegreeCourse json course CourseId @@ -72,8 +74,8 @@ Course deregisterUntil UTCTime Maybe registerSecret Text Maybe -- Falls ein Passwort erforderlich ist materialFree Bool - CourseTermShort term shorthand - CourseTermName term name + TermSchoolCourseShort term school shorthand + TermSchoolCourseName term school name CourseEdit user UserId time UTCTime @@ -114,6 +116,7 @@ SheetCorrector user UserId sheet SheetId load Load + state CorrectorState default='CorrectorNormal' UniqueSheetCorrector user sheet deriving Show Eq Ord SheetFile diff --git a/package.yaml b/package.yaml index 74bb7bf3c..613489a82 100644 --- a/package.yaml +++ b/package.yaml @@ -20,7 +20,7 @@ dependencies: - classy-prelude-conduit >=0.10.2 - bytestring >=0.9 && <0.11 - text >=0.11 && <2.0 -- persistent >=2.0 && <2.8 +- persistent >=2.7.2 && <2.8 - persistent-postgresql >=2.1.1 && <2.8 - persistent-template >=2.0 && <2.8 - template-haskell @@ -88,6 +88,10 @@ dependencies: - Glob - ldap-client - connection +- universe +- universe-base +- random-shuffle +- th-abstraction # The library contains all of our application code. The executable # defined below is just a thin wrapper. diff --git a/routes b/routes index 097e6a0b8..d58947041 100644 --- a/routes +++ b/routes @@ -46,11 +46,13 @@ /terms/edit TermEditR GET POST /terms/#TermId/edit TermEditExistR GET !/terms/#TermId TermCourseListR GET !free +!/terms/#TermId/#SchoolId TermSchoolCourseListR GET !free + -- For Pattern Synonyms see Foundation /course/ CourseListR GET !free !/course/new CourseNewR GET POST !lecturer -/course/#TermId/#CourseShorthand CourseR !lecturer: +/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: / CShowR GET !free /register CRegisterR POST !timeANDcapacity /edit CEditR GET POST diff --git a/src/Application.hs b/src/Application.hs index aa4685549..93bd35d76 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -98,7 +98,7 @@ makeFoundation appSettings@(AppSettings{..}) = do (pgPoolSize appDatabaseConf) -- Perform database migration using our application's logging settings. - runLoggingT (runSqlPool (runMigration $ migrateAll) pool) logFunc + runLoggingT (runSqlPool migrateAll pool) logFunc -- Return the foundation return $ mkFoundation pool diff --git a/src/CryptoID.hs b/src/CryptoID.hs index c0739843f..e2f6361cb 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -27,35 +27,17 @@ import System.FilePath.Cryptographic.ImplicitNamespace import qualified Data.Text as Text -import Data.UUID.Types +-- import Data.UUID.Types import Web.PathPieces import Data.CaseInsensitive (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 decCryptoIDs [ ''SubmissionId , ''FileId , ''UserId - , ''CourseId ] instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where diff --git a/src/Data/CaseInsensitive/Instances.hs b/src/Data/CaseInsensitive/Instances.hs new file mode 100644 index 000000000..ea5253f44 --- /dev/null +++ b/src/Data/CaseInsensitive/Instances.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.CaseInsensitive.Instances + () where + +import ClassyPrelude.Yesod + +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI + +import Database.Persist.Sql + +import Text.Blaze (ToMarkup(..)) + +import Data.Text (Text) +import qualified Data.Text.Encoding as Text + + +instance PersistField (CI Text) where + toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText + fromPersistValue (PersistDbSpecific bs) = Right . CI.mk $ Text.decodeUtf8 bs + fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x + +instance PersistField (CI String) where + toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 . pack $ CI.original ciText + fromPersistValue (PersistDbSpecific bs) = Right . CI.mk . unpack $ Text.decodeUtf8 bs + fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x + +instance PersistFieldSql (CI Text) where + sqlType _ = SqlOther "citext" + +instance PersistFieldSql (CI String) where + sqlType _ = SqlOther "citext" + +instance ToJSON a => ToJSON (CI a) where + toJSON = toJSON . CI.original + +instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where + parseJSON = fmap CI.mk . parseJSON + +instance ToMessage a => ToMessage (CI a) where + toMessage = toMessage . CI.original + +instance ToMarkup a => ToMarkup (CI a) where + toMarkup = toMarkup . CI.original + preEscapedToMarkup = preEscapedToMarkup . CI.original + +instance ToWidget site a => ToWidget site (CI a) where + toWidget = toWidget . CI.original + +instance RenderMessage site a => RenderMessage site (CI a) where + renderMessage f ls msg = renderMessage f ls $ CI.original msg diff --git a/src/Foundation.hs b/src/Foundation.hs index 58414a529..90371f955 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -97,6 +97,8 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission instance DisplayAble TermId where display = termToText . unTermKey +instance DisplayAble SchoolId where + display = CI.original . unSchoolKey -- infixl 9 :$: -- 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 -- -- This function also generates the following type synonyms: --- type Handler = HandlerT UniWorX IO --- type Widget = WidgetT UniWorX IO () +-- type Handler x = HandlerT UniWorX IO x +-- type Widget = WidgetT UniWorX IO () mkYesodData "UniWorX" $(parseRoutesFile "routes") -- | Convenient Type Synonyms: @@ -134,11 +136,11 @@ type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) type MsgRenderer = MsgRendererS UniWorX -- see Utils -- Pattern Synonyms for convenience -pattern CSheetR tid csh shn ptn - = CourseR tid csh (SheetR shn ptn) +pattern CSheetR tid ssh csh shn ptn + = CourseR tid ssh csh (SheetR shn ptn) -pattern CSubmissionR tid csh shn cid ptn - = CSheetR tid csh shn (SubmissionR cid ptn) +pattern CSubmissionR tid ssh csh shn cid ptn + = CSheetR tid ssh csh shn (SubmissionR cid ptn) -- Menus and Favourites data MenuItem = MenuItem @@ -159,7 +161,7 @@ data MenuTypes -- Semantische Rolle: | NavbarRight { menuItem :: MenuItem } -- Generell, nahezu immer sichtbar | NavbarSecondary { menuItem :: MenuItem } -- Generell, nahezu immer sichtbar | 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 mkMessage "UniWorX" "messages/uniworx" "de" @@ -196,6 +198,13 @@ instance RenderMessage UniWorX SheetFileType where SheetMarking -> renderMessage' MsgSheetMarking 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 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 = APDB $ \route _ -> case route of -- 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 [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh return (E.countRows :: E.SqlExpr (E.Value Int64)) 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 ) ,("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 [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh return (E.countRows :: E.SqlExpr (E.Value Int64)) 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.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] case route of - CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do + CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID Submission{..} <- MaybeT . lift $ get sid guard $ maybe False (== authId) submissionRatingBy return Authorized - CSheetR tid csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do - Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh + CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) return Authorized - CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do - Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh guard $ cid `Set.member` Map.keysSet resMap return Authorized _ -> do @@ -333,8 +344,8 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req return Authorized ) ,("time", APDB $ \route _ -> case route of - CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do - Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh + CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do + Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn cTime <- liftIO getCurrentTime let @@ -352,18 +363,9 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req _ -> return () 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 - Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh + CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do + Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh cTime <- (NTop . Just) <$> liftIO getCurrentTime guard $ NTop courseRegisterFrom <= 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 ) ,("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 [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId - E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh return (E.countRows :: E.SqlExpr (E.Value Int64)) 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 ) ,("capacity", APDB $ \route _ -> case route of - CourseR tid csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do - Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do + Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ NTop courseCapacity > NTop (Just registered) return Authorized r -> $unsupportedAuthPredicate "capacity" r ) ,("materials", APDB $ \route _ -> case route of - CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do - Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do + Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh guard courseMaterialFree return Authorized r -> $unsupportedAuthPredicate "materials" r ) ,("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 authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId 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 ) ,("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 sub <- MaybeT $ get sid guard $ submissionRatingDone sub @@ -478,14 +481,14 @@ instance Yesod UniWorX where updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do route <- MaybeT getCurrentRoute case route of -- update Course Favourites here - CourseR tid csh _ -> do + CourseR tid ssh csh _ -> 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" now <- liftIO $ getCurrentTime uid <- MaybeT $ liftHandlerT maybeAuthId - cid <- MaybeT . getKeyBy $ CourseTermShort tid csh + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh user <- MaybeT $ get uid let courseFavourite = CourseFavourite uid now cid @@ -515,6 +518,7 @@ instance Yesod UniWorX where defaultLayout widget = do master <- getYesod + let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master mmsgs <- getMessages mcurrentRoute <- getCurrentRoute @@ -525,19 +529,17 @@ instance Yesod UniWorX where -- let isParent :: Route UniWorX -> Bool -- isParent r = r == (fst parents) - - let - menu = defaultLinks ++ maybe [] pageActions mcurrentRoute + let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute menuTypes <- filterM (menuItemAccessCallback . menuItem) menu isAuth <- isJust <$> maybeAuthId -- Lookup Favourites & Theme if possible -- TODO: cache this info in a cookie?! - (favourites',show -> currentTheme) <- do + (favourites', currentTheme) <- do muid <- maybeAuthPair case muid of - Nothing -> return ([],Default) + Nothing -> return ([],userDefaultTheme) (Just (uid,user)) -> do favs <- runDB $ E.select . E.from $ \(course `E.InnerJoin` courseFavourite) -> do E.on (course E.^. CourseId E.==. courseFavourite E.^. CourseFavouriteCourse) @@ -547,7 +549,7 @@ instance Yesod UniWorX where return (favs, userTheme user) favourites <- forM favourites' $ \(Entity _ c@Course{..}) -> let - courseRoute = CourseR courseTerm courseShorthand CShowR + courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute) let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority @@ -577,10 +579,11 @@ instance Yesod UniWorX where breadcrumbs :: Widget breadcrumbs = $(widgetFile "widgets/breadcrumbs") pageactionprime :: Widget - pageactionprime = $(widgetFile "widgets/pageactionprime") - -- functions to determine if there are page-actions + pageactionprime = $(widgetFile "widgets/pageactionprime") -- TODO: rename, since it also shows secondary pageActions now + -- functions to determine if there are page-actions (primary or secondary) isPageActionPrime :: MenuTypes -> Bool - isPageActionPrime (PageActionPrime _) = True + isPageActionPrime (PageActionPrime _) = True + isPageActionPrime (PageActionSecondary _) = True isPageActionPrime _ = False hasPageActions :: Bool hasPageActions = any isPageActionPrime menuTypes @@ -644,10 +647,7 @@ instance Yesod UniWorX where -- What messages should be logged. The following includes all messages when -- in development, and warnings and errors in production. - shouldLog app _source level = - appShouldLogAll (appSettings app) - || level == LevelWarn - || level == LevelError + shouldLog app _source level = appShouldLogAll (appSettings app) || level >= appMinimumLogLevel (appSettings app) makeLogger = return . appLogger @@ -670,27 +670,29 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid) 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 CourseNewR = return ("Neu" , Just CourseListR) - breadcrumb (CourseR tid csh CShowR) = return (CI.original csh, Just $ TermCourseListR tid) - -- (CourseR tid csh CRegisterR) -- is POST only - breadcrumb (CourseR tid csh CEditR) = return ("Editieren", Just $ CourseR tid csh CShowR) - breadcrumb (CourseR tid csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid csh CShowR) - breadcrumb (CourseR tid csh SheetListR) = return ("Übungen" , Just $ CourseR tid csh CShowR) - breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR) + breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) + -- (CourseR tid ssh csh CRegisterR) -- is POST only + breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR) + 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 csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR) - breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR) - breadcrumb (CSheetR tid csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid csh shn SShowR) - breadcrumb (CSheetR tid csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) - breadcrumb (CSheetR tid csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) - breadcrumb (CSubmissionR tid csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) --- (CSubmissionR tid csh shn _ SubArchiveR) -- just for Download - breadcrumb (CSubmissionR tid csh shn cid CorrectionR) = return ("Korrektur", Just $ CSubmissionR tid csh shn cid SubShowR) --- (CSubmissionR tid csh shn _ SubDownloadR) -- just for Download - breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR) - -- (CSheetR tid csh shn SFileR) -- just for Downloads + breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) + breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSheetR tid ssh csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSubmissionR tid ssh csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) +-- (CSubmissionR tid ssh csh shn _ SubArchiveR) -- just for Download + breadcrumb (CSubmissionR tid ssh csh shn cid CorrectionR) = return ("Korrektur", Just $ CSubmissionR tid ssh csh shn cid SubShowR) +-- (CSubmissionR tid ssh csh shn _ SubDownloadR) -- just for Download + breadcrumb (CSheetR tid ssh csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid ssh csh shn SShowR) + -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads -- Others breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR) breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR) @@ -769,6 +771,7 @@ defaultLinks = -- Define the menu items of the header. } ] + pageActions :: Route UniWorX -> [MenuTypes] {- Icons: https://fontawesome.com/icons?d=gallery @@ -830,22 +833,22 @@ pageActions (CourseListR) = , menuItemAccessCallback' = return True } ] -pageActions (CourseR tid csh CShowR) = +pageActions (CourseR tid ssh csh CShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Kurs Editieren" , menuItemIcon = Nothing - , menuItemRoute = CourseR tid csh CEditR + , menuItemRoute = CourseR tid ssh csh CEditR , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Übungsblätter" , menuItemIcon = Nothing - , menuItemRoute = CourseR tid csh SheetListR + , menuItemRoute = CourseR tid ssh csh SheetListR , 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 (sheets,lecturer) <- runDB $ do - cid <- getKeyBy404 $ CourseTermShort tid csh + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom] lecturer <- case muid of Nothing -> return False @@ -856,29 +859,29 @@ pageActions (CourseR tid csh CShowR) = , PageActionPrime $ MenuItem { menuItemLabel = "Abgaben" , menuItemIcon = Nothing - , menuItemRoute = CourseR tid csh CCorrectionsR + , menuItemRoute = CourseR tid ssh csh CCorrectionsR , menuItemAccessCallback' = return True } , PageActionSecondary $ MenuItem { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing - , menuItemRoute = CourseR tid csh SheetNewR + , menuItemRoute = CourseR tid ssh csh SheetNewR , menuItemAccessCallback' = return True } ] -pageActions (CourseR tid csh SheetListR) = +pageActions (CourseR tid ssh csh SheetListR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing - , menuItemRoute = CourseR tid csh SheetNewR + , menuItemRoute = CourseR tid ssh csh SheetNewR , menuItemAccessCallback' = return True } ] -pageActions (CSheetR tid csh shn SShowR) = +pageActions (CSheetR tid ssh csh shn SShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Abgabe anlegen" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh shn SubmissionNewR + , menuItemRoute = CSheetR tid ssh csh shn SubmissionNewR , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId submissions <- lift $ submissionList tid csh shn uid @@ -888,7 +891,7 @@ pageActions (CSheetR tid csh shn SShowR) = , PageActionPrime $ MenuItem { menuItemLabel = "Abgabe ansehen" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh shn SubmissionOwnR + , menuItemRoute = CSheetR tid ssh csh shn SubmissionOwnR , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId submissions <- lift $ submissionList tid csh shn uid @@ -898,35 +901,49 @@ pageActions (CSheetR tid csh shn SShowR) = , PageActionPrime $ MenuItem { menuItemLabel = "Korrektoren" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh shn SCorrR + , menuItemRoute = CSheetR tid ssh csh shn SCorrR , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Abgaben" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh shn SSubsR + , menuItemRoute = CSheetR tid ssh csh shn SSubsR , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Blatt Editieren" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh shn SEditR + , menuItemRoute = CSheetR tid ssh csh shn SEditR , 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 { menuItemLabel = "Korrektur" , menuItemIcon = Nothing - , menuItemRoute = CSubmissionR tid csh shn cid CorrectionR + , menuItemRoute = CSubmissionR tid ssh csh shn cid CorrectionR , menuItemAccessCallback' = return True } ] -pageActions (CSheetR tid csh shn SCorrR) = +pageActions (CSheetR tid ssh csh shn SCorrR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Abgaben" , 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 } ] @@ -973,45 +990,49 @@ pageHeading (TermEditExistR tid) = Just $ i18nHeading $ MsgTermEditTid tid pageHeading (TermCourseListR tid) = Just . i18nHeading . MsgTermCourseListHeading $ tid +pageHeading (TermSchoolCourseListR tid ssh) + = Just $ do + School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh + i18nHeading $ MsgTermSchoolCourseListHeading tid school pageHeading (CourseListR) = Just $ i18nHeading $ MsgCourseListTitle pageHeading CourseNewR = Just $ i18nHeading MsgCourseNewHeading -pageHeading (CourseR tid csh CShowR) +pageHeading (CourseR tid ssh csh CShowR) = Just $ do - Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ CourseTermShort tid csh + Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ TermSchoolCourseShort tid ssh csh toWidget courseName -- (CourseR tid csh CRegisterR) -- just for POST -pageHeading (CourseR tid csh CEditR) - = Just $ i18nHeading $ MsgCourseEditHeading tid csh -pageHeading (CourseR tid csh CCorrectionsR) - = Just $ i18nHeading $ MsgSubmissionsCourse tid csh -pageHeading (CourseR tid csh SheetListR) - = Just $ i18nHeading $ MsgSheetList tid csh -pageHeading (CourseR tid csh SheetNewR) - = Just $ i18nHeading $ MsgSheetNewHeading tid csh -pageHeading (CSheetR tid csh shn SShowR) - = Just $ i18nHeading $ MsgSheetTitle tid csh shn -pageHeading (CSheetR tid csh shn SEditR) - = Just $ i18nHeading $ MsgSheetEditHead tid csh shn -pageHeading (CSheetR tid csh shn SDelR) - = Just $ i18nHeading $ MsgSheetDelHead tid csh shn -pageHeading (CSheetR tid csh shn SSubsR) +pageHeading (CourseR tid ssh csh CEditR) + = Just $ i18nHeading $ MsgCourseEditHeading tid ssh csh +pageHeading (CourseR tid ssh csh CCorrectionsR) + = Just $ i18nHeading $ MsgSubmissionsCourse tid ssh csh +pageHeading (CourseR tid ssh csh SheetListR) + = Just $ i18nHeading $ MsgSheetList tid ssh csh +pageHeading (CourseR tid ssh csh SheetNewR) + = Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh +pageHeading (CSheetR tid ssh csh shn SShowR) + = Just $ i18nHeading $ MsgSheetTitle tid ssh csh shn +pageHeading (CSheetR tid ssh csh shn SEditR) + = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn +pageHeading (CSheetR tid ssh csh shn SDelR) + = Just $ i18nHeading $ MsgSheetDelHead tid ssh csh shn +pageHeading (CSheetR tid ssh csh shn SSubsR) = Just $ i18nHeading $ MsgSubmissionsSheet shn -pageHeading (CSheetR tid csh shn SubmissionNewR) - = Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn -pageHeading (CSheetR tid csh shn SubmissionOwnR) - = Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn -pageHeading (CSubmissionR tid csh shn _ SubShowR) -- TODO: Rethink this one! - = Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn +pageHeading (CSheetR tid ssh csh shn SubmissionNewR) + = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn +pageHeading (CSheetR tid ssh csh shn SubmissionOwnR) + = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn +pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one! + = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn -- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download -pageHeading (CSubmissionR tid csh shn cid CorrectionR) - = Just $ i18nHeading $ MsgCorrectionHead tid csh shn cid +pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR) + = Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid -- (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 --- (CSheetR tid csh shn SFileR) -- just for Downloads +-- (CSheetR tid ssh csh shn SFileR) -- just for Downloads pageHeading CorrectionsR = Just $ i18nHeading MsgCorrectionsTitle @@ -1026,6 +1047,7 @@ pageHeading _ routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)] routeNormalizers = [ normalizeRender + , ncSchool , ncCourse , ncSheet ] @@ -1046,17 +1068,25 @@ routeNormalizers = $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|] tell $ Any True | 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 - CourseR tid csh subRoute <- return route - Entity _ Course{..} <- MaybeT . lift . getBy $ CourseTermShort tid csh + CourseR tid ssh csh subRoute <- return route + Entity _ Course{..} <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh hasChanged csh courseShorthand - return $ CourseR tid courseShorthand subRoute + (hasChanged `on` unSchoolKey) ssh courseSchool + return $ CourseR tid courseSchool courseShorthand subRoute ncSheet = maybeOrig $ \route -> do - CSheetR tid csh shn subRoute <- return route - Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh + CSheetR tid ssh csh shn subRoute <- return route + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn hasChanged shn sheetName - return $ CSheetR tid csh sheetName subRoute + return $ CSheetR tid ssh csh sheetName subRoute -- How to run database actions. @@ -1120,7 +1150,7 @@ instance YesodAuth UniWorX where acceptExisting = maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth $logDebugS "auth" $ tshow Creds{..} - AppSettings{..} <- getsYesod appSettings + AppSettings{ appUserDefaults = UserDefaultConf{..}, ..} <- getsYesod appSettings flip catches excHandlers $ case appLdapConf of Just ldapConf -> fmap (either id id) . runExceptT $ do @@ -1154,12 +1184,15 @@ instance YesodAuth UniWorX where -> throwError $ ServerError "Could not decode user matriculation" let - userMaxFavourites = appDefaultMaxFavourites - userTheme = appDefaultTheme - userDateTimeFormat = appDefaultDateTimeFormat - userDateFormat = appDefaultDateFormat - userTimeFormat = appDefaultTimeFormat - newUser = User{..} + newUser = User + { userMaxFavourites = userDefaultMaxFavourites + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , .. + } userUpdate = [ UserMatrikelnummer =. userMatrikelnummer , UserDisplayName =. userDisplayName , UserEmail =. userEmail diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 670cb1c17..5e587c624 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -86,33 +86,36 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm) colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> - let tid = course ^. _3 - csh = course ^. _2 - in anchorCell (CourseR tid csh CShowR) [whamlet|#{display csh}|] + let csh = course ^. _2 + tid = course ^. _3 + ssh = course ^. _4 + in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|] colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> - let tid = course ^. _3 - csh = course ^. _2 + let csh = course ^. _2 + tid = course ^. _3 + ssh = course ^. _4 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 = 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 colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> - let tid = course ^. _3 - csh = course ^. _2 + let csh = course ^. _2 + tid = course ^. _3 + ssh = course ^. _4 shn = sheetName $ entityVal sheet mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice mkRoute = do cid <- mkCid - return $ CSubmissionR tid csh shn cid SubShowR + return $ CSubmissionR tid ssh csh shn cid SubShowR in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) @@ -125,12 +128,13 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } -> - let tid = course ^. _3 - csh = course ^. _2 + let csh = course ^. _2 + tid = course ^. _3 + ssh = course ^. _4 -- shn = sheetName mkRoute = do cid <- encrypt subId - return $ CSubmissionR tid csh sheetName cid CorrectionR + return $ CSubmissionR tid ssh csh sheetName cid CorrectionR 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)) @@ -340,10 +344,10 @@ postCorrectionsR = do [ downloadAction ] -getCCorrectionsR, postCCorrectionsR :: TermId -> CourseShorthand -> Handler TypedContent +getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent getCCorrectionsR = postCCorrectionsR -postCCorrectionsR tid csh = do - Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh +postCCorrectionsR tid ssh csh = do + Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh let whereClause = courseIs cid colonnade = mconcat [ colSelect @@ -360,10 +364,10 @@ postCCorrectionsR tid csh = do , assignAction (Left cid) ] -getSSubsR, postSSubsR :: TermId -> CourseShorthand -> SheetName -> Handler TypedContent +getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSSubsR = postSSubsR -postSSubsR tid csh shn = do - shid <- runDB $ fetchSheetId tid csh shn +postSSubsR tid ssh csh shn = do + shid <- runDB $ fetchSheetId tid ssh csh shn let whereClause = sheetIs shid colonnade = mconcat [ colSelect @@ -380,26 +384,26 @@ postSSubsR tid csh shn = do , 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 $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. sheet E.^. SheetName E.==. E.val shn + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. submission E.^. SubmissionId E.==. E.val sub - return (course, sheet, submission, corrector) -getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html -getCorrectionR tid csh shn cid = do - mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True - bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid csh shn cid -postCorrectionR tid csh shn cid = do +getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html +getCorrectionR tid ssh csh shn cid = do + mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True + bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid +postCorrectionR tid ssh csh shn cid = do sub <- decrypt cid - results <- runDB $ correctionData tid csh shn sub + results <- runDB $ correctionData tid ssh csh shn sub case results of [(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 - update sub [ SubmissionRatingBy =. (uid <$ guard rated) - , SubmissionRatingTime =. (now <$ guard rated) - , SubmissionRatingPoints =. ratingPoints + update sub [ SubmissionRatingBy =. (uid <$ guard rated) + , SubmissionRatingTime =. (now <$ guard rated) + , SubmissionRatingPoints =. ratingPoints , SubmissionRatingComment =. ratingComment ] addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated - redirect $ CSubmissionR tid csh shn cid CorrectionR + redirect $ CSubmissionR tid ssh csh shn cid CorrectionR case uploadResult of FormMissing -> return () @@ -442,16 +446,16 @@ postCorrectionR tid csh shn cid = do runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True addMessageI "success" MsgRatingFilesUpdated - redirect $ CSubmissionR tid csh shn cid CorrectionR + redirect $ CSubmissionR tid ssh csh shn cid CorrectionR defaultLayout $ do let userCorrection = $(widgetFile "correction-user") $(widgetFile "correction") _ -> notFound -getCorrectionUserR tid csh shn cid = do +getCorrectionUserR tid ssh csh shn cid = do sub <- decrypt cid - results <- runDB $ correctionData tid csh shn sub + results <- runDB $ correctionData tid ssh csh shn sub case results of [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index f65c92a73..f8bddf741 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -39,13 +39,13 @@ type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School) colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> - anchorCell (CourseR courseTerm courseShorthand CShowR) + anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseName}|] colCourseDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ \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 Nothing -> mempty (Just descr) -> cell [whamlet| ^{modalStatic descr} |] @@ -61,12 +61,12 @@ colDescription = sortable Nothing (i18nCell MsgCourseDescription) colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) $ \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 = sortable (Just "cshort") (i18nCell MsgCourseShort) $ \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 Nothing -> mempty (Just descr) -> cell @@ -80,13 +80,13 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm) colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) - $ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } -> - cell [whamlet|#{display schoolName}|] + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } -> + anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|] colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) -colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchool) - $ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } -> - cell [whamlet|#{display schoolShorthand}|] +colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } -> + anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|] colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) @@ -187,7 +187,7 @@ getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!! whereClause = const $ E.val True validator = def & defaultSorting [("course", SortAsc), ("term", SortDesc)] - coursesTable <- makeCourseTable whereClause colonnade validator + ((), coursesTable) <- makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI MsgCourseListTitle [whamlet|TODO: Such-/Filterfunktion hier einbauen|] -- TODO @@ -201,6 +201,30 @@ getTermCurrentR = do (Just (maximum -> tid)) -> -- getTermCourseListR tid redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc. +getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html +getTermSchoolCourseListR tid ssh = do + void . runDB $ get404 tid -- Just ensure the term exists + School{schoolName=school} <- runDB $ get404 ssh -- Just ensure the term exists + muid <- maybeAuthId + let colonnade = widgetColonnade $ mconcat + [ dbRow + , colCShortDescr + , colRegFrom + , colRegTo + , colParticipants + , maybe mempty (const colRegistered) muid + ] + whereClause = \(course, _, _) -> + course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + validator = def + & defaultSorting [("cshort", SortAsc)] + ((), coursesTable) <- makeCourseTable whereClause colonnade validator + defaultLayout $ do + setTitleI $ MsgTermSchoolCourseListTitle tid school + $(widgetFile "courses") + + getTermCourseListR :: TermId -> Handler Html getTermCourseListR tid = do void . runDB $ get404 tid -- Just ensure the term exists @@ -217,18 +241,18 @@ getTermCourseListR tid = do whereClause = \(course, _, _) -> course E.^. CourseTerm E.==. E.val tid validator = def & defaultSorting [("cshort", SortAsc)] - coursesTable <- makeCourseTable whereClause colonnade validator + ((), coursesTable) <- makeCourseTable whereClause colonnade validator defaultLayout $ do setTitleI . MsgTermCourseListTitle $ tid $(widgetFile "courses") -getCShowR :: TermId -> CourseShorthand -> Handler Html -getCShowR tid csh = do +getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCShowR tid ssh csh = do mbAid <- maybeAuthId (courseEnt,(schoolMB,participants,registered)) <- runDB $ do - courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh + courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh dependent <- (,,) - <$> get (courseSchool course) -- join + <$> get (courseSchool course) -- join -- just fetch full school name here <*> count [CourseParticipantCourse ==. cid] -- join <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here! Nothing -> return False @@ -238,7 +262,7 @@ getCShowR tid csh = do return $ (courseEnt,dependent) let course = entityVal courseEnt (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 mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course 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 -postCRegisterR :: TermId -> CourseShorthand -> Handler Html -postCRegisterR tid csh = do +postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +postCRegisterR tid ssh csh = do aid <- requireAuthId (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) return (cid, course, registered) ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course @@ -277,7 +301,7 @@ postCRegisterR tid csh = do when (isJust regOk) $ addMessageI "success" MsgCourseRegisterOk | otherwise -> addMessageI "danger" MsgCourseSecretWrong (_other) -> return () -- TODO check this! - redirect $ CourseR tid csh CShowR + redirect $ CourseR tid ssh csh CShowR getCourseNewR :: Handler Html getCourseNewR = do @@ -287,14 +311,14 @@ getCourseNewR = do postCourseNewR :: Handler Html postCourseNewR = courseEditHandler False Nothing -getCEditR :: TermId -> CourseShorthand -> Handler Html -getCEditR tid csh = do - course <- runDB $ getBy $ CourseTermShort tid csh +getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCEditR tid ssh csh = do + course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh courseEditHandler True course -postCEditR :: TermId -> CourseShorthand -> Handler Html -postCEditR tid csh = do - course <- runDB $ getBy $ CourseTermShort tid csh +postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +postCEditR tid ssh csh = do + course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh courseEditHandler False course @@ -311,12 +335,14 @@ courseDeleteHandler = undefined courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html courseEditHandler isGet course = do + $logDebug "€€€€€€ courseEditHandler started" aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! ((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm case result of (FormSuccess res@( CourseForm { cfCourseId = Nothing , cfShort = csh + , cfSchool = ssh , cfTerm = tid })) -> do -- create new course now <- liftIO getCurrentTime @@ -339,17 +365,17 @@ courseEditHandler isGet course = do runDB $ do insert_ $ CourseEdit aid now cid insert_ $ Lecturer aid cid - addMessageI "info" $ MsgCourseNewOk tid csh + addMessageI "info" $ MsgCourseNewOk tid ssh csh redirect $ TermCourseListR tid Nothing -> - addMessageI "danger" $ MsgCourseNewDupShort tid csh + addMessageI "danger" $ MsgCourseNewDupShort tid ssh csh (FormSuccess res@( - CourseForm { cfCourseId = Just cID + CourseForm { cfCourseId = Just cid , cfShort = csh + , cfSchool = ssh , cfTerm = tid })) -> do -- edit existing course - cid <- decrypt cID now <- liftIO getCurrentTime -- addMessage "debug" [shamlet| #{show res}|] success <- runDB $ do @@ -373,12 +399,12 @@ courseEditHandler isGet course = do } ) case updOkay of - (Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid csh) $> False + (Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid ssh csh) $> False Nothing -> do insert_ $ CourseEdit aid now cid - addMessageI "success" $ MsgCourseEditOk tid csh + addMessageI "success" $ MsgCourseEditOk tid ssh csh return True - when success $ redirect $ CourseR tid csh CShowR + when success $ redirect $ CourseR tid ssh csh CShowR (FormFailure _) -> addMessageI "warning" MsgInvalidInput (FormMissing) -> return () @@ -389,7 +415,7 @@ courseEditHandler isGet course = do data CourseForm = CourseForm - { cfCourseId :: Maybe CryptoUUIDCourse + { cfCourseId :: Maybe CourseId , cfName :: CourseName , cfDesc :: Maybe Html , cfLink :: Maybe Text @@ -406,9 +432,8 @@ data CourseForm = CourseForm courseToForm :: MonadCrypto m => Entity Course -> m CourseForm courseToForm (Entity cid Course{..}) = do - cfCourseId <- Just <$> encrypt cid return $ CourseForm - { cfCourseId + { cfCourseId = Just cid , cfName = courseName , cfDesc = courseDescription , cfLink = courseLinkExternal @@ -425,40 +450,35 @@ courseToForm (Entity cid Course{..}) = do newCourseForm :: Maybe CourseForm -> Form CourseForm newCourseForm template = identForm FIDcourse $ \html -> do - -- mopt hiddenField - -- cidKey <- getsYesod appCryptoIDKey - -- courseId <- runMaybeT $ do - -- cid <- cfCourseId template - -- UUID.encrypt cidKey cid + userSchools <- liftHandlerT . runDB $ do + userId <- liftHandlerT requireAuthId + (fmap concat . sequence) + [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] [] + , map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] [] + ] (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm - -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work? - <$> aopt hiddenField "courseId" (cfCourseId <$> template) - <*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template) + <$> pure (cfCourseId =<< template) + <*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template) <*> aopt htmlField (fslI MsgCourseDescription & setTooltip MsgCourseDescriptionTip) (cfDesc <$> template) - <*> aopt urlField (fslI MsgCourseHomepage) (cfLink <$> template) + <*> aopt urlField (fslI MsgCourseHomepage) (cfLink <$> template) <*> areq (ciField textField) (fslI MsgCourseShorthand -- & addAttr "disabled" "disabled" & setTooltip MsgCourseShorthandUnique) (cfShort <$> template) - <*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template) - <*> areq schoolField (fslI MsgCourseSchool) (cfSchool <$> template) - <*> aopt (natField "Kapazität") (fslI MsgCourseCapacity - & setTooltip MsgCourseCapacityTip - ) (cfCapacity <$> template) - <*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette" - & setTooltip MsgCourseSecretTip) - (cfSecret <$> template) - <*> areq checkBoxField (fslI MsgMaterialFree)(cfMatFree <$> template) - <*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum" - & setTooltip MsgCourseRegisterFromTip) - (cfRegFrom <$> template) - <*> aopt utcTimeField (fslpI MsgRegisterTo "Datum" - & setTooltip MsgCourseRegisterToTip) - (cfRegTo <$> template) - <*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum" - & setTooltip MsgCourseDeregisterUntilTip) - (cfDeRegUntil <$> template) + <*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template) + <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template) + <*> aopt (natField "Kapazität") (fslI MsgCourseCapacity + & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template) + <*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette" + & setTooltip MsgCourseSecretTip) (cfSecret <$> template) + <*> areq checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template) + <*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum" + & setTooltip MsgCourseRegisterFromTip) (cfRegFrom <$> template) + <*> aopt utcTimeField (fslpI MsgRegisterTo "Datum" + & setTooltip MsgCourseRegisterToTip) (cfRegTo <$> template) + <*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum" + & setTooltip MsgCourseDeregisterUntilTip) (cfDeRegUntil <$> template) <* submitButton return $ case result of FormSuccess courseResult @@ -476,9 +496,6 @@ newCourseForm template = identForm FIDcourse $ \html -> do |] ) _ -> (result, widget) --- where --- cid :: Maybe CourseId --- cid = join $ cfCourseId <$> template validateCourse :: CourseForm -> [Text] diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 6f198828b..9a744f208 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -38,23 +38,23 @@ instance CryptoRoute UUID SubmissionId where cryptoIDRoute _ (CryptoID -> cID) = do (smid :: SubmissionId) <- decrypt cID cID' <- encrypt smid - (tid,csh,shn) <- runDB $ do + (tid,ssh,csh,shn) <- runDB $ do shid <- submissionSheet <$> get404 smid Sheet{..} <- get404 shid Course{..} <- get404 sheetCourse - return (courseTerm, courseShorthand, sheetName) - return $ CSubmissionR tid csh shn cID' SubShowR + return (courseTerm, courseSchool, courseShorthand, sheetName) + return $ CSubmissionR tid ssh csh shn cID' SubShowR instance CryptoRoute (CI FilePath) SubmissionId where cryptoIDRoute _ ciphertext | Just cID <- fromPathPiece . Text.pack $ CI.original ciphertext = do smid <- decrypt cID - (tid,csh,shn) <- runDB $ do + (tid,ssh,csh,shn) <- runDB $ do shid <- submissionSheet <$> get404 smid Sheet{..} <- get404 shid Course{..} <- get404 sheetCourse - return (courseTerm, courseShorthand, sheetName) - return $ CSubmissionR tid csh shn cID SubShowR + return (courseTerm, courseSchool, courseShorthand, sheetName) + return $ CSubmissionR tid ssh csh shn cID SubShowR | otherwise = notFound instance CryptoRoute UUID UserId where diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 960ff2757..601fbfed9 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -22,12 +22,12 @@ import Data.Time hiding (formatTime) -- import Web.PathPieces (showToPathPiece, readFromPathPiece) -import Control.Lens -import Colonnade hiding (fromMaybe, singleton) +-- import Control.Lens +-- import Colonnade hiding (fromMaybe, singleton) -- import Yesod.Colonnade import qualified Database.Esqueleto as E -import Text.Shakespeare.Text +-- import Text.Shakespeare.Text import Development.GitRev @@ -55,29 +55,31 @@ getHomeR = do homeAnonymous :: Handler Html homeAnonymous = do cTime <- liftIO getCurrentTime - let fTime = addUTCTime (offCourseDeadlines * nominalDay) cTime let tableData :: E.SqlExpr (Entity Course) -> E.SqlQuery (E.SqlExpr (Entity Course)) 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.&&. ((E.isNothing $ course E.^. CourseRegisterTo) E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime))) return course - colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (WidgetT UniWorX IO) ()) + colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ()) colonnade = mconcat [ -- dbRow - sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do - let tid = courseTerm course - csh = courseShorthand course - cell [whamlet|#{display csh}|] - , sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> + sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = 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}) } -> cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget ] - courseTable <- dbTable def $ DBTable + ((), courseTable) <- dbTable def $ DBTable { dbtSQLQuery = tableData , dbtColonnade = colonnade , dbtProj = return @@ -85,6 +87,9 @@ homeAnonymous = do [ ( "term" , SortColumn $ \(course) -> course E.^. CourseTerm ) + , ( "school" + , SortColumn $ \(course) -> course E.^. CourseSchool + ) , ( "course" , SortColumn $ \(course) -> course E.^. CourseShorthand ) @@ -116,6 +121,7 @@ homeUser uid = do -- (E.SqlExpr (Entity Course ))) -- (E.SqlExpr (Entity Sheet )) _ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term)) + , E.SqlExpr (E.Value SchoolId) , E.SqlExpr (E.Value CourseShorthand) , E.SqlExpr (E.Value SheetName) , E.SqlExpr (E.Value UTCTime) @@ -132,6 +138,7 @@ homeUser uid = do -- E.limit nrSheetDeadlines -- arbitrary limits are not intuitive return ( course E.^. CourseTerm + , course E.^. CourseSchool , course E.^. CourseShorthand , sheet E.^. SheetName , sheet E.^. SheetActiveTo @@ -139,38 +146,45 @@ homeUser uid = do ) colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term) + , E.Value SchoolId , E.Value CourseShorthand , E.Value SheetName , E.Value UTCTime , E.Value (Maybe SubmissionId) )) - (DBCell (WidgetT UniWorX IO) ()) + (DBCell (HandlerT UniWorX IO) ()) colonnade = mconcat [ -- dbRow - sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _, _) } -> - anchorCell (CourseR tid csh CShowR) (toWidget $ display csh) - , sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid, _,_,_,_) } -> + -- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } -> + sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } -> textCell $ display tid - , sortable (Just "sheet") (textCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, _) } -> - anchorCell (CSheetR tid csh shn SShowR) (toWidget $ display shn) - , sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline, _) } -> + , sortable (Just "school") (textCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } -> + textCell $ display ssh + , 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 - , 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 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 ] let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)] - sheetTable <- dbTable validator $ DBTable + ((), sheetTable) <- dbTable validator $ DBTable { dbtSQLQuery = tableData , dbtColonnade = colonnade - , dbtProj = \dbRow@DBRow{ dbrOutput = (E.Value tid, E.Value csh, E.Value shn, _, _) } - -> dbRow <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh shn SShowR) False) + , dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } + -> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False) , dbtSorting = Map.fromList [ ( "term" , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm ) + , ( "school" + , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseSchool + ) , ( "course" , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseShorthand ) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index c5d92dc48..4bb62d344 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -1,21 +1,25 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} + module Handler.Profile where import Import import Handler.Utils - +import Utils.Lens -- import Colonnade hiding (fromMaybe, singleton) -- import Yesod.Colonnade - +import qualified Data.Map as Map import qualified Database.Esqueleto as E -import Database.Esqueleto ((^.)) +-- import Database.Esqueleto ((^.)) @@ -25,19 +29,23 @@ data SettingsForm = SettingsForm , stgDateTime :: DateTimeFormat , stgDate :: DateTimeFormat , stgTime :: DateTimeFormat + , stgDownloadFiles :: Bool } makeSettingForm :: Maybe SettingsForm -> Form SettingsForm 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 <$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here (fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template) - <*> areq (selectFieldList themeList) - (fslpI MsgTheme "theme-select" ) (stgTheme <$> template) -- TODO: pass theme-select as id-attribute or similar. + <*> areq (selectField . return $ mkOptionList themeList) + (fslI MsgTheme) { fsId = Just "theme-select" } (stgTheme <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) (stgDateTime <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template) <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template) + <*> areq checkBoxField (fslI MsgDownloadFiles + & setTooltip MsgDownloadFilesTip + ) (stgDownloadFiles <$> template) <* submitButton return (result, widget) -- no validation required here @@ -52,6 +60,7 @@ getProfileR = do , stgDateTime = userDateTimeFormat , stgDate = userDateFormat , stgTime = userTimeFormat + , stgDownloadFiles = userDownloadFiles } ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate case res of @@ -62,6 +71,7 @@ getProfileR = do , UserDateTimeFormat =. stgDateTime , UserDateFormat =. stgDate , UserTimeFormat =. stgTime + , UserDownloadFiles =. stgDownloadFiles ] when (stgMaxFavourties < userMaxFavourites) $ do -- prune Favourites to user-defined size @@ -79,45 +89,45 @@ getProfileR = do (admin_rights,lecturer_rights,lecture_owner,lecture_corrector,participant,studies) <- runDB $ (,,,,,) <$> (E.select $ E.from $ \(adright `E.InnerJoin` school) -> do - E.where_ $ adright ^. UserAdminUser E.==. E.val uid - E.on $ adright ^. UserAdminSchool E.==. school ^. SchoolId - return (school ^. SchoolShorthand) + E.where_ $ adright E.^. UserAdminUser E.==. E.val uid + E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId + return (school E.^. SchoolShorthand) ) <*> (E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do - E.where_ $ lecright ^. UserLecturerUser E.==. E.val uid - E.on $ lecright ^. UserLecturerSchool E.==. school ^. SchoolId - return (school ^. SchoolShorthand) + E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid + E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId + return (school E.^. SchoolShorthand) ) <*> (E.select $ E.from $ \(lecturer `E.InnerJoin` course) -> do - E.where_ $ lecturer ^. LecturerUser E.==. E.val uid - E.on $ lecturer ^. LecturerCourse E.==. course ^. CourseId - return (course ^. CourseShorthand, course ^. CourseTerm) + E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid + E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + return (course E.^. CourseTerm, course E.^.CourseSchool, course E.^. CourseShorthand) ) <*> (E.select $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do - E.on $ sheet ^. SheetCourse E.==. course ^. CourseId - E.on $ sheet ^. SheetId E.==. corrector ^. SheetCorrectorSheet - E.where_ $ corrector ^. SheetCorrectorUser E.==. E.val uid + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet + E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid - return (course ^. CourseShorthand, course ^. CourseTerm) + return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand) ) <*> (E.select $ E.from $ \(participant `E.InnerJoin` course) -> do - E.where_ $ participant ^. CourseParticipantUser E.==. E.val uid - E.on $ participant ^. CourseParticipantCourse E.==. course ^. CourseId - return (course ^. CourseShorthand, course ^. CourseTerm, participant ^. CourseParticipantRegistration) + E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid + E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, participant E.^. CourseParticipantRegistration) ) <*> (E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do - E.where_ $ studyfeat ^. StudyFeaturesUser E.==. E.val uid - E.on $ studyfeat ^. StudyFeaturesField E.==. studyterms ^. StudyTermsId - E.on $ studyfeat ^. StudyFeaturesDegree E.==. studydegree ^. StudyDegreeId - return (studydegree ^. StudyDegreeName - ,studyterms ^. StudyTermsName - ,studyfeat ^. StudyFeaturesType - ,studyfeat ^. StudyFeaturesSemester) + E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid + E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId + E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId + return (studydegree E.^. StudyDegreeName + ,studyterms E.^. StudyTermsName + ,studyfeat E.^. StudyFeaturesType + ,studyfeat E.^. StudyFeaturesSemester) ) let formText = Just MsgSettings actionUrl = ProfileR @@ -133,11 +143,48 @@ postProfileR = do getProfileR + getProfileDataR :: Handler Html getProfileDataR = do (uid, User{..}) <- requireAuthPair -- 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 $(widgetFile "profileData") $(widgetFile "dsgvDisclaimer") diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 8284164c1..8ea156247 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -21,31 +21,31 @@ import Import import System.FilePath (takeFileName) import Handler.Utils -import Handler.Utils.Zip +-- import Handler.Utils.Zip -- import Data.Time -import qualified Data.Text as T +-- import qualified Data.Text as T -- import Data.Function ((&)) -- -import Colonnade hiding (fromMaybe, singleton, bool) +-- import Colonnade hiding (fromMaybe, singleton, bool) import qualified Yesod.Colonnade as Yesod 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 Data.CaseInsensitive (CI) +-- import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto as E -import qualified Database.Esqueleto.Internal.Sql as E +-- import qualified Database.Esqueleto.Internal.Sql as E 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 @@ -56,8 +56,10 @@ import qualified Data.Map as Map import Data.Map (Map, (!), (!?)) import qualified Data.Map as Map +import Data.Monoid (Sum(..)) + import Control.Lens -import Utils.Lens +-- import Utils.Lens instance Eq (Unique Sheet) where @@ -132,17 +134,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do FormSuccess sheetResult | errorMsgs <- validateSheet mr sheetResult , not $ null errorMsgs -> - (FormFailure errorMsgs, - [whamlet| -
-
-

Fehler: -
    - $forall errmsg <- errorMsgs -
  • #{errmsg} - ^{widget} - |] - ) + (FormFailure errorMsgs, widget) _ -> (result, widget) where validateSheet :: MsgRenderer -> SheetForm -> [Text] @@ -154,24 +146,24 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do , ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly) ] ] -getSheetListR :: TermId -> CourseShorthand -> Handler Html -getSheetListR tid csh = do +getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getSheetListR tid ssh csh = do muid <- maybeAuthId - Entity cid _ <- runDB . getBy404 $ CourseTermShort tid csh + Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh 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 (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid - let sheetEdit = E.sub_select . E.from $ \sheetEdit -> do - E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId - return . E.max_ $ sheetEdit E.^. SheetEditTime + let sheetEdit = E.sub_select . E.from $ \sheetEdit' -> do + E.where_ $ sheetEdit' E.^. SheetEditSheet E.==. sheet E.^. SheetId + return . E.max_ $ sheetEdit' E.^. SheetEditTime E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return (sheet, sheetEdit, submission) sheetCol = widgetColonnade . mconcat $ [ 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) $ \(_, E.Value mEditTime, _) -> case mEditTime of Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget @@ -188,9 +180,9 @@ getSheetListR tid csh = do (Just (Entity sid Submission{..})) -> let mkCid = encrypt sid -- TODO: executed twice mkRoute = do - cid <- mkCid - return $ CSubmissionR tid csh sheetName cid SubShowR - in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) + cid' <- mkCid + return $ CSubmissionR tid ssh csh sheetName cid' SubShowR + in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|]) , sortable (Just "rating") (i18nCell MsgRating) $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of Nothing -> mempty @@ -198,8 +190,9 @@ getSheetListR tid csh = do let mkCid = encrypt sid mkRoute = do cid <- mkCid - return $ CSubmissionR tid csh sheetName cid CorrectionR - in anchorCellM mkRoute $(widgetFile "widgets/rating") + return $ CSubmissionR tid ssh csh sheetName cid CorrectionR + protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating") + in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints))) , sortable Nothing -- (Just "percent") (i18nCell MsgRatingPercent) $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of @@ -214,11 +207,11 @@ getSheetListR tid csh = do ] psValidator = def & defaultSorting [("submission-since", SortAsc)] - table <- dbTable psValidator $ DBTable + (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable { dbtSQLQuery = sheetData , dbtColonnade = sheetCol , 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 [ ( "name" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName @@ -248,27 +241,14 @@ getSheetListR tid csh = do , dbtStyle = def , 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 $(widgetFile "sheetList") $(widgetFile "widgets/sheetTypeSummary") -- Show single sheet -getSShowR :: TermId -> CourseShorthand -> SheetName -> Handler Html -getSShowR tid csh shn = do - entSheet <- runDB $ fetchSheet tid csh shn +getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +getSShowR tid ssh csh shn = do + entSheet <- runDB $ fetchSheet tid ssh csh shn let sheet = entityVal entSheet sid = entityKey entSheet -- without Colonnade @@ -281,7 +261,7 @@ getSShowR tid csh shn = do -- E.where_ (sheet E.^. SheetId E.==. E.val sid ) -- -- return desired columns -- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) --- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid csh (SheetFileR shn fType fName),modified)) fileNameTypes +-- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes -- with Colonnade let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do @@ -295,17 +275,17 @@ getSShowR tid csh shn = do return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = widgetColonnade $ mconcat [ 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) , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget ] let psValidator = def & defaultSorting [("type", SortAsc), ("path", SortAsc)] - fileTable <- dbTable psValidator $ DBTable + ((), fileTable) <- dbTable psValidator $ DBTable { dbtSQLQuery = fileData , dbtColonnade = colonnadeFiles , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } - -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh shn $ SFileR fType fName) False) + -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False) , dbtStyle = def , dbtFilter = Map.empty , dbtIdent = "files" :: Text @@ -329,19 +309,19 @@ getSShowR tid csh shn = do when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $ maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom defaultLayout $ do - setTitleI $ MsgSheetTitle tid csh shn + setTitleI $ MsgSheetTitle tid ssh csh shn sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet $(widgetFile "sheetShow") -getSFileR :: TermId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent -getSFileR tid csh shn typ title = do +getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent +getSFileR tid ssh csh shn typ title = do results <- runDB $ E.select $ E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do -- Restrict to consistent rows that correspond to each other - E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) + E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) -- filter to requested file @@ -349,7 +329,8 @@ getSFileR tid csh shn typ title = do E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ ) E.&&. (sheet E.^. SheetName E.==. E.val shn ) E.&&. (course E.^. CourseShorthand E.==. E.val csh ) - E.&&. (course E.^. 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 $ (file E.^. FileTitle, file E.^. FileContent) @@ -357,7 +338,8 @@ getSFileR tid csh shn typ title = do case results of [(E.Value fileTitle, E.Value fileContent)] | 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') | otherwise -> sendResponseStatus noContent204 () [] -> notFound @@ -365,21 +347,21 @@ getSFileR tid csh shn typ title = do $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other error "Multiple matching files found." -getSheetNewR :: TermId -> CourseShorthand -> Handler Html -getSheetNewR tid csh = do +getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getSheetNewR tid ssh csh = do 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 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 -getSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html -getSEditR tid csh shn = do +getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +getSEditR tid ssh csh shn = do (sheetEnt, sheetFileIds) <- runDB $ do - ent <- fetchSheet tid csh shn + ent <- fetchSheet tid ssh csh shn fti <- getFtIdMap $ entityKey ent return (ent, fti) let sid = entityKey sheetEnt @@ -405,13 +387,13 @@ getSEditR tid csh shn = do case replaceRes of Nothing -> return $ Just sid (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here - handleSheetEdit tid csh (Just sid) template action + handleSheetEdit tid ssh csh (Just sid) template action -postSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html +postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html postSEditR = getSEditR -handleSheetEdit :: TermId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html -handleSheetEdit tid csh msId template dbAction = do +handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html +handleSheetEdit tid ssh csh msId template dbAction = do let mbshn = sfName <$> template aid <- requireAuthId ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template @@ -419,7 +401,7 @@ handleSheetEdit tid csh msId template dbAction = do (FormSuccess SheetForm{..}) -> do saveOkay <- runDB $ do actTime <- liftIO getCurrentTime - cid <- getKeyBy404 $ CourseTermShort tid csh + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh let newSheet = Sheet { sheetCourse = cid , sheetName = sfName @@ -435,51 +417,53 @@ handleSheetEdit tid csh msId template dbAction = do } mbsid <- dbAction newSheet 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: whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise whenIsJust sfHintF $ insertSheetFile' sid SheetHint whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking insert_ $ SheetEdit aid actTime sid - addMessageI "info" $ MsgSheetEditOk tid csh sfName + addMessageI "info" $ MsgSheetEditOk tid ssh csh sfName 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 _ -> return () - let pageTitle = maybe (MsgSheetTitleNew tid csh) - (MsgSheetTitle tid csh) mbshn + let pageTitle = maybe (MsgSheetTitleNew tid ssh csh) + (MsgSheetTitle tid ssh csh) mbshn -- let formTitle = pageTitle -- no longer used in template let formText = Nothing :: Maybe UniWorXMessage - actionUrl <- fromMaybe (CourseR tid csh SheetNewR) <$> getCurrentRoute + actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute defaultLayout $ do setTitleI pageTitle $(widgetFile "formPageI18n") -getSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html -getSDelR tid csh shn = do +getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +getSDelR tid ssh csh shn = do ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) case result of - (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh shn SShowR + (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid ssh csh shn SShowR (FormSuccess BtnDelete) -> do - runDB $ fetchSheetId tid csh shn >>= deleteCascade + runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! - addMessageI "info" $ MsgSheetDelOk tid csh shn - redirect $ CourseR tid csh SheetListR + addMessageI "info" $ MsgSheetDelOk tid ssh csh shn + redirect $ CourseR tid ssh csh SheetListR _other -> do submissionno <- runDB $ do - sid <- fetchSheetId tid csh shn + sid <- fetchSheetId tid ssh csh shn count [SubmissionSheet ==. sid] - let formTitle = MsgSheetDelHead tid csh shn + let formTitle = MsgSheetDelHead tid ssh csh shn let formText = Just $ MsgSheetDelText submissionno - let actionUrl = CSheetR tid csh shn SDelR + let actionUrl = CSheetR tid ssh csh shn SDelR defaultLayout $ do - setTitleI $ MsgSheetTitle tid csh shn + setTitleI $ MsgSheetTitle tid ssh csh shn $(widgetFile "formPageI18n") -postSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html +postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html postSDelR = getSDelR @@ -511,11 +495,11 @@ insertSheetFile' sid ftype fs = do data CorrectorForm = CorrectorForm { cfUserId :: UserId , cfUserName :: Text - , cfResult :: FormResult Load - , cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX + , cfResult :: FormResult (CorrectorState, Load) + , cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX } -type Loads = Map UserId Load +type Loads = Map UserId (CorrectorState, Load) defaultLoads :: SheetId -> DB Loads -- ^ Generate `Loads` in such a way that minimal editing is required @@ -535,10 +519,10 @@ defaultLoads shid = do E.orderBy [E.desc creationTime] - return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad) + return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState) where - toMap :: [(E.Value UserId, E.Value Load)] -> Loads - toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load + toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads + toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load) correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX]) @@ -553,19 +537,19 @@ correctorForm shid = do formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser]) let 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 - 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' , 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') let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions) didDelete = any (flip Set.member deletions) formCIDs - (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads' + (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads' let tutorField :: Field Handler [UserEmail] tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField @@ -595,7 +579,7 @@ correctorForm shid = do case mUid of Nothing -> loads'' <$ addMessageI "error" (MsgEMailUnknown email) 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) FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs _ -> return loads'' @@ -607,8 +591,8 @@ correctorForm shid = do return $ (user E.^. UserId, user E.^. UserDisplayName) let - constructFields :: (UserId, Text, Load) -> MForm Handler CorrectorForm - constructFields (uid, uname, Load{..}) = do + constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm + constructFields (uid, uname, (state, Load{..})) = do cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser let fs name = "" @@ -616,12 +600,13 @@ correctorForm shid = do } rationalField = convertField toRational fromRational doubleField + (stateRes, cfViewState) <- mreq (selectField $ optionsFinite id) (fs "state") (Just state) (byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial) (propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion) (_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False) let - cfResult :: FormResult Load - cfResult = Load <$> tutRes' <*> propRes + cfResult :: FormResult (CorrectorState, Load) + cfResult = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes) tutRes' | FormSuccess True <- byTutRes = Just <$> countTutRes | otherwise = Nothing <$ byTutRes @@ -638,6 +623,7 @@ correctorForm shid = do let corrColonnade = mconcat [ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName + , headed (Yesod.textCell $ mr MsgCorState) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewState , headed (Yesod.textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut , headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp , headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel @@ -646,7 +632,7 @@ correctorForm shid = do | FormSuccess (Just es) <- addTutRes , not $ null es = 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 ] idField CorrectorForm{..} = do @@ -678,10 +664,10 @@ correctorForm shid = do -- Eingabebox für Korrektor hinzufü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 -getSCorrR tid csh shn = do - Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn +getSCorrR tid ssh csh shn = do + Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton @@ -694,10 +680,10 @@ getSCorrR tid csh shn = do FormMissing -> return () let - -- formTitle = MsgSheetCorrectorsTitle tid csh shn + -- formTitle = MsgSheetCorrectorsTitle tid ssh csh shn formText = Nothing :: Maybe (SomeMessage UniWorX) - actionUrl = CSheetR tid csh shn SCorrR - -- actionUrl = CSheetR tid csh shn SShowR + actionUrl = CSheetR tid ssh csh shn SCorrR + -- actionUrl = CSheetR tid ssh csh shn SShowR defaultLayout $ do - setTitleI $ MsgSheetCorrectorsTitle tid csh shn + setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn $(widgetFile "formPageI18n") diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 73f68f988..e55a8a25f 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -78,20 +78,20 @@ makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ aforced' f fs (Just (Just v)) = Just <$> aforced f fs v 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 -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 -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 tid csh shn = do +getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +getSubmissionOwnR tid ssh csh shn = do authId <- requireAuthId sid <- runDB $ do - shid <- fetchSheetId tid csh shn + shid <- fetchSheetId tid ssh csh shn submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId @@ -101,14 +101,14 @@ getSubmissionOwnR tid csh shn = do ((E.Value sid):_) -> return sid [] -> notFound 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 tid csh shn (SubmissionMode mcid) = do +submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html +submissionHelper tid ssh csh shn (SubmissionMode mcid) = do uid <- requireAuthId msmid <- traverse decrypt mcid (Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do - sheet@(Entity shid Sheet{..}) <- fetchSheet tid csh shn + sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn case msmid of Nothing -> 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 cID <- encrypt smid addMessageI "info" $ MsgSubmissionAlreadyExists - redirect $ CSubmissionR tid csh shn cID SubShowR + redirect $ CSubmissionR tid ssh csh shn cID SubShowR (Just smid) -> do - void $ submissionMatchesSheet tid csh shn (fromJust mcid) + void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid) shid' <- submissionSheet <$> get404 smid -- fetch buddies from current submission @@ -239,14 +239,14 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do _other -> return Nothing case mCID of - Just cID -> redirect $ CSubmissionR tid csh shn cID SubShowR + Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR Nothing -> return () actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- 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 [ sortable (Just "path") (textCell MsgFileTitle) $ \(coalesce -> (mOrig, mCorr)) -> let 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 Just isFile = origIsFile <|> corrIsFile 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'}|]) | otherwise -> textCell $ bool (<> "/") id isFile fileTitle' , sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of Nothing -> cell mempty 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}|]) | otherwise -> textCell MsgFileCorrected , sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let @@ -299,22 +299,22 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do ] , dbtFilter = [] } - mFileTable <- traverse (dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid + mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid defaultLayout $ do - setTitleI $ MsgSubmissionEditHead tid csh shn + setTitleI $ MsgSubmissionEditHead tid ssh csh shn $(widgetFile "submission") -getSubDownloadR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent -getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do +getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent +getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do runDB $ do - submissionID <- submissionMatchesSheet tid csh shn cID + submissionID <- submissionMatchesSheet tid ssh csh shn cID isRating <- maybe False (== submissionID) <$> isRatingFile path 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 True @@ -335,17 +335,18 @@ getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = let fileName = Text.pack $ takeFileName path case results of [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) [Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 () other -> do $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other error "Multiple matching files found." -getSubArchiveR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent -getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do +getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent +getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do when (sfType == SubmissionCorrected) $ - guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False + guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False let filename | 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}"|] respondSourceDB "application/zip" $ do - submissionID <- lift $ submissionMatchesSheet tid csh shn cID + submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID rating <- lift $ getRating submissionID let diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 20f12eaa3..c14b796eb 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -17,11 +17,40 @@ import Handler.Utils -- import qualified Data.Text as T import Yesod.Form.Bootstrap3 - -import Colonnade hiding (bool) +-- import Colonnade hiding (bool) import qualified Database.Esqueleto as E + + +validateTerm :: Term -> [Text] +validateTerm (Term{..}) = + [ msg | (False, msg) <- + [ --startOk + ( termStart `withinTerm` termName + , "Jahreszahl im Namenskürzel stimmt nicht mit Semesterbeginn überein." + ) + , -- endOk + ( termStart < termEnd + , "Semester darf nicht enden, bevor es begann." + ) + , -- startOk + ( termLectureStart < termLectureEnd + , "Vorlesungszeit muss vor ihrem Ende anfgangen." + ) + , -- lecStartOk + ( termStart <= termLectureStart + , "Semester muss vor der Vorlesungszeit beginnen." + ) + , -- lecEndOk + ( termEnd >= termLectureEnd + , "Vorlesungszeit muss vor dem Semester enden." + ) + ] ] + + + + getTermShowR :: Handler TypedContent getTermShowR = do -- terms <- runDB $ selectList [] [Desc TermStart] @@ -78,7 +107,7 @@ getTermShowR = do -- #{termToText termName} -- |] -- ] - table <- dbTable def $ DBTable + ((), table) <- dbTable def $ DBTable { dbtSQLQuery = termData , dbtColonnade = colonnadeTerms , dbtProj = return . dbrOutput diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index ef9d012e1..ae6e07c64 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -4,7 +4,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} module Handler.Users where @@ -12,6 +12,8 @@ import Import -- import Data.Text import Handler.Utils +import Utils.Lens + import qualified Data.Map as Map import qualified Data.Set as Set @@ -29,7 +31,7 @@ hijackUserForm uid csrf = do getUsersR :: Handler Html getUsersR = do let - colonnadeUsers = dbColonnade . mconcat $ + dbtColonnade = dbColonnade . mconcat $ [ dbRow , sortable (Just "display-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM (AdminUserR <$> encrypt uid) @@ -40,32 +42,28 @@ getUsersR = do -- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM -- (AdminUserR <$> encrypt uid) -- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName) - , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> mempty - { dbCellContents = do - schools <- E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do - E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool - E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid - E.orderBy [E.asc $ school E.^. SchoolShorthand] - return $ school E.^. SchoolShorthand - return [whamlet| -
      - $forall (E.Value sh) <- schools -
    • #{sh} - |] - } - , sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> mempty - { dbCellContents = do - schools <- E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do - E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool - E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid - E.orderBy [E.asc $ school E.^. SchoolShorthand] - return $ school E.^. SchoolShorthand - return [whamlet| -
        - $forall (E.Value sh) <- schools -
      • #{sh} - |] - } + , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do + schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do + E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool + E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid + E.orderBy [E.asc $ school E.^. SchoolShorthand] + return $ school E.^. SchoolShorthand + return [whamlet| +
          + $forall (E.Value sh) <- schools +
        • #{sh} + |] + , sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do + schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do + E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool + E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid + E.orderBy [E.asc $ school E.^. SchoolShorthand] + return $ school E.^. SchoolShorthand + return [whamlet| +
            + $forall (E.Value sh) <- schools +
          • #{sh} + |] , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do (hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm uid cID <- encrypt uid @@ -77,9 +75,9 @@ getUsersR = do psValidator = def & defaultSorting [("display-name", SortAsc)] - userList <- dbTable psValidator $ DBTable + ((), userList) <- dbTable psValidator $ DBTable { dbtSQLQuery = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User)) - , dbtColonnade = colonnadeUsers + , dbtColonnade , dbtProj = return , dbtSorting = Map.fromList [ ( "display-name" diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index b173b2219..d9710c119 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -2,16 +2,16 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} module Handler.Utils ( module Handler.Utils ) where - +import Import import Handler.Utils.DateTime as Handler.Utils -import Handler.Utils.Term as Handler.Utils import Handler.Utils.Form as Handler.Utils import Handler.Utils.Table as Handler.Utils import Handler.Utils.Table.Pagination as Handler.Utils @@ -21,3 +21,13 @@ import Handler.Utils.Rating as Handler.Utils hiding (extractRatings) import Handler.Utils.Submission as Handler.Utils import Handler.Utils.Sheet as Handler.Utils import Handler.Utils.Templates as Handler.Utils + + +downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool +downloadFiles = do + mauth <- liftHandlerT maybeAuth + case mauth of + Just (Entity _ User{..}) -> return userDownloadFiles + Nothing -> do + AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings + return userDefaultDownloadFiles diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index ced936b06..c9d465366 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -57,7 +57,7 @@ getTimeLocale = getTimeLocale' <$> languages getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat getDateTimeFormat sel = do mauth <- liftHandlerT maybeAuth - AppSettings{..} <- getsYesod appSettings + AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings let fmt | Just (Entity _ User{..}) <- mauth @@ -67,9 +67,9 @@ getDateTimeFormat sel = do SelFormatTime -> userTimeFormat | otherwise = case sel of - SelFormatDateTime -> appDefaultDateTimeFormat - SelFormatDate -> appDefaultDateFormat - SelFormatTime -> appDefaultTimeFormat + SelFormatDateTime -> userDefaultDateTimeFormat + SelFormatDate -> userDefaultDateFormat + SelFormatTime -> userDefaultTimeFormat return fmt validDateTimeFormats :: TimeLocale -> SelDateTimeFormat -> Set DateTimeFormat diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 7600f1d8e..e1fab772b 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -218,17 +218,36 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..} sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific) 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 = selectField schools - where - schools = optionsPersistKey [] [Asc SchoolName] schoolName +schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName -schoolEntField :: Field Handler (Entity School) -schoolEntField = selectField schools - where - schools = optionsPersist [] [Asc SchoolName] schoolName +schoolFieldEnt :: Field Handler (Entity School) +schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName + +schoolFieldFor :: [SchoolId] -> Field Handler SchoolId +schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName zipFileField :: Bool -- ^ Unpack zips? -> Field Handler (Source Handler File) @@ -354,7 +373,7 @@ utcTimeField = Field readTime t = case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of (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 Nothing -> Left MsgInvalidDateTimeFormat @@ -376,17 +395,29 @@ optionsPersistCryptoId :: forall site backend a msg. => [Filter a] -> [SelectOpt a] -> (a -> msg) - -> HandlerT site IO (OptionList (Key a)) + -> HandlerT site IO (OptionList (Entity a)) optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do mr <- getMessageRender pairs <- runDB $ selectList filts ords cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e - return $ map (\(cId, Entity key value) -> Option + return $ map (\(cId, e@(Entity key value)) -> Option { optionDisplay = mr (toDisplay value) - , optionInternalValue = key + , optionInternalValue = e , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a)) }) cPairs +optionsFinite :: ( MonadHandler m, Finite a, RenderMessage site msg, HandlerSite m ~ site, PathPiece a ) + => (a -> msg) -> m (OptionList a) +optionsFinite toMsg = do + mr <- getMessageRender + let + mkOption a = Option + { optionDisplay = mr $ toMsg a + , optionInternalValue = a + , optionExternalValue = toPathPiece a + } + return . mkOptionList $ mkOption <$> universeF + mforced :: (site ~ HandlerSite m, MonadHandler m) => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site) mforced Field{..} FieldSettings{..} val = do diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index dbcd79dd9..d38d2e10a 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/src/Handler/Utils/Sheet.hs @@ -24,29 +24,30 @@ fetchSheetAux :: ( BaseBackend backend ~ SqlBackend , PersistQueryRead backend, PersistUniqueRead backend ) => (E.SqlExpr (Entity Sheet) -> b) - -> TermId -> CourseShorthand -> SheetName -> ReaderT backend m a -fetchSheetAux prj tid csh shn = - let cachId = encodeUtf8 $ tshow (tid,csh,shn) + -> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a +fetchSheetAux prj tid ssh csh shn = + let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn) in cachedBy cachId $ do -- Mit Yesod: - -- cid <- getKeyBy404 $ CourseTermShort tid csh + -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh -- getBy404 $ CourseSheet cid shn -- Mit Esqueleto: sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. sheet E.^. SheetName E.==. E.val shn + E.where_ $ course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh + E.&&. course E.^. CourseShorthand E.==. E.val csh + E.&&. sheet E.^. SheetName E.==. E.val shn return $ prj sheet case sheetList of [sheet] -> return sheet _other -> notFound -fetchSheet :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet) +fetchSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet) fetchSheet = fetchSheetAux id -fetchSheetId :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet) -fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn +fetchSheetId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet) +fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid ssh cid shn -fetchSheetIdCourseId :: TermId -> 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 :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course) +fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid ssh cid shn diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 097a505d8..bd4f44daa 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -25,6 +25,7 @@ module Handler.Utils.Submission ) where import Import hiding ((.=), joinPath) +import Prelude (lcm) import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import Control.Lens @@ -32,9 +33,10 @@ import Control.Lens.Extras (is) import Utils.Lens 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 qualified Control.Monad.Random as Rand +import qualified System.Random.Shuffle as Rand (shuffleM) import Data.Maybe @@ -45,11 +47,12 @@ import Data.Map (Map, (!?)) import qualified Data.Map as Map import qualified Data.Text as Text +import Data.Ratio import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI -import Data.Monoid (Monoid, Any(..)) +import Data.Monoid (Monoid, Any(..), Sum(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) 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) ) assignSubmissions sid restriction = do - correctors <- selectList [SheetCorrectorSheet ==. sid] [] - let corrsGroup = filter hasTutorialLoad correctors -- needed as List within Esqueleto - let corrsProp = filter hasPositiveLoad correctors - let countsToLoad' :: UserId -> Bool - countsToLoad' uid = -- refactor by simply using Map.(!) - fromMaybe (error "Called `countsToLoad'` on entity not element of `corrsGroup`") $ - Map.lookup uid loadMap - loadMap :: Map UserId Bool - loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsGroup] + Sheet{..} <- getJust sid + correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] [] + let + byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ] + corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto + corrsProp = filter hasPositiveLoad correctors + countsToLoad' :: UserId -> Bool + countsToLoad' uid = Map.findWithDefault True uid loadMap + loadMap :: Map UserId Bool + loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsTutorial] - 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 -- Uncomment next line for equal chance between tutors, irrespective of the number of students per tutor per submission group -- E.distinctOn [E.don $ tutorial E.^. TutorialTutor] $ do E.on (tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial) E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser) - E.where_ (tutorial E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsGroup)) + E.where_ (tutorial E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial)) 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.&&. 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, user) -- , listToMaybe tutors) + return (submission E.^. SubmissionId, tutor) - 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) - subTutor' = Map.fromListWith (<|>) $ map (over (_2.traverse) entityKey . over _1 E.unValue) subs + prevSubs <- E.select . E.from $ \((sheet `E.InnerJoin` sheetCorrector) `E.LeftOuterJoin` submission) -> do + E.on $ E.joinV (submission E.?. SubmissionRatingBy) E.==. E.just (sheetCorrector E.^. SheetCorrectorUser) + E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId + let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial) -> do + E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialUserTutorial + E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialUserUser + E.where_ $ tutorial E.^. TutorialTutor E.==. sheetCorrector E.^. SheetCorrectorUser + E.&&. submission E.?. SubmissionId E.==. E.just (submissionUser E.^. SubmissionUserSubmission) + E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse + E.&&. sheetCorrector E.^. SheetCorrectorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) correctors) + return (sheetCorrector, isByTutorial, E.isNothing (submission E.?. SubmissionId)) - subTutor <- fmap fst . flip execStateT (Map.empty, queue) . forM_ (Map.toList subTutor') $ \case - (smid, Just tutid) -> do + let + prevSubs' :: Map SheetId (Map UserId (Rational, Integer)) + prevSubs' = Map.unionsWith (Map.unionWith $ \(prop, n) (_, n') -> (prop, n + n')) $ do + (Entity _ sc@SheetCorrector{ sheetCorrectorLoad = Load{..}, .. }, E.Value isByTutorial, E.Value isPlaceholder) <- prevSubs + guard $ maybe True (not isByTutorial ||) byTutorial + let proportion + | CorrectorExcused <- sheetCorrectorState = 0 + | otherwise = byProportion + return . Map.singleton sheetCorrectorSheet $ Map.singleton sheetCorrectorUser (proportion, bool 1 0 isPlaceholder) + + deficit :: Map UserId Integer + deficit = Map.filter (> 0) $ Map.foldr (Map.unionWith (+) . toDeficit) Map.empty prevSubs' + + toDeficit :: Map UserId (Rational, Integer) -> Map UserId Integer + toDeficit assignments = toDeficit' <$> assignments + where + assigned' = getSum $ foldMap (Sum . snd) assignments + props = getSum $ foldMap (Sum . fst) assignments + + toDeficit' (prop, assigned) = let + target = round $ fromInteger assigned' * (prop / props) + in target - assigned + + $logDebugS "assignSubmissions" $ "Previous submissions: " <> tshow prevSubs' + $logDebugS "assignSubmissions" $ "Current deficit: " <> tshow deficit + + let + lcd :: Integer + lcd = foldr lcm 1 $ map (denominator . byProportion . sheetCorrectorLoad . entityVal) corrsProp + wholeProps :: Map UserId Integer + wholeProps = Map.fromList [ ( sheetCorrectorUser, round $ byProportion * fromInteger lcd ) | Entity _ SheetCorrector{ sheetCorrectorLoad = Load{..}, .. } <- corrsProp ] + detQueueLength = fromIntegral (Map.size $ Map.filter (\tuts -> all countsToLoad' tuts) subTutor') - sum deficit + detQueue = concat . List.genericReplicate (detQueueLength `div` sum wholeProps) . concatMap (uncurry $ flip List.genericReplicate) $ Map.toList wholeProps + + $logDebugS "assignSubmissions" $ "Deterministic Queue: " <> tshow detQueue + + queue <- liftIO . Rand.evalRandIO . execWriterT $ do + tell $ map Just detQueue + forever $ + tell . pure =<< Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp ] + + $logDebugS "assignSubmissions" $ "Queue: " <> tshow (take (Map.size subTutor') queue) + + let + assignSubmission :: MonadState (Map SubmissionId UserId, [Maybe UserId], Map UserId Integer) m => Bool -> SubmissionId -> UserId -> m () + assignSubmission countsToLoad smid tutid = do _1 %= Map.insert smid tutid - when (any ((== tutid) . sheetCorrectorUser . entityVal) corrsProp && countsToLoad' tutid) $ + _3 . at tutid %= assertM' (> 0) . maybe (-1) pred + when countsToLoad $ _2 %= List.delete (Just tutid) - (smid, Nothing) -> do - (q:qs) <- use _2 - _2 .= qs - case q of - Just q -> _1 %= Map.insert smid q - Nothing -> return () -- NOTE: throwM NoCorrectorsByProportion + + maximumDeficit :: (MonadState (_a, _b, Map UserId Integer) m, MonadIO m) => m (Maybe UserId) + maximumDeficit = do + transposed <- uses _3 invertMap + traverse (liftIO . Rand.evalRandIO . Rand.uniform . snd) (Map.lookupMax transposed) + + subTutor'' <- liftIO . Rand.evalRandIO . Rand.shuffleM $ Map.toList subTutor' + + subTutor <- fmap (view _1) . flip execStateT (Map.empty, queue, deficit) . forM_ subTutor'' $ \(smid, tuts) -> do + let + restrictTuts + | Set.null tuts = id + | otherwise = flip Map.restrictKeys tuts + byDeficit <- withStateT (over _3 restrictTuts) maximumDeficit + case byDeficit of + Just q' -> do + $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (byDeficit)" + assignSubmission False smid q' + Nothing + | Set.null tuts -> do + q <- preuse $ _2 . _head . _Just + case q of + Just q' -> do + $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q' <> " (queue)" + assignSubmission True smid q' + Nothing -> return () + | otherwise -> do + q <- liftIO . Rand.evalRandIO $ Rand.uniform tuts + $logDebugS "assignSubmissions" $ tshow smid <> " -> " <> tshow q <> " (tutorial)" + assignSubmission (countsToLoad' q) smid q forM_ (Map.toList subTutor) $ \(smid, tutid) -> update smid [SubmissionRatingBy =. Just tutid] @@ -466,7 +551,7 @@ sinkMultiSubmission userId isUpdate = do Submission{..} <- get404 sId Sheet{..} <- get404 submissionSheet 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 sink' <- lift $ yield val ++$$ sink case sink' of @@ -514,10 +599,10 @@ sinkMultiSubmission userId isUpdate = do handleCryptoID _ = return Nothing -submissionMatchesSheet :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId -submissionMatchesSheet tid csh shn cid = do +submissionMatchesSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId +submissionMatchesSheet tid ssh csh shn cid = do sid <- decrypt cid - shid <- fetchSheetId tid csh shn + shid <- fetchSheetId tid ssh csh shn Submission{..} <- get404 sid when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet] return sid diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index cc2b06fe6..c550356d1 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -21,7 +21,7 @@ module Handler.Utils.Table.Pagination ( SortColumn(..), SortDirection(..) , FilterColumn(..), IsFilterColumn - , DBRow(..) + , DBRow(..), HasDBRow(..) , DBStyle(..), DBEmptyStyle(..) , DBTable(..), IsDBTable(..), DBCell(..) , cellAttrs, cellContents @@ -31,6 +31,7 @@ module Handler.Utils.Table.Pagination , restrictFilter, restrictSorting , ToSortable(..), Sortable(..), sortable , dbTable + , dbTableWidget, dbTableWidget' , widgetColonnade, formColonnade, dbColonnade , cell, textCell, stringCell, i18nCell , anchorCell, anchorCell', anchorCellM @@ -40,6 +41,7 @@ module Handler.Utils.Table.Pagination , dbRow, dbSelect , (&) , module Control.Monad.Trans.Maybe + , module Colonnade ) where 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 | 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 { dbrOutput :: r , dbrIndex, dbrCount :: Int64 } deriving (Show, Read, Eq, Ord) +makeClassy_ ''DBRow + instance Functor DBRow where fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. } @@ -139,6 +180,50 @@ instance Foldable DBRow where instance Traversable DBRow where traverse f DBRow{..} = DBRow <$> f dbrOutput <*> pure dbrIndex <*> pure dbrCount +newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) } + +instance Default (PSValidator m x) where + def = PSValidator $ \DBTable{..} -> \case + Nothing -> def + Just 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 deriving (Enum, Bounded, Ord, Eq, Show, Read) @@ -173,82 +258,6 @@ data DBTable m x = forall a r r' h i t. , 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 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) -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x) - dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget - dbHandler :: forall m'. (MonadHandler m' , HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x) + dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget + dbHandler :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x) runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x) cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)] @@ -267,46 +276,46 @@ cellAttrs = dbCell . _1 cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget) cellContents = dbCell . _2 -instance IsDBTable (WidgetT UniWorX IO) () where - type DBResult (WidgetT UniWorX IO) () = Widget +instance Monoid x => IsDBTable (HandlerT UniWorX IO) x where + type DBResult (HandlerT UniWorX IO) x = (x, Widget) -- type DBResult' (WidgetT UniWorX IO) () = () - data DBCell (WidgetT UniWorX IO) () = WidgetCell + data DBCell (HandlerT UniWorX IO) x = WidgetCell { wgtCellAttrs :: [(Text, Text)] - , wgtCellContents :: Widget + , wgtCellContents :: WriterT x (HandlerT UniWorX IO) Widget } dbCell = iso - (\WidgetCell{..} -> (wgtCellAttrs, return wgtCellContents)) - (\(attrs, mkWidget) -> WidgetCell attrs . join . fmap fst $ runWriterT mkWidget) + (\WidgetCell{..} -> (wgtCellAttrs, wgtCellContents)) + (\(attrs, mkWidget) -> WidgetCell attrs mkWidget) -- dbWidget Proxy Proxy = iso (, ()) $ view _1 - dbWidget _ = return - dbHandler _ f x = return $ f x - runDBTable = return . join . fmap (view _2) + dbWidget _ = return . snd + dbHandler _ f = return . over _2 f + runDBTable act = liftHandlerT act -instance Monoid (DBCell (WidgetT UniWorX IO) ()) where - mempty = WidgetCell mempty mempty - (WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend c c') +instance Monoid x => Monoid (DBCell (HandlerT UniWorX IO) x) where + mempty = WidgetCell mempty $ return mempty + (WidgetCell a c) `mappend` (WidgetCell a' c') = WidgetCell (mappend a a') (mappend <$> c <*> c') -instance IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) () where - type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) () = Widget +instance Monoid x => IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) x where + type DBResult (ReaderT SqlBackend (HandlerT UniWorX IO)) x = (x, Widget) - data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) () = DBCell + data DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x = DBCell { dbCellAttrs :: [(Text, Text)] - , dbCellContents :: ReaderT SqlBackend (HandlerT UniWorX IO) Widget + , dbCellContents :: WriterT x (ReaderT SqlBackend (HandlerT UniWorX IO)) Widget } dbCell = iso - (\DBCell{..} -> (dbCellAttrs, lift dbCellContents)) - (\(attrs, mkWidget) -> DBCell attrs . fmap fst $ runWriterT mkWidget) + (\DBCell{..} -> (dbCellAttrs, dbCellContents)) + (\(attrs, mkWidget) -> DBCell attrs mkWidget) - dbWidget _ = return - dbHandler _ f x = return $ f x + dbWidget _ = return . snd + dbHandler _ f = return . over _2 f -- runDBTable :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT SqlBackend (HandlerT UniWorX IO) ((), Widget) -> m (Widget) - runDBTable = 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 (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 <$> 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 "page") <*> ireq checkBoxField (wIdent "table-only") @@ -448,11 +457,16 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), setParam :: Text -> Maybe Text -> QueryText -> QueryText 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 - => Colonnade h r (DBCell (WidgetT UniWorX IO) ()) - -> Colonnade h r (DBCell (WidgetT UniWorX IO) ()) +dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> Handler Widget +dbTableWidget' = fmap (fmap snd) . dbTable + +widgetColonnade :: (Headedness h, Monoid x) + => Colonnade h r (DBCell (HandlerT UniWorX IO) x) + -> Colonnade h r (DBCell (HandlerT UniWorX IO) x) widgetColonnade = id formColonnade :: (Headedness h, Monoid a) @@ -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)) formColonnade = id -dbColonnade :: Headedness h - => Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ()) - -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ()) +dbColonnade :: (Headedness h, Monoid x) + => Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) + -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) dbColonnade = id + +--- DBCell utility functions + cell :: IsDBTable m a => Widget -> DBCell m a cell wgt = dbCell # ([], return wgt) @@ -523,6 +540,7 @@ formCell genIndex genForm input = FormCell return (DBFormResult . Map.singleton i . (input,) <$> edit, w) } + -- Predefined colonnades dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a) diff --git a/src/Handler/Utils/Term.hs b/src/Handler/Utils/Term.hs deleted file mode 100644 index fa2186bf0..000000000 --- a/src/Handler/Utils/Term.hs +++ /dev/null @@ -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." - ) - ] ] diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 665c509b5..252e9f8ac 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -3,8 +3,10 @@ module Import.NoFoundation ( module Import ) where -import ClassyPrelude.Yesod as Import hiding (formatTime) +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON) import Model as Import +import Model.Types.JSON as Import +import Model.Migration as Import import Settings as Import import Settings.StaticFiles as Import import Yesod.Auth as Import @@ -21,3 +23,5 @@ import Data.UUID as Import (UUID) import Text.Lucius as Import import Text.Shakespeare.Text as Import hiding (text, stext) + +import Data.Universe as Import diff --git a/src/Model.hs b/src/Model.hs index 9bff65c56..f57f39a7c 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -18,30 +18,24 @@ module Model import ClassyPrelude.Yesod import Database.Persist.Quasi -import Database.Persist.Postgresql (migrateEnableExtension) -import Database.Persist.Sql (Migration) -- import Data.Time -- import Data.ByteString import Model.Types import Data.Aeson.TH import Data.CaseInsensitive (CI) +import Data.CaseInsensitive.Instances () -- You can define all of your database entities in the entities file. -- You can find more information on persistent and how to declare entities -- at: -- http://www.yesodweb.com/book/persistent/ -share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'"] +share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'", mkSave "currentModel"] $(persistFileWith lowerCaseSettings "models") -- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only deriving instance Eq (Unique Course) -migrateAll :: Migration -migrateAll = do - migrateEnableExtension "citext" - migrateAll' - data PWEntry = PWEntry { pwUser :: User , pwHash :: Text diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs new file mode 100644 index 000000000..8d16d1d1e --- /dev/null +++ b/src/Model/Migration.hs @@ -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 diff --git a/src/Model/Migration/Version.hs b/src/Model/Migration/Version.hs new file mode 100644 index 000000000..37bbd8f3f --- /dev/null +++ b/src/Model/Migration/Version.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveLift, DeriveGeneric, DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Model.Migration.Version + ( MigrationVersion(..) + , version, migrationVersion + , module Data.Version + ) where + +import ClassyPrelude.Yesod + +import Database.Persist.Sql +import Text.ParserCombinators.ReadP +import Data.Maybe (fromJust) + +import Data.Version + +import Data.Aeson.TH + +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax (Lift) +import qualified Language.Haskell.TH.Syntax as TH (lift) + +import Data.Data (Data) + + +deriving instance Lift Version + + +data MigrationVersion = InitialVersion | MigrationVersion Version + deriving (Eq, Ord, Show, Read, Generic, Typeable, Data, Lift) + +deriveJSON defaultOptions + { constructorTagModifier = toLower . fromJust . stripSuffix "Version" + , sumEncoding = UntaggedValue + } ''MigrationVersion + +instance PersistField MigrationVersion where + toPersistValue InitialVersion = PersistText "initial" + toPersistValue (MigrationVersion v) = PersistText . pack $ showVersion v + + fromPersistValue (PersistText t) + | t == "initial" = return InitialVersion + | otherwise = case [ x | (x, "") <- readP_to_S parseVersion $ unpack t] of + [x] -> Right $ MigrationVersion x + [] -> Left "No parse" + _ -> Left "Ambiguous parse" + fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x + +instance PersistFieldSql MigrationVersion where + sqlType _ = SqlString + + +instance PersistField Version where + toPersistValue = PersistText . pack . showVersion + + fromPersistValue (PersistText t) = case [ x | (x, "") <- readP_to_S parseVersion $ unpack t] of + [x] -> Right x + [] -> Left "No parse" + _ -> Left "Ambiguous parse" + fromPersistValue x = Left $ "Expected PersistText, received: " <> tshow x + +instance PersistFieldSql Version where + sqlType _ = SqlString + + +version, migrationVersion :: QuasiQuoter +version = QuasiQuoter{..} + where + quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of + [x] -> x + [] -> error "No parse" + _ -> error "Ambiguous parse" + quotePat = error "version cannot be used as pattern" + quoteType = error "version cannot be used as type" + quoteDec = error "version cannot be used as declaration" +migrationVersion = QuasiQuoter{..} + where + quoteExp "initial" = TH.lift InitialVersion + quoteExp v = TH.lift $ case [ x | (x, "") <- readP_to_S parseVersion v] of + [x] -> MigrationVersion x + [] -> error "No parse" + _ -> error "Ambiguous parse" + quotePat = error "version cannot be used as pattern" + quoteType = error "version cannot be used as type" + quoteDec = error "version cannot be used as declaration" diff --git a/src/Model/Types.hs b/src/Model/Types.hs index aff3ccd1b..a84f6ba7a 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -8,7 +8,7 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE ViewPatterns #-} {-- # LANGUAGE ExistentialQuantification #-} -- for DA type -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) module Model.Types where @@ -16,37 +16,65 @@ import ClassyPrelude import Utils import Control.Lens -import Data.Map (Map) -import qualified Data.Map as Map import Data.Set (Set) import qualified Data.Set as Set +import qualified Data.Map as Map import Data.Fixed +import Data.Monoid (Sum(..)) +import Data.Maybe (fromJust) +import Data.Universe +import Data.Universe.Helpers +import Data.UUID.Types -import Database.Persist.TH +import Text.Read (readMaybe) + +import Database.Persist.TH hiding (derivePersistFieldJSON) +import Model.Types.JSON import Database.Persist.Class import Database.Persist.Sql import Web.HttpApiData +import Web.PathPieces import Data.Text (Text) import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text - -import Text.Read (readMaybe,readsPrec) +import qualified Data.Text.Lens as Text import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI +import Data.CaseInsensitive.Instances () import Yesod.Core.Dispatch (PathPiece(..)) 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 Generics.Deriving.Monoid (memptydefault, mappenddefault) import Data.Typeable (Typeable) -import Text.Shakespeare.I18N (ToMessage(..), RenderMessage(..)) -import Text.Blaze (ToMarkup(..)) -import Yesod.Core.Widget (ToWidget(..)) + +instance PathPiece UUID where + fromPathPiece = Data.UUID.Types.fromString . unpack + toPathPiece = pack . toString + +instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where + fromPathPiece = fmap CI.mk . fromPathPiece + toPathPiece = toPathPiece . CI.original + +instance {-# OVERLAPS #-} PathMultiPiece FilePath where + fromPathMultiPiece = Just . unpack . intercalate "/" + toPathMultiPiece = Text.splitOn "/" . pack + +instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where + fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece + toPathMultiPiece = toPathMultiPiece . CI.foldedCase + +instance ToHttpApiData (CI Text) where + toUrlPiece = CI.original + +instance FromHttpApiData (CI Text) where + parseUrlPiece = return . CI.mk + type Points = Centi @@ -74,32 +102,27 @@ instance DisplayAble SheetType where display (NotGraded) = "Unbewertet" deriveJSON defaultOptions ''SheetType -derivePersistFieldJSON "SheetType" +derivePersistFieldJSON ''SheetType data SheetTypeSummary = SheetTypeSummary - { sumBonusPoints :: Points - , sumNormalPoints :: Points - , numPassSheets :: Int - , numNotGraded :: Int - , achievedBonus :: Maybe Points - , achievedNormal :: Maybe Points - , achievedPasses :: Maybe Int - } + { sumBonusPoints :: Sum Points + , sumNormalPoints :: Sum Points + , numPassSheets :: Sum Int + , numNotGraded :: Sum Int + , achievedBonus :: Maybe (Sum Points) + , achievedNormal :: Maybe (Sum Points) + , achievedPasses :: Maybe (Sum Int) + } deriving (Generic) +instance Monoid SheetTypeSummary where + mempty = memptydefault + mappend = mappenddefault -emptySheetTypeSummary :: SheetTypeSummary -emptySheetTypeSummary = SheetTypeSummary 0 0 0 0 Nothing Nothing Nothing - --- TODO: refactor with lenses! -sumSheetTypes :: SheetTypeSummary -> (SheetType, Maybe Points) -> SheetTypeSummary -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 } +sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary +sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum maxPoints, achievedBonus = Sum <$> achieved } +sheetTypeSum (Normal{..}, achieved) = mempty { sumNormalPoints = Sum maxPoints, achievedNormal = Sum <$> achieved } +sheetTypeSum (Pass{..}, achieved) = mempty { numPassSheets = Sum 1, achievedPasses = Sum . bool 0 1 . (passingPoints <=) <$> achieved} +sheetTypeSum (NotGraded, _ ) = mempty { numNotGraded = Sum 1 } data SheetGroup @@ -108,21 +131,21 @@ data SheetGroup | NoGroups deriving (Show, Read, Eq) deriveJSON defaultOptions ''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]] +derivePersistFieldJSON ''SheetGroup data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking deriving (Show, Read, Eq, Ord, Enum, Bounded) derivePersistField "SheetFileType" +instance Universe SheetFileType where universe = universeDef +instance Finite SheetFileType + instance PathPiece SheetFileType where toPathPiece SheetExercise = "file" toPathPiece SheetHint = "hint" toPathPiece SheetSolution = "solution" toPathPiece SheetMarking = "marking" - fromPathPiece = enumFromPathPiece + fromPathPiece = finiteFromPathPiece -- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType) 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 :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a -partitionFileType fts = - 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) +partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs data SubmissionFileType = SubmissionOriginal | SubmissionCorrected deriving (Show, Read, Eq, Ord, Enum, Bounded) +instance Universe SubmissionFileType where universe = universeDef +instance Finite SubmissionFileType + submissionFileTypeIsUpdate :: SubmissionFileType -> Bool submissionFileTypeIsUpdate SubmissionOriginal = False submissionFileTypeIsUpdate SubmissionCorrected = True @@ -162,7 +177,7 @@ isUpdateSubmissionFileType True = SubmissionCorrected instance PathPiece SubmissionFileType where toPathPiece SubmissionOriginal = "original" toPathPiece SubmissionCorrected = "corrected" - fromPathPiece = enumFromPathPiece + fromPathPiece = finiteFromPathPiece instance DisplayAble SubmissionFileType where display SubmissionOriginal = "Abgabe" @@ -322,36 +337,27 @@ data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded) derivePersistField "StudyFieldType" +data Theme + = ThemeDefault + | ThemeLavender + | ThemeNeutralBlue + | ThemeAberdeenReds + | ThemeMossGreen + | ThemeSkyLove + deriving (Eq, Ord, Bounded, Enum, Show, Read) --- Skins / Themes -data Theme --Simply add Themes to this type only. CamelCase will be converted to "-lower" - = Default - | Lavender - | NeutralBlue - | AberdeenReds -- e.g. turned into "theme--aberdeen-reds" - | MossGreen - | SkyLove - deriving (Eq,Ord,Bounded,Enum) +deriveJSON defaultOptions + { constructorTagModifier = fromJust . stripPrefix "Theme" + } ''Theme -$(deriveJSON defaultOptions ''Theme) -$(deriveShowWith uncamel ''Theme) -- show for internal use in css/js -$(deriveSimpleWith ''DisplayAble 'display camelSpace ''Theme) -- display to display at user +instance Universe Theme where universe = universeDef +instance Finite Theme -allThemes :: [Theme] -allThemes = [minBound..maxBound] +instance PathPiece Theme where + toPathPiece = $(nullaryToPathPiece ''Theme [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel]) + fromPathPiece = finiteFromPathPiece -readTheme :: Map String Theme -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 --} +$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user derivePersistField "Theme" @@ -370,41 +376,28 @@ data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime deriving (Eq, Ord, Read, Show, Enum, Bounded) -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 +data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused + deriving (Eq, Ord, Read, Show, Enum, Bounded) -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" +deriveJSON defaultOptions + { constructorTagModifier = fromJust . stripPrefix "Corrector" + } ''CorrectorState -instance ToJSON a => ToJSON (CI a) where - toJSON = toJSON . CI.original +instance Universe CorrectorState where universe = universeDef +instance Finite CorrectorState -instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where - parseJSON = fmap CI.mk . parseJSON +instance PathPiece CorrectorState where + toPathPiece = $(nullaryToPathPiece ''CorrectorState [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel]) + fromPathPiece = finiteFromPathPiece -instance ToMessage a => ToMessage (CI a) where - toMessage = toMessage . CI.original +derivePersistField "CorrectorState" -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 SheetName = CI Text +type SchoolName = CI Text +type SchoolShorthand = CI Text +type CourseName = CI Text type CourseShorthand = CI Text -type CourseName = CI Text -type UserEmail = CI Text +type SheetName = CI Text +type UserEmail = CI Text diff --git a/src/Model/Types/JSON.hs b/src/Model/Types/JSON.hs new file mode 100644 index 000000000..655c95294 --- /dev/null +++ b/src/Model/Types/JSON.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} + +module Model.Types.JSON + ( derivePersistFieldJSON + ) where + +import ClassyPrelude.Yesod hiding (derivePersistFieldJSON) +import Data.List (foldl) +import Database.Persist.Sql + +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text.Encoding as Text + +import qualified Data.Aeson as JSON + +import Language.Haskell.TH +import Language.Haskell.TH.Datatype + + +derivePersistFieldJSON :: Name -> DecsQ +derivePersistFieldJSON n = do + DatatypeInfo{..} <- reifyDatatype n + vars <- forM datatypeVars (const $ newName "a") + let t = foldl (\t n -> t `appT` varT n) (conT n) vars + iCxt + | null vars = cxt [] + | otherwise = cxt [[t|ToJSON|] `appT` t, [t|FromJSON|] `appT` t] + sqlCxt + | null vars = cxt [] + | otherwise = cxt [[t|PersistField|] `appT` t] + sequence + [ instanceD iCxt ([t|PersistField|] `appT` t) + [ funD (mkName "toPersistValue") + [ clause [] (normalB [e|PersistDbSpecific . LBS.toStrict . JSON.encode|]) [] + ] + , funD (mkName "fromPersistValue") + [ do + bs <- newName "bs" + clause [[p|PersistDbSpecific $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) [] + , do + bs <- newName "bs" + clause [[p|PersistByteString $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) [] + , do + t <- newName "t" + clause [[p|PersistText $(varP t)|]] (normalB [e|first pack . JSON.eitherDecodeStrict' $ Text.encodeUtf8 $(varE t)|]) [] + , clause [wildP] (normalB [e|Left "JSON values must be converted from PersistDbSpecific, PersistText, or PersistByteString"|]) [] + ] + ] + , instanceD sqlCxt ([t|PersistFieldSql|] `appT` t) + [ funD (mkName "sqlType") + [ clause [wildP] (normalB [e|SqlOther "json"|]) [] + ] + ] + ] diff --git a/src/Settings.hs b/src/Settings.hs index 399e029e7..ce68f6a75 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -31,6 +31,12 @@ import qualified Data.Text.Encoding as Text import qualified Ldap.Client as Ldap +import Utils +import Control.Lens + +import Data.Maybe (fromJust) +import qualified Data.Char as Char + import Model -- | Runtime settings to configure this application. These settings can be @@ -42,6 +48,7 @@ data AppSettings = AppSettings , appDatabaseConf :: PostgresConf -- ^ Configuration settings for accessing the database. , appLdapConf :: Maybe LdapConf + -- ^ Configuration settings for accessing the LDAP-directory , appRoot :: Maybe Text -- ^ Base for all generated URLs. If @Nothing@, determined -- from the request headers. @@ -63,29 +70,37 @@ data AppSettings = AppSettings -- ^ Assume that files in the static dir may change after compilation , appSkipCombining :: Bool -- ^ 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 -- ^ Indicate if auth dummy login should be enabled. - , appAuthPWFile :: Maybe FilePath - -- ^ If set authenticate against a local password file , appAllowDeprecated :: Bool -- ^ Indicate if deprecated routes are accessible for everyone + , appAuthPWFile :: Maybe FilePath + -- ^ If set authenticate against a local password file + , appMinimumLogLevel :: LogLevel + , appUserDefaults :: UserDefaultConf + + , 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 { ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password @@ -115,6 +130,13 @@ instance FromJSON LdapConf where ldapTimeout <- o .: "timeout" return LdapConf{..} +deriveFromJSON + defaultOptions + { constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level" + , sumEncoding = UntaggedValue + } + ''LogLevel + instance FromJSON AppSettings where parseJSON = withObject "AppSettings" $ \o -> do let defaultDev = @@ -128,7 +150,7 @@ instance FromJSON AppSettings where let nonEmptyHost LdapConf{..} = case ldapHost of Ldap.Tls 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" appHost <- fromString <$> o .: "host" appPort <- o .: "port" @@ -136,24 +158,18 @@ instance FromJSON AppSettings where appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev appShouldLogAll <- o .:? "should-log-all" .!= defaultDev + appMinimumLogLevel <- o .: "minimum-log-level" appReloadTemplates <- o .:? "reload-templates" .!= defaultDev appMutableStatic <- o .:? "mutable-static" .!= defaultDev appSkipCombining <- o .:? "skip-combining" .!= defaultDev + appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev + appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev + appAuthPWFile <- assertM (not . null) <$> o .:? "auth-pwfile" - appDefaultMaxFavourites <- o .: "default-favourites" - appDefaultTheme <- o .: "default-theme" - appDefaultDateTimeFormat <- o .: "default-date-time-format" - appDefaultDateFormat <- o .: "default-date-format" - appDefaultTimeFormat <- o .: "default-time-format" + appUserDefaults <- o .: "user-defaults" - appCopyright <- o .: "copyright" - appAnalytics <- o .:? "analytics" 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 {..} -- | Settings for 'widgetFile', such as which template languages to support and diff --git a/src/Utils.hs b/src/Utils.hs index 9f70d3159..e472e72ca 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -15,16 +15,15 @@ module Utils import ClassyPrelude.Yesod -- import Data.Double.Conversion.Text -- faster implementation for textPercent? -import Data.List (foldl) import Data.Foldable as Fold -import qualified Data.Char as Char import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Utils.DB as Utils -import Utils.Common as Utils +import Utils.TH as Utils import Utils.DateTime as Utils +import Utils.PathPiece as Utils import Text.Blaze (Markup, ToMarkup) @@ -87,6 +86,11 @@ unsupportedAuthPredicate = do tickmark :: IsString a => a tickmark = fromString "✔" +-- Avoid annoying warnings: +tickmarkS :: String +tickmarkS = tickmark +tickmarkT :: Text +tickmarkT = tickmark text2Html :: Text -> Html text2Html = toHtml -- prevents ambiguous types @@ -95,10 +99,15 @@ toWgt :: (ToMarkup a, MonadBaseControl IO m, MonadThrow m, MonadIO m) => a -> WidgetT site m () toWgt = toWidget . toHtml +-- Convenience Functions to avoid type signatures: text2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => Text -> WidgetT site m () text2widget t = [whamlet|#{t}|] +citext2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => + (CI Text) -> WidgetT site m () +citext2widget t = [whamlet|#{CI.original t}|] + str2widget :: (MonadBaseControl IO m, MonadThrow m, MonadIO m) => String -> WidgetT site m () str2widget s = [whamlet|#{s}|] @@ -109,24 +118,6 @@ withFragment :: ( Monad m 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 class DisplayAble a where 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 = Map.fromListWith mappend +invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k) +invertMap = groupMap . map swap . Map.toList + ----------- -- Maybe -- ----------- @@ -302,6 +296,12 @@ shortCircuitM sc mx my op = do guardM :: MonadPlus m => m Bool -> m () guardM f = guard =<< f +assertM :: MonadPlus m => (a -> Bool) -> m a -> m a +assertM f x = x >>= assertM' f + +assertM' :: MonadPlus m => (a -> Bool) -> a -> m a +assertM' f x = x <$ guard (f x) + -- Some Utility Functions from Agda.Utils.Monad -- | Monadic if-then-else. ifM :: Monad m => m Bool -> m a -> m a -> m a diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs new file mode 100644 index 000000000..a56358638 --- /dev/null +++ b/src/Utils/PathPiece.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE NoImplicitPrelude + #-} + +module Utils.PathPiece + ( finiteFromPathPiece + , nullaryToPathPiece + , splitCamel + ) where + +import ClassyPrelude.Yesod + +import Language.Haskell.TH +import qualified Language.Haskell.TH.Syntax as TH (Lift(..)) +import Data.Universe + +import qualified Data.Text as Text +import qualified Data.Char as Char + +import Data.Monoid (Endo(..)) + +finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a +finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of + [x] -> Just x + _xs -> Nothing + +nullaryToPathPiece :: Name -> [Text -> Text] -> ExpQ +nullaryToPathPiece nullaryType manglers = do + TyConI (DataD _ _ _ _ constructors _) <- reify nullaryType + helperName <- newName "helper" + let + toClause (NormalC cName []) = clause [conP cName []] (normalB . TH.lift . mangle $ nameBase cName) [] + toClause con = fail $ "Unsupported constructor: " ++ show con + helperDec = funD helperName $ map toClause constructors + letE [helperDec] $ varE helperName + where + mangle = appEndo (foldMap Endo manglers) . Text.pack + +splitCamel :: 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 diff --git a/src/Utils/Common.hs b/src/Utils/TH.hs similarity index 96% rename from src/Utils/Common.hs rename to src/Utils/TH.hs index 8583ccf86..04eebdfa2 100644 --- a/src/Utils/Common.hs +++ b/src/Utils/TH.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} -module Utils.Common where +module Utils.TH where -- Common Utility Functions that require TemplateHaskell -- 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 +{- projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2) --ghci -fth -- $(projN n m) :: (t1,..,tn) -> tm (for m<=n) projNI n i = lamE [pat] rhs where pat = tupP (map varP xs) rhs = varE (xs !! (i - 1)) xs = [ mkName $ "x" ++ show j | j <- [1..n] ] - +-} --------------- -- Functions -- @@ -73,7 +74,7 @@ deriveSimpleWith cls fun strOp ty = do genClause :: Con -> Q Clause genClause (NormalC name []) = let pats = [ConP name []] - body = NormalB $ LitE $ StringL $ strOp $ show $ name + body = NormalB $ LitE $ StringL $ strOp $ nameBase name in return $ Clause pats body [] genClause _ = fail "deriveShowTheme: constructors not allowed to have arguments" diff --git a/src/index.md b/src/index.md new file mode 100644 index 000000000..fee16d2ba --- /dev/null +++ b/src/index.md @@ -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 diff --git a/stack.yaml b/stack.yaml index 82f2e0c30..8f93444f8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -34,4 +34,6 @@ extra-deps: - system-locale-0.3.0.0 + - persistent-2.7.3.1 + resolver: lts-10.5 diff --git a/start.sh b/start.sh index b73e8bc05..da7e422d4 100755 --- a/start.sh +++ b/start.sh @@ -7,4 +7,15 @@ export DUMMY_LOGIN=true export ALLOW_DEPRECATED=true export PWFILE=users.yml -exec -- stack exec -- yesod devel +move-back() { + mv -v .stack-work .stack-work-run + [[ -d .stack-work-ghci ]] && mv -v .stack-work-ghci .stack-work +} + +if [[ -d .stack-work-run ]]; then + [[ -d .stack-work ]] && mv -v .stack-work .stack-work-ghci + mv -v .stack-work-run .stack-work + trap move-back EXIT +fi + +stack exec -- yesod devel diff --git a/templates/course.hamlet b/templates/course.hamlet index 2f2a56a1e..f63629fee 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -6,7 +6,7 @@
            #{schoolName school} $maybe descr <- courseDescription course -
            Beschreibung +
            _{MsgCourseDescription}
            #{descr} @@ -33,7 +33,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
            -
            + $# regWidget is defined through templates/widgets/registerForm ^{regWidget}
            diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet index d963d1431..3eba4f9f1 100644 --- a/templates/default-layout-wrapper.hamlet +++ b/templates/default-layout-wrapper.hamlet @@ -39,21 +39,9 @@ $newline never } - +