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

Merge branch 'master' into 'live'

Browse Source 
Master

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

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

3
.gitignore vendored
View File

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

4
ChangeLog.md
View File

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

56
config/settings.yml
View File

@ -1,29 +1,26 @@
# Values formatted like "_env:ENV_VAR_NAME:default_value" can be overridden by the specified environment variable.
# 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

4
config/submission-blacklist
View File

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

85
db.hs
View File

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

13
ghci.sh
View File

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

53
messages/uniworx/de.msg
View File

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

9
models
View File

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

6
package.yaml
View File

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

4
routes
View File

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

2
src/Application.hs
View File

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

20
src/CryptoID.hs
View File

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

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

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

291
src/Foundation.hs
View File

@ -97,6 +97,8 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission
instance DisplayAble TermId where
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

80
src/Handler/Corrections.hs
View File

@ -86,33 +86,36 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCourse = 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

149
src/Handler/Course.hs
View File

@ -39,13 +39,13 @@ type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School)
colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCourse = 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| <span style="float:right"> ^{modalStatic descr} |]
@ -61,12 +61,12 @@ colDescription = sortable Nothing (i18nCell MsgCourseDescription)
colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCShort = 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]

12
src/Handler/CryptoIDDispatch.hs
View File

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

62
src/Handler/Home.hs
View File

@ -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|<a href=@{CourseR tid csh CShowR}>#{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
)

105
src/Handler/Profile.hs
View File

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

212
src/Handler/Sheet.hs
View File

@ -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|
<div class="alert alert-danger">
<div class="alert__content">
<h4> Fehler:
<ul>
$forall errmsg <- errorMsgs
<li> #{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")

57
src/Handler/Submission.hs
View File

@ -78,20 +78,20 @@ makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $
aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
aforced' _ _ _ = 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

35
src/Handler/Term.hs
View File

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

58
src/Handler/Users.hs
View File

@ -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|
<ul .list--inline .list--comma-separated>
$forall (E.Value sh) <- schools
<li>#{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|
<ul .list--inline .list--comma-separated>
$forall (E.Value sh) <- schools
<li>#{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|
<ul .list--inline .list--comma-separated>
$forall (E.Value sh) <- schools
<li>#{sh}
|]
, sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do
E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool
E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
E.orderBy [E.asc $ school E.^. SchoolShorthand]
return $ school E.^. SchoolShorthand
return [whamlet|
<ul .list--inline .list--comma-separated>
$forall (E.Value sh) <- schools
<li>#{sh}
|]
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
(hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm uid
cID <- encrypt uid
@ -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"

14
src/Handler/Utils.hs
View File

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

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

@ -57,7 +57,7 @@ getTimeLocale = getTimeLocale' <$> languages
getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
getDateTimeFormat 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

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

@ -218,17 +218,36 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific)
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

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

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

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

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

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

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

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

@ -1,59 +0,0 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.Utils.Term where
import Import
import qualified Data.Text as T
import Model.Types
-- import Data.Maybe
termActiveField :: Field Handler TermId
termActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
termActiveOld :: Field Handler TermIdentifier
termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
termNewField :: Field Handler TermIdentifier
termNewField = checkMMap checkTerm termToText textField
where
errTextParse :: Text
errTextParse = "Semester: S oder W gefolgt von Jahreszahl"
errTextFreigabe :: TermIdentifier -> Text
errTextFreigabe ti = "Semester " `T.append` (termToText ti) `T.append` " wurde noch nicht freigegeben."
checkTerm :: Text -> HandlerT UniWorX IO (Either Text TermIdentifier)
checkTerm t = case termFromText t of
Left _ -> return $ Left errTextParse
res@(Right _) -> return res
validateTerm :: Term -> [Text]
validateTerm (Term{..}) =
[ msg | (False, msg) <-
[ --startOk
( termStart `withinTerm` termName
, "Jahreszahl im Namenskürzel stimmt nicht mit Semesterbeginn überein."
)
, -- endOk
( termStart < termEnd
, "Semester darf nicht enden, bevor es begann."
)
, -- startOk
( termLectureStart < termLectureEnd
, "Vorlesungszeit muss vor ihrem Ende anfgangen."
)
, -- lecStartOk
( termStart <= termLectureStart
, "Semester muss vor der Vorlesungszeit beginnen."
)
, -- lecEndOk
( termEnd >= termLectureEnd
, "Vorlesungszeit muss vor dem Semester enden."
)
] ]

6
src/Import/NoFoundation.hs
View File

@ -3,8 +3,10 @@ module Import.NoFoundation
( module Import
) 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

10
src/Model.hs
View File

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

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

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

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

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

205
src/Model/Types.hs
View File

@ -8,7 +8,7 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE 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

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

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

72
src/Settings.hs
View File

@ -31,6 +31,12 @@ import qualified Data.Text.Encoding as Text
import qualified Ldap.Client as Ldap
import 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

42
src/Utils.hs
View File

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

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

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

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

@ -1,7 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE 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"

92
src/index.md Normal file
View File

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

2
stack.yaml
View File

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

13
start.sh
View File

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

4
templates/course.hamlet
View File

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

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

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

14
templates/profile.hamlet
View File

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

6
templates/profile.julius
View File

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

7
templates/profileData.hamlet
View File

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

4
templates/submission.hamlet
View File

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

8
templates/widgets/pageactionprime.hamlet
View File

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

2
templates/widgets/rating.hamlet
View File

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

26
templates/widgets/sheetTypeSummary.hamlet
View File

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

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

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

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

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

BIN
testdata/ProMo_Uebung10.pdf vendored Normal file
View File

Binary file not shown.

343
uniworx.sublime-workspace
View File

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