Merge branch 'master' into 205-klausuren
This commit is contained in:
Gregor Kleen
commit
c0056c10d3
@ -1,3 +1,7 @@
|
||||
* Version 20.05.2019
|
||||
|
||||
Komplett überarbeitete Funktionalität zur automatischen Verteilung von Korrekturen
|
||||
|
||||
* Version 13.05.2019
|
||||
|
||||
Kursverwalter können Teilnehmer hinzufügen
|
||||
|
||||
40
config/archive-types
Normal file
40
config/archive-types
Normal file
@ -0,0 +1,40 @@
|
||||
# Simple list of mime-types corresponding to archive-formats
|
||||
#
|
||||
# Comments are empty lines and any line for which the first non-whitespace symbol is ‘#’
|
||||
#
|
||||
# Format is a single mime-type per line (may not contain whitespace)
|
||||
#
|
||||
# Largely copied from https://en.wikipedia.org/wiki/List_of_archive_formats
|
||||
|
||||
application/x-archive
|
||||
application/x-cpio
|
||||
application/x-bcpio
|
||||
application/x-shar
|
||||
application/x-iso9660-image
|
||||
application/x-sbx
|
||||
application/x-tar
|
||||
application/x-7z-compressed
|
||||
application/x-ace-compressed
|
||||
application/x-astrotite-afa
|
||||
application/x-alz-compressed
|
||||
application/vnd.android.package-archive
|
||||
application/x-arj
|
||||
application/x-b1
|
||||
application/vnd.ms-cab-compressed
|
||||
application/x-cfs-compressed
|
||||
application/x-dar
|
||||
application/x-dgc-compressed
|
||||
application/x-apple-diskimage
|
||||
application/x-gca-compressed
|
||||
application/java-archive
|
||||
application/x-lzh
|
||||
application/x-lzx
|
||||
application/x-rar-compressed
|
||||
application/x-stuffit
|
||||
application/x-stuffitx
|
||||
application/x-gtar
|
||||
application/x-ms-wim
|
||||
application/x-xar
|
||||
application/zip
|
||||
application/x-zoo
|
||||
application/x-par2
|
||||
@ -30,9 +30,14 @@ session-timeout: 7200
|
||||
jwt-expiration: 604800
|
||||
jwt-encoding: HS256
|
||||
maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728"
|
||||
health-check-interval: "_env:HEALTHCHECK_INTERVAL:600" # or WATCHDOG_USEC/2, whichever is smaller
|
||||
health-check-http: "_env:HEALTHCHECK_HTTP:true"
|
||||
health-check-interval:
|
||||
matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600"
|
||||
http-reachable: "_env:HEALTHCHECK_INTERVAL_HTTP_REACHABLE:600"
|
||||
ldap-admins: "_env:HEALTHCHECK_INTERVAL_LDAP_ADMINS:600"
|
||||
smtp-connect: "_env:HEALTHCHECK_INTERVAL_SMTP_CONNECT:600"
|
||||
widget-memcached: "_env:HEALTHCHECK_INTERVAL_WIDGET_MEMCACHED:600"
|
||||
health-check-delay-notify: "_env:HEALTHCHECK_DELAY_NOTIFY:true"
|
||||
health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can reach ourselves under APPROOT via HTTP (reverse proxies or firewalls might prevent this)?
|
||||
|
||||
log-settings:
|
||||
detailed: "_env:DETAILED_LOGGING:false"
|
||||
|
||||
@ -64,7 +64,7 @@ TermActive: Aktiv
|
||||
|
||||
|
||||
SchoolListHeading: Übersicht über verwaltete Institute
|
||||
SchoolHeading school@SchoolName: Übersicht #{display school}
|
||||
SchoolHeading school@SchoolName: Übersicht #{school}
|
||||
|
||||
LectureStart: Beginn Vorlesungen
|
||||
|
||||
@ -89,10 +89,10 @@ CourseNewDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display t
|
||||
CourseEditDupShort tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{csh} in diesem Semester.
|
||||
FFSheetName: Name
|
||||
TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
|
||||
TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{display school}
|
||||
TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{school}
|
||||
CourseListTitle: Alle Kurse
|
||||
TermCourseListTitle tid@TermId: Kurse #{display tid}
|
||||
TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{display school}
|
||||
TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{school}
|
||||
CourseNewHeading: Neuen Kurs anlegen
|
||||
CourseEditHeading tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} editieren
|
||||
CourseEditTitle: Kurs editieren/anlegen
|
||||
@ -142,7 +142,7 @@ CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Re
|
||||
|
||||
NoSuchTerm tid@TermId: Semester #{display tid} gibt es nicht.
|
||||
NoSuchSchool ssh@SchoolId: Institut #{display ssh} gibt es nicht.
|
||||
NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{display csh} bekannt.
|
||||
NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{csh} bekannt.
|
||||
NoSuchCourse: Keinen passenden Kurs gefunden.
|
||||
|
||||
Sheet: Blatt
|
||||
@ -169,6 +169,7 @@ SheetHintFrom: Hinweis ab
|
||||
SheetSolution: Lösung
|
||||
SheetSolutionFrom: Lösung ab
|
||||
SheetMarking: Hinweise für Korrektoren
|
||||
SheetMarkingFiles: Korrektur
|
||||
SheetType: Wertung
|
||||
SheetInvisible: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar!
|
||||
SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{date}!
|
||||
@ -186,11 +187,16 @@ SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren
|
||||
SheetPseudonym: Persönliches Abgabe-Pseudonym
|
||||
SheetGeneratePseudonym: Generieren
|
||||
|
||||
SheetFormType: Wertung & Abgabe
|
||||
SheetFormTimes: Zeiten
|
||||
SheetFormFiles: Dateien
|
||||
|
||||
SheetErrVisibility: "Beginn Abgabezeitraum" muss nach "Sichbar für Teilnehmer ab" liegen
|
||||
SheetErrDeadlineEarly: "Ende Abgabezeitraum" muss nach "Beginn Abzeitraum" liegen
|
||||
SheetErrHintEarly: Hinweise dürfen erst nach Beginn des Abgabezeitraums herausgegeben werden
|
||||
SheetErrSolutionEarly: Lösungen dürfen erst nach Ende der Abgabezeitraums herausgegeben werden
|
||||
|
||||
SheetNoCurrent: Es gibt momentan kein aktives Übungsblatt.
|
||||
SheetNoOldUnassigned: Alle Abgaben inaktiver Blätter sind bereits einen Korrektor zugeteilt.
|
||||
|
||||
Deadline: Abgabe
|
||||
Done: Eingereicht
|
||||
@ -210,6 +216,7 @@ SubmissionFiles: Abgegebene Dateien
|
||||
SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem Übungsblatt.
|
||||
SubmissionUsersEmpty: Es kann keine Abgabe ohne Abgebende erstellt werden
|
||||
SubmissionUserAlreadyAdded: Dieser Nutzer ist bereits als Mitabgebende(r) eingetragen
|
||||
NoOpenSubmissions: Keine unkorrigierten Abgaben vorhanden
|
||||
|
||||
SubmissionsDeleteQuestion n@Int: Wollen Sie #{pluralDE n "die unten aufgeführte Abgabe" "die unten aufgeführten Abgaben"} wirklich löschen?
|
||||
SubmissionsDeleted n@Int: #{pluralDE n "Abgabe gelöscht" "Abgaben gelöscht"}
|
||||
@ -387,6 +394,10 @@ UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den
|
||||
CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden:
|
||||
SelfCorrectors num@Int64: #{display num} Abgaben wurden Abgebenden als eigenem Korrektor zugeteilt!
|
||||
|
||||
AssignSubmissionExceptionNoCorrectors: Es sind keine Korrektoren eingestellt
|
||||
AssignSubmissionExceptionNoCorrectorsByProportion: Es sind keine Korrektoren mit Anteil ungleich Null eingestellt
|
||||
AssignSubmissionExceptionSubmissionsNotFound n@Int: #{tshow n} Abgaben konnten nicht gefunden werden
|
||||
|
||||
|
||||
CorrectionsUploaded num@Int64: #{display num} Korrekturen wurden gespeichert:
|
||||
NoCorrectionsUploaded: In der hochgeladenen Datei wurden keine Korrekturen gefunden.
|
||||
@ -443,6 +454,7 @@ SubmissionSinkExceptionDuplicateFileTitle file@FilePath: Dateiname #{show file}
|
||||
SubmissionSinkExceptionDuplicateRating: Mehr als eine Bewertung gefunden.
|
||||
SubmissionSinkExceptionRatingWithoutUpdate: Bewertung gefunden, es ist hier aber keine Bewertung der Abgabe möglich.
|
||||
SubmissionSinkExceptionForeignRating smid@CryptoFileNameSubmission: Fremde Bewertung für Abgabe #{toPathPiece smid} enthalten. Bewertungen müssen sich immer auf die gleiche Abgabe beziehen!
|
||||
SubmissionSinkExceptionInvalidFileTitleExtension file@FilePath: Dateiname #{show file} hat keine der für dieses Übungsblatt zulässigen Dateiendungen.
|
||||
|
||||
MultiSinkException name@Text error@Text: In Abgabe #{name} ist ein Fehler aufgetreten: #{error}
|
||||
|
||||
@ -486,7 +498,7 @@ LastEdit: Letzte Änderung
|
||||
LastEditByUser: Ihre letzte Bearbeitung
|
||||
NoEditByUser: Nicht von Ihnen bearbeitet
|
||||
|
||||
SubmissionFilesIgnored: Es wurden Dateien in der hochgeladenen Abgabe ignoriert:
|
||||
SubmissionFilesIgnored n@Int: Es #{pluralDE n "wurde" "wurden"} #{tshow n} #{pluralDE n "Datei" "Dateien"} in der hochgeladenen Abgabe ignoriert
|
||||
SubmissionDoesNotExist smid@CryptoFileNameSubmission: Es existiert keine Abgabe mit Nummer #{toPathPiece smid}.
|
||||
|
||||
LDAPLoginTitle: Campus-Login
|
||||
@ -505,8 +517,23 @@ DayIsOutOfLecture tid@TermId date@Text: #{date} ist außerhalb der Vorlesungszei
|
||||
DayIsOutOfTerm tid@TermId date@Text: #{date} liegt nicht im #{display tid}
|
||||
|
||||
UploadModeNone: Kein Upload
|
||||
UploadModeUnpack: Upload, einzelne Datei
|
||||
UploadModeNoUnpack: Upload, ZIP-Archive entpacken
|
||||
UploadModeAny: Upload, beliebige Datei(en)
|
||||
UploadModeSpecific: Upload, vorgegebene Dateinamen
|
||||
|
||||
UploadModeUnpackZips: Abgabe mehrerer Dateien
|
||||
UploadModeUnpackZipsTip: Wenn die Abgabe mehrerer Dateien erlaubt ist, werden auch unterstützte Archiv-Formate zugelassen. Diese werden nach dann beim Hochladen automatisch entpackt.
|
||||
|
||||
UploadModeExtensionRestriction: Zulässige Dateiendungen
|
||||
UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen angegeben werden erfolgt keine Einschränkung.
|
||||
UploadModeExtensionRestrictionEmpty: Liste von zulässigen Dateiendungen darf nicht leer sein
|
||||
|
||||
UploadSpecificFiles: Vorgegebene Dateinamen
|
||||
NoUploadSpecificFilesConfigured: Wenn der Abgabemodus vorgegebene Dateinamen vorsieht, muss mindestens ein vorgegebener Dateiname konfiguriert werden.
|
||||
UploadSpecificFilesDuplicateNames: Vorgegebene Dateinamen müssen eindeutig sein
|
||||
UploadSpecificFilesDuplicateLabels: Bezeichner für vorgegebene Dateinamen müssen eindeutig sein
|
||||
UploadSpecificFileLabel: Bezeichnung
|
||||
UploadSpecificFileName: Dateiname
|
||||
UploadSpecificFileRequired: Zur Abgabe erforderlich
|
||||
|
||||
NoSubmissions: Keine Abgabe
|
||||
CorrectorSubmissions: Abgabe extern mit Pseudonym
|
||||
@ -793,8 +820,9 @@ MenuSheetEdit: Übungsblatt editieren
|
||||
MenuSheetDelete: Übungsblatt löschen
|
||||
MenuSheetClone: Als neues Übungsblatt klonen
|
||||
MenuCorrectionsUpload: Korrekturen hochladen
|
||||
MenuCorrectionsDownload: Offene Abgaben herunterladen
|
||||
MenuCorrectionsCreate: Abgaben registrieren
|
||||
MenuCorrectionsGrade: Abgaben bewerten
|
||||
MenuCorrectionsGrade: Abgaben online korrigieren
|
||||
MenuAuthPreds: Authorisierungseinstellungen
|
||||
MenuTutorialDelete: Tutorium löschen
|
||||
MenuTutorialEdit: Tutorium editieren
|
||||
|
||||
@ -3,7 +3,7 @@ Exam
|
||||
name (CI Text)
|
||||
gradingKey [Points] -- [n1,n2,n3,...] means 0 <= p < n1 -> p ~= 5, n1 <= p < n2 -> p ~ 4.7, n2 <= p < n3 -> p ~ 4.3, ...
|
||||
bonusRule ExamBonusRule
|
||||
occuranceRule ExamOccuranceRule
|
||||
occurrenceRule ExamOccurenceRule
|
||||
registerFrom UTCTime Maybe
|
||||
registerTo UTCTime Maybe
|
||||
deregisterUntil UTCTime Maybe
|
||||
@ -20,14 +20,14 @@ ExamPart
|
||||
maxPoints Points Maybe
|
||||
weight Rational
|
||||
UniqueExamPart exam name
|
||||
ExamOccurance
|
||||
ExamOccurence
|
||||
exam ExamId
|
||||
room Text
|
||||
capacity Natural
|
||||
ExamRegistration
|
||||
exam ExamId
|
||||
user UserId
|
||||
occurance ExamOccuranceId Maybe
|
||||
occurance ExamOccurenceId Maybe
|
||||
UniqueExamRegistration exam user
|
||||
ExamResult
|
||||
examPart ExamPartId
|
||||
|
||||
@ -11,6 +11,7 @@ Tutorial json
|
||||
deregisterUntil UTCTime Maybe
|
||||
lastChanged UTCTime default=now()
|
||||
UniqueTutorial course name
|
||||
deriving Generic
|
||||
Tutor
|
||||
tutorial TutorialId
|
||||
user UserId
|
||||
|
||||
@ -126,6 +126,7 @@ dependencies:
|
||||
- streaming-commons
|
||||
- hourglass
|
||||
- unix
|
||||
- stm-delay
|
||||
|
||||
other-extensions:
|
||||
- GeneralizedNewtypeDeriving
|
||||
@ -185,6 +186,7 @@ ghc-options:
|
||||
- -fno-warn-unrecognised-pragmas
|
||||
- -fno-warn-partial-type-signatures
|
||||
- -fno-max-relevant-binds
|
||||
- -j3
|
||||
|
||||
when:
|
||||
- condition: flag(pedantic)
|
||||
@ -242,6 +244,7 @@ tests:
|
||||
- uniworx
|
||||
- hspec >=2.0.0
|
||||
- QuickCheck
|
||||
- HUnit
|
||||
- yesod-test
|
||||
- conduit-extra
|
||||
- quickcheck-classes
|
||||
|
||||
26
routes
26
routes
@ -95,7 +95,7 @@
|
||||
/ex SheetListR GET !course-registered !materials !corrector
|
||||
/ex/new SheetNewR GET POST
|
||||
/ex/current SheetCurrentR GET !course-registered !materials !corrector
|
||||
/ex/unassigned SheetOldUnassigned GET
|
||||
/ex/unassigned SheetOldUnassignedR GET
|
||||
/ex/#SheetName SheetR:
|
||||
/show SShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
|
||||
/edit SEditR GET POST
|
||||
@ -104,28 +104,27 @@
|
||||
!/subs/new SubmissionNewR GET POST !timeANDcourse-registeredANDuser-submissions
|
||||
!/subs/own SubmissionOwnR GET !free -- just redirect
|
||||
/subs/#CryptoFileNameSubmission SubmissionR:
|
||||
/ SubShowR GET POST !ownerANDtime !ownerANDread !correctorANDread
|
||||
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner !corrector
|
||||
/delete SubDelR GET POST !ownerANDtime
|
||||
/ SubShowR GET POST !ownerANDtimeANDuser-submissions !ownerANDread !correctorANDread
|
||||
/delete SubDelR GET POST !ownerANDtimeANDuser-submissions
|
||||
/assign SAssignR GET POST !lecturerANDtime
|
||||
/correction CorrectionR GET POST !corrector !ownerANDreadANDrated
|
||||
/invite SInviteR GET POST !ownerANDtime
|
||||
/invite SInviteR GET POST !ownerANDtimeANDuser-submissions
|
||||
!/#SubmissionFileType SubArchiveR GET !owner !corrector
|
||||
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector
|
||||
/correctors SCorrR GET POST
|
||||
/iscorrector SIsCorrR GET !corrector -- Route is used to check for corrector access to this sheet
|
||||
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions
|
||||
/corrector-invite/ SCorrInviteR GET POST
|
||||
!/#SheetFileType SZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
|
||||
!/#{ZIPArchiveName SheetFileType} SZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
|
||||
/file MaterialListR GET !course-registered !materials !corrector !tutor
|
||||
/file/new MaterialNewR GET POST
|
||||
/file/#MaterialName MaterialR:
|
||||
/edit MEditR GET POST
|
||||
/delete MDelR GET POST
|
||||
/show MShowR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
|
||||
/load/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
|
||||
/download MArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
|
||||
/zip MZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
|
||||
!/download MArchiveR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
|
||||
!/download/*FilePath MFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !tutor
|
||||
/tuts CTutorialListR GET !tutor -- THIS route is used to check for overall course tutor access!
|
||||
/tuts/new CTutorialNewR GET POST
|
||||
/tuts/#TutorialName TutorialR:
|
||||
@ -137,10 +136,11 @@
|
||||
/tutor-invite TInviteR GET POST
|
||||
|
||||
|
||||
/subs CorrectionsR GET POST !corrector !lecturer
|
||||
/subs/upload CorrectionsUploadR GET POST !corrector !lecturer
|
||||
/subs/create CorrectionsCreateR GET POST !corrector !lecturer
|
||||
/subs/grade CorrectionsGradeR GET POST !corrector !lecturer
|
||||
/subs CorrectionsR GET POST !corrector !lecturer
|
||||
/subs/upload CorrectionsUploadR GET POST !corrector !lecturer
|
||||
/subs/create CorrectionsCreateR GET POST !corrector !lecturer
|
||||
/subs/grade CorrectionsGradeR GET POST !corrector !lecturer
|
||||
/subs/download CorrectionsDownloadR GET !corrector !lecturer
|
||||
|
||||
|
||||
/msgs MessageListR GET POST
|
||||
|
||||
@ -19,7 +19,7 @@ module Application
|
||||
import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..))
|
||||
import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr,
|
||||
pgPoolSize, runSqlPool)
|
||||
import Import
|
||||
import Import hiding (cancel)
|
||||
import Language.Haskell.TH.Syntax (qLocation)
|
||||
import Network.Wai (Middleware)
|
||||
import Network.Wai.Handler.Warp (Settings, defaultSettings,
|
||||
@ -75,17 +75,22 @@ import System.Exit
|
||||
import qualified Database.Memcached.Binary.IO as Memcached
|
||||
|
||||
import qualified System.Systemd.Daemon as Systemd
|
||||
import Control.Concurrent.Async.Lifted.Safe (async, waitAnyCancel)
|
||||
import Control.Concurrent.Async.Lifted.Safe
|
||||
import System.Environment (lookupEnv)
|
||||
import System.Posix.Process (getProcessID)
|
||||
import System.Posix.Signals (SignalInfo(..), installHandler, sigTERM)
|
||||
import qualified System.Posix.Signals as Signals (Handler(..))
|
||||
|
||||
import Control.Monad.Trans.State (execStateT)
|
||||
|
||||
import Network (socketPort)
|
||||
import qualified Network.Socket as Socket (close)
|
||||
|
||||
import Control.Concurrent.STM.Delay
|
||||
import Control.Monad.STM (retry)
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Data.Semigroup (Max(..), Min(..))
|
||||
|
||||
-- Import all relevant handler modules here.
|
||||
-- (HPack takes care to add new modules to our cabal file nowadays.)
|
||||
import Handler.Common
|
||||
@ -152,7 +157,7 @@ makeFoundation appSettings'@AppSettings{..} = do
|
||||
|
||||
appJobCtl <- liftIO $ newTVarIO Map.empty
|
||||
appCronThread <- liftIO newEmptyTMVarIO
|
||||
appHealthReport <- liftIO $ newTVarIO Nothing
|
||||
appHealthReport <- liftIO $ newTVarIO Set.empty
|
||||
|
||||
-- We need a log function to create a connection pool. We need a connection
|
||||
-- pool to create our foundation. And we need our foundation to get a
|
||||
@ -333,7 +338,12 @@ warpSettings foundation = defaultSettings
|
||||
if
|
||||
| foundation ^. _appHealthCheckDelayNotify
|
||||
-> void . fork $ do
|
||||
atomically $ readTVar (foundation ^. _appHealthReport) >>= guard . maybe False ((== HealthSuccess) . classifyHealthReport . snd)
|
||||
let activeChecks = Set.fromList universeF
|
||||
& Set.filter (is _Just . (foundation ^. _appHealthCheckInterval))
|
||||
atomically $ do
|
||||
results <- readTVar $ foundation ^. _appHealthReport
|
||||
guard $ activeChecks == Set.map (classifyHealthReport . snd) results
|
||||
guard . (== Min HealthSuccess) $ foldMap (Min . healthReportStatus . snd) results
|
||||
notifyReady
|
||||
| otherwise
|
||||
-> notifyReady
|
||||
@ -354,19 +364,8 @@ warpSettings foundation = defaultSettings
|
||||
|
||||
|
||||
getAppDevSettings, getAppSettings :: MonadIO m => m AppSettings
|
||||
getAppDevSettings = liftIO $ adjustSettings =<< loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
|
||||
getAppSettings = liftIO $ adjustSettings =<< loadYamlSettingsArgs [configSettingsYmlValue] useEnv
|
||||
|
||||
adjustSettings :: MonadIO m => AppSettings -> m AppSettings
|
||||
adjustSettings = execStateT $ do
|
||||
watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC"
|
||||
watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID"
|
||||
myProcessID <- liftIO getProcessID
|
||||
case watchdogMicroSec of
|
||||
Just wInterval
|
||||
| maybe True (== myProcessID) watchdogProcess
|
||||
-> _appHealthCheckInterval %= min (fromRational $ (toRational wInterval / 1e6) / 2)
|
||||
_other -> return ()
|
||||
getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
|
||||
getAppSettings = liftIO $ loadYamlSettingsArgs [configSettingsYmlValue] useEnv
|
||||
|
||||
-- | main function for use by yesod devel
|
||||
develMain :: IO ()
|
||||
@ -417,7 +416,47 @@ appMain = runResourceT $ do
|
||||
case didStore of
|
||||
Just () -> $logInfoS "shutdown" "Stored all bound sockets for restart"
|
||||
Nothing -> forM_ sockets $ liftIO . Socket.close
|
||||
liftIO . throwTo mainThreadId . ExitFailure $ 0b10000000 + fromIntegral siginfoSignal
|
||||
liftIO $ throwTo mainThreadId ExitSuccess
|
||||
|
||||
watchdogMicroSec <- liftIO $ (>>= readMay) <$> lookupEnv "WATCHDOG_USEC"
|
||||
watchdogProcess <- liftIO $ (>>= fmap fromInteger . readMay) <$> lookupEnv "WATCHDOG_PID"
|
||||
myProcessID <- liftIO getProcessID
|
||||
case watchdogMicroSec of
|
||||
Just wInterval
|
||||
| maybe True (== myProcessID) watchdogProcess
|
||||
-> let notifyWatchdog :: IO ()
|
||||
notifyWatchdog = runAppLoggingT foundation $ go Nothing
|
||||
where
|
||||
go pStatus = do
|
||||
d <- liftIO . newDelay . floor $ wInterval % 2
|
||||
|
||||
status <- atomically $ asum
|
||||
[ Nothing <$ waitDelay d
|
||||
, Just <$> do
|
||||
results <- readTVar $ foundation ^. _appHealthReport
|
||||
case fromNullable results of
|
||||
Nothing -> retry
|
||||
Just rs -> do
|
||||
let status = ofoldMap1 (Max *** Min . healthReportStatus) rs
|
||||
guard $ pStatus /= Just status
|
||||
return status
|
||||
]
|
||||
|
||||
case status of
|
||||
Just (_, Min status') -> do
|
||||
$logInfoS "NotifyStatus" $ toPathPiece status'
|
||||
liftIO . void . Systemd.notifyStatus . unpack $ toPathPiece status'
|
||||
Nothing -> return ()
|
||||
|
||||
case status of
|
||||
Just (_, Min HealthSuccess) -> do
|
||||
$logInfoS "NotifyWatchdog" "Notify"
|
||||
liftIO $ void Systemd.notifyWatchdog
|
||||
_other -> return ()
|
||||
|
||||
go status
|
||||
in void $ allocate (async notifyWatchdog >>= \a -> a <$ link a) cancel
|
||||
_other -> return ()
|
||||
|
||||
let runWarp socket = runSettingsSocket (warpSettings foundation) socket app
|
||||
case sockets of
|
||||
|
||||
@ -14,9 +14,13 @@ import Data.Binary (Binary)
|
||||
import Data.HashMap.Strict.Instances ()
|
||||
import Data.Vector.Instances ()
|
||||
|
||||
import Model.Types.TH.JSON (derivePersistFieldJSON)
|
||||
|
||||
|
||||
instance MonadThrow Parser where
|
||||
throwM = fail . show
|
||||
|
||||
|
||||
instance Binary Value
|
||||
|
||||
|
||||
derivePersistFieldJSON ''Value
|
||||
|
||||
18
src/Data/Time/Calendar/Instances.hs
Normal file
18
src/Data/Time/Calendar/Instances.hs
Normal file
@ -0,0 +1,18 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.Time.Calendar.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
|
||||
deriving newtype instance Hashable Day
|
||||
|
||||
instance Binary Day where
|
||||
get = ModifiedJulianDay <$> Binary.get
|
||||
put = Binary.put . toModifiedJulianDay
|
||||
|
||||
@ -11,14 +11,17 @@ import Data.Time.Clock
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
import Data.Time.Calendar.Instances ()
|
||||
|
||||
|
||||
instance Hashable DiffTime where
|
||||
hashWithSalt s = hashWithSalt s . toRational
|
||||
|
||||
|
||||
deriving instance Generic UTCTime
|
||||
instance Hashable UTCTime
|
||||
|
||||
|
||||
instance Binary Day where
|
||||
get = ModifiedJulianDay <$> Binary.get
|
||||
put = Binary.put . toModifiedJulianDay
|
||||
|
||||
instance Binary DiffTime where
|
||||
get = fromRational <$> Binary.get
|
||||
put = Binary.put . toRational
|
||||
|
||||
14
src/Data/Time/Format/Instances.hs
Normal file
14
src/Data/Time/Format/Instances.hs
Normal file
@ -0,0 +1,14 @@
|
||||
{-# OPTIONS -fno-warn-orphans #-}
|
||||
|
||||
module Data.Time.Format.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import qualified Language.Haskell.TH.Syntax as TH
|
||||
|
||||
import Data.Time.Format
|
||||
|
||||
import Data.Time.LocalTime.Instances ()
|
||||
|
||||
|
||||
deriving instance TH.Lift TimeLocale
|
||||
23
src/Data/Time/LocalTime/Instances.hs
Normal file
23
src/Data/Time/LocalTime/Instances.hs
Normal file
@ -0,0 +1,23 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.Time.LocalTime.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Data.Time.LocalTime
|
||||
|
||||
import Data.Binary (Binary)
|
||||
|
||||
import qualified Language.Haskell.TH.Syntax as TH
|
||||
|
||||
|
||||
deriving instance Generic TimeOfDay
|
||||
deriving instance Typeable TimeOfDay
|
||||
|
||||
instance Hashable TimeOfDay
|
||||
instance Binary TimeOfDay
|
||||
|
||||
|
||||
deriving instance TH.Lift TimeZone
|
||||
27
src/Data/UUID/Instances.hs
Normal file
27
src/Data/UUID/Instances.hs
Normal file
@ -0,0 +1,27 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.UUID.Instances
|
||||
() where
|
||||
|
||||
import ClassyPrelude
|
||||
import Data.UUID (UUID)
|
||||
import qualified Data.UUID as UUID
|
||||
|
||||
import Database.Persist.Sql
|
||||
import Web.PathPieces
|
||||
|
||||
|
||||
instance PathPiece UUID where
|
||||
fromPathPiece = UUID.fromString . unpack
|
||||
toPathPiece = pack . UUID.toString
|
||||
|
||||
instance PersistField UUID where
|
||||
toPersistValue = PersistDbSpecific . UUID.toASCIIBytes
|
||||
|
||||
fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t
|
||||
fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
|
||||
fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs
|
||||
fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x
|
||||
|
||||
instance PersistFieldSql UUID where
|
||||
sqlType _ = SqlOther "uuid"
|
||||
17
src/Data/Universe/Instances/Reverse/MonoTraversable.hs
Normal file
17
src/Data/Universe/Instances/Reverse/MonoTraversable.hs
Normal file
@ -0,0 +1,17 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.Universe.Instances.Reverse.MonoTraversable
|
||||
(
|
||||
) where
|
||||
|
||||
import Data.Universe
|
||||
import Data.MonoTraversable
|
||||
|
||||
import Data.Universe.Instances.Reverse
|
||||
|
||||
|
||||
type instance Element (a -> b) = b
|
||||
|
||||
instance Finite a => MonoFoldable (a -> b)
|
||||
instance (Ord a, Finite a) => MonoTraversable (a -> b)
|
||||
|
||||
@ -50,7 +50,8 @@ sqlInTuple arity = do
|
||||
]
|
||||
|
||||
-- | Generic unValuing of Tuples of Values, i.e.
|
||||
-- $(unValueN 3) :: (E.Value a, E.Value b, E.Value c) -> (a,b,c)
|
||||
--
|
||||
-- > $(unValueN 3) :: (E.Value a, E.Value b, E.Value c) -> (a,b,c)
|
||||
unValueN :: Int -> ExpQ
|
||||
unValueN arity = do
|
||||
vs <- replicateM arity $ newName "v"
|
||||
@ -60,7 +61,8 @@ unValueN arity = do
|
||||
lam1E pat rhs
|
||||
|
||||
-- | Generic unValuing of certain indices of a Tuple, i.e.
|
||||
-- $(unValueNIs 3 [1,3]) :: (E.Value a, b, E.Value c) -> (a,b,c)
|
||||
--
|
||||
-- > $(unValueNIs 3 [1,3]) :: (E.Value a, b, E.Value c) -> (a,b,c)
|
||||
unValueNIs :: Int -> [Int] -> ExpQ
|
||||
unValueNIs arity uvIdx = do
|
||||
vs <- replicateM arity $ newName "v"
|
||||
@ -74,8 +76,9 @@ unValueNIs arity uvIdx = do
|
||||
|
||||
|
||||
-- | Generic projections for InnerJoin-tuples
|
||||
-- gives I-th element of N-tuple of left-associative InnerJoin-pairs,
|
||||
-- i.e. @$(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)
|
||||
-- gives I-th element of N-tuple of left-associative InnerJoin-pairs, i.e.
|
||||
--
|
||||
-- > $(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n)
|
||||
sqlIJproj :: Int -> Int -> ExpQ
|
||||
sqlIJproj = leftAssociativePairProjection 'E.InnerJoin
|
||||
|
||||
|
||||
22
src/Database/Persist/Class/Instances.hs
Normal file
22
src/Database/Persist/Class/Instances.hs
Normal file
@ -0,0 +1,22 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Database.Persist.Class.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Database.Persist.Class
|
||||
import Database.Persist.Types.Instances ()
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
|
||||
instance PersistEntity record => Hashable (Key record) where
|
||||
hashWithSalt s = hashWithSalt s . toPersistValue
|
||||
|
||||
instance PersistEntity record => Binary (Key record) where
|
||||
put = Binary.put . toPersistValue
|
||||
putList = Binary.putList . map toPersistValue
|
||||
get = either (fail . unpack) return . fromPersistValue =<< Binary.get
|
||||
@ -1,33 +0,0 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Database.Persist.Sql.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
|
||||
import Data.Binary (Binary)
|
||||
import qualified Data.Binary as B
|
||||
|
||||
import Database.Persist.Sql
|
||||
|
||||
|
||||
instance Binary (BackendKey SqlWriteBackend) where
|
||||
put = B.put . unSqlWriteBackendKey
|
||||
putList = B.putList . map unSqlWriteBackendKey
|
||||
get = SqlWriteBackendKey <$> B.get
|
||||
instance Binary (BackendKey SqlReadBackend) where
|
||||
put = B.put . unSqlReadBackendKey
|
||||
putList = B.putList . map unSqlReadBackendKey
|
||||
get = SqlReadBackendKey <$> B.get
|
||||
instance Binary (BackendKey SqlBackend) where
|
||||
put = B.put . unSqlBackendKey
|
||||
putList = B.putList . map unSqlBackendKey
|
||||
get = SqlBackendKey <$> B.get
|
||||
|
||||
|
||||
instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Binary (Key record) where
|
||||
put = B.put . fromSqlKey
|
||||
putList = B.putList . map fromSqlKey
|
||||
get = toSqlKey <$> B.get
|
||||
@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Database.Persist.Types.Instances
|
||||
@ -6,7 +5,18 @@ module Database.Persist.Types.Instances
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Database.Persist.Types
|
||||
|
||||
instance (Hashable record, Hashable (Key record)) => Hashable (Entity record) where
|
||||
s `hashWithSalt` Entity{..} = s `hashWithSalt` entityKey `hashWithSalt` entityVal
|
||||
import Data.Time.Calendar.Instances ()
|
||||
import Data.Time.LocalTime.Instances ()
|
||||
import Data.Time.Clock.Instances ()
|
||||
|
||||
import Data.Binary (Binary)
|
||||
|
||||
|
||||
deriving instance Generic PersistValue
|
||||
deriving instance Typeable PersistValue
|
||||
|
||||
instance Hashable PersistValue
|
||||
instance Binary PersistValue
|
||||
|
||||
@ -130,7 +130,7 @@ data UniWorX = UniWorX
|
||||
, appSessionKey :: ClientSession.Key
|
||||
, appSecretBoxKey :: SecretBox.Key
|
||||
, appJSONWebKeySet :: Jose.JwkSet
|
||||
, appHealthReport :: TVar (Maybe (UTCTime, HealthReport))
|
||||
, appHealthReport :: TVar (Set (UTCTime, HealthReport))
|
||||
}
|
||||
|
||||
makeLenses_ ''UniWorX
|
||||
@ -280,18 +280,12 @@ embedRenderMessage ''UniWorX ''SubmissionModeDescr
|
||||
verbMap [_, _, v] = v <> "Submissions"
|
||||
verbMap _ = error "Invalid number of verbs"
|
||||
in verbMap . splitCamel
|
||||
embedRenderMessage ''UniWorX ''UploadModeDescr id
|
||||
embedRenderMessage ''UniWorX ''SecretJSONFieldException id
|
||||
|
||||
newtype SheetTypeHeader = SheetTypeHeader SheetType
|
||||
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
|
||||
|
||||
instance RenderMessage UniWorX UploadMode where
|
||||
renderMessage foundation ls uploadMode = case uploadMode of
|
||||
NoUpload -> mr MsgUploadModeNone
|
||||
Upload False -> mr MsgUploadModeNoUnpack
|
||||
Upload True -> mr MsgUploadModeUnpack
|
||||
where
|
||||
mr = renderMessage foundation ls
|
||||
|
||||
instance RenderMessage UniWorX SheetType where
|
||||
renderMessage foundation ls sheetType = case sheetType of
|
||||
NotGraded -> mr $ SheetTypeHeader NotGraded
|
||||
@ -677,10 +671,10 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
|
||||
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
|
||||
SFileR _ _ -> mzero
|
||||
-- Archives of SheetFileType
|
||||
SZipR (ZIPArchiveName SheetExercise) -> guard $ sheetActiveFrom <= cTime
|
||||
SZipR (ZIPArchiveName SheetHint ) -> guard $ maybe False (<= cTime) sheetHintFrom
|
||||
SZipR (ZIPArchiveName SheetSolution) -> guard $ maybe False (<= cTime) sheetSolutionFrom
|
||||
SZipR _ -> mzero
|
||||
SZipR SheetExercise -> guard $ sheetActiveFrom <= cTime
|
||||
SZipR SheetHint -> guard $ maybe False (<= cTime) sheetHintFrom
|
||||
SZipR SheetSolution -> guard $ maybe False (<= cTime) sheetSolutionFrom
|
||||
SZipR _ -> mzero
|
||||
-- Submissions
|
||||
SubmissionNewR -> guard active
|
||||
SubmissionR _ SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
|
||||
@ -1120,7 +1114,7 @@ instance Yesod UniWorX where
|
||||
|
||||
lift . bracketOnError getMessages (mapM_ $ uncurry Yesod.addMessage) $ \msgs -> do
|
||||
Just msgs' <- return . forM msgs $ \(msgState, content) -> Message <$> fromPathPiece msgState <*> return content
|
||||
addCustomHeader HeaderAlerts . decodeUtf8 $ JSON.encode msgs'
|
||||
addCustomHeader HeaderAlerts . decodeUtf8 . urlEncode True . toStrict $ JSON.encode msgs'
|
||||
|
||||
-- Since we implement `errorHandler` ourselves we don't need `defaultMessageWidget`
|
||||
defaultMessageWidget _title _body = error "defaultMessageWidget: undefined"
|
||||
@ -1340,6 +1334,7 @@ siteLayout' headingOverride widget = do
|
||||
addScript $ StaticR js_polyfills_urlPolyfill_js
|
||||
-- JavaScript services
|
||||
addScript $ StaticR js_services_utilRegistry_js
|
||||
addScript $ StaticR js_services_htmlHelpers_js
|
||||
addScript $ StaticR js_services_httpClient_js
|
||||
addScript $ StaticR js_services_i18n_js
|
||||
-- JavaScript utils
|
||||
@ -1393,12 +1388,8 @@ applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .|
|
||||
Nothing -> (systemMessageSummary, systemMessageContent)
|
||||
Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
|
||||
case summary of
|
||||
Just s -> do
|
||||
html <- withUrlRenderer [hamlet|
|
||||
<a href=@{MessageR cID}>
|
||||
#{s}
|
||||
|]
|
||||
addMessage systemMessageSeverity html
|
||||
Just s ->
|
||||
addMessageWidget systemMessageSeverity $ msgModal (toWidget s) (Left . SomeRoute $ MessageR cID)
|
||||
Nothing -> addMessage systemMessageSeverity content
|
||||
|
||||
-- Define breadcrumbs.
|
||||
@ -1450,6 +1441,8 @@ instance YesodBreadcrumbs UniWorX where
|
||||
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 (CourseR tid ssh csh SheetCurrentR) = return ("Aktuelles Blatt", Just $ CourseR tid ssh csh SheetListR)
|
||||
breadcrumb (CourseR tid ssh csh SheetOldUnassignedR) = return ("Offene Abgaben", Just $ CourseR tid ssh csh SheetListR)
|
||||
breadcrumb (CourseR tid ssh csh CCommR ) = return ("Kursmitteilung", Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CourseR tid ssh csh CTutorialListR) = return ("Tutorien", Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CourseR tid ssh csh CTutorialNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CTutorialListR)
|
||||
@ -1949,7 +1942,7 @@ pageActions (CourseR tid ssh csh SheetListR) =
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuSheetOldUnassigned
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassigned
|
||||
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassignedR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
|
||||
void . MaybeT $ sheetOldUnassigned tid ssh csh
|
||||
@ -2231,17 +2224,25 @@ pageActions (CSheetR tid ssh csh shn SCorrR) =
|
||||
]
|
||||
pageActions (CorrectionsR) =
|
||||
[ MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuCorrectionsDownload
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute CorrectionsDownloadR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuCorrectionsUpload
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute CorrectionsUploadR
|
||||
, menuItemModal = True
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuCorrectionsCreate
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute CorrectionsCreateR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
|
||||
|
||||
@ -2,7 +2,6 @@ module Handler.Admin where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Jobs
|
||||
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
|
||||
|
||||
@ -261,7 +260,11 @@ postAdminErrMsgR = do
|
||||
[whamlet|
|
||||
$maybe t <- plaintext
|
||||
<pre style="white-space:pre-wrap; font-family:monospace">
|
||||
#{encodePrettyToTextBuilder t}
|
||||
$case t
|
||||
$of String t'
|
||||
#{t'}
|
||||
$of t'
|
||||
#{encodePrettyToTextBuilder t'}
|
||||
|
||||
^{ctView'}
|
||||
|]
|
||||
|
||||
@ -36,6 +36,7 @@ import Data.Monoid (All(..))
|
||||
-- import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Language (From)
|
||||
-- import qualified Database.Esqueleto.Internal.Sql as E
|
||||
|
||||
-- import Control.Monad.Writer (MonadWriter(..), execWriterT)
|
||||
@ -60,7 +61,7 @@ import Data.Foldable (foldrM)
|
||||
|
||||
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
type CorrectionTableWhere = CorrectionTableExpr -> E.SqlExpr (E.Value Bool)
|
||||
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym))
|
||||
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Maybe UTCTime, Map UserId (User, Maybe Pseudonym))
|
||||
|
||||
correctionsTableQuery :: CorrectionTableWhere -> (CorrectionTableExpr -> v) -> CorrectionTableExpr -> E.SqlQuery v
|
||||
correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
|
||||
@ -70,6 +71,12 @@ correctionsTableQuery whereClause returnStatement t@((course `E.InnerJoin` sheet
|
||||
E.where_ $ whereClause t
|
||||
return $ returnStatement t
|
||||
|
||||
lastEditQuery :: Database.Esqueleto.Internal.Language.From query expr backend (expr (Entity SubmissionEdit))
|
||||
=> expr (Entity Submission) -> expr (E.Value (Maybe UTCTime))
|
||||
lastEditQuery submission = E.sub_select $ E.from $ \edit -> do
|
||||
E.where_ $ edit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId
|
||||
return $ E.max_ $ edit E.^. SubmissionEditTime
|
||||
|
||||
-- Where Clauses
|
||||
ratedBy :: UserId -> CorrectionTableWhere
|
||||
ratedBy uid ((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
||||
@ -84,40 +91,41 @@ sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftO
|
||||
-- Columns
|
||||
colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
||||
$ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
|
||||
-- cell [whamlet| _{untermKey $ course ^. _3}|] -- lange, internationale Semester
|
||||
textCell $ termToText $ unTermKey $ course ^. _3 -- kurze Semsterkürzel
|
||||
$ \DBRow{ dbrOutput } ->
|
||||
textCell $ termToText $ unTermKey $ dbrOutput ^. _3 . _3 -- kurze Semsterkürzel
|
||||
|
||||
colSchool :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
|
||||
$ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
|
||||
$ \DBRow{ dbrOutput } -> let course = dbrOutput ^. _3 in
|
||||
anchorCell (TermSchoolCourseListR (course ^. _3) (course ^. _4)) [whamlet|#{unSchoolKey (course ^. _4)}|]
|
||||
|
||||
colCourse :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colCourse = sortable (Just "course") (i18nCell MsgCourse)
|
||||
$ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid), _, _) } -> courseCellCL (tid,sid,csh)
|
||||
$ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid),_ , _, _) } -> courseCellCL (tid,sid,csh)
|
||||
|
||||
colSheet :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
|
||||
$ \DBRow{ dbrOutput=(_, sheet, course, _, _) } ->
|
||||
let tid = course ^. _3
|
||||
colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \row ->
|
||||
let sheet = row ^. _dbrOutput . _2
|
||||
course= row ^. _dbrOutput . _3
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
csh = course ^. _2
|
||||
shn = sheetName $ entityVal sheet
|
||||
in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|]
|
||||
|
||||
colSheetType :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType)
|
||||
$ \DBRow{ dbrOutput=(_, sheet, _, _, _) } -> i18nCell . sheetType $ entityVal sheet
|
||||
colSheetType = sortable (toNothing "sheetType") (i18nCell MsgSheetType) $
|
||||
i18nCell . sheetType <$> view (_dbrOutput . _2 . _entityVal)
|
||||
-- \DBRow{ dbrOutput=(_, sheet, _, _, _, _) } -> i18nCell . sheetType $ entityVal sheet
|
||||
|
||||
colCorrector :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
|
||||
DBRow{ dbrOutput = (_, _, _, Nothing , _) } -> cell mempty
|
||||
DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _) } -> userCell userDisplayName userSurname
|
||||
DBRow{ dbrOutput = (_, _, _, Nothing , _, _) } -> cell mempty
|
||||
DBRow{ dbrOutput = (_, _, _, Just (Entity _ User{..}), _, _) } -> userCell userDisplayName userSurname
|
||||
|
||||
colSubmissionLink :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
|
||||
$ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } ->
|
||||
$ \DBRow{ dbrOutput=(submission, sheet, course, _, _,_) } ->
|
||||
let csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
@ -129,10 +137,10 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
|
||||
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
|
||||
|
||||
colSelect :: forall act h. (Semigroup act, Monoid act, Headedness h) => Colonnade h CorrectionTableData (DBCell _ (FormResult (act, DBFormResult CryptoFileNameSubmission Bool CorrectionTableData), SheetTypeSummary))
|
||||
colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
|
||||
colSelect = dbSelect (_1 . applying _2) id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> encrypt subId
|
||||
|
||||
colSubmittors :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, users) } -> let
|
||||
colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, course, _, _, users) } -> let
|
||||
csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
@ -144,12 +152,12 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \DB
|
||||
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
|
||||
colSMatrikel :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
|
||||
colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let
|
||||
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
|
||||
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
|
||||
colRating :: forall m a. IsDBTable m (a, SheetTypeSummary) => Colonnade Sortable CorrectionTableData (DBCell m (a, SheetTypeSummary))
|
||||
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _) } ->
|
||||
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId sub@Submission{..}, Entity _ Sheet{..}, course, _, _, _) } ->
|
||||
let csh = course ^. _2
|
||||
tid = course ^. _3
|
||||
ssh = course ^. _4
|
||||
@ -169,36 +177,40 @@ colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(E
|
||||
]
|
||||
|
||||
colAssigned :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
|
||||
colAssigned = sortable (Just "assignedtime") (i18nCell MsgAssignedTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _) } ->
|
||||
maybe mempty dateTimeCell submissionRatingAssigned
|
||||
|
||||
colRated :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
|
||||
colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _, _) } ->
|
||||
maybe mempty dateTimeCell submissionRatingTime
|
||||
|
||||
colPseudonyms :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
|
||||
colPseudonyms = sortable Nothing (i18nCell MsgPseudonyms) $ \DBRow{ dbrOutput=(_, _, _, _, _, users) } -> let
|
||||
lCell = listCell (catMaybes $ snd . snd <$> Map.toList users) $ \pseudo ->
|
||||
cell [whamlet|#{review _PseudonymText pseudo}|]
|
||||
in lCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
|
||||
|
||||
colRatedField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (Bool, a, b) CorrectionTableData)))
|
||||
colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell id
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done))
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _, _) } mkUnique -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField (fsUniq mkUnique "rated") (Just done))
|
||||
|
||||
colPointsField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, Maybe Points, b) CorrectionTableData)))
|
||||
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPoints) $ formCell id
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } mkUnique -> case sheetType of
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _, _) } mkUnique -> case sheetType of
|
||||
NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
|
||||
_other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField (fsUniq mkUnique "points") (Just submissionRatingPoints)
|
||||
)
|
||||
|
||||
colCommentField :: Colonnade Sortable CorrectionTableData (DBCell _ (FormResult (DBFormResult SubmissionId (a, b, Maybe Text) CorrectionTableData)))
|
||||
colCommentField = sortable (Just "comment") (i18nCell MsgRatingComment) $ formCell id
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
|
||||
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _, _) } -> return subId)
|
||||
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _, _) } mkUnique -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment))
|
||||
|
||||
colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a)
|
||||
colLastEdit = sortable (Just "last-edit") (i18nCell MsgLastEdit) $
|
||||
\DBRow{ dbrOutput=(_, _, _, _, mbLastEdit, _) } -> maybe mempty dateTimeCell mbLastEdit
|
||||
|
||||
|
||||
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
|
||||
@ -212,10 +224,10 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
|
||||
, course E.^. CourseTerm
|
||||
, course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId)
|
||||
)
|
||||
in (submission, sheet, crse, corrector)
|
||||
in (submission, sheet, crse, corrector, lastEditQuery submission)
|
||||
)
|
||||
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
|
||||
dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
|
||||
dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector, E.Value mbLastEdit) -> do
|
||||
submittors <- lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do
|
||||
E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId)
|
||||
E.&&. pseudonym E.?. SheetPseudonymSheet E.==. E.just (E.val shId)
|
||||
@ -225,7 +237,7 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
|
||||
return (user, pseudonym E.?. SheetPseudonymPseudonym)
|
||||
let
|
||||
submittorMap = foldr (\(Entity userId user, E.Value pseudo) -> Map.insert userId (user, pseudo)) Map.empty submittors
|
||||
dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
|
||||
dbtProj' (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, mbLastEdit, submittorMap)
|
||||
dbTable psValidator DBTable
|
||||
{ dbtSQLQuery
|
||||
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _ :: CorrectionTableExpr) -> submission E.^. SubmissionId
|
||||
@ -271,6 +283,9 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI psValidator dbtProj' d
|
||||
, ( "comment" -- sorting by comment specifically requested by correctors to easily see submissions to be done
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingComment
|
||||
)
|
||||
, ( "last-edit"
|
||||
, SortColumn $ \((_course `E.InnerJoin` _sheet `E.InnerJoin` submission) `E.LeftOuterJoin` _corrector) -> lastEditQuery submission
|
||||
)
|
||||
]
|
||||
, dbtFilter = Map.fromList
|
||||
[ ( "term"
|
||||
@ -417,7 +432,18 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do
|
||||
redirect currentRoute
|
||||
FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do
|
||||
subs <- mapM decrypt $ Set.toList subs'
|
||||
runDB $ do
|
||||
let
|
||||
assignExceptions :: AssignSubmissionException -> Handler ()
|
||||
assignExceptions NoCorrectors = addMessageI Error MsgAssignSubmissionExceptionNoCorrectors
|
||||
assignExceptions NoCorrectorsByProportion = addMessageI Error MsgAssignSubmissionExceptionNoCorrectorsByProportion
|
||||
assignExceptions (SubmissionsNotFound subIds) = do
|
||||
subCIDs <- mapM encrypt . Set.toList $ toNullable subIds :: Handler [CryptoFileNameSubmission]
|
||||
let errorModal = msgModal
|
||||
[whamlet|_{MsgAssignSubmissionExceptionSubmissionsNotFound (length subCIDs)}|]
|
||||
(Right $(widgetFile "messages/submissionsAssignNotFound"))
|
||||
addMessageWidget Error errorModal
|
||||
|
||||
handle assignExceptions . runDB $ do
|
||||
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
|
||||
unless (null alreadyAssigned) $ do
|
||||
mr <- (toHtml . ) <$> getMessageRender
|
||||
@ -502,7 +528,7 @@ postCorrectionsR = do
|
||||
let whereClause = ratedBy uid
|
||||
colonnade = mconcat
|
||||
[ colSelect
|
||||
, dbRow
|
||||
, dbRow -- very useful, since correction statistics are still missing.
|
||||
, colSchool
|
||||
, colTerm
|
||||
, colCourse
|
||||
@ -531,7 +557,7 @@ postCorrectionsR = do
|
||||
optionsPairs $ map (id &&& id) $ nub $ map (CI.original . unSchoolKey . courseSchool . entityVal) courses
|
||||
|
||||
psValidator = def
|
||||
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||
& restrictSorting (\name _ -> name /= "corrector")
|
||||
& defaultSorting [SortAscBy "israted", SortDescBy "ratingTime", SortAscBy "assignedtime" ]
|
||||
-- & defaultFilter (Map.fromList [("israted",[toPathPiece False])]) -- DEPENDS ON ISSUE #371 UNCOMMENT THEN
|
||||
@ -551,6 +577,7 @@ postCCorrectionsR tid ssh csh = do
|
||||
, colSMatrikel
|
||||
, colSubmittors
|
||||
, colSubmissionLink
|
||||
, colLastEdit
|
||||
, colRating
|
||||
, colRated
|
||||
, colCorrector
|
||||
@ -574,6 +601,7 @@ postSSubsR tid ssh csh shn = do
|
||||
, colSMatrikel
|
||||
, colSubmittors
|
||||
, colSubmissionLink
|
||||
, colLastEdit
|
||||
, colRating
|
||||
, colRated
|
||||
, colCorrector
|
||||
@ -627,7 +655,7 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
}
|
||||
|
||||
((uploadResult, uploadForm'), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionUpload . renderAForm FormStandard $
|
||||
areq (zipFileField True) (fslI MsgRatingFiles) Nothing
|
||||
areq (zipFileField True Nothing) (fslI MsgRatingFiles) Nothing
|
||||
let uploadForm = wrapForm uploadForm' def
|
||||
{ formAction = Just . SomeRoute $ CSubmissionR tid ssh csh shn cid CorrectionR
|
||||
, formEncoding = uploadEncoding
|
||||
@ -703,7 +731,7 @@ getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
|
||||
getCorrectionsUploadR = postCorrectionsUploadR
|
||||
postCorrectionsUploadR = do
|
||||
((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $
|
||||
areq (zipFileField True) (fslI MsgCorrUploadField & addAttr "uw-file-input" "") Nothing
|
||||
areq (zipFileField True Nothing) (fslI MsgCorrUploadField) Nothing
|
||||
|
||||
case uploadRes of
|
||||
FormMissing -> return ()
|
||||
@ -897,8 +925,8 @@ postCorrectionsGradeR = do
|
||||
] -- Continue here
|
||||
psValidator = def
|
||||
& defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData))
|
||||
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
|
||||
dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) = do
|
||||
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
|
||||
dbtProj' i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _, _) = do
|
||||
cID <- encrypt subId
|
||||
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
|
||||
return i
|
||||
|
||||
@ -11,7 +11,6 @@ import Handler.Utils
|
||||
import Handler.Utils.Course
|
||||
import Handler.Utils.Tutorial
|
||||
import Handler.Utils.Communication
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Database
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
@ -9,55 +9,71 @@ import Utils.Lens
|
||||
|
||||
import qualified Data.UUID as UUID
|
||||
|
||||
import Data.Semigroup (Min(..), Max(..))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Control.Concurrent.STM.Delay
|
||||
|
||||
|
||||
getHealthR :: Handler TypedContent
|
||||
getHealthR = do
|
||||
healthReport' <- liftIO . readTVarIO =<< getsYesod appHealthReport
|
||||
let
|
||||
handleMissing = do
|
||||
interval <- getsYesod $ round . (* 1e6) . toRational . view _appHealthCheckInterval
|
||||
reportStore <- getsYesod appHealthReport
|
||||
waitResult <- threadDelay interval `race` atomically (readTVar reportStore >>= guard . is _Just)
|
||||
case waitResult of
|
||||
Left () -> fail "System is not generating HealthReports"
|
||||
Right _ -> redirect HealthR
|
||||
(lastUpdated, healthReport) <- maybe handleMissing return healthReport'
|
||||
reportStore <- getsYesod appHealthReport
|
||||
healthReports' <- liftIO $ readTVarIO reportStore
|
||||
interval <- getsYesod $ view _appHealthCheckInterval
|
||||
instanceId <- getsYesod appInstanceID
|
||||
|
||||
setWeakEtagHashable (instanceId, lastUpdated)
|
||||
expiresAt $ interval `addUTCTime` lastUpdated
|
||||
setLastModified lastUpdated
|
||||
|
||||
let status
|
||||
| HealthSuccess <- classifyHealthReport healthReport
|
||||
= ok200
|
||||
| otherwise
|
||||
= internalServerError500
|
||||
sendResponseStatus status <=< selectRep $ do
|
||||
provideRep . siteLayoutMsg MsgHealthReport $ do
|
||||
setTitleI MsgHealthReport
|
||||
let HealthReport{..} = healthReport
|
||||
[whamlet|
|
||||
$newline never
|
||||
<dl .deflist>
|
||||
<dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
|
||||
<dd .deflist__dd>#{boolSymbol healthMatchingClusterConfig}
|
||||
$maybe httpReachable <- healthHTTPReachable
|
||||
<dt .deflist__dt>_{MsgHealthHTTPReachable}
|
||||
<dd .deflist__dd>#{boolSymbol httpReachable}
|
||||
$maybe ldapAdmins <- healthLDAPAdmins
|
||||
<dt .deflist__dt>_{MsgHealthLDAPAdmins}
|
||||
<dd .deflist__dd>#{textPercent ldapAdmins}
|
||||
$maybe smtpConnect <- healthSMTPConnect
|
||||
<dt .deflist__dt>_{MsgHealthSMTPConnect}
|
||||
<dd .deflist__dd>#{boolSymbol smtpConnect}
|
||||
$maybe widgetMemcached <- healthWidgetMemcached
|
||||
<dt .deflist__dt>_{MsgHealthWidgetMemcached}
|
||||
<dd .deflist__dd>#{boolSymbol widgetMemcached}
|
||||
|]
|
||||
provideJson healthReport
|
||||
provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReport
|
||||
case fromNullable healthReports' of
|
||||
Nothing -> do
|
||||
let Min (NTop minInterval) = ofoldMap1 (Min . NTop) $ impureNonNull interval
|
||||
delay <- for minInterval $ \minInterval' -> liftIO . newDelay . round $ toRational minInterval' * 1e6
|
||||
waitResult <- atomically $ maybe (pure $ Left False) (fmap (const $ Left True) . waitDelay) delay <|> (fmap Right . assertM (not. Set.null) $ readTVar reportStore)
|
||||
case waitResult of
|
||||
Left False -> sendResponseStatus noContent204 ()
|
||||
Left True -> fail "System is not generating HealthReports"
|
||||
Right _ -> redirect HealthR
|
||||
Just healthReports -> do
|
||||
let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports
|
||||
reportNextUpdate (lastCheck, classifyHealthReport -> kind)
|
||||
= fromMaybe 0 (interval kind) `addUTCTime` lastCheck
|
||||
Max nextUpdate = ofoldMap1 (Max . reportNextUpdate) healthReports
|
||||
instanceId <- getsYesod appInstanceID
|
||||
|
||||
setWeakEtagHashable (instanceId, lastUpdated)
|
||||
expiresAt nextUpdate
|
||||
setLastModified lastUpdated
|
||||
|
||||
let status'
|
||||
| HealthSuccess <- status
|
||||
= ok200
|
||||
| otherwise
|
||||
= internalServerError500
|
||||
sendResponseStatus status' <=< selectRep $ do
|
||||
provideRep . siteLayoutMsg MsgHealthReport $ do
|
||||
setTitleI MsgHealthReport
|
||||
[whamlet|
|
||||
$newline never
|
||||
<dl .deflist>
|
||||
$forall (_, report) <- healthReports'
|
||||
$case report
|
||||
$of HealthMatchingClusterConfig passed
|
||||
<dt .deflist__dt>_{MsgHealthMatchingClusterConfig}
|
||||
<dd .deflist__dd>#{boolSymbol passed}
|
||||
$of HealthHTTPReachable (Just passed)
|
||||
<dt .deflist__dt>_{MsgHealthHTTPReachable}
|
||||
<dd .deflist__dd>#{boolSymbol passed}
|
||||
$of HealthLDAPAdmins (Just found)
|
||||
<dt .deflist__dt>_{MsgHealthLDAPAdmins}
|
||||
<dd .deflist__dd>#{textPercent found}
|
||||
$of HealthSMTPConnect (Just passed)
|
||||
<dt .deflist__dt>_{MsgHealthSMTPConnect}
|
||||
<dd .deflist__dd>#{boolSymbol passed}
|
||||
$of HealthWidgetMemcached (Just passed)
|
||||
<dt .deflist__dt>_{MsgHealthWidgetMemcached}
|
||||
<dd .deflist__dd>#{boolSymbol passed}
|
||||
$of _
|
||||
|]
|
||||
provideJson healthReports
|
||||
provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports
|
||||
|
||||
getInstanceR :: Handler TypedContent
|
||||
getInstanceR = do
|
||||
|
||||
@ -9,7 +9,7 @@ import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Conduit.List as C
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text.Encoding as Text
|
||||
-- import qualified Data.Text.Encoding as Text
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
@ -107,15 +107,18 @@ getMaterialListR tid ssh csh = do
|
||||
seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility
|
||||
table <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let row2material = entityVal . dbrOutput -- no inner join, just Entity Material
|
||||
let row2material = view $ _dbrOutput . _1 . _entityVal
|
||||
psValidator = def & defaultSorting [SortDescBy "last-edit"]
|
||||
dbTableWidget' psValidator DBTable
|
||||
{ dbtIdent = "material-list" :: Text
|
||||
, dbtStyle = def
|
||||
, dbtParams = def
|
||||
, dbtSQLQuery = \material -> do
|
||||
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
|
||||
return material
|
||||
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
|
||||
let filesNum = E.sub_select . E.from $ \materialFile -> do
|
||||
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
|
||||
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int64))
|
||||
return (material, filesNum)
|
||||
, dbtRowKey = (E.^. MaterialId)
|
||||
-- , dbtProj = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr
|
||||
, dbtProj = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->)
|
||||
@ -127,8 +130,10 @@ getMaterialListR tid ssh csh = do
|
||||
$ liftA2 anchorCell matLink toWgt . materialName . row2material
|
||||
, sortable (toNothingS "description") mempty
|
||||
$ foldMap modalCell . materialDescription . row2material
|
||||
, sortable (toNothingS "zip-archive") mempty -- TODO: don't show if there are no files!
|
||||
$ fileCell . filesLink . materialName . row2material
|
||||
, sortable (toNothingS "zip-archive") mempty
|
||||
$ \DBRow{ dbrOutput = (Entity _ Material{..}, E.Value fileNum) } -> if
|
||||
| fileNum == 0 -> mempty
|
||||
| otherwise -> fileCell $ filesLink materialName
|
||||
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
|
||||
$ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material
|
||||
, sortable (Just "last-edit") (i18nCell MsgFileModified)
|
||||
@ -156,9 +161,9 @@ getMaterialListR tid ssh csh = do
|
||||
|
||||
|
||||
getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -> Handler TypedContent
|
||||
getMFileR tid ssh csh mnm title = serveOneFile fileQuery
|
||||
getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal
|
||||
where
|
||||
fileQuery = E.select $ E.from $
|
||||
fileQuery = E.selectSource $ E.from $
|
||||
\(course `E.InnerJoin` material `E.InnerJoin` matFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
E.on (file E.^. FileId E.==. matFile E.^. MaterialFileFile)
|
||||
@ -180,7 +185,7 @@ getMShowR tid ssh csh mnm = do
|
||||
matLink = CourseR tid ssh csh . MaterialR mnm . MFileR
|
||||
|
||||
zipLink :: Route UniWorX
|
||||
zipLink = CMaterialR tid ssh csh mnm MZipR
|
||||
zipLink = CMaterialR tid ssh csh mnm MArchiveR
|
||||
|
||||
seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility
|
||||
|
||||
@ -351,28 +356,12 @@ postMDelR tid ssh csh mnm = do
|
||||
, drAbort = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR
|
||||
}
|
||||
|
||||
-- | Variant of getMArchiveR that always serves a Zip Archive, even for single files. Kept, since we might change this according to UX feedback.
|
||||
getMZipR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent
|
||||
getMZipR tid ssh csh mnm = do
|
||||
let filename = ZIPArchiveName mnm
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
|
||||
respondSourceDB "application/zip" $ do
|
||||
mid <- lift $ getMaterialKeyBy404 tid ssh csh mnm
|
||||
-- Entity{entityKey=mid, entityVal=material} <- lift $ fetchMaterial tid ssh csh mnm
|
||||
let
|
||||
fileSelect = E.selectSource . E.from $ \(materialFile `E.InnerJoin` file) -> do
|
||||
E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId
|
||||
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid
|
||||
return file
|
||||
zipComment = Text.encodeUtf8 $ termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> ":" <> mnm)
|
||||
fileSelect .| C.map entityVal .| produceZip ZipInfo{..} .| C.map toFlushBuilder
|
||||
|
||||
-- | Variant of getMZipR that does not serve single file Zip Archives. Maybe confusing to users.
|
||||
-- | Serve all material-files
|
||||
getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent
|
||||
getMArchiveR tid ssh csh mnm = serveSomeFiles archivename getMatQuery
|
||||
where
|
||||
archivename = termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm)
|
||||
getMatQuery = E.select . E.from $
|
||||
archivename = unpack (termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> "-" <> mnm)) <.> "zip"
|
||||
getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $
|
||||
\(course `E.InnerJoin` material `E.InnerJoin` materialFile `E.InnerJoin` file) -> do
|
||||
E.on $ file E.^. FileId E.==. materialFile E.^. MaterialFileFile
|
||||
E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial
|
||||
|
||||
@ -14,7 +14,6 @@ import Handler.Utils.Table.Cells
|
||||
-- import Handler.Utils.Table.Columns
|
||||
import Handler.Utils.SheetType
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
-- import Data.Time
|
||||
@ -69,19 +68,19 @@ import Text.Hamlet (ihamlet)
|
||||
|
||||
data SheetForm = SheetForm
|
||||
{ sfName :: SheetName
|
||||
, sfDescription :: Maybe Html
|
||||
, sfType :: SheetType
|
||||
, sfGrouping :: SheetGroup
|
||||
, sfVisibleFrom :: Maybe UTCTime
|
||||
, sfActiveFrom :: UTCTime
|
||||
, sfActiveTo :: UTCTime
|
||||
, sfSubmissionMode :: SubmissionMode
|
||||
, sfSheetF :: Maybe (Source Handler (Either FileId File))
|
||||
, sfHintFrom :: Maybe UTCTime
|
||||
, sfHintF :: Maybe (Source Handler (Either FileId File))
|
||||
, sfSolutionFrom :: Maybe UTCTime
|
||||
, sfSheetF :: Maybe (Source Handler (Either FileId File))
|
||||
, sfHintF :: Maybe (Source Handler (Either FileId File))
|
||||
, sfSolutionF :: Maybe (Source Handler (Either FileId File))
|
||||
, sfMarkingF :: Maybe (Source Handler (Either FileId File))
|
||||
, sfType :: SheetType
|
||||
, sfGrouping :: SheetGroup
|
||||
, sfSubmissionMode :: SubmissionMode
|
||||
, sfDescription :: Maybe Html
|
||||
, sfMarkingText :: Maybe Html
|
||||
-- Keine SheetId im Formular!
|
||||
}
|
||||
@ -103,12 +102,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
|
||||
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
|
||||
<$> areq ciField (fslI MsgSheetName) (sfName <$> template)
|
||||
<*> aopt htmlField (fslpI MsgSheetDescription "Html")
|
||||
(sfDescription <$> template)
|
||||
<*> sheetTypeAFormReq (fslI MsgSheetType
|
||||
& setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
|
||||
(sfType <$> template)
|
||||
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
|
||||
<* aformSection MsgSheetFormTimes
|
||||
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
|
||||
& setTooltip MsgSheetVisibleFromTip)
|
||||
((sfVisibleFrom <$> template) <|> pure (Just ctime))
|
||||
@ -116,17 +110,24 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
|
||||
& setTooltip MsgSheetActiveFromTip)
|
||||
(sfActiveFrom <$> template)
|
||||
<*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template)
|
||||
<*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ Upload True))
|
||||
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
|
||||
& setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgSheetSolutionFrom "Datum, sonst nur für Korrektoren"
|
||||
& setTooltip MsgSheetSolutionFromTip)
|
||||
(sfSolutionFrom <$> template)
|
||||
& setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template)
|
||||
<* aformSection MsgSheetFormFiles
|
||||
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking
|
||||
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles
|
||||
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
|
||||
<* aformSection MsgSheetFormType
|
||||
<*> sheetTypeAFormReq (fslI MsgSheetType
|
||||
& setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
|
||||
(sfType <$> template)
|
||||
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
|
||||
<*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
|
||||
<*> aopt htmlField (fslpI MsgSheetDescription "Html")
|
||||
(sfDescription <$> template)
|
||||
<*> aopt htmlField (fslpI MsgSheetMarking "Html") (sfMarkingText <$> template)
|
||||
return $ case result of
|
||||
FormSuccess sheetResult
|
||||
@ -146,16 +147,33 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do
|
||||
|
||||
|
||||
getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetCurrentR tid ssh csh = runDB $ do
|
||||
let redi shn = redirectAccess $ CSheetR tid ssh csh shn SShowR
|
||||
shn <- sheetCurrent tid ssh csh
|
||||
maybe notFound redi shn
|
||||
getSheetCurrentR tid ssh csh = do
|
||||
mbShn <- runDB $ sheetCurrent tid ssh csh
|
||||
case mbShn of
|
||||
Just shn -> redirectAccess $ CSheetR tid ssh csh shn SShowR
|
||||
Nothing -> do -- no current sheet exists
|
||||
-- users should never see a link to this URL in this situation,
|
||||
-- but we had confused users that used a bookmark instead.
|
||||
let headingShort = [whamlet|_{MsgMenuSheetCurrent}|]
|
||||
headingLong = prependCourseTitle tid ssh csh MsgMenuSheetCurrent
|
||||
siteLayout headingShort $ do
|
||||
setTitleI headingLong
|
||||
[whamlet|_{MsgSheetNoCurrent}|]
|
||||
|
||||
getSheetOldUnassigned :: TermId -> SchoolId -> CourseShorthand -> Handler ()
|
||||
getSheetOldUnassigned tid ssh csh = runDB $ do
|
||||
let redi shn = redirectAccess $ CSheetR tid ssh csh shn SSubsR
|
||||
shn <- sheetOldUnassigned tid ssh csh
|
||||
maybe notFound redi shn
|
||||
|
||||
getSheetOldUnassignedR:: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetOldUnassignedR tid ssh csh = do
|
||||
mbShn <- runDB $ sheetOldUnassigned tid ssh csh
|
||||
case mbShn of
|
||||
Just shn -> redirectAccess $ CSheetR tid ssh csh shn SSubsR
|
||||
Nothing -> do -- no unassigned submissions in any inactive sheet
|
||||
-- users should never see a link to this URL in this situation,
|
||||
-- but we had confused users that used a bookmark instead.
|
||||
let headingShort = [whamlet|_{MsgMenuSheetOldUnassigned}|]
|
||||
headingLong = prependCourseTitle tid ssh csh MsgMenuSheetOldUnassigned
|
||||
siteLayout headingShort $ do
|
||||
setTitleI headingLong
|
||||
[whamlet|_{MsgSheetNoOldUnassigned}|]
|
||||
|
||||
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetListR tid ssh csh = do
|
||||
@ -194,16 +212,16 @@ getSheetListR tid ssh csh = do
|
||||
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom
|
||||
, sortable (toNothing "downloads") (i18nCell MsgFiles)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, existFiles)} -> mconcat
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, existFiles)} -> listCell
|
||||
[ icnCell & addIconFixedWidth
|
||||
| let existingSFTs = hasSFT existFiles
|
||||
, sft <- [minBound..maxBound]
|
||||
, let link = CSheetR tid ssh csh sheetName $ SZipR $ ZIPArchiveName sft
|
||||
, let link = CSheetR tid ssh csh sheetName $ SZipR sft
|
||||
, let icn = toWidget $ sheetFile2markup sft
|
||||
, let icnCell = if sft `elem` existingSFTs
|
||||
then linkEmptyCell link icn
|
||||
else spacerCell
|
||||
]
|
||||
] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
|
||||
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> dateTimeCell sheetActiveFrom
|
||||
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
|
||||
@ -438,11 +456,11 @@ postSPseudonymR tid ssh csh shn = do
|
||||
|
||||
|
||||
getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
|
||||
getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file
|
||||
getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file .| C.map entityVal
|
||||
|
||||
getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> ZIPArchiveName SheetFileType -> Handler TypedContent
|
||||
getSZipR tid ssh csh shn filename@(ZIPArchiveName sft)
|
||||
= serveSomeFiles (toPathPiece filename) $ sheetFilesAllQuery tid ssh csh shn sft
|
||||
getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent
|
||||
getSZipR tid ssh csh shn sft
|
||||
= serveSomeFiles (unpack (toPathPiece sft) <.> "zip") $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal
|
||||
|
||||
|
||||
getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
|
||||
@ -14,7 +14,6 @@ import Handler.Utils
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Submission
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
-- import Control.Monad.Trans.Maybe
|
||||
@ -38,8 +37,6 @@ import Data.Map (Map, (!), (!?))
|
||||
import qualified Data.Map as Map
|
||||
-- import Data.Bifunctor
|
||||
|
||||
import System.FilePath
|
||||
|
||||
import Text.Blaze (Markup)
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Text.Hamlet (ihamlet)
|
||||
@ -132,8 +129,19 @@ makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = ident
|
||||
fileUploadForm = case uploadMode of
|
||||
NoUpload
|
||||
-> pure Nothing
|
||||
(Upload unpackZips)
|
||||
-> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
||||
UploadAny{..}
|
||||
-> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips extensionRestriction) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
|
||||
UploadSpecific{..}
|
||||
-> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
|
||||
|
||||
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (Source Handler File))
|
||||
specificFileForm spec@UploadSpecificFile{..}
|
||||
= bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing
|
||||
|
||||
mergeFileSources :: [Maybe (Source Handler File)] -> Maybe (Source Handler File)
|
||||
mergeFileSources (catMaybes -> sources) = case sources of
|
||||
[] -> Nothing
|
||||
fs -> Just $ sequence_ fs
|
||||
|
||||
miCell' :: Markup -> Either UserEmail UserId -> Widget
|
||||
miCell' csrf (Left email) = $(widgetFile "widgets/massinput/submissionUsers/cellInvitation")
|
||||
@ -354,7 +362,9 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
return (userName, submissionEdit E.^. SubmissionEditTime)
|
||||
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
|
||||
return (csheet,buddies,lastEdits,maySubmit,isLecturer,isOwner)
|
||||
((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies
|
||||
-- @submissionModeUser == Nothing@ below iff we are currently serving a user with elevated rights (lecturer, admin, ...)
|
||||
-- Therefore we do not restrict upload behaviour in any way in that case
|
||||
((res,formWidget'), formEnctype) <- runFormPost . makeSubmissionForm sheetCourse msmid (fromMaybe (UploadAny True Nothing) . submissionModeUser $ sheetSubmissionMode) sheetGrouping isLecturer $ bool id (Set.insert $ Right uid) isOwner buddies
|
||||
let formWidget = wrapForm' BtnHandIn formWidget' def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = formEnctype
|
||||
@ -515,8 +525,8 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSubmissionEditHead tid ssh csh shn
|
||||
let urlArchive cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))
|
||||
urlOriginal cID = CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))
|
||||
let urlArchive cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionCorrected
|
||||
urlOriginal cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionOriginal
|
||||
$(widgetFile "submission")
|
||||
|
||||
getSInviteR, postSInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||
@ -525,72 +535,60 @@ postSInviteR = invitationR submissionUserInvitationConfig
|
||||
|
||||
|
||||
getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
|
||||
getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = runDB $ do
|
||||
submissionID <- submissionMatchesSheet tid ssh csh shn cID
|
||||
getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
|
||||
(submissionID, isRating) <- runDB $ do
|
||||
submissionID <- submissionMatchesSheet tid ssh csh shn cID
|
||||
|
||||
isRating <- (== Just submissionID) <$> isRatingFile path
|
||||
isRating <- (== Just submissionID) <$> isRatingFile path
|
||||
|
||||
when (isUpdate || isRating) $
|
||||
guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
|
||||
when (isUpdate || isRating) $
|
||||
guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
|
||||
|
||||
return (submissionID, isRating)
|
||||
|
||||
case isRating of
|
||||
True
|
||||
| isUpdate -> do
|
||||
| isUpdate -> runDB $ do
|
||||
file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
|
||||
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
|
||||
| otherwise -> notFound
|
||||
False -> do
|
||||
results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
|
||||
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.&&. f E.^. FileTitle E.==. E.val path
|
||||
E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
|
||||
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
|
||||
-- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
|
||||
return f
|
||||
let results = (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
|
||||
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.&&. f E.^. FileTitle E.==. E.val path
|
||||
E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
|
||||
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
|
||||
-- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
|
||||
return f
|
||||
|
||||
case results of
|
||||
[] -> notFound
|
||||
[Entity _ File{ fileContent = Just c, fileTitle }] -> do
|
||||
whenM downloadFiles $
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
|
||||
return $ TypedContent (mimeLookup (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."
|
||||
serveOneFile results
|
||||
|
||||
getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
|
||||
getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
|
||||
getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> Handler TypedContent
|
||||
getSubArchiveR tid ssh csh shn cID sfType = do
|
||||
when (sfType == SubmissionCorrected) $
|
||||
guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False
|
||||
|
||||
let filename
|
||||
| SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType
|
||||
| otherwise = ZIPArchiveName $ toPathPiece cID
|
||||
| SubmissionOriginal <- sfType = toPathPiece cID <> "-" <> toPathPiece sfType
|
||||
| otherwise = toPathPiece cID
|
||||
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
|
||||
respondSourceDB "application/zip" $ do
|
||||
submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
|
||||
rating <- lift $ getRating submissionID
|
||||
source = do
|
||||
submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
|
||||
rating <- lift $ getRating submissionID
|
||||
|
||||
let
|
||||
fileSelect = case sfType of
|
||||
SubmissionOriginal -> E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
|
||||
E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False
|
||||
return f
|
||||
_ -> submissionFileSource submissionID
|
||||
case sfType of
|
||||
SubmissionOriginal -> (.| Conduit.map entityVal) . E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> do
|
||||
E.on $ f E.^. FileId E.==. sf E.^. SubmissionFileFile
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False
|
||||
return f
|
||||
_ -> submissionFileSource submissionID .| Conduit.map entityVal
|
||||
|
||||
fileSource' = do
|
||||
fileSelect .| Conduit.map entityVal
|
||||
when (sfType == SubmissionCorrected) $
|
||||
maybe (return ()) (yieldM . ratingFile cID) rating
|
||||
|
||||
zipComment = Text.encodeUtf8 $ toPathPiece cID
|
||||
|
||||
fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||||
serveSomeFiles (unpack filename <.> "zip") source
|
||||
|
||||
getSubDelR, postSubDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
|
||||
getSubDelR = postSubDelR
|
||||
@ -600,3 +598,16 @@ postSubDelR tid ssh csh shn cID = do
|
||||
{ drAbort = SomeRoute $ CSubmissionR tid ssh csh shn cID SubShowR
|
||||
, drSuccess = SomeRoute $ CSheetR tid ssh csh shn SShowR
|
||||
}
|
||||
|
||||
|
||||
getCorrectionsDownloadR :: Handler TypedContent
|
||||
getCorrectionsDownloadR = do -- download all assigned and open submissions
|
||||
uid <- requireAuthId
|
||||
subs <- runDB $ selectKeysList
|
||||
[ SubmissionRatingBy ==. Just uid
|
||||
, SubmissionRatingTime ==. Nothing
|
||||
] []
|
||||
when (null subs) $ do
|
||||
addMessageI Info MsgNoOpenSubmissions
|
||||
redirect CorrectionsR
|
||||
submissionMultiArchive $ Set.fromList subs
|
||||
|
||||
@ -3,7 +3,6 @@ module Handler.Term where
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.Form.MassInput
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
@ -8,7 +8,6 @@ import Handler.Utils.Tutorial
|
||||
import Handler.Utils.Table.Cells
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Communication
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Handler.Utils.Form.Occurences
|
||||
import Handler.Utils.Invitations
|
||||
import Jobs.Queue
|
||||
|
||||
@ -38,6 +38,7 @@ import qualified Data.List as List
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
|
||||
-- | Check whether the user's preference for files is inline-viewing or downloading
|
||||
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
|
||||
downloadFiles = do
|
||||
mauth <- liftHandlerT maybeAuth
|
||||
@ -47,40 +48,47 @@ downloadFiles = do
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
return userDefaultDownloadFiles
|
||||
|
||||
setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe FilePath -> m ()
|
||||
setContentDisposition' mFileName = do
|
||||
wantsDownload <- downloadFiles
|
||||
setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName
|
||||
|
||||
-- | Simply send a `File`-Value
|
||||
sendThisFile :: File -> Handler TypedContent
|
||||
sendThisFile File{..}
|
||||
| Just fileContent' <- fileContent = do
|
||||
setContentDisposition' . Just $ takeFileName fileTitle
|
||||
return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
|
||||
| otherwise = sendResponseStatus noContent204 ()
|
||||
|
||||
-- | Serve a single file, identified through a given DB query
|
||||
serveOneFile :: DB [Entity File] -> Handler TypedContent
|
||||
serveOneFile query = do
|
||||
results <- runDB query
|
||||
serveOneFile :: Source (YesodDB UniWorX) File -> Handler TypedContent
|
||||
serveOneFile source = do
|
||||
results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below
|
||||
case results of
|
||||
[Entity _fileId File{fileTitle, fileContent}]
|
||||
| Just fileContent' <- fileContent -> do
|
||||
whenM downloadFiles $
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
|
||||
return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
|
||||
| otherwise -> sendResponseStatus noContent204 ()
|
||||
[] -> notFound
|
||||
other -> do
|
||||
[file] -> sendThisFile file
|
||||
[] -> notFound
|
||||
other -> do
|
||||
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
|
||||
error "Multiple matching files found."
|
||||
|
||||
-- | Serve one file directly or a zip-archive of files, identified through a given DB query
|
||||
--
|
||||
-- Like `serveOneFile`, but sends a zip-archive if multiple results are returned
|
||||
serveSomeFiles :: Text -> DB [Entity File] -> Handler TypedContent
|
||||
serveSomeFiles archiveName query = do
|
||||
results <- runDB query
|
||||
serveSomeFiles :: FilePath -> Source (YesodDB UniWorX) File -> Handler TypedContent
|
||||
serveSomeFiles archiveName source = do
|
||||
results <- runDB . runConduit $ source .| peekN 2
|
||||
|
||||
$logDebugS "serveSomeFiles" . tshow $ length results
|
||||
|
||||
case results of
|
||||
[] -> notFound
|
||||
[Entity _fileId File{fileTitle, fileContent}]
|
||||
| Just fileContent' <- fileContent -> do
|
||||
whenM downloadFiles $
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
|
||||
return $ TypedContent (mimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
|
||||
| otherwise -> sendResponseStatus noContent204 ()
|
||||
files -> do
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece archiveName}"|]
|
||||
[] -> notFound
|
||||
[file] -> sendThisFile file
|
||||
_moreFiles -> do
|
||||
setContentDisposition' $ Just archiveName
|
||||
respondSourceDB "application/zip" $ do
|
||||
let zipComment = T.encodeUtf8 archiveName
|
||||
yieldMany files .| Conduit.map entityVal .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||||
let zipComment = T.encodeUtf8 $ pack archiveName
|
||||
source .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||||
|
||||
|
||||
tidFromText :: Text -> Maybe TermId
|
||||
|
||||
@ -9,7 +9,6 @@ module Handler.Utils.Communication
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Utils.Lens
|
||||
|
||||
import Jobs.Queue
|
||||
@ -21,9 +20,6 @@ import Data.Map ((!), (!?))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Data.Aeson.TH
|
||||
import Data.Aeson.Types (ToJSONKey(..), FromJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..))
|
||||
|
||||
|
||||
data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors
|
||||
| RGTutorialParticipants
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
module Handler.Utils.Form
|
||||
( module Handler.Utils.Form
|
||||
, module Handler.Utils.Form.MassInput
|
||||
, module Utils.Form
|
||||
, MonadWriter(..)
|
||||
) where
|
||||
@ -35,6 +36,7 @@ import qualified Data.Map as Map
|
||||
import Control.Monad.Trans.Writer (execWriterT, WriterT)
|
||||
import Control.Monad.Trans.Except (throwE, runExceptT)
|
||||
import Control.Monad.Writer.Class
|
||||
import Control.Monad.Error.Class (MonadError(..))
|
||||
|
||||
import Data.Scientific (Scientific)
|
||||
import Text.Read (readMaybe)
|
||||
@ -49,6 +51,13 @@ import Data.Proxy
|
||||
|
||||
import qualified Text.Email.Validate as Email
|
||||
|
||||
import Yesod.Core.Types (FileInfo(..))
|
||||
|
||||
import System.FilePath (isExtensionOf)
|
||||
import Data.Text.Lens (unpacked)
|
||||
|
||||
import Handler.Utils.Form.MassInput
|
||||
|
||||
----------------------------
|
||||
-- Buttons (new version ) --
|
||||
----------------------------
|
||||
@ -341,14 +350,88 @@ studyFeaturesPrimaryFieldFor isOptional oldFeatures mbuid = selectField $ do
|
||||
}
|
||||
|
||||
|
||||
uploadModeField :: Field Handler UploadMode
|
||||
uploadModeField = selectField optionsFinite
|
||||
uploadModeForm :: Maybe UploadMode -> AForm Handler UploadMode
|
||||
uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (classifyUploadMode <$> prev)
|
||||
where
|
||||
actions :: Map UploadModeDescr (AForm Handler UploadMode)
|
||||
actions = Map.fromList
|
||||
[ ( UploadModeNone, pure NoUpload)
|
||||
, ( UploadModeAny
|
||||
, UploadAny
|
||||
<$> apreq checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (prev ^? _Just . _unpackZips)
|
||||
<*> aopt extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction)
|
||||
)
|
||||
, ( UploadModeSpecific
|
||||
, UploadSpecific <$> specificFileForm
|
||||
)
|
||||
]
|
||||
|
||||
extensionRestrictionField :: Field Handler (NonNull (Set Extension))
|
||||
extensionRestrictionField = checkMMap (return . maybe (Left MsgUploadModeExtensionRestrictionEmpty) Right . fromNullable . toSet) (intercalate ", " . Set.toList . toNullable) textField
|
||||
where
|
||||
toSet = Set.fromList . filter (not . Text.null) . map (stripDot . Text.strip) . Text.splitOn ","
|
||||
stripDot ext
|
||||
| Just nExt <- Text.stripPrefix "." ext = nExt
|
||||
| otherwise = ext
|
||||
|
||||
specificFileForm :: AForm Handler (NonNull (Set UploadSpecificFile))
|
||||
specificFileForm = wFormToAForm $ do
|
||||
Just currentRoute <- getCurrentRoute
|
||||
let miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
||||
miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
|
||||
miIdent <- ("specific-files--" <>) <$> newIdent
|
||||
postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles & setTooltip MsgMassInputTip) True (preProcess <$> prev ^? _Just . _specificFiles)
|
||||
where
|
||||
preProcess :: NonNull (Set UploadSpecificFile) -> Map ListPosition (UploadSpecificFile, UploadSpecificFile)
|
||||
preProcess = Map.fromList . zip [0..] . map (\x -> (x, x)) . Set.toList . toNullable
|
||||
|
||||
postProcess :: FormResult (Map ListPosition (UploadSpecificFile, UploadSpecificFile)) -> WForm Handler (FormResult (NonNull (Set UploadSpecificFile)))
|
||||
postProcess mapResult = do
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
return $ do
|
||||
mapResult' <- Set.fromList . map snd . Map.elems <$> mapResult
|
||||
case fromNullable mapResult' of
|
||||
Nothing -> throwError [mr MsgNoUploadSpecificFilesConfigured]
|
||||
Just lResult -> do
|
||||
let names = Set.map specificFileName mapResult'
|
||||
labels = Set.map specificFileLabel mapResult'
|
||||
if
|
||||
| Set.size names /= Set.size mapResult'
|
||||
-> throwError [mr MsgUploadSpecificFilesDuplicateNames]
|
||||
| Set.size labels /= Set.size mapResult'
|
||||
-> throwError [mr MsgUploadSpecificFilesDuplicateLabels]
|
||||
| otherwise
|
||||
-> return lResult
|
||||
|
||||
sFileForm :: (Text -> Text) -> Maybe UploadSpecificFile -> Form UploadSpecificFile
|
||||
sFileForm nudge mPrevUF csrf = do
|
||||
(labelRes, labelView) <- mpreq textField ("" & addName (nudge "label")) $ specificFileLabel <$> mPrevUF
|
||||
(nameRes, nameView) <- mpreq textField ("" & addName (nudge "name")) $ specificFileName <$> mPrevUF
|
||||
(reqRes, reqView) <- mpreq checkBoxField ("" & addName (nudge "required")) $ specificFileRequired <$> mPrevUF
|
||||
|
||||
return ( UploadSpecificFile <$> labelRes <*> nameRes <*> reqRes
|
||||
, $(widgetFile "widgets/massinput/uploadSpecificFiles/form")
|
||||
)
|
||||
|
||||
miAdd _ _ nudge submitView = Just $ \csrf -> do
|
||||
(formRes, formWidget) <- sFileForm nudge Nothing csrf
|
||||
let formWidget' = $(widgetFile "widgets/massinput/uploadSpecificFiles/add")
|
||||
addRes' = formRes <&> \fileRes oldRess ->
|
||||
let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess
|
||||
in pure $ Map.singleton iStart fileRes
|
||||
return (addRes', formWidget')
|
||||
miCell _ initFile initFile' nudge csrf =
|
||||
sFileForm nudge (Just $ fromMaybe initFile initFile') csrf
|
||||
miDelete = miDeleteList
|
||||
miAllowAdd _ _ _ = True
|
||||
miAddEmpty _ _ _ = Set.empty
|
||||
miLayout :: MassInputLayout ListLength UploadSpecificFile UploadSpecificFile
|
||||
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout")
|
||||
|
||||
|
||||
submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
|
||||
submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev
|
||||
where
|
||||
uploadModeForm = apreq uploadModeField (fslI MsgSheetUploadMode) (preview (_Just . _submissionModeUser . _Just) $ prev)
|
||||
|
||||
actions :: Map SubmissionModeDescr (AForm Handler SubmissionMode)
|
||||
actions = Map.fromList
|
||||
[ ( SubmissionModeNone
|
||||
@ -358,10 +441,10 @@ submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ c
|
||||
, pure $ SubmissionMode True Nothing
|
||||
)
|
||||
, ( SubmissionModeUser
|
||||
, SubmissionMode False . Just <$> uploadModeForm
|
||||
, SubmissionMode False . Just <$> uploadModeForm (prev ^? _Just . _submissionModeUser . _Just)
|
||||
)
|
||||
, ( SubmissionModeBoth
|
||||
, SubmissionMode True . Just <$> uploadModeForm
|
||||
, SubmissionMode True . Just <$> uploadModeForm (prev ^? _Just . _submissionModeUser . _Just)
|
||||
)
|
||||
]
|
||||
|
||||
@ -374,17 +457,41 @@ pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (re
|
||||
| otherwise
|
||||
= return . Left $ MsgUnknownPseudonymWord (CI.original w)
|
||||
|
||||
zipFileField :: Bool -- ^ Unpack zips?
|
||||
-> Field Handler (Source Handler File)
|
||||
zipFileField doUnpack = Field{..}
|
||||
specificFileField :: UploadSpecificFile -> Field Handler (Source Handler File)
|
||||
specificFileField UploadSpecificFile{..} = Field{..}
|
||||
where
|
||||
fieldEnctype = Multipart
|
||||
fieldParse _ files
|
||||
| [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
|
||||
| [f] <- files
|
||||
= return . Right . Just $ yieldM (acceptFile f) .| modifyFileTitle (const $ unpack specificFileName)
|
||||
| null files = return $ Right Nothing
|
||||
| otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile
|
||||
fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/specificFileField")
|
||||
|
||||
extensions = fileNameExtensions specificFileName
|
||||
acceptRestricted = not $ null extensions
|
||||
accept = Text.intercalate "," . map ("." <>) $ extensions
|
||||
|
||||
|
||||
zipFileField :: Bool -- ^ Unpack zips?
|
||||
-> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
|
||||
-> Field Handler (Source Handler File)
|
||||
zipFileField doUnpack permittedExtensions = Field{..}
|
||||
where
|
||||
fieldEnctype = Multipart
|
||||
fieldParse _ files
|
||||
| [f@FileInfo{..}] <- files
|
||||
, maybe True (anyOf (re _nullable . folded . unpacked) (`isExtensionOf` unpack fileName)) permittedExtensions || doUnpack
|
||||
= return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
|
||||
| null files = return $ Right Nothing
|
||||
| otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile
|
||||
fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/zipFileField")
|
||||
|
||||
zipExtensions = mimeExtensions "application/zip"
|
||||
|
||||
acceptRestricted = isJust permittedExtensions
|
||||
accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) doUnpack ++ toListOf (_Just . re _nullable . folded) permittedExtensions
|
||||
|
||||
multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either FileId File))
|
||||
multiFileField permittedFiles' = Field{..}
|
||||
where
|
||||
@ -590,23 +697,6 @@ jsonField hide = Field{..}
|
||||
|]
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
secretJsonField :: ( ToJSON a, FromJSON a
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Field m a
|
||||
secretJsonField = Field{..}
|
||||
where
|
||||
fieldParse [v] [] = bimap (\_ -> SomeMessage MsgSecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
|
||||
fieldParse [] [] = return $ Right Nothing
|
||||
fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
|
||||
fieldView theId name attrs val _isReq = do
|
||||
val' <- traverse (encodedSecretBox SecretBoxShort) val
|
||||
[whamlet|
|
||||
<input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
|
||||
|]
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
boolField :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-} -- tupleBoxCoord
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
module Handler.Utils.Form.MassInput
|
||||
@ -17,12 +17,9 @@ module Handler.Utils.Form.MassInput
|
||||
import Import
|
||||
import Utils.Form
|
||||
import Utils.Lens
|
||||
import Handler.Utils.Form (secretJsonField)
|
||||
import Handler.Utils.Form.MassInput.Liveliness
|
||||
import Handler.Utils.Form.MassInput.TH
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
import Algebra.Lattice hiding (join)
|
||||
|
||||
import Text.Blaze (Markup)
|
||||
|
||||
@ -4,7 +4,6 @@ module Handler.Utils.Form.Occurences
|
||||
|
||||
import Import
|
||||
import Handler.Utils.Form
|
||||
import Handler.Utils.Form.MassInput
|
||||
import Handler.Utils.DateTime
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
@ -32,7 +32,6 @@ import qualified Data.HashSet as HashSet
|
||||
|
||||
import Data.Aeson (fromJSON)
|
||||
import qualified Data.Aeson as JSON
|
||||
import Data.Aeson.TH
|
||||
|
||||
import Data.Proxy (Proxy(..))
|
||||
import Data.Typeable
|
||||
|
||||
@ -13,27 +13,25 @@ module Handler.Utils.Submission
|
||||
|
||||
import Import hiding (joinPath)
|
||||
import Jobs.Queue
|
||||
import Prelude (lcm)
|
||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Control.Monad.State hiding (forM_, mapM_,foldM)
|
||||
import Control.Monad.Writer (MonadWriter(..), execWriterT)
|
||||
import Control.Monad.RWS.Lazy (RWST)
|
||||
import Control.Monad.State as State (StateT)
|
||||
import Control.Monad.State.Class as State
|
||||
import Control.Monad.Writer (MonadWriter(..), execWriterT, execWriter)
|
||||
import Control.Monad.RWS.Lazy (MonadRWS, RWST, execRWST)
|
||||
import qualified Control.Monad.Random as Rand
|
||||
import qualified System.Random.Shuffle as Rand (shuffleM)
|
||||
|
||||
import Data.Maybe ()
|
||||
|
||||
import qualified Data.List as List
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map (Map)
|
||||
import Data.Map (Map, (!), (!?))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import Data.Ratio
|
||||
|
||||
import Data.Monoid (Monoid, Any(..), Sum(..))
|
||||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||
@ -43,6 +41,7 @@ import qualified Handler.Utils.Rating as Rating (extractRatings)
|
||||
import Handler.Utils.Delete
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils.TH as E
|
||||
|
||||
import qualified Data.Conduit.List as Conduit
|
||||
import Data.Conduit.ResumableSink
|
||||
@ -55,155 +54,178 @@ import Text.Hamlet (ihamletFile)
|
||||
import qualified Control.Monad.Catch as E (Handler(..))
|
||||
|
||||
|
||||
data AssignSubmissionException = NoCorrectorsByProportion
|
||||
deriving (Typeable, Show)
|
||||
data AssignSubmissionException = NoCorrectors
|
||||
| NoCorrectorsByProportion
|
||||
| SubmissionsNotFound (NonNull (Set SubmissionId))
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Exception AssignSubmissionException
|
||||
|
||||
-- | Assigns all submissions according to sheet corrector loads
|
||||
assignSubmissions :: SheetId -- ^ Sheet do distribute to correction
|
||||
assignSubmissions :: SheetId -- ^ Sheet to distribute to correctors
|
||||
-> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
|
||||
-> YesodDB UniWorX ( Set SubmissionId
|
||||
, Set SubmissionId
|
||||
) -- ^ Returns assigned and unassigned submissions; unassigned submissions occur only if no tutors have an assigned load
|
||||
assignSubmissions sid restriction = do
|
||||
Sheet{..} <- getJust sid
|
||||
correctors <- selectList [ SheetCorrectorSheet ==. sid, SheetCorrectorState ==. CorrectorNormal ] []
|
||||
let
|
||||
-- byTutorial' uid = join . Map.lookup uid $ Map.fromList [ (sheetCorrectorUser, byTutorial sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsTutorial ]
|
||||
corrsTutorial = filter hasTutorialLoad correctors -- needed as List within Esqueleto
|
||||
corrsProp = filter hasPositiveLoad correctors
|
||||
countsToLoad' :: UserId -> Bool
|
||||
countsToLoad' uid = Map.findWithDefault True uid loadMap
|
||||
loadMap :: Map UserId Bool
|
||||
loadMap = Map.fromList [(sheetCorrectorUser,b) | Entity _ SheetCorrector{ sheetCorrectorLoad = (Load {byTutorial = Just b}), .. } <- corrsTutorial]
|
||||
|
||||
currentSubs <- E.select . E.from $ \(submission `E.LeftOuterJoin` tutor') -> do
|
||||
let tutors = E.subList_select . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> 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.==. tutor E.^. TutorTutorial)
|
||||
E.on (tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial)
|
||||
E.on (submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser)
|
||||
E.where_ (tutor E.^. TutorUser `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsTutorial))
|
||||
return $ tutor E.^. TutorUser
|
||||
E.on $ tutor' E.?. UserId `E.in_` E.justList tutors
|
||||
E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid
|
||||
E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction)
|
||||
return (submission E.^. SubmissionId, tutor' E.?. UserId)
|
||||
|
||||
let subTutor' :: Map SubmissionId (Set UserId)
|
||||
subTutor' = Map.fromListWith Set.union $ currentSubs
|
||||
& mapped._2 %~ (maybe Set.empty Set.singleton . E.unValue)
|
||||
& mapped._1 %~ E.unValue
|
||||
|
||||
prevSubs <- E.select . E.from $ \((sheet `E.InnerJoin` sheetCorrector) `E.LeftOuterJoin` submission) -> do
|
||||
E.on $ E.joinV (submission E.?. SubmissionRatingBy) E.==. E.just (sheetCorrector E.^. SheetCorrectorUser)
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||||
let isByTutorial = E.exists . E.from $ \(submissionUser `E.InnerJoin` tutorialUser `E.InnerJoin` tutorial `E.InnerJoin` tutor) -> do
|
||||
E.on (tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial)
|
||||
E.on $ tutorial E.^. TutorialId E.==. tutorialUser E.^. TutorialParticipantTutorial
|
||||
E.on $ submissionUser E.^. SubmissionUserUser E.==. tutorialUser E.^. TutorialParticipantUser
|
||||
E.where_ $ tutor E.^. TutorUser 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))
|
||||
correctorsRaw <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
E.where_ $ sheetCorrector E.^. SheetCorrectorState `E.in_` E.valList [CorrectorNormal, CorrectorMissing]
|
||||
return (sheet E.^. SheetId, sheetCorrector)
|
||||
|
||||
let
|
||||
prevSubs' :: Map SheetId (Map UserId (Rational, Integer))
|
||||
prevSubs' = Map.unionsWith (Map.unionWith $ \(prop, n) (_, n') -> (prop, n + n')) $ do
|
||||
(Entity _ 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)
|
||||
correctors :: Map SheetId (Map UserId (Load, CorrectorState))
|
||||
correctors = Map.fromList $ do
|
||||
E.Value sheetId <- Set.toList $ setOf (folded . _1) correctorsRaw
|
||||
let loads = Map.fromList $ do
|
||||
(E.Value sheetId', Entity _ SheetCorrector{..})
|
||||
<- correctorsRaw
|
||||
guard $ sheetId' == sheetId
|
||||
return (sheetCorrectorUser, (sheetCorrectorLoad, sheetCorrectorState))
|
||||
return (sheetId, loads)
|
||||
|
||||
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
|
||||
sheetCorrectors :: Map UserId Load
|
||||
sheetCorrectors = Map.mapMaybe filterLoad $ correctors ! sid
|
||||
where
|
||||
assigned' = getSum $ foldMap (Sum . snd) assignments
|
||||
props = getSum $ foldMap (Sum . fst) assignments
|
||||
filterLoad (l@Load{..}, CorrectorNormal) = l <$ guard (isJust byTutorial || byProportion /= 0)
|
||||
filterLoad _ = Nothing
|
||||
|
||||
toDeficit' (prop, assigned) = let
|
||||
target
|
||||
| props == 0 = 0
|
||||
| otherwise = round $ fromInteger assigned' * (prop / props)
|
||||
in target - assigned
|
||||
unless (Map.member sid correctors) $
|
||||
throwM NoCorrectors
|
||||
|
||||
$logDebugS "assignSubmissions" $ "Previous submissions: " <> tshow prevSubs'
|
||||
$logDebugS "assignSubmissions" $ "Current deficit: " <> tshow deficit
|
||||
submissionDataRaw <- E.select . E.from $ \((sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) `E.LeftOuterJoin` (tutorial `E.InnerJoin` tutorialUser `E.InnerJoin` tutor)) -> do
|
||||
E.on $ tutor E.?. TutorTutorial E.==. tutorial E.?. TutorialId
|
||||
E.on $ tutorialUser E.?. TutorialParticipantTutorial E.==. tutorial E.?. TutorialId
|
||||
E.on $ tutorialUser E.?. TutorialParticipantUser E.==. E.just (submissionUser E.^. SubmissionUserUser)
|
||||
E.&&. tutor E.?. TutorUser `E.in_` E.justList (E.valList $ foldMap Map.keys correctors)
|
||||
E.&&. tutorial E.?. TutorialCourse E.==. E.just (E.val sheetCourse)
|
||||
E.on $ submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission
|
||||
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val sheetCourse
|
||||
|
||||
return (sheet E.^. SheetId, submission, tutor E.?. TutorUser)
|
||||
|
||||
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
|
||||
-- | All submissions in this course so far
|
||||
submissionData :: Map SubmissionId
|
||||
( Maybe UserId -- Corrector
|
||||
, Map UserId (Sum Natural) -- Tutors
|
||||
, SheetId
|
||||
)
|
||||
submissionData = Map.fromListWith merge $ map process submissionDataRaw
|
||||
where
|
||||
process (E.Value sheetId, Entity subId Submission{..}, E.Value mTutId) = (subId, (submissionRatingBy, maybe Map.empty (flip Map.singleton $ Sum 1) $ assertM isCorrectorByTutorial mTutId, sheetId))
|
||||
merge (corrA, tutorsA, sheetA) (corrB, tutorsB, sheetB)
|
||||
| corrA /= corrB = error "Same submission seen with different correctors"
|
||||
| sheetA /= sheetB = error "Same submission seen with different sheets"
|
||||
| otherwise = (corrA, Map.unionWith mappend tutorsA tutorsB, sheetA)
|
||||
|
||||
$logDebugS "assignSubmissions" $ "Deterministic Queue: " <> tshow detQueue
|
||||
-- Not done in esqueleto, since inspection of `Load`-Values is difficult
|
||||
isCorrectorByTutorial = maybe False (\Load{..} -> is _Just byTutorial) . flip Map.lookup sheetCorrectors
|
||||
|
||||
queue <- liftIO . Rand.evalRandIO . execWriterT $ do
|
||||
tell $ map Just detQueue
|
||||
forever $
|
||||
tell . pure =<< Rand.weightedMay [ (sheetCorrectorUser, byProportion sheetCorrectorLoad) | Entity _ SheetCorrector{..} <- corrsProp ]
|
||||
targetSubmissions = Set.fromList $ do
|
||||
(E.Value sheetId, Entity subId Submission{..}, _) <- submissionDataRaw
|
||||
guard $ sheetId == sid
|
||||
case restriction of
|
||||
Just restriction' ->
|
||||
guard $ subId `Set.member` restriction'
|
||||
Nothing ->
|
||||
guard $ is _Nothing submissionRatingBy
|
||||
return subId
|
||||
|
||||
$logDebugS "assignSubmissions" $ "Queue: " <> tshow (take (Map.size subTutor') queue)
|
||||
targetSubmissionData = set _1 Nothing <$> Map.restrictKeys submissionData targetSubmissions
|
||||
oldSubmissionData = Map.withoutKeys submissionData targetSubmissions
|
||||
|
||||
whenIsJust (fromNullable =<< fmap (`Set.difference` targetSubmissions) restriction) $ \missing ->
|
||||
throwM $ SubmissionsNotFound missing
|
||||
|
||||
let
|
||||
assignSubmission :: MonadState (Map SubmissionId UserId, [Maybe UserId], Map UserId Integer) m => Bool -> SubmissionId -> UserId -> m ()
|
||||
assignSubmission countsToLoad smid tutid = do
|
||||
_1 %= Map.insert smid tutid
|
||||
_3 . at tutid %= assertM' (> 0) . maybe (-1) pred
|
||||
when countsToLoad $
|
||||
_2 %= List.delete (Just tutid)
|
||||
withSubmissionData :: MonadRWS (Map SubmissionId a) w (Map SubmissionId a) m
|
||||
=> (Map SubmissionId a -> b)
|
||||
-> m b
|
||||
withSubmissionData f = f <$> (mappend <$> ask <*> State.get)
|
||||
|
||||
-- | How many additional submission should the given corrector be assigned, if possible?
|
||||
calculateDeficit :: UserId -> Map SubmissionId (Maybe UserId, Map UserId _, SheetId) -> Rational
|
||||
calculateDeficit corrector submissionState = getSum $ foldMap Sum deficitBySheet
|
||||
where
|
||||
sheetSizes :: Map SheetId Integer
|
||||
-- ^ Number of assigned submissions (to anyone) per sheet
|
||||
sheetSizes = Map.map getSum . Map.fromListWith mappend $ do
|
||||
(_, (Just _, _, sheetId)) <- Map.toList submissionState
|
||||
return (sheetId, Sum 1)
|
||||
|
||||
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)
|
||||
deficitBySheet :: Map SheetId Rational
|
||||
-- ^ Deficite of @corrector@ per sheet
|
||||
deficitBySheet = flip Map.mapMaybeWithKey sheetSizes $ \sheetId sheetSize -> do
|
||||
let assigned :: Rational
|
||||
assigned = fromIntegral . Map.size $ Map.filter (\(mCorr, _, sheetId') -> mCorr == Just corrector && sheetId == sheetId') submissionState
|
||||
proportionSum :: Rational
|
||||
proportionSum = getSum . foldMap corrProportion . fromMaybe Map.empty $ correctors !? sheetId
|
||||
where corrProportion (_, CorrectorExcused) = mempty
|
||||
corrProportion (Load{..}, _) = Sum byProportion
|
||||
extra
|
||||
| Just (Load{..}, corrState) <- correctors !? sheetId >>= Map.lookup corrector
|
||||
= sum
|
||||
[ assigned
|
||||
, fromMaybe 0 $ do -- If corrections assigned by tutorial do not count against proportion, substract them from deficit
|
||||
tutCounts <- byTutorial
|
||||
guard $ not tutCounts
|
||||
guard $ corrState /= CorrectorExcused
|
||||
return . negate . fromIntegral . Map.size $ Map.filter (\(mCorr, tutors, sheetId') -> mCorr == Just corrector && sheetId == sheetId' && Map.member corrector tutors) submissionState
|
||||
, fromMaybe 0 $ do
|
||||
guard $ corrState /= CorrectorExcused
|
||||
return . negate $ (byProportion / proportionSum) * fromIntegral sheetSize
|
||||
]
|
||||
| otherwise
|
||||
= assigned
|
||||
return $ negate extra
|
||||
|
||||
subTutor'' <- liftIO . Rand.evalRandIO . Rand.shuffleM $ Map.toList subTutor'
|
||||
-- Sort target submissions by those that have tutors first and otherwise random
|
||||
--
|
||||
-- Deficit produced by restriction to tutors can thus be fixed by later submissions
|
||||
targetSubmissions' <- liftIO . unstableSortBy (comparing $ \subId -> Map.null . view _2 $ submissionData ! subId) $ Set.toList targetSubmissions
|
||||
|
||||
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
|
||||
(newSubmissionData, ()) <- (\act -> execRWST act oldSubmissionData targetSubmissionData) . forM_ (zip [1..] targetSubmissions') $ \(i, subId) -> do
|
||||
tutors <- gets $ view _2 . (! subId) -- :: Map UserId (Sum Natural)
|
||||
let acceptableCorrectors
|
||||
| correctorsByTut <- Map.filter (is _Just . view _byTutorial) $ sheetCorrectors `Map.restrictKeys` Map.keysSet tutors
|
||||
, not $ null correctorsByTut
|
||||
= Map.keysSet correctorsByTut
|
||||
| otherwise
|
||||
= Map.keysSet $ Map.filter (views _byProportion (/= 0)) sheetCorrectors
|
||||
|
||||
when (not $ null acceptableCorrectors) $ do
|
||||
deficits <- sequence . flip Map.fromSet acceptableCorrectors $ withSubmissionData . calculateDeficit
|
||||
let
|
||||
bestCorrectors :: Set UserId
|
||||
bestCorrectors = acceptableCorrectors
|
||||
& maximumsBy (deficits !)
|
||||
& maximumsBy (tutors !?)
|
||||
|
||||
$logDebugS "assignSubmissions" [st|#{tshow i} Tutors for #{tshow subId}: #{tshow tutors}|]
|
||||
$logDebugS "assignSubmissions" [st|#{tshow i} Current (#{tshow subId}) relevant deficits: #{tshow deficits}|]
|
||||
$logDebugS "assignSubmissions" [st|#{tshow i} Assigning #{tshow subId} to one of #{tshow bestCorrectors}|]
|
||||
|
||||
ix subId . _1 <~ Just <$> liftIO (Rand.uniform bestCorrectors)
|
||||
|
||||
now <- liftIO getCurrentTime
|
||||
forM_ (Map.toList subTutor) $
|
||||
\(smid, tutid) -> update smid [ SubmissionRatingBy =. Just tutid
|
||||
, SubmissionRatingAssigned =. Just now ]
|
||||
execWriterT . forM_ (Map.toList newSubmissionData) $ \(subId, (mCorrector, _, _)) -> case mCorrector of
|
||||
Just corrector -> do
|
||||
lift $ update subId [ SubmissionRatingBy =. Just corrector
|
||||
, SubmissionRatingAssigned =. Just now
|
||||
]
|
||||
tell (Set.singleton subId, mempty)
|
||||
Nothing ->
|
||||
tell (mempty, Set.singleton subId)
|
||||
where
|
||||
maximumsBy :: (Ord a, Ord b) => (a -> b) -> Set a -> Set a
|
||||
maximumsBy f xs = flip Set.filter xs $ \x -> maybe True (((==) `on` f) x . maximumBy (comparing f)) $ fromNullable xs
|
||||
|
||||
let assignedSubmissions = Map.keysSet subTutor
|
||||
unassigendSubmissions = Map.keysSet subTutor' \\ assignedSubmissions
|
||||
return (assignedSubmissions, unassigendSubmissions)
|
||||
where
|
||||
hasPositiveLoad = (> 0) . byProportion . sheetCorrectorLoad . entityVal
|
||||
hasTutorialLoad = isJust . byTutorial . sheetCorrectorLoad . entityVal
|
||||
unstableSortBy :: MonadRandom m => (a -> a -> Ordering) -> [a] -> m [a]
|
||||
unstableSortBy cmp = fmap concat . mapM Rand.shuffleM . groupBy (\a b -> cmp a b == EQ) . sortBy cmp
|
||||
|
||||
|
||||
submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
|
||||
@ -223,17 +245,34 @@ submissionMultiArchive (Set.toList -> ids) = do
|
||||
(dbrunner, cleanup) <- getDBRunner
|
||||
|
||||
ratedSubmissions <- runDBRunner dbrunner $ do
|
||||
submissions <- selectList [ SubmissionId <-. ids ] []
|
||||
forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
|
||||
submissions <- E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission) -> do
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
E.where_ $ submission E.^. SubmissionId `E.in_` E.valList ids
|
||||
return (submission, (sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseSchool, course E.^. CourseTerm))
|
||||
|
||||
forM submissions $ \(s@(Entity submissionId _), courseSheetInfo) ->
|
||||
maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s, $(E.unValueN 4) courseSheetInfo)) =<< getRating submissionId
|
||||
let (setSheet,setCourse,setSchool,setTerm) =
|
||||
execWriter . forM ratedSubmissions $ \(_rating,_submission,(shn,csh,ssh,tid)) ->
|
||||
tell (Set.singleton shn, Set.singleton csh, Set.singleton ssh, Set.singleton tid)
|
||||
|
||||
(<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
|
||||
let
|
||||
fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
|
||||
fileEntitySource' (rating, Entity submissionID Submission{..}) = do
|
||||
fileEntitySource' :: (Rating, Entity Submission, (SheetName,CourseShorthand,SchoolId,TermId)) -> Source (YesodDB UniWorX) File
|
||||
fileEntitySource' (rating, Entity submissionID Submission{..},(shn,csh,ssh,tid)) = do
|
||||
cID <- encrypt submissionID
|
||||
|
||||
let
|
||||
directoryName = Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)
|
||||
dirFrag :: PathPiece p => p -> FilePath
|
||||
dirFrag = Text.unpack . toPathPiece
|
||||
submissionDirectory = dirFrag (cID :: CryptoFileNameSubmission)
|
||||
directoryName
|
||||
| Set.size setTerm > 1 = dirFrag tid </> dirFrag ssh </> dirFrag csh </> dirFrag shn </> submissionDirectory
|
||||
| Set.size setSchool > 1 = dirFrag ssh </> dirFrag csh </> dirFrag shn </> submissionDirectory
|
||||
| Set.size setCourse > 1 = dirFrag csh </> dirFrag shn </> submissionDirectory
|
||||
| Set.size setSheet > 1 = dirFrag shn </> submissionDirectory
|
||||
| otherwise = submissionDirectory
|
||||
|
||||
fileEntitySource = do
|
||||
submissionFileSource submissionID =$= Conduit.map entityVal
|
||||
@ -300,8 +339,10 @@ extractRatingsMsg = do
|
||||
let ignoredFiles :: Set (Either CryptoFileNameSubmission FilePath)
|
||||
ignoredFiles = Right `Set.map` ignored'
|
||||
unless (null ignoredFiles) $ do
|
||||
mr <- (toHtml . ) <$> getMessageRender
|
||||
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
|
||||
let ignoredModal = msgModal
|
||||
[whamlet|_{MsgSubmissionFilesIgnored (Set.size ignoredFiles)}|]
|
||||
(Right $(widgetFile "messages/submissionFilesIgnored"))
|
||||
addMessageWidget Warning ignoredModal
|
||||
|
||||
-- Nicht innerhalb von runDB aufrufen, damit das DB Rollback passieren kann!
|
||||
msgSubmissionErrors :: (MonadHandler m, MonadCatch m, HandlerSite m ~ UniWorX) => m a -> m (Maybe a)
|
||||
@ -344,10 +385,28 @@ sinkSubmission userId mExists isUpdate = do
|
||||
return sId
|
||||
Right sId -> return sId
|
||||
|
||||
sId <$ sinkSubmission' sId
|
||||
Sheet{..} <- lift $ case mExists of
|
||||
Left sheetId -> getJust sheetId
|
||||
Right subId -> getJust . submissionSheet =<< getJust subId
|
||||
|
||||
sId <$ (guardFileTitles sheetSubmissionMode .| sinkSubmission' sId)
|
||||
where
|
||||
tellSt = modify . mappend
|
||||
|
||||
guardFileTitles :: MonadThrow m => SubmissionMode -> Conduit SubmissionContent m SubmissionContent
|
||||
guardFileTitles SubmissionMode{..}
|
||||
| Just UploadAny{..} <- submissionModeUser
|
||||
, not isUpdate
|
||||
, Just (map unpack . Set.toList . toNullable -> exts) <- extensionRestriction
|
||||
= Conduit.mapM $ \x -> if
|
||||
| Left File{..} <- x
|
||||
, none (`isExtensionOf` fileTitle) exts
|
||||
, isn't _Nothing fileContent -- File record is not a directory, we don't care about those
|
||||
-> throwM $ InvalidFileTitleExtension fileTitle
|
||||
| otherwise
|
||||
-> return x
|
||||
| otherwise = Conduit.map id
|
||||
|
||||
sinkSubmission' :: SubmissionId
|
||||
-> Sink SubmissionContent (YesodJobDB UniWorX) ()
|
||||
sinkSubmission' submissionId = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
|
||||
|
||||
@ -1,5 +1,3 @@
|
||||
{-# OPTIONS -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Utils.Table.Pagination
|
||||
( module Handler.Utils.Table.Pagination.Types
|
||||
, SortColumn(..), SortDirection(..)
|
||||
|
||||
@ -1,105 +1,17 @@
|
||||
module Import.NoFoundation
|
||||
( module Import
|
||||
, MForm
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons)
|
||||
import Import.NoModel as Import
|
||||
import Model as Import
|
||||
import Model.Types.JSON as Import
|
||||
import Model.Migration as Import
|
||||
import Model.Rating as Import
|
||||
import Model.Submission as Import
|
||||
import Model.Tokens as Import
|
||||
import Utils.Tokens as Import
|
||||
import Utils.Frontend.Modal as Import
|
||||
|
||||
import Settings as Import
|
||||
import Settings.StaticFiles as Import
|
||||
import Yesod.Auth as Import
|
||||
import Yesod.Core.Types as Import (loggerSet)
|
||||
import Yesod.Default.Config2 as Import
|
||||
import Utils as Import
|
||||
import Utils.Frontend.Modal as Import
|
||||
import Utils.Frontend.I18n as Import
|
||||
import Utils.DB as Import
|
||||
import Yesod.Core.Json as Import (provideJson)
|
||||
import Yesod.Core.Types.Instances as Import (CachedMemoT(..))
|
||||
|
||||
import Language.Haskell.TH.Instances as Import ()
|
||||
|
||||
import Utils.Tokens as Import
|
||||
|
||||
|
||||
import Data.Fixed as Import
|
||||
|
||||
import CryptoID as Import
|
||||
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
|
||||
import Data.Universe.TH as Import
|
||||
import Data.Pool as Import (Pool)
|
||||
import Network.HaskellNet.SMTP as Import (SMTPConnection)
|
||||
|
||||
import Mail as Import
|
||||
|
||||
import Data.Data as Import (Data)
|
||||
import Data.Typeable as Import (Typeable)
|
||||
import GHC.Generics as Import (Generic)
|
||||
import GHC.Exts as Import (IsList)
|
||||
|
||||
import Data.Hashable as Import
|
||||
import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty)
|
||||
import Data.List.NonEmpty.Instances as Import ()
|
||||
import Data.NonNull.Instances as Import ()
|
||||
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||
import Data.Semigroup as Import (Semigroup)
|
||||
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..))
|
||||
import Data.Monoid.Instances as Import ()
|
||||
import Data.Set.Instances as Import ()
|
||||
import Data.HashMap.Strict.Instances as Import ()
|
||||
import Data.HashSet.Instances as Import ()
|
||||
import Data.Vector.Instances as Import ()
|
||||
import Data.Time.Clock.Instances as Import ()
|
||||
|
||||
import Data.Binary as Import (Binary)
|
||||
|
||||
import Control.Monad.Morph as Import (MFunctor(..))
|
||||
|
||||
import Control.Monad.Trans.Resource as Import (ReleaseKey)
|
||||
|
||||
import Network.Mail.Mime.Instances as Import ()
|
||||
import Yesod.Core.Instances as Import ()
|
||||
import Data.Aeson.Types.Instances as Import ()
|
||||
|
||||
import Ldap.Client.Pool as Import
|
||||
|
||||
import Database.Esqueleto.Instances as Import ()
|
||||
import Database.Persist.Sql.Instances as Import ()
|
||||
import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
|
||||
import Database.Persist.Types.Instances as Import ()
|
||||
|
||||
import Numeric.Natural.Instances as Import ()
|
||||
import System.Random as Import (Random)
|
||||
import Control.Monad.Random.Class as Import (MonadRandom(..))
|
||||
|
||||
import Text.Blaze.Instances as Import ()
|
||||
import Jose.Jwt.Instances as Import ()
|
||||
import Jose.Jwt as Import (Jwt)
|
||||
import Web.PathPieces.Instances as Import ()
|
||||
|
||||
import Data.Time.Calendar as Import
|
||||
import Data.Time.Clock as Import
|
||||
import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC)
|
||||
import Time.Types as Import (WeekDay(..))
|
||||
|
||||
import Time.Types.Instances as Import ()
|
||||
|
||||
import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase)
|
||||
|
||||
import Data.Ratio as Import ((%))
|
||||
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
|
||||
type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m
|
||||
|
||||
105
src/Import/NoModel.hs
Normal file
105
src/Import/NoModel.hs
Normal file
@ -0,0 +1,105 @@
|
||||
module Import.NoModel
|
||||
( module Import
|
||||
, MForm
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons)
|
||||
|
||||
import Model.Types.TH.JSON as Import
|
||||
import Model.Types.TH.Wordlist as Import
|
||||
|
||||
import Mail as Import
|
||||
|
||||
import Yesod.Auth as Import
|
||||
import Yesod.Core.Types as Import (loggerSet)
|
||||
import Yesod.Default.Config2 as Import
|
||||
import Yesod.Core.Json as Import (provideJson)
|
||||
import Yesod.Core.Types.Instances as Import (CachedMemoT(..))
|
||||
|
||||
import Utils as Import
|
||||
import Utils.Frontend.I18n as Import
|
||||
import Utils.DB as Import
|
||||
|
||||
import Data.Fixed as Import
|
||||
|
||||
import Data.UUID as Import (UUID)
|
||||
|
||||
import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase)
|
||||
|
||||
import Text.Lucius as Import
|
||||
import Text.Shakespeare.Text as Import hiding (text, stext)
|
||||
|
||||
import Data.Universe as Import
|
||||
import Data.Universe.TH as Import
|
||||
import Data.Pool as Import (Pool)
|
||||
import Network.HaskellNet.SMTP as Import (SMTPConnection)
|
||||
|
||||
import Data.Data as Import (Data)
|
||||
import Data.Typeable as Import (Typeable)
|
||||
import GHC.Generics as Import (Generic)
|
||||
import GHC.Exts as Import (IsList)
|
||||
import Data.Ix as Import (Ix)
|
||||
|
||||
import Data.Hashable as Import
|
||||
import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty)
|
||||
import Data.Text.Encoding.Error as Import(UnicodeException(..))
|
||||
import Data.Semigroup as Import (Semigroup)
|
||||
import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..))
|
||||
import Data.Binary as Import (Binary)
|
||||
|
||||
import Numeric.Natural as Import (Natural)
|
||||
import Data.Ratio as Import ((%))
|
||||
|
||||
import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, fromSqlKey, toSqlKey)
|
||||
|
||||
import Ldap.Client.Pool as Import
|
||||
|
||||
import System.Random as Import (Random(..))
|
||||
import Control.Monad.Random.Class as Import (MonadRandom(..))
|
||||
|
||||
import Control.Monad.Morph as Import (MFunctor(..))
|
||||
import Control.Monad.Trans.Resource as Import (ReleaseKey)
|
||||
|
||||
import Jose.Jwt as Import (Jwt)
|
||||
|
||||
import Data.Time.Calendar as Import
|
||||
import Data.Time.Clock as Import
|
||||
import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC)
|
||||
import Time.Types as Import (WeekDay(..))
|
||||
|
||||
import Network.Mime as Import
|
||||
|
||||
import Data.Aeson.TH as Import
|
||||
import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..), ToJSONKeyFunction(..), Value)
|
||||
|
||||
import Language.Haskell.TH.Instances as Import ()
|
||||
import Data.List.NonEmpty.Instances as Import ()
|
||||
import Data.NonNull.Instances as Import ()
|
||||
import Data.Monoid.Instances as Import ()
|
||||
import Data.Set.Instances as Import ()
|
||||
import Data.HashMap.Strict.Instances as Import ()
|
||||
import Data.HashSet.Instances as Import ()
|
||||
import Data.Vector.Instances as Import ()
|
||||
import Data.Time.Clock.Instances as Import ()
|
||||
import Data.Time.LocalTime.Instances as Import ()
|
||||
import Data.Time.Calendar.Instances as Import ()
|
||||
import Data.Time.Format.Instances as Import ()
|
||||
import Time.Types.Instances as Import ()
|
||||
import Network.Mail.Mime.Instances as Import ()
|
||||
import Yesod.Core.Instances as Import ()
|
||||
import Data.Aeson.Types.Instances as Import ()
|
||||
import Database.Esqueleto.Instances as Import ()
|
||||
import Numeric.Natural.Instances as Import ()
|
||||
import Text.Blaze.Instances as Import ()
|
||||
import Jose.Jwt.Instances as Import ()
|
||||
import Web.PathPieces.Instances as Import ()
|
||||
import Data.Universe.Instances.Reverse.MonoTraversable ()
|
||||
import Database.Persist.Class.Instances as Import ()
|
||||
import Database.Persist.Types.Instances as Import ()
|
||||
import Data.UUID.Instances as Import ()
|
||||
import System.FilePath.Instances as Import ()
|
||||
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
|
||||
type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m
|
||||
19
src/Jobs.hs
19
src/Jobs.hs
@ -32,6 +32,7 @@ import Control.Monad.Random (evalRand, mkStdGen, getRandomR)
|
||||
import Cron
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
|
||||
@ -51,8 +52,6 @@ import Data.Time.Zones
|
||||
|
||||
import Control.Concurrent.STM (retry)
|
||||
|
||||
import qualified System.Systemd.Daemon as Systemd
|
||||
|
||||
|
||||
import Jobs.Handler.SendNotification
|
||||
import Jobs.Handler.SendTestEmail
|
||||
@ -284,21 +283,19 @@ handleJobs' wNum = C.mapM_ $ \jctl -> do
|
||||
-- logDebugS logIdent $ tshow newCTab
|
||||
mapReaderT (liftIO . atomically) $
|
||||
lift . void . flip swapTMVar newCTab =<< asks jobCrontab
|
||||
handleCmd JobCtlGenerateHealthReport = do
|
||||
handleCmd (JobCtlGenerateHealthReport kind) = do
|
||||
hrStorage <- getsYesod appHealthReport
|
||||
newReport@(classifyHealthReport -> newStatus) <- lift generateHealthReport
|
||||
newReport@(healthReportStatus -> newStatus) <- lift $ generateHealthReport kind
|
||||
|
||||
$logInfoS "HealthReport" $ toPathPiece newStatus
|
||||
$logInfoS (tshow kind) $ toPathPiece newStatus
|
||||
unless (newStatus == HealthSuccess) $ do
|
||||
$logErrorS "HealthReport" $ tshow newReport
|
||||
$logErrorS (tshow kind) $ tshow newReport
|
||||
|
||||
liftIO $ do
|
||||
now <- getCurrentTime
|
||||
atomically . writeTVar hrStorage $ Just (now, newReport)
|
||||
|
||||
void . Systemd.notifyStatus . unpack $ toPathPiece newStatus
|
||||
when (newStatus == HealthSuccess) $
|
||||
void Systemd.notifyWatchdog
|
||||
let updateReports = Set.insert (now, newReport)
|
||||
. Set.filter (((/=) `on` classifyHealthReport) newReport . snd)
|
||||
atomically . modifyTVar' hrStorage $ force . updateReports
|
||||
|
||||
jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
|
||||
jLocked jId act = do
|
||||
|
||||
@ -2,18 +2,17 @@ module Jobs.Crontab
|
||||
( determineCrontab
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Import
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Jobs.Types
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Semigroup (Max(..))
|
||||
|
||||
import Data.Time.Zones
|
||||
|
||||
import Control.Monad.Trans.Writer (execWriterT)
|
||||
import Control.Monad.Trans.Writer (WriterT, execWriterT)
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
@ -44,14 +43,17 @@ determineCrontab = execWriterT $ do
|
||||
, cronNotAfter = Right CronNotScheduled
|
||||
}
|
||||
|
||||
tell $ HashMap.singleton
|
||||
JobCtlGenerateHealthReport
|
||||
Cron
|
||||
{ cronInitial = CronAsap
|
||||
, cronRepeat = CronRepeatScheduled CronAsap
|
||||
, cronRateLimit = appHealthCheckInterval
|
||||
, cronNotAfter = Right CronNotScheduled
|
||||
}
|
||||
tell . flip foldMap universeF $ \kind ->
|
||||
case appHealthCheckInterval kind of
|
||||
Just int -> HashMap.singleton
|
||||
(JobCtlGenerateHealthReport kind)
|
||||
Cron
|
||||
{ cronInitial = CronAsap
|
||||
, cronRepeat = CronRepeatScheduled CronAsap
|
||||
, cronRateLimit = int
|
||||
, cronNotAfter = Right CronNotScheduled
|
||||
}
|
||||
Nothing -> mempty
|
||||
|
||||
let
|
||||
sheetJobs (Entity nSheet Sheet{..}) = do
|
||||
@ -88,28 +90,31 @@ determineCrontab = execWriterT $ do
|
||||
, cronRateLimit = 3600 -- Irrelevant due to `cronRepeat`
|
||||
, cronNotAfter = Left nominalDay
|
||||
}
|
||||
|
||||
sheetSubmissions <- lift $ collateSubmissions <$>
|
||||
selectList [SubmissionRatingBy !=. Nothing, SubmissionSheet ==. nSheet] []
|
||||
tell $ flip Map.foldMapWithKey sheetSubmissions $
|
||||
\nUser (Max mbTime) -> if
|
||||
| Just time <- mbTime -> HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationCorrectionsAssigned { nUser, nSheet } )
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay time
|
||||
, cronRepeat = CronRepeatNever
|
||||
, cronRateLimit = appNotificationRateLimit
|
||||
, cronNotAfter = Left appNotificationExpiration
|
||||
}
|
||||
| otherwise -> mempty
|
||||
|
||||
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ sheetJobs
|
||||
|
||||
-- | Partial function: Submission must not have Nothing at ratingBy
|
||||
collateSubmissions :: [Entity Submission] -> Map UserId (Max (Maybe UTCTime))
|
||||
collateSubmissions = Map.fromListWith (<>) . fmap procCorrector
|
||||
where
|
||||
procCorrector :: Entity Submission -> (UserId ,Max (Maybe UTCTime))
|
||||
procCorrector = (,) <$> fromJust . submissionRatingBy . entityVal
|
||||
<*> Max . submissionRatingAssigned . entityVal
|
||||
|
||||
let
|
||||
correctorNotifications :: Map (UserId, SheetId) (Max UTCTime) -> WriterT (Crontab JobCtl) DB ()
|
||||
correctorNotifications = (tell .) . Map.foldMapWithKey $ \(nUser, nSheet) (Max time) -> HashMap.singleton
|
||||
(JobCtlQueue $ JobQueueNotification NotificationCorrectionsAssigned { nUser, nSheet } )
|
||||
Cron
|
||||
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appNotificationCollateDelay time
|
||||
, cronRepeat = CronRepeatNever
|
||||
, cronRateLimit = appNotificationRateLimit
|
||||
, cronNotAfter = Left appNotificationExpiration
|
||||
}
|
||||
|
||||
submissionsByCorrector :: Entity Submission -> Map (UserId, SheetId) (Max UTCTime)
|
||||
submissionsByCorrector (Entity _ sub)
|
||||
| Just ratingBy <- submissionRatingBy sub
|
||||
, Just assigned <- submissionRatingAssigned sub
|
||||
, not $ submissionRatingDone sub
|
||||
= Map.singleton (ratingBy, submissionSheet sub) $ Max assigned
|
||||
| otherwise
|
||||
= Map.empty
|
||||
|
||||
collateSubmissionsByCorrector acc entity = Map.unionWith (<>) acc $ submissionsByCorrector entity
|
||||
correctorNotifications <=< runConduit $
|
||||
transPipe lift ( selectSource [ SubmissionRatingBy !=. Nothing, SubmissionRatingAssigned !=. Nothing ] []
|
||||
)
|
||||
.| C.fold collateSubmissionsByCorrector Map.empty
|
||||
|
||||
@ -28,18 +28,13 @@ import qualified Network.HaskellNet.SMTP as SMTP
|
||||
import Data.Pool (withResource)
|
||||
|
||||
|
||||
generateHealthReport :: Handler HealthReport
|
||||
generateHealthReport
|
||||
= runConcurrently $ HealthReport
|
||||
<$> Concurrently matchingClusterConfig
|
||||
<*> Concurrently httpReachable
|
||||
<*> Concurrently ldapAdmins
|
||||
<*> Concurrently smtpConnect
|
||||
<*> Concurrently widgetMemcached
|
||||
generateHealthReport :: HealthCheck -> Handler HealthReport
|
||||
generateHealthReport = $(dispatchTH ''HealthCheck)
|
||||
|
||||
matchingClusterConfig :: Handler Bool
|
||||
dispatchHealthCheckMatchingClusterConfig :: Handler HealthReport
|
||||
-- ^ Can the cluster configuration be read from the database and does it match our configuration?
|
||||
matchingClusterConfig = runDB $ and <$> forM universeF clusterSettingMatches
|
||||
dispatchHealthCheckMatchingClusterConfig
|
||||
= fmap HealthMatchingClusterConfig . runDB $ and <$> forM universeF clusterSettingMatches
|
||||
where
|
||||
clusterSettingMatches ClusterCryptoIDKey = do
|
||||
ourSetting <- getsYesod appCryptoIDKey
|
||||
@ -74,11 +69,11 @@ matchingClusterConfig = runDB $ and <$> forM universeF clusterSettingMatches
|
||||
_other -> return Nothing
|
||||
|
||||
|
||||
httpReachable :: Handler (Maybe Bool)
|
||||
httpReachable = do
|
||||
dispatchHealthCheckHTTPReachable :: Handler HealthReport
|
||||
dispatchHealthCheckHTTPReachable = HealthHTTPReachable <$> do
|
||||
staticAppRoot <- getsYesod $ view _appRoot
|
||||
doHTTP <- getsYesod $ view _appHealthCheckHTTP
|
||||
for (staticAppRoot <* guard doHTTP) $ \_textAppRoot -> do
|
||||
for (staticAppRoot <* guard doHTTP) $ \_ -> do
|
||||
url <- getUrlRender <*> pure InstanceR
|
||||
baseRequest <- HTTP.parseRequest $ unpack url
|
||||
httpManager <- getsYesod appHttpManager
|
||||
@ -88,8 +83,8 @@ httpReachable = do
|
||||
getsYesod $ (== clusterId) . appClusterID
|
||||
|
||||
|
||||
ldapAdmins :: Handler (Maybe Rational)
|
||||
ldapAdmins = do
|
||||
dispatchHealthCheckLDAPAdmins :: Handler HealthReport
|
||||
dispatchHealthCheckLDAPAdmins = HealthLDAPAdmins <$> do
|
||||
ldapPool' <- getsYesod appLdapPool
|
||||
ldapConf' <- getsYesod $ view _appLdapConf
|
||||
ldapAdminUsers <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
|
||||
@ -109,8 +104,8 @@ ldapAdmins = do
|
||||
_other -> return Nothing
|
||||
|
||||
|
||||
smtpConnect :: Handler (Maybe Bool)
|
||||
smtpConnect = do
|
||||
dispatchHealthCheckSMTPConnect :: Handler HealthReport
|
||||
dispatchHealthCheckSMTPConnect = HealthSMTPConnect <$> do
|
||||
smtpPool <- getsYesod appSmtpPool
|
||||
for smtpPool . flip withResource $ \smtpConn -> do
|
||||
response@(rCode, _) <- liftIO $ SMTP.sendCommand smtpConn SMTP.NOOP
|
||||
@ -121,8 +116,8 @@ smtpConnect = do
|
||||
return False
|
||||
|
||||
|
||||
widgetMemcached :: Handler (Maybe Bool)
|
||||
widgetMemcached = do
|
||||
dispatchHealthCheckWidgetMemcached :: Handler HealthReport
|
||||
dispatchHealthCheckWidgetMemcached = HealthWidgetMemcached <$> do
|
||||
memcachedConn <- getsYesod appWidgetMemcached
|
||||
for memcachedConn $ \_memcachedConn' -> do
|
||||
let ext = "bin"
|
||||
|
||||
@ -69,7 +69,7 @@ data JobCtl = JobCtlFlush
|
||||
| JobCtlPerform QueuedJobId
|
||||
| JobCtlDetermineCrontab
|
||||
| JobCtlQueue Job
|
||||
| JobCtlGenerateHealthReport
|
||||
| JobCtlGenerateHealthReport HealthCheck
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Hashable JobCtl
|
||||
|
||||
@ -35,7 +35,9 @@ module Mail
|
||||
, _partType, _partEncoding, _partFilename, _partHeaders, _partContent
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender)
|
||||
import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON)
|
||||
|
||||
import Model.Types.TH.JSON
|
||||
|
||||
import Network.Mail.Mime hiding (addPart, addAttachment)
|
||||
import qualified Network.Mail.Mime as Mime (addPart)
|
||||
@ -159,6 +161,7 @@ instance Default MailLanguages where
|
||||
|
||||
instance Hashable MailLanguages
|
||||
|
||||
|
||||
data MailContext = MailContext
|
||||
{ mcLanguages :: MailLanguages
|
||||
, mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat
|
||||
@ -506,3 +509,6 @@ setMailSmtpData = do
|
||||
in tell $ mempty { smtpEnvelopeFrom = Last $ Just verp }
|
||||
| otherwise
|
||||
-> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }
|
||||
|
||||
|
||||
derivePersistFieldJSON ''MailLanguages
|
||||
|
||||
@ -6,7 +6,7 @@ module Model
|
||||
, module Cron.Types
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Import.NoModel
|
||||
import Database.Persist.Quasi
|
||||
import Database.Persist.TH.Directory
|
||||
-- import Data.Time
|
||||
@ -23,8 +23,6 @@ import Utils.Message (MessageStatus)
|
||||
|
||||
import Settings.Cluster (ClusterSettingsKey)
|
||||
|
||||
import Data.Binary (Binary)
|
||||
|
||||
-- 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:
|
||||
@ -38,9 +36,5 @@ deriving instance Eq (Unique Sheet) -- instance Eq CourseSheet
|
||||
deriving instance Eq (Unique Material) -- instance Eq UniqueMaterial
|
||||
deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial
|
||||
|
||||
-- Primary keys mentioned in dbtable row-keys must be Binary
|
||||
-- Automatically generated (i.e. numeric) ids are already taken care of
|
||||
deriving instance Binary (Key Term)
|
||||
|
||||
submissionRatingDone :: Submission -> Bool
|
||||
submissionRatingDone Submission{..} = isJust submissionRatingTime
|
||||
|
||||
@ -79,7 +79,7 @@ migrateAll = do
|
||||
|
||||
requiresMigration :: forall m. (MonadLogger m, MonadBaseControl IO m, MonadIO m) => ReaderT SqlBackend m Bool
|
||||
requiresMigration = mapReaderT (exceptT return return) $ do
|
||||
initial <- getMigration initialMigration
|
||||
initial <- either id (map snd) <$> parseMigration initialMigration
|
||||
when (not $ null initial) $ do
|
||||
$logInfoS "Migration" $ intercalate "; " initial
|
||||
throwError True
|
||||
@ -89,7 +89,7 @@ requiresMigration = mapReaderT (exceptT return return) $ do
|
||||
$logInfoS "Migration" . intercalate ", " . map tshow $ Map.keys customs
|
||||
throwError True
|
||||
|
||||
automatic <- getMigration migrateAll'
|
||||
automatic <- either id (map snd) <$> parseMigration migrateAll'
|
||||
when (not $ null automatic) $ do
|
||||
$logInfoS "Migration" $ intercalate "; " automatic
|
||||
throwError True
|
||||
@ -279,8 +279,8 @@ customMigrations = Map.fromListWith (>>)
|
||||
( Legacy.NoSubmissions , _ ) -> SubmissionMode False Nothing
|
||||
( Legacy.CorrectorSubmissions, _ ) -> SubmissionMode True Nothing
|
||||
( Legacy.UserSubmissions , Legacy.NoUpload ) -> SubmissionMode False (Just NoUpload)
|
||||
( Legacy.UserSubmissions , Legacy.Upload True ) -> SubmissionMode False (Just $ Upload True)
|
||||
( Legacy.UserSubmissions , Legacy.Upload False ) -> SubmissionMode False (Just $ Upload False)
|
||||
( Legacy.UserSubmissions , Legacy.Upload True ) -> SubmissionMode False (Just $ UploadAny True defaultExtensionRestriction)
|
||||
( Legacy.UserSubmissions , Legacy.Upload False ) -> SubmissionMode False (Just $ UploadAny False defaultExtensionRestriction)
|
||||
[executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
|
||||
)
|
||||
, ( AppliedMigrationKey [migrationVersion|11.0.0|] [version|12.0.0|]
|
||||
|
||||
@ -7,7 +7,7 @@ import Data.Aeson.TH (deriveJSON, defaultOptions)
|
||||
import Utils.PathPiece
|
||||
|
||||
import qualified Model as Current
|
||||
import qualified Model.Types.JSON as Current
|
||||
import qualified Model.Types.TH.JSON as Current
|
||||
|
||||
import Data.Universe
|
||||
|
||||
|
||||
@ -7,6 +7,7 @@ data SubmissionSinkException = DuplicateFileTitle FilePath
|
||||
| DuplicateRating
|
||||
| RatingWithoutUpdate
|
||||
| ForeignRating CryptoFileNameSubmission
|
||||
| InvalidFileTitleExtension FilePath
|
||||
deriving (Typeable, Show)
|
||||
|
||||
instance Exception SubmissionSinkException
|
||||
|
||||
1042
src/Model/Types.hs
1042
src/Model/Types.hs
File diff suppressed because it is too large
Load Diff
35
src/Model/Types/Common.hs
Normal file
35
src/Model/Types/Common.hs
Normal file
@ -0,0 +1,35 @@
|
||||
{-|
|
||||
Module: Model.Types.Common
|
||||
Description: Common types used by most @Model.Types.*@-Modules
|
||||
|
||||
Types used by multiple other @Model.Types.*@-Modules
|
||||
-}
|
||||
module Model.Types.Common
|
||||
( module Model.Types.Common
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
|
||||
import qualified Yesod.Auth.Util.PasswordStore as PWStore
|
||||
|
||||
|
||||
type Count = Sum Integer
|
||||
type Points = Centi
|
||||
|
||||
|
||||
type Email = Text
|
||||
|
||||
type SchoolName = CI Text
|
||||
type SchoolShorthand = CI Text
|
||||
type CourseName = CI Text
|
||||
type CourseShorthand = CI Text
|
||||
type SheetName = CI Text
|
||||
type MaterialName = CI Text
|
||||
type UserEmail = CI Email
|
||||
type TutorialName = CI Text
|
||||
|
||||
type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
|
||||
type InstanceId = UUID
|
||||
type ClusterId = UUID
|
||||
type TokenId = UUID
|
||||
type TermCandidateIncidence = UUID
|
||||
26
src/Model/Types/Course.hs
Normal file
26
src/Model/Types/Course.hs
Normal file
@ -0,0 +1,26 @@
|
||||
{-|
|
||||
Module: Model.Types.Course
|
||||
Description: Types for modeling Courses
|
||||
|
||||
Also see `Model.Types.Sheet`
|
||||
-}
|
||||
module Model.Types.Course
|
||||
( module Model.Types.Course
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
|
||||
|
||||
data LecturerType = CourseLecturer | CourseAssistant
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
|
||||
instance Universe LecturerType
|
||||
instance Finite LecturerType
|
||||
|
||||
nullaryPathPiece ''LecturerType $ camelToPathPiece' 1
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
} ''LecturerType
|
||||
derivePersistFieldJSON ''LecturerType
|
||||
|
||||
instance Hashable LecturerType
|
||||
194
src/Model/Types/DateTime.hs
Normal file
194
src/Model/Types/DateTime.hs
Normal file
@ -0,0 +1,194 @@
|
||||
{-|
|
||||
Module: Model.Types.DateTime
|
||||
Description: Time related types
|
||||
|
||||
Terms, Seasons, and Occurence schedules
|
||||
-}
|
||||
module Model.Types.DateTime
|
||||
( module Model.Types.DateTime
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
import Control.Lens
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Text.Read (readMaybe)
|
||||
|
||||
import Database.Persist.Sql
|
||||
|
||||
import Web.HttpApiData
|
||||
|
||||
import Data.Aeson.Types as Aeson
|
||||
|
||||
import Time.Types (WeekDay(..))
|
||||
import Data.Time.LocalTime (LocalTime, TimeOfDay)
|
||||
|
||||
|
||||
----
|
||||
-- Terms, Seaons, anything loosely related to time
|
||||
|
||||
data Season = Summer | Winter
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable)
|
||||
|
||||
instance Binary Season
|
||||
|
||||
seasonToChar :: Season -> Char
|
||||
seasonToChar Summer = 'S'
|
||||
seasonToChar Winter = 'W'
|
||||
|
||||
seasonFromChar :: Char -> Either Text Season
|
||||
seasonFromChar c
|
||||
| c ~= 'S' = Right Summer
|
||||
| c ~= 'W' = Right Winter
|
||||
| otherwise = Left $ "Invalid season character: ‘" <> tshow c <> "’"
|
||||
where
|
||||
(~=) = (==) `on` CI.mk
|
||||
|
||||
-- instance DisplayAble Season
|
||||
|
||||
data TermIdentifier = TermIdentifier
|
||||
{ year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
|
||||
, season :: Season
|
||||
} deriving (Show, Read, Eq, Ord, Generic, Typeable)
|
||||
|
||||
instance Binary TermIdentifier
|
||||
|
||||
instance Enum TermIdentifier where
|
||||
-- ^ Do not use for conversion – Enumeration only
|
||||
toEnum int = let (toInteger -> year, toEnum -> season) = int `divMod` 2 in TermIdentifier{..}
|
||||
fromEnum TermIdentifier{..} = fromInteger year * 2 + fromEnum season
|
||||
|
||||
-- Conversion TermId <-> TermIdentifier::
|
||||
-- from_TermId_to_TermIdentifier = unTermKey
|
||||
-- from_TermIdentifier_to_TermId = TermKey
|
||||
|
||||
shortened :: Iso' Integer Integer
|
||||
-- ^ Year numbers shortened to two digits
|
||||
shortened = iso shorten expand
|
||||
where
|
||||
century = ($currentYear `div` 100) * 100
|
||||
expand year
|
||||
| 0 <= year
|
||||
, year < 100 = let
|
||||
options = [ expanded | offset <- [-1, 0, 1]
|
||||
, let century' = century + offset * 100
|
||||
expanded = century' + year
|
||||
, $currentYear - 50 <= expanded
|
||||
, expanded < $currentYear + 50
|
||||
]
|
||||
in case options of
|
||||
[unique] -> unique
|
||||
failed -> error $ "Could not expand year " ++ show year ++ ": " ++ show failed
|
||||
| otherwise = year
|
||||
shorten year
|
||||
| $currentYear - 50 <= year
|
||||
, year < $currentYear + 50 = year `mod` 100
|
||||
| otherwise = year
|
||||
|
||||
termToText :: TermIdentifier -> Text
|
||||
termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)
|
||||
|
||||
-- also see Hander.Utils.tidFromText
|
||||
termFromText :: Text -> Either Text TermIdentifier
|
||||
termFromText t
|
||||
| (s:ys) <- Text.unpack t
|
||||
, Just (review shortened -> year) <- readMaybe ys
|
||||
, Right season <- seasonFromChar s
|
||||
= Right TermIdentifier{..}
|
||||
| otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" -- TODO: Could be improved, I.e. say "W"/"S" from Number
|
||||
|
||||
termToRational :: TermIdentifier -> Rational
|
||||
termToRational TermIdentifier{..} = fromInteger year + seasonOffset
|
||||
where
|
||||
seasonOffset
|
||||
| Summer <- season = 0
|
||||
| Winter <- season = 0.5
|
||||
|
||||
termFromRational :: Rational -> TermIdentifier
|
||||
termFromRational n = TermIdentifier{..}
|
||||
where
|
||||
year = floor n
|
||||
remainder = n - fromInteger (floor n)
|
||||
season
|
||||
| remainder == 0 = Summer
|
||||
| otherwise = Winter
|
||||
|
||||
instance PersistField TermIdentifier where
|
||||
toPersistValue = PersistRational . termToRational
|
||||
fromPersistValue (PersistRational t) = Right $ termFromRational t
|
||||
fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x
|
||||
|
||||
instance PersistFieldSql TermIdentifier where
|
||||
sqlType _ = SqlNumeric 5 1
|
||||
|
||||
instance ToHttpApiData TermIdentifier where
|
||||
toUrlPiece = termToText
|
||||
|
||||
instance FromHttpApiData TermIdentifier where
|
||||
parseUrlPiece = termFromText
|
||||
|
||||
instance PathPiece TermIdentifier where
|
||||
fromPathPiece = either (const Nothing) Just . termFromText
|
||||
toPathPiece = termToText
|
||||
|
||||
instance ToJSON TermIdentifier where
|
||||
toJSON = Aeson.String . termToText
|
||||
|
||||
instance FromJSON TermIdentifier where
|
||||
parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
|
||||
|
||||
{- Must be defined in a later module:
|
||||
termField :: Field (HandlerT UniWorX IO) TermIdentifier
|
||||
termField = checkMMap (return . termFromText) termToText textField
|
||||
See Handler.Utils.Form.termsField and termActiveField
|
||||
-}
|
||||
|
||||
|
||||
withinTerm :: Day -> TermIdentifier -> Bool
|
||||
time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
|
||||
where
|
||||
timeYear = fst3 $ toGregorian time
|
||||
termYear = year term
|
||||
|
||||
|
||||
data OccurenceSchedule = ScheduleWeekly
|
||||
{ scheduleDayOfWeek :: WeekDay
|
||||
, scheduleStart :: TimeOfDay
|
||||
, scheduleEnd :: TimeOfDay
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
, constructorTagModifier = camelToPathPiece' 1
|
||||
, tagSingleConstructors = True
|
||||
, sumEncoding = TaggedObject "repeat" "schedule"
|
||||
} ''OccurenceSchedule
|
||||
|
||||
data OccurenceException = ExceptOccur
|
||||
{ exceptDay :: Day
|
||||
, exceptStart :: TimeOfDay
|
||||
, exceptEnd :: TimeOfDay
|
||||
}
|
||||
| ExceptNoOccur
|
||||
{ exceptTime :: LocalTime
|
||||
}
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
, constructorTagModifier = camelToPathPiece' 1
|
||||
, sumEncoding = TaggedObject "exception" "for"
|
||||
} ''OccurenceException
|
||||
|
||||
data Occurences = Occurences
|
||||
{ occurencesScheduled :: Set OccurenceSchedule
|
||||
, occurencesExceptions :: Set OccurenceException
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 1
|
||||
} ''Occurences
|
||||
derivePersistFieldJSON ''Occurences
|
||||
|
||||
47
src/Model/Types/Exam.hs
Normal file
47
src/Model/Types/Exam.hs
Normal file
@ -0,0 +1,47 @@
|
||||
{-|
|
||||
Module: Model.Types.Exam
|
||||
Description: Types for modeling Exams
|
||||
-}
|
||||
module Model.Types.Exam
|
||||
( module Model.Types.Exam
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
import Model.Types.Common
|
||||
|
||||
data ExamPartResult = ExamAttended { examPartResult :: Maybe Points }
|
||||
| ExamNoShow
|
||||
| ExamVoided
|
||||
deriving (Show, Read, Eq, Ord, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
, fieldLabelModifier = camelToPathPiece' 2
|
||||
, omitNothingFields = True
|
||||
, sumEncoding = TaggedObject "status" "result"
|
||||
} ''ExamPartResult
|
||||
derivePersistFieldJSON ''ExamPartResult
|
||||
|
||||
data ExamBonusRule = ExamNoBonus
|
||||
| ExamBonusPoints
|
||||
{ bonusExchangeRate :: Rational
|
||||
, bonusOnlyPassed :: Bool
|
||||
}
|
||||
deriving (Show, Read, Eq, Ord, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
, fieldLabelModifier = camelToPathPiece' 1
|
||||
, sumEncoding = TaggedObject "rule" "settings"
|
||||
} ''ExamBonusRule
|
||||
derivePersistFieldJSON ''ExamBonusRule
|
||||
|
||||
data ExamOccurenceRule = ExamRoomManual
|
||||
| ExamRoomSurname
|
||||
| ExamRoomMatriculation
|
||||
| ExamRoomRandom
|
||||
deriving (Show, Read, Eq, Ord, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 2
|
||||
, fieldLabelModifier = camelToPathPiece' 1
|
||||
, sumEncoding = TaggedObject "rule" "settings"
|
||||
} ''ExamOccurenceRule
|
||||
derivePersistFieldJSON ''ExamOccurenceRule
|
||||
87
src/Model/Types/Health.hs
Normal file
87
src/Model/Types/Health.hs
Normal file
@ -0,0 +1,87 @@
|
||||
{-|
|
||||
Module: Model.Types.Health
|
||||
Description: Types for running self-tests
|
||||
-}
|
||||
module Model.Types.Health
|
||||
( module Model.Types.Health
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
|
||||
|
||||
data HealthCheck
|
||||
= HealthCheckMatchingClusterConfig
|
||||
| HealthCheckHTTPReachable
|
||||
| HealthCheckLDAPAdmins
|
||||
| HealthCheckSMTPConnect
|
||||
| HealthCheckWidgetMemcached
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
instance Universe HealthCheck
|
||||
instance Finite HealthCheck
|
||||
instance Hashable HealthCheck
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 2
|
||||
} ''HealthCheck
|
||||
nullaryPathPiece ''HealthCheck $ camelToPathPiece' 2
|
||||
pathPieceJSONKey ''HealthCheck
|
||||
|
||||
data HealthReport
|
||||
= HealthMatchingClusterConfig { healthMatchingClusterConfig :: Bool }
|
||||
-- ^ Is the database-stored configuration we're running under still up to date?
|
||||
--
|
||||
-- Also tests database connection as a side effect
|
||||
| HealthHTTPReachable { healthHTTPReachable :: Maybe Bool }
|
||||
-- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP?
|
||||
| HealthLDAPAdmins { healthLDAPAdmins :: Maybe Rational }
|
||||
-- ^ Proportion of school admins that could be found in LDAP
|
||||
| HealthSMTPConnect { healthSMTPConnect :: Maybe Bool }
|
||||
-- ^ Can we connect to the SMTP server and say @NOOP@?
|
||||
| HealthWidgetMemcached { healthWidgetMemcached :: Maybe Bool }
|
||||
-- ^ Can we store values in memcached and retrieve them via HTTP?
|
||||
deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
|
||||
|
||||
instance NFData HealthReport
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
, fieldLabelModifier = camelToPathPiece' 1
|
||||
, omitNothingFields = True
|
||||
, sumEncoding = TaggedObject "test" "result"
|
||||
, tagSingleConstructors = True
|
||||
} ''HealthReport
|
||||
|
||||
classifyHealthReport :: HealthReport -> HealthCheck
|
||||
classifyHealthReport HealthMatchingClusterConfig{} = HealthCheckMatchingClusterConfig
|
||||
classifyHealthReport HealthLDAPAdmins{} = HealthCheckLDAPAdmins
|
||||
classifyHealthReport HealthHTTPReachable{} = HealthCheckHTTPReachable
|
||||
classifyHealthReport HealthSMTPConnect{} = HealthCheckSMTPConnect
|
||||
classifyHealthReport HealthWidgetMemcached{} = HealthCheckWidgetMemcached
|
||||
|
||||
-- | `HealthReport` classified (`classifyHealthReport`) by badness
|
||||
--
|
||||
-- > a < b = a `worseThan` b
|
||||
--
|
||||
-- Currently all consumers of this type check for @(== HealthSuccess)@; this
|
||||
-- needs to be adjusted on a case-by-case basis if new constructors are added
|
||||
data HealthStatus = HealthFailure | HealthSuccess
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
|
||||
instance Universe HealthStatus
|
||||
instance Finite HealthStatus
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
} ''HealthStatus
|
||||
nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1
|
||||
|
||||
healthReportStatus :: HealthReport -> HealthStatus
|
||||
-- ^ Classify `HealthReport` by badness
|
||||
healthReportStatus = \case
|
||||
HealthMatchingClusterConfig False -> HealthFailure
|
||||
HealthHTTPReachable (Just False) -> HealthFailure
|
||||
HealthLDAPAdmins (Just prop )
|
||||
| prop <= 0 -> HealthFailure
|
||||
HealthSMTPConnect (Just False) -> HealthFailure
|
||||
HealthWidgetMemcached (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully?
|
||||
_other -> maxBound -- Minimum badness
|
||||
75
src/Model/Types/Mail.hs
Normal file
75
src/Model/Types/Mail.hs
Normal file
@ -0,0 +1,75 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
{-|
|
||||
Module: Model.Types.Mail
|
||||
Description: Types related to Notifications
|
||||
-}
|
||||
|
||||
module Model.Types.Mail
|
||||
( module Model.Types.Mail
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
|
||||
-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
|
||||
--
|
||||
-- Could maybe be replaced with `Structure Notification` in the long term
|
||||
data NotificationTrigger
|
||||
= NTSubmissionRatedGraded
|
||||
| NTSubmissionRated
|
||||
| NTSheetActive
|
||||
| NTSheetSoonInactive
|
||||
| NTSheetInactive
|
||||
| NTCorrectionsAssigned
|
||||
| NTCorrectionsNotDistributed
|
||||
| NTUserRightsUpdate
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
|
||||
instance Universe NotificationTrigger
|
||||
instance Finite NotificationTrigger
|
||||
|
||||
instance Hashable NotificationTrigger
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||||
} ''NotificationTrigger
|
||||
|
||||
instance ToJSONKey NotificationTrigger where
|
||||
toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
|
||||
|
||||
instance FromJSONKey NotificationTrigger where
|
||||
fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
|
||||
|
||||
|
||||
newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool }
|
||||
deriving (Generic, Typeable)
|
||||
deriving newtype (Eq, Ord, Read, Show)
|
||||
|
||||
instance Default NotificationSettings where
|
||||
def = NotificationSettings $ \case
|
||||
NTSubmissionRatedGraded -> True
|
||||
NTSubmissionRated -> False
|
||||
NTSheetActive -> True
|
||||
NTSheetSoonInactive -> False
|
||||
NTSheetInactive -> True
|
||||
NTCorrectionsAssigned -> True
|
||||
NTCorrectionsNotDistributed -> True
|
||||
NTUserRightsUpdate -> True
|
||||
|
||||
instance ToJSON NotificationSettings where
|
||||
toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
|
||||
|
||||
instance FromJSON NotificationSettings where
|
||||
parseJSON = Aeson.withObject "NotificationSettings" $ \o -> do
|
||||
o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool)
|
||||
return . NotificationSettings $ \n -> case HashMap.lookup n o' of
|
||||
Nothing -> notificationAllowed def n
|
||||
Just b -> b
|
||||
|
||||
derivePersistFieldJSON ''NotificationSettings
|
||||
44
src/Model/Types/Misc.hs
Normal file
44
src/Model/Types/Misc.hs
Normal file
@ -0,0 +1,44 @@
|
||||
{-|
|
||||
Module: Model.Types.Misc
|
||||
Description: Additional uncategorized types
|
||||
-}
|
||||
|
||||
module Model.Types.Misc
|
||||
( module Model.Types.Misc
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
import Control.Lens
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Lens as Text
|
||||
|
||||
|
||||
data StudyFieldType = FieldPrimary | FieldSecondary
|
||||
deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic)
|
||||
derivePersistField "StudyFieldType"
|
||||
|
||||
|
||||
data Theme
|
||||
= ThemeDefault
|
||||
| ThemeLavender
|
||||
| ThemeNeutralBlue
|
||||
| ThemeAberdeenReds
|
||||
| ThemeMossGreen
|
||||
| ThemeSkyLove
|
||||
deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = fromJust . stripPrefix "Theme"
|
||||
} ''Theme
|
||||
|
||||
instance Universe Theme
|
||||
instance Finite Theme
|
||||
|
||||
nullaryPathPiece ''Theme $ camelToPathPiece' 1
|
||||
|
||||
$(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user
|
||||
|
||||
derivePersistField "Theme"
|
||||
143
src/Model/Types/Security.hs
Normal file
143
src/Model/Types/Security.hs
Normal file
@ -0,0 +1,143 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
{-|
|
||||
Module: Model.Types.Security
|
||||
Description: Types for authentication and authorisation
|
||||
-}
|
||||
|
||||
module Model.Types.Security
|
||||
( module Model.Types.Security
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
|
||||
import Data.Set (Set)
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
|
||||
import qualified Data.Binary as Binary
|
||||
|
||||
|
||||
data AuthenticationMode = AuthLDAP
|
||||
| AuthPWHash { authPWHash :: Text }
|
||||
deriving (Eq, Ord, Read, Show, Generic)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||||
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
|
||||
, sumEncoding = UntaggedValue
|
||||
} ''AuthenticationMode
|
||||
|
||||
derivePersistFieldJSON ''AuthenticationMode
|
||||
|
||||
|
||||
data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
|
||||
= AuthAdmin
|
||||
| AuthLecturer
|
||||
| AuthCorrector
|
||||
| AuthTutor
|
||||
| AuthCourseRegistered
|
||||
| AuthTutorialRegistered
|
||||
| AuthParticipant
|
||||
| AuthTime
|
||||
| AuthMaterials
|
||||
| AuthOwner
|
||||
| AuthRated
|
||||
| AuthUserSubmissions
|
||||
| AuthCorrectorSubmissions
|
||||
| AuthCapacity
|
||||
| AuthRegisterGroup
|
||||
| AuthEmpty
|
||||
| AuthSelf
|
||||
| AuthAuthentication
|
||||
| AuthNoEscalation
|
||||
| AuthRead
|
||||
| AuthWrite
|
||||
| AuthToken
|
||||
| AuthDeprecated
|
||||
| AuthDevelopment
|
||||
| AuthFree
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Universe AuthTag
|
||||
instance Finite AuthTag
|
||||
instance Hashable AuthTag
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
} ''AuthTag
|
||||
|
||||
nullaryPathPiece ''AuthTag (camelToPathPiece' 1)
|
||||
|
||||
instance ToJSONKey AuthTag where
|
||||
toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
|
||||
|
||||
instance FromJSONKey AuthTag where
|
||||
fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
|
||||
|
||||
instance Binary AuthTag
|
||||
|
||||
|
||||
newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool }
|
||||
deriving (Read, Show, Generic)
|
||||
deriving newtype (Eq, Ord)
|
||||
|
||||
instance Default AuthTagActive where
|
||||
def = AuthTagActive $ \case
|
||||
AuthAdmin -> False
|
||||
_ -> True
|
||||
|
||||
instance ToJSON AuthTagActive where
|
||||
toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF
|
||||
|
||||
instance FromJSON AuthTagActive where
|
||||
parseJSON = Aeson.withObject "AuthTagActive" $ \o -> do
|
||||
o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool)
|
||||
return . AuthTagActive $ \n -> case HashMap.lookup n o' of
|
||||
Nothing -> authTagIsActive def n
|
||||
Just b -> b
|
||||
|
||||
derivePersistFieldJSON ''AuthTagActive
|
||||
|
||||
|
||||
data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
instance Hashable a => Hashable (PredLiteral a)
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
, sumEncoding = TaggedObject "val" "var"
|
||||
} ''PredLiteral
|
||||
|
||||
instance PathPiece a => PathPiece (PredLiteral a) where
|
||||
toPathPiece PLVariable{..} = toPathPiece plVar
|
||||
toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar
|
||||
|
||||
fromPathPiece t = PLVariable <$> fromPathPiece t
|
||||
<|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)
|
||||
|
||||
instance Binary a => Binary (PredLiteral a)
|
||||
|
||||
|
||||
newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
|
||||
$(return [])
|
||||
|
||||
instance ToJSON a => ToJSON (PredDNF a) where
|
||||
toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
|
||||
instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
|
||||
parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
|
||||
|
||||
instance (Ord a, Binary a) => Binary (PredDNF a) where
|
||||
get = PredDNF <$> Binary.get
|
||||
put = Binary.put . dnfTerms
|
||||
|
||||
type AuthLiteral = PredLiteral AuthTag
|
||||
|
||||
type AuthDNF = PredDNF AuthTag
|
||||
307
src/Model/Types/Sheet.hs
Normal file
307
src/Model/Types/Sheet.hs
Normal file
@ -0,0 +1,307 @@
|
||||
{-|
|
||||
Module: Model.Types.Sheet
|
||||
Description: Types for modeling sheets
|
||||
-}
|
||||
|
||||
module Model.Types.Sheet
|
||||
( module Model.Types.Sheet
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
import Model.Types.Common
|
||||
import Utils.Lens.TH
|
||||
|
||||
import Control.Lens
|
||||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
|
||||
|
||||
import Text.Blaze (Markup)
|
||||
|
||||
import Yesod.Core.Dispatch (PathPiece(..))
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
|
||||
data SheetGrading
|
||||
= Points { maxPoints :: Points }
|
||||
| PassPoints { maxPoints, passingPoints :: Points }
|
||||
| PassBinary -- non-zero means passed
|
||||
deriving (Eq, Read, Show, Generic)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece
|
||||
, fieldLabelModifier = intercalate "-" . map toLower . dropEnd 1 . splitCamel
|
||||
, sumEncoding = TaggedObject "type" "data"
|
||||
} ''SheetGrading
|
||||
derivePersistFieldJSON ''SheetGrading
|
||||
|
||||
makeLenses_ ''SheetGrading
|
||||
|
||||
_passingBound :: Fold SheetGrading (Either () Points)
|
||||
_passingBound = folding passPts
|
||||
where
|
||||
passPts :: SheetGrading -> Maybe (Either () Points)
|
||||
passPts Points{} = Nothing
|
||||
passPts PassPoints{passingPoints} = Just $ Right passingPoints
|
||||
passPts PassBinary = Just $ Left ()
|
||||
|
||||
gradingPassed :: SheetGrading -> Points -> Maybe Bool
|
||||
gradingPassed gr pts = either pBinary pPoints <$> gr ^? _passingBound
|
||||
where pBinary _ = pts /= 0
|
||||
pPoints b = pts >= b
|
||||
|
||||
|
||||
data SheetGradeSummary = SheetGradeSummary
|
||||
{ numSheets :: Count -- Total number of sheets, includes all
|
||||
, numSheetsPasses :: Count -- Number of sheets required to pass FKA: numGradePasses
|
||||
, numSheetsPoints :: Count -- Number of sheets having points FKA: sumGradePointsd
|
||||
, sumSheetsPoints :: Sum Points -- Total of all points in all sheets
|
||||
-- Marking dependend
|
||||
, numMarked :: Count -- Number of already marked sheets
|
||||
, numMarkedPasses :: Count -- Number of already marked sheets with passes
|
||||
, numMarkedPoints :: Count -- Number of already marked sheets with points
|
||||
, sumMarkedPoints :: Sum Points -- Achieveable points within marked sheets
|
||||
--
|
||||
, achievedPasses :: Count -- Achieved passes (within marked sheets)
|
||||
, achievedPoints :: Sum Points -- Achieved points (within marked sheets)
|
||||
} deriving (Generic, Read, Show, Eq)
|
||||
|
||||
instance Monoid SheetGradeSummary where
|
||||
mempty = memptydefault
|
||||
mappend = mappenddefault
|
||||
|
||||
instance Semigroup SheetGradeSummary where
|
||||
(<>) = mappend -- TODO: remove for GHC > 8.4.x
|
||||
|
||||
makeLenses_ ''SheetGradeSummary
|
||||
|
||||
sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary
|
||||
sheetGradeSum gr Nothing = mempty
|
||||
{ numSheets = 1
|
||||
, numSheetsPasses = bool mempty 1 $ has _passingBound gr
|
||||
, numSheetsPoints = bool mempty 1 $ has _maxPoints gr
|
||||
, sumSheetsPoints = maybe mempty Sum $ gr ^? _maxPoints
|
||||
}
|
||||
sheetGradeSum gr (Just p) =
|
||||
let unmarked@SheetGradeSummary{..} = sheetGradeSum gr Nothing
|
||||
in unmarked
|
||||
{ numMarked = numSheets
|
||||
, numMarkedPasses = numSheetsPasses
|
||||
, numMarkedPoints = numSheetsPoints
|
||||
, sumMarkedPoints = sumSheetsPoints
|
||||
, achievedPasses = maybe mempty (bool 0 1) (gradingPassed gr p)
|
||||
, achievedPoints = bool mempty (Sum p) $ has _maxPoints gr
|
||||
}
|
||||
|
||||
|
||||
data SheetType
|
||||
= NotGraded
|
||||
| Normal { grading :: SheetGrading }
|
||||
| Bonus { grading :: SheetGrading }
|
||||
| Informational { grading :: SheetGrading }
|
||||
deriving (Eq, Read, Show, Generic)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece
|
||||
, fieldLabelModifier = camelToPathPiece
|
||||
, sumEncoding = TaggedObject "type" "data"
|
||||
} ''SheetType
|
||||
derivePersistFieldJSON ''SheetType
|
||||
|
||||
data SheetTypeSummary = SheetTypeSummary
|
||||
{ normalSummary
|
||||
, bonusSummary
|
||||
, informationalSummary :: SheetGradeSummary
|
||||
, numNotGraded :: Count
|
||||
} deriving (Generic, Read, Show, Eq)
|
||||
|
||||
instance Monoid SheetTypeSummary where
|
||||
mempty = memptydefault
|
||||
mappend = mappenddefault
|
||||
|
||||
instance Semigroup SheetTypeSummary where
|
||||
(<>) = mappend -- TODO: remove for GHC > 8.4.x
|
||||
|
||||
makeLenses_ ''SheetTypeSummary
|
||||
|
||||
sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary
|
||||
sheetTypeSum Bonus{..} mps = mempty { bonusSummary = sheetGradeSum grading mps }
|
||||
sheetTypeSum Normal{..} mps = mempty { normalSummary = sheetGradeSum grading mps }
|
||||
sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps }
|
||||
sheetTypeSum NotGraded _ = mempty { numNotGraded = Sum 1 }
|
||||
|
||||
data SheetGroup
|
||||
= Arbitrary { maxParticipants :: Natural }
|
||||
| RegisteredGroups
|
||||
| NoGroups
|
||||
deriving (Show, Read, Eq, Generic)
|
||||
deriveJSON defaultOptions ''SheetGroup
|
||||
derivePersistFieldJSON ''SheetGroup
|
||||
|
||||
makeLenses_ ''SheetGroup
|
||||
|
||||
data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
|
||||
derivePersistField "SheetFileType"
|
||||
|
||||
instance Universe SheetFileType
|
||||
instance Finite SheetFileType
|
||||
|
||||
instance PathPiece SheetFileType where
|
||||
toPathPiece SheetExercise = "file"
|
||||
toPathPiece SheetHint = "hint"
|
||||
toPathPiece SheetSolution = "solution"
|
||||
toPathPiece SheetMarking = "marking"
|
||||
fromPathPiece = finiteFromPathPiece
|
||||
|
||||
sheetFile2markup :: SheetFileType -> Markup
|
||||
sheetFile2markup SheetExercise = iconQuestion
|
||||
sheetFile2markup SheetHint = iconHint
|
||||
sheetFile2markup SheetSolution = iconSolution
|
||||
sheetFile2markup SheetMarking = iconMarking
|
||||
|
||||
-- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
|
||||
-- instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
|
||||
-- display SheetExercise = "Aufgabenstellung"
|
||||
-- display SheetHint = "Hinweise"
|
||||
-- display SheetSolution = "Musterlösung"
|
||||
-- display SheetMarking = "Korrekturhinweise"
|
||||
|
||||
-- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a)
|
||||
-- partitionFileType' = groupMap
|
||||
|
||||
partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a
|
||||
partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs
|
||||
|
||||
|
||||
data UploadSpecificFile = UploadSpecificFile
|
||||
{ specificFileLabel :: Text
|
||||
, specificFileName :: FileName
|
||||
, specificFileRequired :: Bool
|
||||
} deriving (Show, Read, Eq, Ord, Generic)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 2
|
||||
} ''UploadSpecificFile
|
||||
derivePersistFieldJSON ''UploadSpecificFile
|
||||
|
||||
data UploadMode = NoUpload
|
||||
| UploadAny
|
||||
{ unpackZips :: Bool
|
||||
, extensionRestriction :: Maybe (NonNull (Set Extension))
|
||||
}
|
||||
| UploadSpecific
|
||||
{ specificFiles :: NonNull (Set UploadSpecificFile)
|
||||
}
|
||||
deriving (Show, Read, Eq, Ord, Generic)
|
||||
|
||||
defaultExtensionRestriction :: Maybe (NonNull (Set Extension))
|
||||
defaultExtensionRestriction = fromNullable $ Set.fromList ["txt", "pdf"]
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = \c -> if
|
||||
| c == "UploadAny" -> "upload"
|
||||
| otherwise -> camelToPathPiece c
|
||||
, fieldLabelModifier = camelToPathPiece
|
||||
, sumEncoding = TaggedObject "mode" "settings"
|
||||
, omitNothingFields = True
|
||||
}''UploadMode
|
||||
derivePersistFieldJSON ''UploadMode
|
||||
|
||||
data UploadModeDescr = UploadModeNone
|
||||
| UploadModeAny
|
||||
| UploadModeSpecific
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
instance Universe UploadModeDescr
|
||||
instance Finite UploadModeDescr
|
||||
|
||||
nullaryPathPiece ''UploadModeDescr $ camelToPathPiece' 2
|
||||
|
||||
classifyUploadMode :: UploadMode -> UploadModeDescr
|
||||
classifyUploadMode NoUpload = UploadModeNone
|
||||
classifyUploadMode UploadAny{} = UploadModeAny
|
||||
classifyUploadMode UploadSpecific{} = UploadModeSpecific
|
||||
|
||||
data SubmissionMode = SubmissionMode
|
||||
{ submissionModeCorrector :: Bool
|
||||
, submissionModeUser :: Maybe UploadMode
|
||||
}
|
||||
deriving (Show, Read, Eq, Ord, Generic)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ fieldLabelModifier = camelToPathPiece' 2
|
||||
} ''SubmissionMode
|
||||
derivePersistFieldJSON ''SubmissionMode
|
||||
|
||||
data SubmissionModeDescr = SubmissionModeNone
|
||||
| SubmissionModeCorrector
|
||||
| SubmissionModeUser
|
||||
| SubmissionModeBoth
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
instance Universe SubmissionModeDescr
|
||||
instance Finite SubmissionModeDescr
|
||||
|
||||
finitePathPiece ''SubmissionModeDescr
|
||||
[ "no-submissions"
|
||||
, "correctors"
|
||||
, "users"
|
||||
, "correctors+users"
|
||||
]
|
||||
|
||||
classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr
|
||||
classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone
|
||||
classifySubmissionMode (SubmissionMode True Nothing ) = SubmissionModeCorrector
|
||||
classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser
|
||||
classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth
|
||||
|
||||
|
||||
-- | Specify a corrector's workload
|
||||
data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational }
|
||||
= Load { byTutorial :: Maybe Bool -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload
|
||||
, byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders
|
||||
}
|
||||
deriving (Show, Read, Eq, Ord, Generic)
|
||||
|
||||
deriveJSON defaultOptions ''Load
|
||||
derivePersistFieldJSON ''Load
|
||||
|
||||
instance Hashable Load
|
||||
|
||||
instance Semigroup Load where
|
||||
(Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
|
||||
where
|
||||
byTut''
|
||||
| Nothing <- byTut = byTut'
|
||||
| Nothing <- byTut' = byTut
|
||||
| Just a <- byTut
|
||||
, Just b <- byTut' = Just $ a || b
|
||||
|
||||
instance Monoid Load where
|
||||
mempty = Load Nothing 0
|
||||
mappend = (<>)
|
||||
|
||||
{- Use (is _ByTutorial) instead of this unneeded definition:
|
||||
isByTutorial :: Load -> Bool
|
||||
isByTutorial (ByTutorial {}) = True
|
||||
isByTutorial _ = False
|
||||
-}
|
||||
|
||||
data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = fromJust . stripPrefix "Corrector"
|
||||
} ''CorrectorState
|
||||
|
||||
instance Universe CorrectorState
|
||||
instance Finite CorrectorState
|
||||
|
||||
instance Hashable CorrectorState
|
||||
|
||||
nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
|
||||
|
||||
derivePersistField "CorrectorState"
|
||||
151
src/Model/Types/Submission.hs
Normal file
151
src/Model/Types/Submission.hs
Normal file
@ -0,0 +1,151 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
|
||||
{-|
|
||||
Module: Model.Types.Submission
|
||||
Description: Types to support sheet submissions
|
||||
-}
|
||||
|
||||
module Model.Types.Submission
|
||||
( module Model.Types.Submission
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
|
||||
import Data.Aeson.Types (ToJSON(..), FromJSON(..))
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
|
||||
import Database.Persist.Sql
|
||||
|
||||
import Data.Word.Word24
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
import Data.List (elemIndex, genericIndex)
|
||||
import Data.Bits
|
||||
import Data.Text.Metrics (damerauLevenshtein)
|
||||
|
||||
-------------------------
|
||||
-- Submission Download --
|
||||
-------------------------
|
||||
|
||||
data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
|
||||
|
||||
instance Universe SubmissionFileType
|
||||
instance Finite SubmissionFileType
|
||||
|
||||
nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1
|
||||
|
||||
submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
|
||||
submissionFileTypeIsUpdate SubmissionOriginal = False
|
||||
submissionFileTypeIsUpdate SubmissionCorrected = True
|
||||
|
||||
isUpdateSubmissionFileType :: Bool -> SubmissionFileType
|
||||
isUpdateSubmissionFileType False = SubmissionOriginal
|
||||
isUpdateSubmissionFileType True = SubmissionCorrected
|
||||
|
||||
---------------------------
|
||||
-- Submission Pseudonyms --
|
||||
---------------------------
|
||||
|
||||
type PseudonymWord = CI Text
|
||||
|
||||
newtype Pseudonym = Pseudonym Word24
|
||||
deriving (Eq, Ord, Read, Show, Generic, Data)
|
||||
deriving newtype (Bounded, Enum, Integral, Num, Real, Ix)
|
||||
|
||||
|
||||
instance PersistField Pseudonym where
|
||||
toPersistValue p = toPersistValue (fromIntegral p :: Word32)
|
||||
fromPersistValue v = do
|
||||
w <- fromPersistValue v :: Either Text Word32
|
||||
if
|
||||
| 0 <= w
|
||||
, w <= fromIntegral (maxBound :: Pseudonym)
|
||||
-> return $ fromIntegral w
|
||||
| otherwise
|
||||
-> Left "Pseudonym out of range"
|
||||
|
||||
instance PersistFieldSql Pseudonym where
|
||||
sqlType _ = SqlInt32
|
||||
|
||||
instance Random Pseudonym where
|
||||
randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen
|
||||
random = randomR (minBound, maxBound)
|
||||
|
||||
instance FromJSON Pseudonym where
|
||||
parseJSON v@(Aeson.Number _) = do
|
||||
w <- parseJSON v :: Aeson.Parser Word32
|
||||
if
|
||||
| 0 <= w
|
||||
, w <= fromIntegral (maxBound :: Pseudonym)
|
||||
-> return $ fromIntegral w
|
||||
| otherwise
|
||||
-> fail "Pseudonym out auf range"
|
||||
parseJSON (Aeson.String t)
|
||||
= case t ^? _PseudonymText of
|
||||
Just p -> return p
|
||||
Nothing -> fail "Could not parse pseudonym"
|
||||
parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do
|
||||
ws' <- toList . map CI.mk <$> mapM parseJSON ws
|
||||
case ws' ^? _PseudonymWords of
|
||||
Just p -> return p
|
||||
Nothing -> fail "Could not parse pseudonym words"
|
||||
|
||||
instance ToJSON Pseudonym where
|
||||
toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord])
|
||||
|
||||
pseudonymWordlist :: [PseudonymWord]
|
||||
pseudonymCharacters :: Set (CI Char)
|
||||
(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt")
|
||||
|
||||
_PseudonymWords :: Prism' [PseudonymWord] Pseudonym
|
||||
_PseudonymWords = prism' pToWords pFromWords
|
||||
where
|
||||
pFromWords :: [PseudonymWord] -> Maybe Pseudonym
|
||||
pFromWords [w1, w2]
|
||||
| Just i1 <- elemIndex w1 pseudonymWordlist
|
||||
, Just i2 <- elemIndex w2 pseudonymWordlist
|
||||
, i1 <= maxWord, i2 <= maxWord
|
||||
= Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2
|
||||
pFromWords _ = Nothing
|
||||
|
||||
pToWords :: Pseudonym -> [PseudonymWord]
|
||||
pToWords (Pseudonym p)
|
||||
= [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord
|
||||
, genericIndex pseudonymWordlist $ p .&. maxWord
|
||||
]
|
||||
|
||||
maxWord :: Num a => a
|
||||
maxWord = 0b111111111111
|
||||
|
||||
_PseudonymText :: Prism' Text Pseudonym
|
||||
_PseudonymText = prism' tToWords tFromWords . _PseudonymWords
|
||||
where
|
||||
tFromWords :: Text -> Maybe [PseudonymWord]
|
||||
tFromWords input
|
||||
| [result] <- input ^.. pseudonymFragments
|
||||
= Just result
|
||||
| otherwise
|
||||
= Nothing
|
||||
|
||||
tToWords :: [PseudonymWord] -> Text
|
||||
tToWords = Text.unwords . map CI.original
|
||||
|
||||
pseudonymWords :: Fold Text PseudonymWord
|
||||
pseudonymWords = folding
|
||||
$ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist
|
||||
where
|
||||
distance = damerauLevenshtein `on` CI.foldedCase
|
||||
-- | Arbitrary cutoff point, for reference: ispell cuts off at 1
|
||||
distanceCutoff = 2
|
||||
|
||||
pseudonymFragments :: Fold Text [PseudonymWord]
|
||||
pseudonymFragments = folding
|
||||
$ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters)
|
||||
@ -1,4 +1,4 @@
|
||||
module Model.Types.JSON
|
||||
module Model.Types.TH.JSON
|
||||
( derivePersistFieldJSON
|
||||
, predNFAesonOptions
|
||||
) where
|
||||
@ -1,4 +1,6 @@
|
||||
module Model.Types.Wordlist (wordlist) where
|
||||
module Model.Types.TH.Wordlist
|
||||
( wordlist
|
||||
) where
|
||||
|
||||
import ClassyPrelude hiding (lift)
|
||||
|
||||
@ -1,11 +1,12 @@
|
||||
module Network.Mime.TH
|
||||
( mimeMapFile
|
||||
( mimeMapFile, mimeSetFile
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (lift)
|
||||
import Language.Haskell.TH hiding (Extension)
|
||||
import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..))
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.Text (Text)
|
||||
@ -18,7 +19,7 @@ import Network.Mime
|
||||
import Instances.TH.Lift ()
|
||||
|
||||
|
||||
mimeMapFile :: FilePath -> ExpQ
|
||||
mimeMapFile, mimeSetFile :: FilePath -> ExpQ
|
||||
mimeMapFile file = do
|
||||
qAddDependentFile file
|
||||
|
||||
@ -36,6 +37,15 @@ mimeMapFile file = do
|
||||
|
||||
|
||||
lift mimeMap
|
||||
mimeSetFile file = do
|
||||
qAddDependentFile file
|
||||
|
||||
ls <- runIO $ filter (not . isComment) . Text.lines <$> Text.readFile file
|
||||
|
||||
let mimeSet :: Set MimeType
|
||||
mimeSet = Set.fromList $ map (encodeUtf8 . Text.strip) ls
|
||||
|
||||
lift mimeSet
|
||||
|
||||
isComment :: Text -> Bool
|
||||
isComment line = or
|
||||
|
||||
@ -10,14 +10,13 @@ module Settings
|
||||
, module Settings.Cluster
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Import.NoModel
|
||||
import Data.UUID (UUID)
|
||||
import qualified Control.Exception as Exception
|
||||
import Data.Aeson (Result (..), fromJSON, withObject
|
||||
import Data.Aeson (fromJSON, withObject
|
||||
,(.!=), (.:?), withScientific
|
||||
)
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import Data.Aeson.TH
|
||||
import Data.FileEmbed (embedFile)
|
||||
import Data.Yaml (decodeEither')
|
||||
import Database.Persist.Postgresql (PostgresConf)
|
||||
@ -45,7 +44,6 @@ import qualified Data.Text.Encoding as Text
|
||||
|
||||
import qualified Ldap.Client as Ldap
|
||||
|
||||
import Utils hiding (MessageStatus(..))
|
||||
import Control.Lens
|
||||
|
||||
import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
|
||||
@ -70,9 +68,11 @@ import Jose.Jwt (JwtEncoding(..))
|
||||
|
||||
import System.FilePath.Glob
|
||||
import Handler.Utils.Submission.TH
|
||||
import Network.Mime
|
||||
import Network.Mime.TH
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
-- | Runtime settings to configure this application. These settings can be
|
||||
-- loaded from various sources: defaults, environment variables, config files,
|
||||
@ -115,9 +115,9 @@ data AppSettings = AppSettings
|
||||
, appJwtExpiration :: Maybe NominalDiffTime
|
||||
, appJwtEncoding :: JwtEncoding
|
||||
|
||||
, appHealthCheckInterval :: NominalDiffTime
|
||||
, appHealthCheckHTTP :: Bool
|
||||
, appHealthCheckInterval :: HealthCheck -> Maybe NominalDiffTime
|
||||
, appHealthCheckDelayNotify :: Bool
|
||||
, appHealthCheckHTTP :: Bool
|
||||
|
||||
, appInitialLogSettings :: LogSettings
|
||||
|
||||
@ -386,9 +386,9 @@ instance FromJSON AppSettings where
|
||||
appJwtExpiration <- o .:? "jwt-expiration"
|
||||
appJwtEncoding <- o .: "jwt-encoding"
|
||||
|
||||
appHealthCheckInterval <- o .: "health-check-interval"
|
||||
appHealthCheckHTTP <- o .: "health-check-http"
|
||||
appHealthCheckInterval <- (assertM' (> 0) . ) <$> o .: "health-check-interval"
|
||||
appHealthCheckDelayNotify <- o .: "health-check-delay-notify"
|
||||
appHealthCheckHTTP <- o .: "health-check-http"
|
||||
|
||||
appSessionTimeout <- o .: "session-timeout"
|
||||
|
||||
@ -431,8 +431,17 @@ widgetFileSettings = def
|
||||
submissionBlacklist :: [Pattern]
|
||||
submissionBlacklist = $(patternFile compDefault "config/submission-blacklist")
|
||||
|
||||
mimeMap :: MimeMap
|
||||
mimeMap = $(mimeMapFile "config/mimetypes")
|
||||
|
||||
mimeLookup :: FileName -> MimeType
|
||||
mimeLookup = mimeByExt $(mimeMapFile "config/mimetypes") defaultMimeType
|
||||
mimeLookup = mimeByExt mimeMap defaultMimeType
|
||||
|
||||
mimeExtensions :: MimeType -> Set Extension
|
||||
mimeExtensions needle = Set.fromList [ ext | (ext, typ) <- Map.toList mimeMap, typ == needle ]
|
||||
|
||||
archiveTypes :: Set MimeType
|
||||
archiveTypes = $(mimeSetFile "config/archive-types")
|
||||
|
||||
-- The rest of this file contains settings which rarely need changing by a
|
||||
-- user.
|
||||
@ -471,5 +480,5 @@ configSettingsYmlValue = either Exception.throw id
|
||||
compileTimeAppSettings :: AppSettings
|
||||
compileTimeAppSettings =
|
||||
case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
|
||||
Error e -> error e
|
||||
Success settings -> settings
|
||||
Aeson.Error e -> error e
|
||||
Aeson.Success settings -> settings
|
||||
|
||||
16
src/System/FilePath/Instances.hs
Normal file
16
src/System/FilePath/Instances.hs
Normal file
@ -0,0 +1,16 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module System.FilePath.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Web.PathPieces
|
||||
|
||||
|
||||
instance {-# OVERLAPS #-} PathMultiPiece FilePath where
|
||||
fromPathMultiPiece = Just . unpack . intercalate "/"
|
||||
toPathMultiPiece = Text.splitOn "/" . pack
|
||||
@ -12,8 +12,14 @@ import Data.Universe
|
||||
|
||||
import Utils.PathPiece
|
||||
|
||||
import Data.Aeson.TH
|
||||
|
||||
|
||||
instance Universe WeekDay
|
||||
instance Finite WeekDay
|
||||
|
||||
nullaryPathPiece ''WeekDay camelToPathPiece
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece
|
||||
} ''WeekDay
|
||||
|
||||
101
src/Utils.hs
101
src/Utils.hs
@ -1,5 +1,3 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult
|
||||
|
||||
module Utils
|
||||
( module Utils
|
||||
) where
|
||||
@ -30,7 +28,7 @@ import Utils.Parameters as Utils
|
||||
|
||||
import Text.Blaze (Markup, ToMarkup)
|
||||
|
||||
import Data.Char (isDigit, isSpace)
|
||||
import Data.Char (isDigit, isSpace, isAscii)
|
||||
import Data.Text (dropWhileEnd, takeWhileEnd, justifyRight)
|
||||
import Numeric (showFFloat)
|
||||
|
||||
@ -68,7 +66,7 @@ import qualified Crypto.Saltine.Core.SecretBox as SecretBox
|
||||
import qualified Crypto.Saltine.Class as Saltine
|
||||
import qualified Crypto.Data.PKCS7 as PKCS7
|
||||
|
||||
import Data.Fixed (Centi)
|
||||
import Data.Fixed
|
||||
import Data.Ratio ((%))
|
||||
|
||||
import qualified Data.Binary as Binary
|
||||
@ -79,6 +77,8 @@ import Data.Time.Clock
|
||||
|
||||
import Data.List.NonEmpty (NonEmpty, nonEmpty)
|
||||
|
||||
import Algebra.Lattice (top, bottom, (/\), (\/), BoundedJoinSemiLattice, BoundedMeetSemiLattice)
|
||||
|
||||
{-# ANN choice ("HLint: ignore Use asum" :: String) #-}
|
||||
|
||||
|
||||
@ -123,33 +123,39 @@ type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBase
|
||||
-- Icons --
|
||||
-----------
|
||||
|
||||
-- Create an icon from font-awesome without additional space
|
||||
fontAwesomeIcon :: Text -> Markup
|
||||
fontAwesomeIcon iconName =
|
||||
[shamlet|$newline never
|
||||
<i .fas .fa-#{iconName}>|]
|
||||
|
||||
-- We collect all used icons here for an overview.
|
||||
-- For consistency, some conditional icons are also provided, e.g. `isIvisble`
|
||||
|
||||
iconQuestion :: Markup
|
||||
iconQuestion = [shamlet|<i .fas .fa-question-circle>|]
|
||||
iconQuestion = fontAwesomeIcon "question-circle"
|
||||
|
||||
iconHint :: Markup
|
||||
iconHint = [shamlet|<i .fas .fa-life-ring>|]
|
||||
iconHint = fontAwesomeIcon "life-ring"
|
||||
|
||||
iconSolution :: Markup
|
||||
iconSolution = [shamlet|<i .fas .fa-exclamation-circle>|]
|
||||
iconSolution =fontAwesomeIcon "exclamation-circle"
|
||||
|
||||
iconMarking :: Markup
|
||||
iconMarking = [shamlet|<i .fas .fa-check-circle>|]
|
||||
iconMarking = fontAwesomeIcon "check-circle"
|
||||
|
||||
fileDownload :: Markup
|
||||
fileDownload = [shamlet|<i .fas .fa-file-download>|]
|
||||
fileDownload = fontAwesomeIcon "file-download"
|
||||
|
||||
zipDownload :: Markup
|
||||
zipDownload = [shamlet|<i .fas .fa-file-archive>|]
|
||||
zipDownload = fontAwesomeIcon "file-archive"
|
||||
|
||||
-- Conditional icons
|
||||
|
||||
isVisible :: Bool -> Markup
|
||||
-- ^ Display an icon that denotes that something™ is visible or invisible
|
||||
isVisible True = [shamlet|<i .fas .fa-eye>|]
|
||||
isVisible False = [shamlet|<i .fas .fa-eye-slash>|]
|
||||
isVisible True = fontAwesomeIcon "eye"
|
||||
isVisible False = fontAwesomeIcon "eye-slash"
|
||||
--
|
||||
-- For documentation on how to avoid these unneccessary functions
|
||||
-- we implement them here just once for the first icon:
|
||||
@ -165,26 +171,26 @@ maybeIsVisibleWidget = toWidget . foldMap isVisible
|
||||
-- Other _frequently_ used icons:
|
||||
hasComment :: Bool -> Markup
|
||||
-- ^ Display an icon that denotes that something™ has a comment or not
|
||||
hasComment True = [shamlet|<i .fas .fa-comment-alt>|]
|
||||
hasComment False = [shamlet|<i .fas .fa-comment-slash>|] -- comment-alt-slash is not available for free
|
||||
hasComment True = fontAwesomeIcon "comment-alt"
|
||||
hasComment False = fontAwesomeIcon "comment-slash" -- comment-alt-slash is not available for free
|
||||
|
||||
hasTickmark :: Bool -> Markup
|
||||
-- ^ Display an icon that denotes that something™ is okay
|
||||
hasTickmark True = [shamlet|<i .fas .fa-check>|]
|
||||
hasTickmark True = fontAwesomeIcon "check"
|
||||
hasTickmark False = mempty
|
||||
|
||||
isBad :: Bool -> Markup
|
||||
-- ^ Display an icon that denotes that something™ is bad
|
||||
isBad True = [shamlet|<i .fas .fa-bolt>|] -- or times?!
|
||||
isBad True = fontAwesomeIcon "bolt" -- or times?!
|
||||
isBad False = mempty
|
||||
|
||||
isNew :: Bool -> Markup
|
||||
isNew True = [shamlet|<i .fas .fa-seedling>|] -- was exclamation
|
||||
isNew True = fontAwesomeIcon "seedling" -- was exclamation
|
||||
isNew False = mempty
|
||||
|
||||
boolSymbol :: Bool -> Markup
|
||||
boolSymbol True = [shamlet|<i .fas .fa-check>|]
|
||||
boolSymbol False = [shamlet|<i .fas .fa-times>|]
|
||||
boolSymbol True = fontAwesomeIcon "check"
|
||||
boolSymbol False = fontAwesomeIcon "times"
|
||||
|
||||
|
||||
|
||||
@ -243,8 +249,8 @@ class DisplayAble a where
|
||||
instance DisplayAble Text where
|
||||
display = id
|
||||
|
||||
instance DisplayAble String where
|
||||
display = pack
|
||||
-- instance DisplayAble String where
|
||||
-- display = pack
|
||||
|
||||
instance DisplayAble Int
|
||||
instance DisplayAble Int64
|
||||
@ -269,6 +275,12 @@ instance DisplayAble a => DisplayAble (E.Value a) where
|
||||
instance DisplayAble a => DisplayAble (CI a) where
|
||||
display = display . CI.original
|
||||
|
||||
instance HasResolution a => DisplayAble (Fixed a) where
|
||||
display = pack . showFixed True
|
||||
|
||||
instance DisplayAble a => DisplayAble (Sum a) where
|
||||
display = display . getSum
|
||||
|
||||
{- We do not want DisplayAble for every Show-Class:
|
||||
We want to explicitly verify that the resulting text can be displayed to the User!
|
||||
For example: UTCTime values were shown without proper format rendering!
|
||||
@ -712,6 +724,16 @@ mconcatForM = flip mconcatMapM
|
||||
findM :: (Monad m, Foldable f) => (a -> MaybeT m b) -> f a -> m (Maybe b)
|
||||
findM f = runMaybeT . Fold.foldr (\x as -> f x <|> as) mzero
|
||||
|
||||
-------------
|
||||
-- Conduit --
|
||||
-------------
|
||||
|
||||
peekN :: (Integral n, Monad m) => n -> Consumer a m [a]
|
||||
peekN n = do
|
||||
peeked <- catMaybes <$> replicateM (fromIntegral n) await
|
||||
mapM_ leftover peeked
|
||||
return peeked
|
||||
|
||||
-----------------
|
||||
-- Alternative --
|
||||
-----------------
|
||||
@ -775,6 +797,33 @@ addCustomHeader, replaceOrAddCustomHeader :: (MonadHandler m, PathPiece payload)
|
||||
addCustomHeader ident payload = addHeader (toPathPiece ident) (toPathPiece payload)
|
||||
replaceOrAddCustomHeader ident payload = replaceOrAddHeader (toPathPiece ident) (toPathPiece payload)
|
||||
|
||||
------------------
|
||||
-- HTTP Headers --
|
||||
------------------
|
||||
|
||||
data ContentDisposition = ContentInline | ContentAttachment
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
instance Universe ContentDisposition
|
||||
instance Finite ContentDisposition
|
||||
nullaryPathPiece ''ContentDisposition $ camelToPathPiece' 1
|
||||
|
||||
setContentDisposition :: MonadHandler m => ContentDisposition -> Maybe FilePath -> m ()
|
||||
-- ^ Set a @Content-Disposition@-header using `replaceOrAddHeader`
|
||||
--
|
||||
-- Takes care of correct formatting and encoding of non-ascii filenames
|
||||
setContentDisposition cd (fmap pack -> mFName) = replaceOrAddHeader "Content-Disposition" headerVal
|
||||
where
|
||||
headerVal
|
||||
| Just fName <- mFName
|
||||
, Text.all isAscii fName
|
||||
, Text.all (not . flip elem ['"', '\\']) fName
|
||||
= [st|#{toPathPiece cd}; filename="#{fName}"|]
|
||||
| Just fName <- mFName
|
||||
= let encoded = decodeUtf8 . urlEncode True $ encodeUtf8 fName
|
||||
in [st|#{toPathPiece cd}; filename*=UTF-8''#{encoded}|]
|
||||
| otherwise
|
||||
= toPathPiece cd
|
||||
|
||||
------------------
|
||||
-- Cryptography --
|
||||
------------------
|
||||
@ -893,3 +942,13 @@ setLastModified lastModified = do
|
||||
precision = 1
|
||||
|
||||
safeMethods = [ methodGet, methodHead, methodOptions ]
|
||||
|
||||
--------------
|
||||
-- Lattices --
|
||||
--------------
|
||||
|
||||
foldJoin :: (MonoFoldable mono, BoundedJoinSemiLattice (Element mono)) => mono -> Element mono
|
||||
foldJoin = foldr (\/) bottom
|
||||
|
||||
foldMeet :: (MonoFoldable mono, BoundedMeetSemiLattice (Element mono)) => mono -> Element mono
|
||||
foldMeet = foldr (/\) top
|
||||
|
||||
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Utils.DateTime
|
||||
( timeLocaleMap
|
||||
@ -14,10 +13,9 @@ module Utils.DateTime
|
||||
import ClassyPrelude.Yesod hiding (lift)
|
||||
import System.Locale.Read
|
||||
|
||||
import Data.Time (TimeZone(..), TimeLocale(..))
|
||||
import Data.Time (TimeLocale(..))
|
||||
import Data.Time.Zones (TZ)
|
||||
import Data.Time.Zones.TH (includeSystemTZ)
|
||||
import Data.Time.Clock.POSIX
|
||||
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Syntax (Lift(..))
|
||||
@ -35,11 +33,8 @@ import Data.Aeson.TH
|
||||
|
||||
import Utils.PathPiece
|
||||
|
||||
deriving instance Lift TimeZone
|
||||
deriving instance Lift TimeLocale
|
||||
|
||||
instance Hashable UTCTime where
|
||||
hashWithSalt s = hashWithSalt s . toRational . utcTimeToPOSIXSeconds
|
||||
import Data.Time.Format.Instances ()
|
||||
|
||||
|
||||
-- $(timeLocaleMap _) :: [Lang] -> TimeLocale
|
||||
timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
|
||||
@ -91,7 +86,7 @@ instance Finite SelDateTimeFormat
|
||||
instance Hashable SelDateTimeFormat
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel
|
||||
{ constructorTagModifier = camelToPathPiece' 2
|
||||
} ''SelDateTimeFormat
|
||||
|
||||
instance ToJSONKey SelDateTimeFormat where
|
||||
|
||||
@ -24,6 +24,7 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
import Control.Monad.Reader.Class (MonadReader(..))
|
||||
import Control.Monad.Writer.Class (MonadWriter(..))
|
||||
import Control.Monad.Trans.RWS (mapRWST)
|
||||
import Control.Monad.Trans.Except (ExceptT, runExceptT)
|
||||
|
||||
import Data.List ((!!))
|
||||
|
||||
@ -445,6 +446,29 @@ optionsFinite = do
|
||||
rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational
|
||||
rationalField = convertField toRational fromRational doubleField
|
||||
|
||||
data SecretJSONFieldException = SecretJSONFieldDecryptFailure
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
instance Exception SecretJSONFieldException
|
||||
|
||||
secretJsonField :: ( ToJSON a, FromJSON a
|
||||
, MonadHandler m
|
||||
, MonadSecretBox (ExceptT EncodedSecretBoxException m)
|
||||
, MonadSecretBox (WidgetT (HandlerSite m) IO)
|
||||
, RenderMessage (HandlerSite m) FormMessage
|
||||
, RenderMessage (HandlerSite m) SecretJSONFieldException
|
||||
)
|
||||
=> Field m a
|
||||
secretJsonField = Field{..}
|
||||
where
|
||||
fieldParse [v] [] = bimap (\_ -> SomeMessage SecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
|
||||
fieldParse [] [] = return $ Right Nothing
|
||||
fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
|
||||
fieldView theId name attrs val _isReq = do
|
||||
val' <- traverse (encodedSecretBox SecretBoxShort) val
|
||||
[whamlet|
|
||||
<input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
|
||||
|]
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
-----------
|
||||
-- Forms --
|
||||
@ -522,6 +546,9 @@ idFormSectionNoinput = "form-section-noinput"
|
||||
aformSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> AForm m ()
|
||||
aformSection = formToAForm . fmap (second pure) . formSection
|
||||
|
||||
wformSection :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> WForm m ()
|
||||
wformSection = void . aFormToWForm . aformSection
|
||||
|
||||
formSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
|
||||
formSection formSectionTitle = do
|
||||
mr <- getMessageRender
|
||||
@ -663,23 +690,32 @@ mforced Field{..} FieldSettings{..} val = do
|
||||
|
||||
aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -> FieldSettings site -> a -> AForm m a
|
||||
aforced field settings val = formToAForm $ second pure <$> mforced field settings val
|
||||
|
||||
apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -> FieldSettings site -> Maybe a -> AForm m a
|
||||
-- ^ Pseudo required
|
||||
apreq f fs mx = formToAForm $ do
|
||||
mr <- getMessageRender
|
||||
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)
|
||||
aforced field settings val = formToAForm $ over _2 pure <$> mforced field settings val
|
||||
|
||||
mpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
|
||||
-- ^ Pseudo required
|
||||
--
|
||||
-- `FieldView` has `fvRequired` set to `True` and @FormSuccess Nothing@ is cast to `FormFailure`.
|
||||
-- Otherwise acts exactly like `mopt`.
|
||||
mpreq f fs mx = do
|
||||
mr <- getMessageRender
|
||||
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
|
||||
(res, fv) <- mopt f fs (Just <$> mx)
|
||||
let fv' = fv { fvRequired = True }
|
||||
return $ case res of
|
||||
FormSuccess (Just res')
|
||||
-> (FormSuccess res', fv')
|
||||
FormSuccess Nothing
|
||||
-> (FormFailure [mr MsgValueRequired], fv' { fvErrors = Just . toHtml $ mr MsgValueRequired })
|
||||
FormFailure errs
|
||||
-> (FormFailure errs, fv')
|
||||
FormMissing
|
||||
-> (FormMissing, fv')
|
||||
|
||||
apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -> FieldSettings site -> Maybe a -> AForm m a
|
||||
apreq f fs mx = formToAForm $ over _2 pure <$> mpreq f fs mx
|
||||
|
||||
wpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
|
||||
wpreq f fs mx = mFormToWForm $ do
|
||||
mr <- getMessageRender
|
||||
over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)
|
||||
wpreq f fs mx = mFormToWForm $ mpreq f fs mx
|
||||
|
||||
@ -11,8 +11,8 @@ import Utils.Route
|
||||
|
||||
import Settings (widgetFile)
|
||||
|
||||
import Control.Monad.Random.Class (MonadRandom(..))
|
||||
import qualified Data.UUID as UUID
|
||||
import Control.Monad.Random.Class (uniform)
|
||||
import Control.Monad.Trans.Random (evalRandTIO)
|
||||
|
||||
|
||||
data Modal site = Modal
|
||||
@ -47,8 +47,17 @@ msgModal :: WidgetT site IO ()
|
||||
-> Either (SomeRoute site) (WidgetT site IO ())
|
||||
-> WidgetT site IO ()
|
||||
msgModal modalTrigger' modalContent = do
|
||||
modalTriggerId <- Just . UUID.toText <$> liftIO getRandom
|
||||
modalId <- Just . UUID.toText <$> liftIO getRandom
|
||||
let
|
||||
randomIdentifier :: MonadIO m => m Text
|
||||
-- ^ Generates valid CSS-Identifiers with roughly 128 bits of entropy
|
||||
--
|
||||
-- See https://www.w3.org/TR/CSS21/syndata.html#value-def-identifier
|
||||
randomIdentifier = fmap pack . evalRandTIO $ do
|
||||
prefix <- uniform $ ['a'..'z'] ++ ['A'..'Z']
|
||||
suffix <- replicateM 21 . uniform $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9']
|
||||
return $ prefix : suffix
|
||||
modalTriggerId <- Just <$> randomIdentifier
|
||||
modalId <- Just <$> randomIdentifier
|
||||
customModal Modal{..}
|
||||
where
|
||||
modalTrigger mRoute triggerId = $(widgetFile "widgets/modal/trigger")
|
||||
|
||||
@ -77,6 +77,8 @@ hasEntityUser = hasEntity
|
||||
|
||||
makeLenses_ ''SheetCorrector
|
||||
|
||||
makeLenses_ ''Load
|
||||
|
||||
makeLenses_ ''SubmissionGroup
|
||||
|
||||
makeLenses_ ''SheetGrading
|
||||
@ -103,6 +105,8 @@ makePrisms ''HandlerContents
|
||||
|
||||
makePrisms ''ErrorResponse
|
||||
|
||||
makeLenses_ ''UploadMode
|
||||
|
||||
makeLenses_ ''SubmissionMode
|
||||
|
||||
makePrisms ''E.Value
|
||||
|
||||
@ -5,6 +5,7 @@ module Utils.PathPiece
|
||||
, splitCamel
|
||||
, camelToPathPiece, camelToPathPiece'
|
||||
, tuplePathPiece
|
||||
, pathPieceJSONKey
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
@ -22,6 +23,8 @@ import qualified Data.Map as Map
|
||||
import Numeric.Natural
|
||||
|
||||
import Data.List (foldl)
|
||||
|
||||
import Data.Aeson.Types
|
||||
|
||||
|
||||
finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a
|
||||
@ -109,3 +112,13 @@ tuplePathPiece tupleDim = do
|
||||
]) []
|
||||
]
|
||||
]
|
||||
|
||||
|
||||
pathPieceJSONKey :: Name -> DecsQ
|
||||
-- ^ Derive `ToJSONKey`- and `FromJSONKey`-Instances from a `PathPiece`-Instance
|
||||
pathPieceJSONKey tName
|
||||
= [d| instance ToJSONKey $(conT tName) where
|
||||
toJSONKey = toJSONKeyText toPathPiece
|
||||
instance FromJSONKey $(conT tName) where
|
||||
fromJSONKey = FromJSONKeyTextParser $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> "via PathPiece") return $ fromPathPiece t
|
||||
|]
|
||||
|
||||
@ -3,7 +3,7 @@ module Utils.Sheet where
|
||||
import Import.NoFoundation
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Database.Esqueleto.Internal.Language (From) -- How to avoid this import?
|
||||
import Database.Esqueleto.Internal.Language (From) -- cannot be avoided here
|
||||
|
||||
-- DB Queries for Sheets that are used in several places
|
||||
|
||||
@ -47,8 +47,8 @@ sheetOldUnassigned tid ssh csh = do
|
||||
_ -> error "SQL Query with limit 1 returned more than one result"
|
||||
|
||||
-- | Return a specfic file from a `Sheet`
|
||||
sheetFileQuery :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> SqlReadT m [Entity File]
|
||||
sheetFileQuery tid ssh csh shn sft title = E.select $ E.from $
|
||||
sheetFileQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Source (SqlPersistT m) (Entity File)
|
||||
sheetFileQuery tid ssh csh shn sft title = E.selectSource $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile)
|
||||
@ -66,8 +66,8 @@ sheetFileQuery tid ssh csh shn sft title = E.select $ E.from $
|
||||
return file
|
||||
|
||||
-- | Return all files of a certain `SheetFileType` for a `Sheet`
|
||||
sheetFilesAllQuery :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> SqlReadT m [Entity File]
|
||||
sheetFilesAllQuery tid ssh csh shn sft = E.select $ E.from $
|
||||
sheetFilesAllQuery :: MonadResource m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Source (SqlPersistT m) (Entity File)
|
||||
sheetFilesAllQuery tid ssh csh shn sft = E.selectSource $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile)
|
||||
@ -85,9 +85,8 @@ sheetFilesAllQuery tid ssh csh shn sft = E.select $ E.from $
|
||||
|
||||
-- | Check whether a sheet has any files for a given file type
|
||||
hasSheetFileQuery :: Database.Esqueleto.Internal.Language.From query expr backend (expr (Entity SheetFile))
|
||||
-- hasSheetFileQuery :: (E.Esqueleto query expr backend)
|
||||
=> expr (Entity Sheet) -> SheetFileType -> expr (E.Value Bool)
|
||||
hasSheetFileQuery sheet sft =
|
||||
E.exists $ E.from $ \sFile ->
|
||||
E.where_ ((sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
|
||||
E.&&. (sFile E.^. SheetFileType E.==. E.val sft ))
|
||||
E.&&. (sFile E.^. SheetFileType E.==. E.val sft ))
|
||||
|
||||
@ -51,4 +51,6 @@ extra-deps:
|
||||
|
||||
- systemd-1.2.0
|
||||
|
||||
- filepath-1.4.2
|
||||
|
||||
resolver: lts-10.5
|
||||
|
||||
50
static/js/services/htmlHelpers.js
Normal file
50
static/js/services/htmlHelpers.js
Normal file
@ -0,0 +1,50 @@
|
||||
(function () {
|
||||
'use strict';
|
||||
|
||||
window.HtmlHelpers = (function() {
|
||||
|
||||
// `parseResponse` takes a raw HttpClient response and an options object.
|
||||
// Returns an object with `element` being an contextual fragment of the
|
||||
// HTML in the response and `ifPrefix` being the prefix that was used to
|
||||
// "unique-ify" the ids of the received HTML.
|
||||
// Original Response IDs can optionally be kept by adding `keepIds: true`
|
||||
// to the `options` object.
|
||||
function parseResponse(response, options) {
|
||||
options = options || {};
|
||||
|
||||
return response.text().then(function (responseText) {
|
||||
var docFrag = document.createRange().createContextualFragment(responseText);
|
||||
var idPrefix;
|
||||
if (!options.keepIds) {
|
||||
idPrefix = _getIdPrefix();
|
||||
_prefixIds(docFrag, idPrefix);
|
||||
}
|
||||
return Promise.resolve({ idPrefix: idPrefix, element: docFrag });
|
||||
},
|
||||
function (error) {
|
||||
return Promise.reject(error);
|
||||
}).catch(function (error) { console.error(error); });
|
||||
}
|
||||
|
||||
function _prefixIds(element, idPrefix) {
|
||||
var idAttrs = ['id', 'for', 'data-conditional-input', 'data-modal-trigger'];
|
||||
|
||||
idAttrs.forEach(function(attr) {
|
||||
Array.from(element.querySelectorAll('[' + attr + ']')).forEach(function(input) {
|
||||
var value = idPrefix + input.getAttribute(attr);
|
||||
input.setAttribute(attr, value);
|
||||
});
|
||||
});
|
||||
}
|
||||
|
||||
function _getIdPrefix() {
|
||||
// leading 'r'(andom) to overcome the fact that IDs
|
||||
// starting with a numeric value are not valid in CSS
|
||||
return 'r' + Math.floor(Math.random() * 100000) + '__';
|
||||
}
|
||||
|
||||
return {
|
||||
parseResponse: parseResponse,
|
||||
}
|
||||
})();
|
||||
})();
|
||||
@ -11,21 +11,23 @@
|
||||
}
|
||||
}
|
||||
|
||||
function _fetch(url, method, additionalHeaders, body) {
|
||||
function _fetch(options) {
|
||||
var requestOptions = {
|
||||
credentials: 'same-origin',
|
||||
headers: { },
|
||||
method: method,
|
||||
body: body,
|
||||
method: options.method,
|
||||
body: options.body,
|
||||
};
|
||||
|
||||
Object.keys(additionalHeaders).forEach(function(headerKey) {
|
||||
requestOptions.headers[headerKey] = additionalHeaders[headerKey];
|
||||
Object.keys(options.headers).forEach(function(headerKey) {
|
||||
requestOptions.headers[headerKey] = options.headers[headerKey];
|
||||
});
|
||||
|
||||
return fetch(url, requestOptions).then(
|
||||
return fetch(options.url, requestOptions).then(
|
||||
function(response) {
|
||||
_responseInterceptors.forEach(function(interceptor) { interceptor(response); });
|
||||
_responseInterceptors.forEach(function(interceptor) {
|
||||
interceptor(response, options);
|
||||
});
|
||||
return Promise.resolve(response);
|
||||
},
|
||||
function(error) {
|
||||
@ -37,13 +39,34 @@
|
||||
}
|
||||
|
||||
return {
|
||||
get: function(url, headers) {
|
||||
return _fetch(url, 'GET', headers);
|
||||
get: function(args) {
|
||||
args.method = 'GET';
|
||||
return _fetch(args);
|
||||
},
|
||||
post: function(url, headers, body) {
|
||||
return _fetch(url, 'POST', headers, body);
|
||||
post: function(args) {
|
||||
args.method = 'POST';
|
||||
return _fetch(args);
|
||||
},
|
||||
addResponseInterceptor: addResponseInterceptor,
|
||||
ACCEPT: {
|
||||
TEXT_HTML: 'text/html',
|
||||
JSON: 'application/json',
|
||||
},
|
||||
}
|
||||
})();
|
||||
|
||||
// HttpClient ships with its own little interceptor to throw an error
|
||||
// if the response does not match the expected content-type
|
||||
function contentTypeInterceptor(response, options) {
|
||||
if (!options || !options.accept) {
|
||||
return;
|
||||
}
|
||||
|
||||
var contentType = response.headers.get("content-type");
|
||||
if (!contentType.match(options.accept)) {
|
||||
throw new Error('Server returned with "' + contentType + '" when "' + options.accept + '" was expected');
|
||||
}
|
||||
}
|
||||
|
||||
HttpClient.addResponseInterceptor(contentTypeInterceptor);
|
||||
})();
|
||||
|
||||
@ -160,7 +160,8 @@
|
||||
var alerts;
|
||||
for (var header of response.headers) {
|
||||
if (header[0] === 'alerts') {
|
||||
alerts = JSON.parse(header[1]);
|
||||
var decodedHeader = decodeURIComponent(header[1]);
|
||||
alerts = JSON.parse(decodedHeader);
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
@ -96,21 +96,21 @@
|
||||
headers[MODAL_HEADER_KEY] = MODAL_HEADER_VALUE;
|
||||
}
|
||||
|
||||
HttpClient.post(url, headers, body)
|
||||
.then(function(response) {
|
||||
if (response.headers.get("content-type").indexOf("application/json") !== -1) {// checking response header
|
||||
return response.json();
|
||||
} else {
|
||||
throw new TypeError('Unexpected Content-Type. Expected Content-Type: "application/json". Requested URL:' + url + '"');
|
||||
}
|
||||
}).then(function(response) {
|
||||
processResponse(response[0]);
|
||||
}).catch(function(error) {
|
||||
var failureMessage = I18n.get('asyncFormFailure');
|
||||
processResponse({ content: failureMessage });
|
||||
HttpClient.post({
|
||||
url: url,
|
||||
headers: headers,
|
||||
body: body,
|
||||
accept: HttpClient.ACCEPT.JSON,
|
||||
}).then(function(response) {
|
||||
return response.json();
|
||||
}).then(function(response) {
|
||||
processResponse(response[0]);
|
||||
}).catch(function(error) {
|
||||
var failureMessage = I18n.get('asyncFormFailure');
|
||||
processResponse({ content: failureMessage });
|
||||
|
||||
element.classList.remove(ASYNC_FORM_LOADING_CLASS);
|
||||
});
|
||||
element.classList.remove(ASYNC_FORM_LOADING_CLASS);
|
||||
});
|
||||
}
|
||||
|
||||
return init();
|
||||
|
||||
@ -35,6 +35,7 @@
|
||||
var pageLinks = [];
|
||||
var pagesizeForm;
|
||||
var scrollTable;
|
||||
var cssIdPrefix = '';
|
||||
|
||||
var tableFilterInputs = {
|
||||
search: [],
|
||||
@ -48,12 +49,18 @@
|
||||
throw new Error('Async Table utility cannot be setup without an element!');
|
||||
}
|
||||
|
||||
if (element.classList.contains(ASYNC_TABLE_INITIALIZED_CLASS)) {
|
||||
return false;
|
||||
}
|
||||
|
||||
// param asyncTableDbHeader
|
||||
if (element.dataset.asyncTableDbHeader !== undefined) {
|
||||
asyncTableHeader = element.dataset.asyncTableDbHeader;
|
||||
}
|
||||
|
||||
asyncTableId = element.querySelector('table').id;
|
||||
var rawTableId = element.querySelector('table').id;
|
||||
cssIdPrefix = findCssIdPrefix(rawTableId);
|
||||
asyncTableId = rawTableId.replace(cssIdPrefix, '');
|
||||
|
||||
// find scrolltable wrapper
|
||||
scrollTable = element.querySelector(ASYNC_TABLE_SCROLLTABLE_SELECTOR);
|
||||
@ -96,7 +103,7 @@
|
||||
}
|
||||
|
||||
function setupPagination() {
|
||||
var pagination = element.querySelector('#' + asyncTableId + '-pagination');
|
||||
var pagination = element.querySelector('#' + cssIdPrefix + asyncTableId + '-pagination');
|
||||
if (pagination) {
|
||||
pageLinks = Array.from(pagination.querySelectorAll('.page-link')).map(function(link) {
|
||||
return { element: link };
|
||||
@ -122,7 +129,7 @@
|
||||
|
||||
function setupPageSizeSelect() {
|
||||
// pagesize form
|
||||
pagesizeForm = element.querySelector('#' + asyncTableId + '-pagesize-form');
|
||||
pagesizeForm = element.querySelector('#' + cssIdPrefix + asyncTableId + '-pagesize-form');
|
||||
|
||||
if (pagesizeForm) {
|
||||
var pagesizeSelect = pagesizeForm.querySelector('[name=' + asyncTableId + '-pagesize]');
|
||||
@ -200,11 +207,15 @@
|
||||
|
||||
var focusedInput = tableFilterForm.querySelector(':focus, :active');
|
||||
// focus previously focused input
|
||||
if (focusedInput) {
|
||||
if (focusedInput && focusedInput.selectionStart !== null) {
|
||||
var selectionStart = focusedInput.selectionStart;
|
||||
var focusId = focusedInput.id;
|
||||
// remove the following part of the id to get rid of the random
|
||||
// (yet somewhat structured) prefix we got from nudging.
|
||||
var prefix = findCssIdPrefix(focusedInput.id);
|
||||
var focusId = focusedInput.id.replace(prefix, '');
|
||||
callback = function(wrapper) {
|
||||
var toBeFocused = wrapper.querySelector('#' + focusId);
|
||||
var idPrefix = getLocalStorageParameter('cssIdPrefix');
|
||||
var toBeFocused = wrapper.querySelector('#' + idPrefix + focusId);
|
||||
if (toBeFocused) {
|
||||
toBeFocused.focus();
|
||||
toBeFocused.selectionStart = selectionStart;
|
||||
@ -298,11 +309,19 @@
|
||||
}
|
||||
|
||||
function changePagesizeHandler(event) {
|
||||
var paginationParamKey = asyncTableId + '-pagination';
|
||||
var pagesizeParamKey = asyncTableId + '-pagesize';
|
||||
var pageParamKey = asyncTableId + '-page';
|
||||
|
||||
var paginationParamEl = pagesizeForm.querySelector('[name="' + paginationParamKey + '"]');
|
||||
var url = new URL(getLocalStorageParameter('currentTableUrl') || window.location.href);
|
||||
url.searchParams.set(pagesizeParamKey, event.target.value);
|
||||
url.searchParams.set(pageParamKey, 0);
|
||||
|
||||
if (paginationParamEl) {
|
||||
var encodedValue = encodeURIComponent(paginationParamEl.value);
|
||||
url.searchParams.set(paginationParamKey, encodedValue);
|
||||
}
|
||||
updateTableFrom(url.href);
|
||||
}
|
||||
|
||||
@ -319,44 +338,56 @@
|
||||
[asyncTableHeader]: asyncTableId
|
||||
};
|
||||
|
||||
HttpClient.get(url, headers).then(function(response) {
|
||||
if (!response.ok) {
|
||||
throw new Error('Looks like there was a problem fetching ' + url.href + '. Status Code: ' + response.status);
|
||||
}
|
||||
return response.text();
|
||||
}).then(function(data) {
|
||||
HttpClient.get({
|
||||
url: url,
|
||||
headers: headers,
|
||||
accept: HttpClient.ACCEPT.TEXT_HTML,
|
||||
}).then(function(response) {
|
||||
return HtmlHelpers.parseResponse(response);
|
||||
}).then(function(response) {
|
||||
setLocalStorageParameter('currentTableUrl', url.href);
|
||||
// reset table
|
||||
removeListeners();
|
||||
element.classList.remove(ASYNC_TABLE_INITIALIZED_CLASS);
|
||||
// update table with new
|
||||
updateWrapperContents(data);
|
||||
updateWrapperContents(response);
|
||||
|
||||
if (callback && typeof callback === 'function') {
|
||||
callback(element);
|
||||
if (UtilRegistry) {
|
||||
UtilRegistry.setupAll(element);
|
||||
}
|
||||
|
||||
element.classList.remove(ASYNC_TABLE_LOADING_CLASS);
|
||||
if (callback && typeof callback === 'function') {
|
||||
setLocalStorageParameter('cssIdPrefix', response.idPrefix);
|
||||
callback(element);
|
||||
setLocalStorageParameter('cssIdPrefix', '');
|
||||
}
|
||||
}).catch(function(err) {
|
||||
console.error(err);
|
||||
}).finally(function() {
|
||||
element.classList.remove(ASYNC_TABLE_LOADING_CLASS);
|
||||
});
|
||||
}
|
||||
|
||||
function updateWrapperContents(newHtml) {
|
||||
function updateWrapperContents(response) {
|
||||
var newPage = document.createElement('div');
|
||||
newPage.innerHTML = newHtml;
|
||||
var newWrapperContents = newPage.querySelector('#' + element.id);
|
||||
newPage.appendChild(response.element);
|
||||
var newWrapperContents = newPage.querySelector('#' + response.idPrefix + element.id);
|
||||
element.innerHTML = newWrapperContents.innerHTML;
|
||||
|
||||
if (UtilRegistry) {
|
||||
UtilRegistry.setupAll(element);
|
||||
}
|
||||
}
|
||||
|
||||
return init();
|
||||
};
|
||||
|
||||
// returns any random nudged prefix found in the given id
|
||||
function findCssIdPrefix(id) {
|
||||
var matcher = /r\d*?__/;
|
||||
var maybePrefix = id.match(matcher);
|
||||
if (maybePrefix && maybePrefix[0]) {
|
||||
return maybePrefix[0]
|
||||
}
|
||||
return '';
|
||||
}
|
||||
|
||||
function setLocalStorageParameter(key, value) {
|
||||
var currentLSState = JSON.parse(window.localStorage.getItem(ASYNC_TABLE_LOCAL_STORAGE_KEY)) || {};
|
||||
if (value !== null) {
|
||||
|
||||
@ -30,6 +30,10 @@
|
||||
throw new Error('Check All utility cannot be setup without an element!');
|
||||
}
|
||||
|
||||
if (element.classList.contains(CHECK_ALL_INITIALIZED_CLASS)) {
|
||||
return false;
|
||||
}
|
||||
|
||||
gatherColumns();
|
||||
setupCheckAllCheckbox();
|
||||
|
||||
|
||||
@ -247,6 +247,88 @@
|
||||
setup: interactiveFieldsetUtil,
|
||||
});
|
||||
|
||||
/**
|
||||
*
|
||||
* Navigate Away Prompt Utility
|
||||
* This utility asks the user if (s)he really wants to navigate away
|
||||
* from a page containing a form if (s)he already touched an input.
|
||||
* Form-Submits will not trigger the prompt.
|
||||
* Utility will ignore forms that contain auto submit elements (buttons, inputs).
|
||||
*
|
||||
* Attribute: [none]
|
||||
* (automatically setup on all form tags that dont automatically submit, see AutoSubmitButtonUtil)
|
||||
*
|
||||
* Example usage:
|
||||
* (any page with a form)
|
||||
*/
|
||||
|
||||
var NAVIGATE_AWAY_PROMPT_UTIL_NAME = 'navigateAwayPrompt';
|
||||
var NAVIGATE_AWAY_PROMPT_UTIL_SELECTOR = 'form';
|
||||
|
||||
var NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS = 'navigate-away-prompt--initialized';
|
||||
|
||||
var navigateAwayPromptUtil = function(element) {
|
||||
var touched = false;
|
||||
var unloadDueToSubmit = false;
|
||||
|
||||
function init() {
|
||||
if (!element) {
|
||||
throw new Error('Navigate Away Prompt utility needs to be passed an element!');
|
||||
}
|
||||
|
||||
if (element.classList.contains(NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS)) {
|
||||
return false;
|
||||
}
|
||||
|
||||
// ignore forms that get submitted automatically
|
||||
if (element.querySelector(AUTO_SUBMIT_BUTTON_UTIL_SELECTOR) || element.querySelector(AUTO_SUBMIT_INPUT_UTIL_SELECTOR)) {
|
||||
return false;
|
||||
}
|
||||
|
||||
window.addEventListener('beforeunload', beforeUnloadHandler);
|
||||
|
||||
element.addEventListener('submit', function() {
|
||||
unloadDueToSubmit = true;
|
||||
});
|
||||
element.addEventListener('change', function() {
|
||||
touched = true;
|
||||
unloadDueToSubmit = false;
|
||||
});
|
||||
|
||||
// mark initialized
|
||||
element.classList.add(NAVIGATE_AWAY_PROMPT_INITIALIZED_CLASS);
|
||||
|
||||
return {
|
||||
name: NAVIGATE_AWAY_PROMPT_UTIL_NAME,
|
||||
element: element,
|
||||
destroy: function() {
|
||||
window.removeEventListener('beforeunload', beforeUnloadHandler);
|
||||
},
|
||||
};
|
||||
}
|
||||
|
||||
function beforeUnloadHandler(event) {
|
||||
// allow the event to happen if the form was not touched by the
|
||||
// user or the unload event was initiated by a form submit
|
||||
if (!touched || unloadDueToSubmit) {
|
||||
return false;
|
||||
}
|
||||
|
||||
// cancel the unload event. This is the standard to force the prompt to appear.
|
||||
event.preventDefault();
|
||||
// for all non standard compliant browsers we return a truthy value to activate the prompt.
|
||||
return true;
|
||||
}
|
||||
|
||||
return init();
|
||||
};
|
||||
|
||||
formUtilities.push({
|
||||
name: NAVIGATE_AWAY_PROMPT_UTIL_NAME,
|
||||
selector: NAVIGATE_AWAY_PROMPT_UTIL_SELECTOR,
|
||||
setup: navigateAwayPromptUtil,
|
||||
});
|
||||
|
||||
/**
|
||||
*
|
||||
* Auto Submit Button Utility
|
||||
@ -270,6 +352,10 @@
|
||||
throw new Error('Auto Submit Button utility needs to be passed an element!');
|
||||
}
|
||||
|
||||
if (element.classList.contains(AUTO_SUBMIT_BUTTON_INITIALIZED_CLASS)) {
|
||||
return false;
|
||||
}
|
||||
|
||||
// hide and mark initialized
|
||||
element.classList.add(AUTO_SUBMIT_BUTTON_HIDDEN_CLASS, AUTO_SUBMIT_BUTTON_INITIALIZED_CLASS);
|
||||
|
||||
@ -315,6 +401,10 @@
|
||||
throw new Error('Auto Submit Input utility needs to be passed an element!');
|
||||
}
|
||||
|
||||
if (element.classList.contains(AUTO_SUBMIT_INPUT_INITIALIZED_CLASS)) {
|
||||
return false;
|
||||
}
|
||||
|
||||
form = element.form;
|
||||
if (!form) {
|
||||
throw new Error('Could not determine associated form for auto submit input');
|
||||
@ -374,6 +464,10 @@
|
||||
throw new Error('Form Error Remover utility needs to be passed an element!');
|
||||
}
|
||||
|
||||
if (element.classList.contains(FORM_ERROR_REMOVER_INITIALIZED_CLASS)) {
|
||||
return false;
|
||||
}
|
||||
|
||||
// find form groups
|
||||
formGroups = Array.from(element.querySelectorAll(FORM_GROUP_SELECTOR));
|
||||
|
||||
@ -428,6 +522,8 @@
|
||||
var DATEPICKER_UTIL_NAME = 'datepicker';
|
||||
var DATEPICKER_UTIL_SELECTOR = 'input[type="date"], input[type="time"], input[type="datetime-local"]';
|
||||
|
||||
var DATEPICKER_INITIALIZED_CLASS = 'datepicker--initialized';
|
||||
|
||||
var DATEPICKER_CONFIG = {
|
||||
"datetime-local": {
|
||||
enableTime: true,
|
||||
@ -459,6 +555,10 @@
|
||||
throw new Error('Datepicker utility needs to be passed an element!');
|
||||
}
|
||||
|
||||
if (element.classList.contains(DATEPICKER_INITIALIZED_CLASS)) {
|
||||
return false;
|
||||
}
|
||||
|
||||
var flatpickrConfig = DATEPICKER_CONFIG[element.getAttribute("type")];
|
||||
|
||||
if (!flatpickrConfig) {
|
||||
@ -467,6 +567,9 @@
|
||||
|
||||
flatpickrInstance = flatpickr(element, flatpickrConfig);
|
||||
|
||||
// mark initialized
|
||||
element.classList.add(DATEPICKER_INITIALIZED_CLASS);
|
||||
|
||||
return {
|
||||
name: DATEPICKER_UTIL_NAME,
|
||||
element: element,
|
||||
|
||||
@ -38,6 +38,10 @@
|
||||
throw new Error('Mass Input utility cannot be setup without an element!');
|
||||
}
|
||||
|
||||
if (element.classList.contains(MASS_INPUT_INITIALIZED_CLASS)) {
|
||||
return false;
|
||||
}
|
||||
|
||||
massInputId = element.dataset.massInputIdent || '_';
|
||||
massInputForm = element.closest('form');
|
||||
|
||||
@ -120,19 +124,20 @@
|
||||
|
||||
if (enctype !== 'multipart/form-data')
|
||||
headers['Content-Type'] = enctype;
|
||||
|
||||
requestFn(
|
||||
url,
|
||||
headers,
|
||||
requestBody,
|
||||
).then(function(response) {
|
||||
return response.text();
|
||||
|
||||
requestFn({
|
||||
url: url,
|
||||
headers: headers,
|
||||
body: requestBody,
|
||||
accept: HttpClient.ACCEPT.TEXT_HTML,
|
||||
}).then(function(response) {
|
||||
processResponse(response);
|
||||
if (isAddCell) {
|
||||
reFocusAddCell();
|
||||
}
|
||||
});
|
||||
return HtmlHelpers.parseResponse(response);
|
||||
}).then(function(response) {
|
||||
processResponse(response.element);
|
||||
if (isAddCell) {
|
||||
reFocusAddCell();
|
||||
}
|
||||
});
|
||||
}
|
||||
};
|
||||
}
|
||||
@ -163,27 +168,17 @@
|
||||
button.removeEventListener('click', massInputFormSubmitHandler);
|
||||
}
|
||||
|
||||
function processResponse(response) {
|
||||
element.innerHTML = response;
|
||||
function processResponse(responseElement) {
|
||||
element.innerHTML = "";
|
||||
element.appendChild(responseElement);
|
||||
|
||||
prefixInputIds();
|
||||
reset()
|
||||
reset();
|
||||
|
||||
if (UtilRegistry) {
|
||||
UtilRegistry.setupAll(element);
|
||||
}
|
||||
}
|
||||
|
||||
function prefixInputIds() {
|
||||
var idAttrs = ['id', 'for', 'data-conditional-input'];
|
||||
idAttrs.forEach(function(attr) {
|
||||
Array.from(element.querySelectorAll('[' + attr + ']')).forEach(function(input) {
|
||||
var value = element.id + '__' + input.getAttribute(attr);
|
||||
input.setAttribute(attr, value);
|
||||
});
|
||||
});
|
||||
}
|
||||
|
||||
function serializeForm(submitButton, enctype) {
|
||||
var formData = new FormData(massInputForm);
|
||||
|
||||
|
||||
@ -167,16 +167,18 @@
|
||||
throw new Error('HttpClient not found! Can\'t fetch modal content from ' + url);
|
||||
}
|
||||
|
||||
HttpClient.get(url, MODAL_HEADERS)
|
||||
.then(function(response) {
|
||||
response.text().then(processResponse);
|
||||
});
|
||||
HttpClient.get({
|
||||
url: url,
|
||||
headers: MODAL_HEADERS,
|
||||
accept: HttpClient.ACCEPT.TEXT_HTML,
|
||||
}).then(function(response) {
|
||||
return HtmlHelpers.parseResponse(response);
|
||||
}).then(function(response) {
|
||||
processResponse(response.element);
|
||||
});
|
||||
}
|
||||
|
||||
function processResponse(responseBody) {
|
||||
var responseElement = document.createElement('div');
|
||||
responseElement.innerHTML = responseBody;
|
||||
|
||||
function processResponse(responseElement) {
|
||||
var modalContent = document.createElement('div');
|
||||
modalContent.classList.add(MODAL_CONTENT_CLASS);
|
||||
|
||||
@ -191,24 +193,12 @@
|
||||
previousModalContent.remove();
|
||||
}
|
||||
|
||||
modalContent = withPrefixedInputIDs(modalContent);
|
||||
element.insertBefore(modalContent, null);
|
||||
|
||||
// setup any newly arrived utils
|
||||
UtilRegistry.setupAll(element);
|
||||
}
|
||||
|
||||
function withPrefixedInputIDs(modalContent) {
|
||||
var idAttrs = ['id', 'for', 'data-conditional-input'];
|
||||
idAttrs.forEach(function(attr) {
|
||||
Array.from(modalContent.querySelectorAll('[' + attr + ']')).forEach(function(input) {
|
||||
var value = element.id + '__' + input.getAttribute(attr);
|
||||
input.setAttribute(attr, value);
|
||||
});
|
||||
});
|
||||
return modalContent;
|
||||
}
|
||||
|
||||
return _init();
|
||||
};
|
||||
|
||||
|
||||
@ -465,6 +465,17 @@ ul.list--inline {
|
||||
}
|
||||
}
|
||||
|
||||
.list--space-separated li {
|
||||
&::after {
|
||||
content: ' ';
|
||||
white-space: pre;
|
||||
}
|
||||
|
||||
&:last-of-type::after {
|
||||
content: none;
|
||||
}
|
||||
}
|
||||
|
||||
/* DEFINITION LIST */
|
||||
.deflist {
|
||||
display: grid;
|
||||
|
||||
6
templates/i18n/README_i18n.txt
Normal file
6
templates/i18n/README_i18n.txt
Normal file
@ -0,0 +1,6 @@
|
||||
This directories contains all language dependent widgets.
|
||||
|
||||
Each widget requires its own directories, the name of which is needed in the source code, e.g. for directory "imprint"
|
||||
$(i18nWidgetFile "imprint")
|
||||
inside this directory must be one file per language "de.hamlet", etc.
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
_{MsgSubmissionFilesIgnored}
|
||||
<h2>_{MsgSubmissionFilesIgnored (Set.size ignoredFiles)}
|
||||
<ul>
|
||||
$forall ident <- ignoredFiles
|
||||
$case ident
|
||||
|
||||
4
templates/messages/submissionsAssignNotFound.hamlet
Normal file
4
templates/messages/submissionsAssignNotFound.hamlet
Normal file
@ -0,0 +1,4 @@
|
||||
<h2>_{MsgAssignSubmissionExceptionSubmissionsNotFound (length subCIDs)}
|
||||
<ul>
|
||||
$forall cID <- subCIDs
|
||||
<li><pre>#{toPathPiece cID}
|
||||
@ -1,3 +1,3 @@
|
||||
$newline never
|
||||
<a href=@{route}>
|
||||
^{widget}
|
||||
^{widget}
|
||||
@ -0,0 +1,4 @@
|
||||
$newline never
|
||||
^{formWidget}
|
||||
<td>
|
||||
^{fvInput submitView}
|
||||
@ -0,0 +1,4 @@
|
||||
$newline never
|
||||
<td>#{csrf}^{fvInput labelView}
|
||||
<td>^{fvInput nameView}
|
||||
<td>^{fvInput reqView}
|
||||
@ -0,0 +1,16 @@
|
||||
$newline never
|
||||
<table>
|
||||
<thead>
|
||||
<th>_{MsgUploadSpecificFileLabel}
|
||||
<th>_{MsgUploadSpecificFileName}
|
||||
<th>_{MsgUploadSpecificFileRequired}
|
||||
<th>
|
||||
<tbody>
|
||||
$forall coord <- review liveCoords lLength
|
||||
<tr .massinput__cell>
|
||||
^{cellWdgts ! coord}
|
||||
<td>
|
||||
^{fvInput (delButtons ! coord)}
|
||||
<tfoot>
|
||||
<tr .massinput__cell.massinput__cell--add>
|
||||
^{addWdgts ! (0, 0)}
|
||||
@ -1,5 +1,5 @@
|
||||
$newline never
|
||||
<div uw-modal data-modal-trigger=##{triggerId'} data-modal-closeable>
|
||||
<div uw-modal data-modal-trigger=#{triggerId'} data-modal-closeable>
|
||||
$case modalContent
|
||||
$of Right content
|
||||
<div .modal__content>
|
||||
|
||||
8
templates/widgets/specificFileField.hamlet
Normal file
8
templates/widgets/specificFileField.hamlet
Normal file
@ -0,0 +1,8 @@
|
||||
$newline never
|
||||
<input type=file uw-file-input ##{fieldId} *{attrs} name=#{fieldName} :req:required :acceptRestricted:accept=#{accept}>
|
||||
$if acceptRestricted
|
||||
<br>
|
||||
_{MsgUploadModeExtensionRestriction}:
|
||||
<ul .list--inline .list--comma-separated .list--iconless>
|
||||
$forall ext <- extensions
|
||||
<li style="font-family: monospace">#{ext}
|
||||
@ -1,2 +1,8 @@
|
||||
$newline never
|
||||
<input type=file uw-file-input ##{fieldId} *{attrs} name=#{fieldName} :req:required>
|
||||
<input type=file uw-file-input ##{fieldId} *{attrs} name=#{fieldName} :req:required :acceptRestricted:accept=#{accept}>
|
||||
$maybe exts <- fmap toNullable permittedExtensions
|
||||
<br>
|
||||
_{MsgUploadModeExtensionRestriction}:
|
||||
<ul .list--inline .list--comma-separated .list--iconless>
|
||||
$forall ext <- zipExtensions <> exts
|
||||
<li style="font-family: monospace">#{ext}
|
||||
|
||||
@ -393,11 +393,11 @@ fillDb = do
|
||||
void . insert $ DegreeCourse ffp sdMst sdInf
|
||||
void . insert $ Lecturer jost ffp CourseLecturer
|
||||
void . insert $ Lecturer gkleen ffp CourseAssistant
|
||||
adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
|
||||
adhoc <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
|
||||
insert_ $ SheetEdit gkleen now adhoc
|
||||
feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
|
||||
feste <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
|
||||
insert_ $ SheetEdit gkleen now feste
|
||||
keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ Upload True) False
|
||||
keine <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (SubmissionMode False . Just $ UploadAny True Nothing) False
|
||||
insert_ $ SheetEdit gkleen now keine
|
||||
void . insertMany $ map (\(u,sf) -> CourseParticipant ffp u now sf)
|
||||
[(fhamann , Nothing)
|
||||
@ -484,7 +484,7 @@ fillDb = do
|
||||
]
|
||||
sh1 <- insert Sheet
|
||||
{ sheetCourse = pmo
|
||||
, sheetName = "Blatt 1"
|
||||
, sheetName = "Papierabgabe"
|
||||
, sheetDescription = Nothing
|
||||
, sheetType = Normal $ Points 6
|
||||
, sheetGrouping = Arbitrary 3
|
||||
@ -511,11 +511,75 @@ fillDb = do
|
||||
void . insert $ SheetFile sh1 h103 SheetSolution
|
||||
void . insert $ SheetFile sh1 pdf10 SheetExercise
|
||||
--
|
||||
sub1 <- insert $ Submission sh1 Nothing Nothing Nothing Nothing Nothing
|
||||
sub1 <- insert $ Submission
|
||||
{ submissionSheet = sh1
|
||||
, submissionRatingPoints = Nothing
|
||||
, submissionRatingComment = Nothing
|
||||
, submissionRatingBy = Just gkleen
|
||||
, submissionRatingAssigned = Just now
|
||||
, submissionRatingTime = Nothing
|
||||
}
|
||||
void . insert $ SubmissionEdit maxMuster (nominalDay `addUTCTime` now) sub1
|
||||
void . insert $ SubmissionUser maxMuster sub1
|
||||
sub1fid1 <- insertFile "AbgabeH10-1.hs"
|
||||
void . insert $ SubmissionFile sub1 sub1fid1 False False
|
||||
sub2 <- insert $ Submission sh1 Nothing Nothing Nothing Nothing Nothing
|
||||
void . insert $ SubmissionEdit fhamann now sub2
|
||||
void . insert $ SubmissionUser fhamann sub2
|
||||
sh2 <- insert Sheet
|
||||
{ sheetCourse = pmo
|
||||
, sheetName = "Spezifische Abgabe"
|
||||
, sheetDescription = Nothing
|
||||
, sheetType = Normal $ Points 6
|
||||
, sheetGrouping = Arbitrary 3
|
||||
, sheetMarkingText = Nothing
|
||||
, sheetVisibleFrom = Just now
|
||||
, sheetActiveFrom = now
|
||||
, sheetActiveTo = (14 * nominalDay) `addUTCTime` now
|
||||
, sheetSubmissionMode = SubmissionMode False $ Just UploadSpecific
|
||||
{ specificFiles = impureNonNull $ Set.fromList
|
||||
[ UploadSpecificFile "Aufgabe 1" "exercise_2.1.hs" False
|
||||
, UploadSpecificFile "Aufgabe 2" "exercise_2.2.hs" False
|
||||
, UploadSpecificFile "Erklärung der Eigenständigkeit" "erklärung.txt" True
|
||||
]
|
||||
}
|
||||
, sheetHintFrom = Nothing
|
||||
, sheetSolutionFrom = Nothing
|
||||
, sheetAutoDistribute = True
|
||||
}
|
||||
void . insert $ SheetEdit jost now sh2
|
||||
sh3 <- insert Sheet
|
||||
{ sheetCourse = pmo
|
||||
, sheetName = "Dateiendung-eingeschränkte Abgabe"
|
||||
, sheetDescription = Nothing
|
||||
, sheetType = Normal $ Points 6
|
||||
, sheetGrouping = Arbitrary 3
|
||||
, sheetMarkingText = Nothing
|
||||
, sheetVisibleFrom = Just now
|
||||
, sheetActiveFrom = now
|
||||
, sheetActiveTo = (14 * nominalDay) `addUTCTime` now
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction
|
||||
, sheetHintFrom = Nothing
|
||||
, sheetSolutionFrom = Nothing
|
||||
, sheetAutoDistribute = True
|
||||
}
|
||||
void . insert $ SheetEdit jost now sh3
|
||||
sh4 <- insert Sheet
|
||||
{ sheetCourse = pmo
|
||||
, sheetName = "Uneingeschränkte Abgabe, einzelne Datei"
|
||||
, sheetDescription = Nothing
|
||||
, sheetType = Normal $ Points 6
|
||||
, sheetGrouping = Arbitrary 3
|
||||
, sheetMarkingText = Nothing
|
||||
, sheetVisibleFrom = Just now
|
||||
, sheetActiveFrom = now
|
||||
, sheetActiveTo = (14 * nominalDay) `addUTCTime` now
|
||||
, sheetSubmissionMode = SubmissionMode False . Just $ UploadAny False Nothing
|
||||
, sheetHintFrom = Nothing
|
||||
, sheetSolutionFrom = Nothing
|
||||
, sheetAutoDistribute = True
|
||||
}
|
||||
void . insert $ SheetEdit jost now sh4
|
||||
tut1 <- insert Tutorial
|
||||
{ tutorialName = "Di08"
|
||||
, tutorialCourse = pmo
|
||||
|
||||
@ -7,12 +7,6 @@ import ModelSpec ()
|
||||
import qualified Data.CryptoID as CID
|
||||
import Yesod.EmbeddedStatic
|
||||
|
||||
instance Arbitrary TermId where
|
||||
arbitrary = TermKey <$> arbitrary
|
||||
|
||||
instance Arbitrary SchoolId where
|
||||
arbitrary = SchoolKey <$> arbitrary
|
||||
|
||||
instance Arbitrary (Route Auth) where
|
||||
arbitrary = oneof
|
||||
[ return CheckR
|
||||
|
||||
192
test/Handler/Utils/SubmissionSpec.hs
Normal file
192
test/Handler/Utils/SubmissionSpec.hs
Normal file
@ -0,0 +1,192 @@
|
||||
module Handler.Utils.SubmissionSpec where
|
||||
|
||||
import qualified Yesod
|
||||
|
||||
import TestImport
|
||||
-- import qualified Test.HUnit.Base as HUnit
|
||||
|
||||
import Handler.Utils.Submission
|
||||
import ModelSpec ()
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.List (genericLength)
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import System.IO.Unsafe
|
||||
|
||||
import System.Random.Shuffle
|
||||
import Control.Monad.Random.Class
|
||||
|
||||
import Database.Persist.Sql (fromSqlKey)
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
-- import Data.Maybe (fromJust)
|
||||
|
||||
|
||||
userNumber :: TVar Natural
|
||||
userNumber = unsafePerformIO $ newTVarIO 1
|
||||
{-# NOINLINE userNumber #-}
|
||||
|
||||
makeUsers :: Natural -> SqlPersistM [Entity User]
|
||||
makeUsers (fromIntegral -> n) = do
|
||||
users' <- liftIO . replicateM n $ generate arbitrary
|
||||
users <- forM users' $ \u -> do
|
||||
i <- atomically $ readTVar userNumber <* modifyTVar userNumber succ
|
||||
let u' = u { userIdent = CI.mk $ "user." <> tshow i
|
||||
, userEmail = CI.mk $ "user." <> tshow i <> "@example.com"
|
||||
}
|
||||
return u'
|
||||
uids <- insertMany users
|
||||
return $ zipWith Entity uids users
|
||||
|
||||
distributionExample :: SqlPersistM [(Natural, [Maybe Load])] -- ^ Number of submissions and corrector specification
|
||||
-> ([Entity Submission] -> [Entity SheetCorrector] -> SqlPersistM ()) -- ^ Setup hook
|
||||
-> (Map (Maybe SheetCorrector) (Set SubmissionId) -> Expectation)
|
||||
-> YesodExample UniWorX ()
|
||||
distributionExample mkParameters setupHook cont = do
|
||||
situations <- runDB $ do
|
||||
term <- liftIO $ generate arbitrary
|
||||
void . insert $ term
|
||||
school <- liftIO $ generate arbitrary
|
||||
void . insert $ school
|
||||
course <- liftIO $ generate arbitrary <&> \c -> c { courseTerm = TermKey $ termName term, courseSchool = SchoolKey $ schoolShorthand school }
|
||||
cid <- insert course
|
||||
|
||||
steps <- mkParameters
|
||||
let subsN = maybe 0 maximum . fromNullable $ map fst steps
|
||||
correctorsN = maybe 0 maximum . fromNullable $ map (genericLength . snd) steps
|
||||
participants <- makeUsers subsN
|
||||
correctors <- makeUsers correctorsN
|
||||
|
||||
situations <- forM (zip [1..] steps) $ \(i, (subsN', loads)) -> do
|
||||
sheet <- liftIO $ generate arbitrary <&> \s -> s { sheetName = CI.mk $ "Sheet " <> tshow (i :: Integer), sheetCourse = cid }
|
||||
sid <- insert sheet
|
||||
|
||||
participants' <- liftIO $ take (fromIntegral subsN') <$> shuffleM participants
|
||||
let loads' = loads ++ replicate (fromIntegral $ correctorsN - genericLength loads) Nothing
|
||||
|
||||
submissions <- forM participants' $ \(Entity uid _) -> do
|
||||
sub@(Entity subId _) <- insertEntity $ Submission
|
||||
sid
|
||||
Nothing
|
||||
Nothing
|
||||
Nothing
|
||||
Nothing
|
||||
Nothing
|
||||
void . insert $ SubmissionUser uid subId
|
||||
return sub
|
||||
|
||||
let sheetCorrectors = [ SheetCorrector corr sid load CorrectorNormal | (Entity corr _, Just load) <- zip correctors loads']
|
||||
scIds <- insertMany sheetCorrectors
|
||||
let sheetCorrectors' = zipWith Entity scIds sheetCorrectors
|
||||
|
||||
return (sid, (submissions, sheetCorrectors'))
|
||||
|
||||
mapM_ (uncurry setupHook) $ map snd situations
|
||||
|
||||
return situations
|
||||
|
||||
let subIds = concatMap (\(_, (subs, _)) -> map entityKey subs) situations
|
||||
|
||||
results <- runHandler . Yesod.runDB . mapM (\sid -> assignSubmissions sid Nothing) $ map fst situations
|
||||
|
||||
submissions <- fmap concat . forM results $ \(assigned, unassigned) -> runDB $ selectList ([ SubmissionId <-. Set.toList assigned ] ||. [ SubmissionId <-. Set.toList unassigned ]) []
|
||||
|
||||
liftIO $ do
|
||||
let (assigned, unassigned) = bimap concat concat $ unzip results
|
||||
Set.union assigned unassigned `shouldBe` Set.fromList subIds
|
||||
cont . Map.fromListWith mappend $ do
|
||||
Entity subId Submission{..} <- submissions
|
||||
let key = listToMaybe . filter (\(Entity _ (SheetCorrector uid _ _ _)) -> Just uid == submissionRatingBy) $ concatMap (\(_, (_, corrs)) -> corrs) situations
|
||||
return (entityVal <$> key, Set.singleton subId)
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = withApp . describe "Submission distribution" $ do
|
||||
it "is fair" $
|
||||
distributionExample
|
||||
(return [(500, replicate 10 (Just $ Load Nothing 1))])
|
||||
(\_ _ -> return ())
|
||||
(\result -> do
|
||||
let countResult = Map.map Set.size result
|
||||
countResult `shouldNotSatisfy` Map.member Nothing
|
||||
countResult `shouldSatisfy` all (== 50)
|
||||
)
|
||||
it "follows distribution" $
|
||||
distributionExample
|
||||
(return [(500, replicate 6 (Just $ Load Nothing 1) ++ replicate 2 (Just $ Load Nothing 2))])
|
||||
(\_ _ -> return ())
|
||||
(\result -> do
|
||||
let countResult = Map.map Set.size result
|
||||
countResult `shouldNotSatisfy` Map.member Nothing
|
||||
countResult `shouldSatisfy` all (\(Just (SheetCorrector _ _ (Load _ prop) _), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList
|
||||
)
|
||||
it "follows cumulative distribution over multiple sheets" $ do
|
||||
ns <- liftIO . replicateM 5 . fmap fromInteger $ getRandomR (0, 100)
|
||||
let ns' = ns ++ [500 - sum ns]
|
||||
loads = replicate 6 (Just $ Load Nothing 1) ++ replicate 2 (Just $ Load Nothing 2)
|
||||
distributionExample
|
||||
(return [ (n, loads) | n <- ns' ])
|
||||
(\_ _ -> return ())
|
||||
(\result -> do
|
||||
let countResult = Map.map Set.size result
|
||||
countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> (fromSqlKey sheetCorrectorUser, byProportion sheetCorrectorLoad)) countResult
|
||||
countResult `shouldNotSatisfy` Map.member Nothing
|
||||
countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> (== 50 * prop) $ fromIntegral subsSet) . Map.toList
|
||||
)
|
||||
it "follows non-constant cumulative distribution over multiple sheets" $ do
|
||||
let ns = replicate 4 100
|
||||
loads = do
|
||||
(onesBefore, onesAfter) <- zip [0,2..6] [6,4..0]
|
||||
return $ replicate onesBefore (Just $ Load Nothing 1)
|
||||
++ replicate 2 (Just $ Load Nothing 2)
|
||||
++ replicate onesAfter (Just $ Load Nothing 1)
|
||||
distributionExample
|
||||
(return $ zip ns loads)
|
||||
(\_ _ -> return ())
|
||||
(\result -> do
|
||||
let countResult = Map.map Set.size result
|
||||
countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> fromSqlKey sheetCorrectorUser) countResult
|
||||
countResult `shouldNotSatisfy` Map.member Nothing
|
||||
countResult' `shouldSatisfy` all (\(Just _, subsSet) -> subsSet == 50) . Map.toList
|
||||
)
|
||||
it "handles tutorials with proportion" $ do
|
||||
ns <- liftIO . replicateM 5 . fmap fromInteger $ getRandomR (0, 100)
|
||||
let ns' = ns ++ [500 - sum ns]
|
||||
loads = replicate 6 (Just $ Load (Just True) 1) ++ replicate 2 (Just $ Load (Just True) 2)
|
||||
tutSubIds <- liftIO $ newTVarIO Map.empty
|
||||
distributionExample
|
||||
(return [ (n, loads) | n <- ns' ])
|
||||
(\subs corrs -> do
|
||||
tutSubmissions <- liftIO $ getRandomR (5,10)
|
||||
subs' <- liftIO $ shuffleM subs
|
||||
forM_ (take tutSubmissions subs') $ \(Entity subId Submission{..}) -> do
|
||||
Entity _ SheetCorrector{..} <- liftIO $ uniform corrs
|
||||
atomically . modifyTVar tutSubIds . Map.insertWith mappend sheetCorrectorUser $ Set.singleton subId
|
||||
Sheet{..} <- getJust submissionSheet
|
||||
tut <- liftIO $ generate arbitrary <&> \c -> c { tutorialName = CI.mk $ "Tut for " <> tshow (fromSqlKey subId), tutorialCourse = sheetCourse }
|
||||
tutId <- insert tut
|
||||
void . insert $ Tutor tutId sheetCorrectorUser
|
||||
E.insertSelect . E.from $ \submissionUser -> do
|
||||
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val subId
|
||||
return $ TutorialParticipant E.<# E.val tutId E.<&> (submissionUser E.^. SubmissionUserUser)
|
||||
)
|
||||
(\result -> do
|
||||
let countResult = Map.map Set.size result
|
||||
countResult' = Map.mapKeysWith (+) (fmap $ \SheetCorrector{..} -> (fromSqlKey sheetCorrectorUser, byProportion sheetCorrectorLoad)) countResult
|
||||
countResult' `shouldNotSatisfy` Map.member Nothing
|
||||
countResult' `shouldSatisfy` all (\(Just (_, prop), subsSet) -> fromIntegral subsSet == 50 * prop) . Map.toList
|
||||
|
||||
-- -- Does not currently work, because `User`s are reused within `distributionExample`, so submissions end up having more associated course-tutors, because the same user might be a member of a tutorial created for another submission
|
||||
--
|
||||
-- let subs = fold tutSubIds'
|
||||
-- forM_ subs $ \subId -> do
|
||||
-- let tutors = Map.keysSet $ Map.filter (Set.member subId) tutSubIds'
|
||||
-- assignedTo = Set.map (sheetCorrectorUser . fromJust) . Map.keysSet $ Map.filter (Set.member subId) result
|
||||
-- HUnit.assertEqual ("Submission " <> show (fromSqlKey subId) <> " assigned to multiple correctors") 1 $ Set.size assignedTo
|
||||
-- HUnit.assertEqual ("Submission " <> show (fromSqlKey subId) <> " assigned to non-tutors (" <> show (Set.map fromSqlKey tutors) <> ")") Set.empty (Set.map fromSqlKey $ assignedTo `Set.difference` tutors)
|
||||
)
|
||||
@ -27,7 +27,7 @@ spec = do
|
||||
lawsCheckHspec (Proxy @MailSmtpData)
|
||||
[ eqLaws, ordLaws, showReadLaws, monoidLaws ]
|
||||
lawsCheckHspec (Proxy @MailLanguages)
|
||||
[ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws ]
|
||||
[ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @MailContext)
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ]
|
||||
lawsCheckHspec (Proxy @VerpMode)
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Model.TypesSpec where
|
||||
|
||||
import TestImport
|
||||
@ -12,7 +14,19 @@ import MailSpec ()
|
||||
import System.IO.Unsafe
|
||||
import Yesod.Auth.Util.PasswordStore
|
||||
|
||||
import Database.Persist.Sql (SqlBackend, fromSqlKey, toSqlKey)
|
||||
|
||||
import Text.Blaze.Html
|
||||
import Text.Blaze.Renderer.Text
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Time.Types (WeekDay(..))
|
||||
|
||||
|
||||
instance (Arbitrary a, MonoFoldable a) => Arbitrary (NonNull a) where
|
||||
arbitrary = arbitrary `suchThatMap` fromNullable
|
||||
|
||||
instance Arbitrary Season where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
@ -24,6 +38,14 @@ instance Arbitrary TermIdentifier where
|
||||
return $ TermIdentifier{..}
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary TermId where
|
||||
arbitrary = TermKey <$> arbitrary
|
||||
shrink = map TermKey . shrink . unTermKey
|
||||
|
||||
instance Arbitrary SchoolId where
|
||||
arbitrary = SchoolKey <$> arbitrary
|
||||
shrink = map SchoolKey . shrink . unSchoolKey
|
||||
|
||||
instance Arbitrary Pseudonym where
|
||||
arbitrary = Pseudonym <$> arbitraryBoundedIntegral
|
||||
|
||||
@ -62,7 +84,24 @@ instance Arbitrary SubmissionFileType where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary UploadSpecificFile where
|
||||
arbitrary = UploadSpecificFile
|
||||
<$> (pack . getPrintableString <$> arbitrary)
|
||||
<*> (pack . getPrintableString <$> arbitrary)
|
||||
<*> arbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary UploadMode where
|
||||
arbitrary = oneof
|
||||
[ pure NoUpload
|
||||
, UploadAny
|
||||
<$> arbitrary
|
||||
<*> (fromNullable . Set.fromList . map (pack . getPrintableString) <$> arbitrary)
|
||||
, UploadSpecific <$> arbitrary
|
||||
]
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary UploadModeDescr where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
@ -74,10 +113,6 @@ instance Arbitrary SubmissionModeDescr where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary ExamStatus where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary Load where
|
||||
arbitrary = do
|
||||
byTutorial <- arbitrary
|
||||
@ -149,7 +184,26 @@ instance Arbitrary LecturerType where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary a => Arbitrary (ZIPArchiveName a) where
|
||||
instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Arbitrary (Key record) where
|
||||
arbitrary = toSqlKey <$> arbitrary
|
||||
shrink = map toSqlKey . shrink . fromSqlKey
|
||||
|
||||
instance Arbitrary Html where
|
||||
arbitrary = (preEscapedToHtml :: String -> Html) . getPrintableString <$> arbitrary
|
||||
shrink = map preEscapedToHtml . shrink . renderMarkup
|
||||
|
||||
instance Arbitrary WeekDay where
|
||||
arbitrary = oneof $ map pure [minBound..maxBound]
|
||||
|
||||
instance Arbitrary OccurenceSchedule where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary OccurenceException where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary Occurences where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
@ -177,14 +231,16 @@ spec = do
|
||||
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
|
||||
lawsCheckHspec (Proxy @SubmissionFileType)
|
||||
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, pathPieceLaws, finiteLaws ]
|
||||
lawsCheckHspec (Proxy @UploadSpecificFile)
|
||||
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @UploadMode)
|
||||
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, pathPieceLaws, finiteLaws ]
|
||||
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @UploadModeDescr)
|
||||
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ]
|
||||
lawsCheckHspec (Proxy @SubmissionMode)
|
||||
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, finiteLaws ]
|
||||
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @SubmissionModeDescr)
|
||||
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, finiteLaws, pathPieceLaws ]
|
||||
lawsCheckHspec (Proxy @ExamStatus)
|
||||
[ eqLaws, showReadLaws, ordLaws, boundedEnumLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @Load)
|
||||
[ eqLaws, showReadLaws, ordLaws, jsonLaws, persistFieldLaws, commutativeSemigroupLaws, commutativeMonoidLaws ]
|
||||
lawsCheckHspec (Proxy @Season)
|
||||
@ -205,8 +261,6 @@ spec = do
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ]
|
||||
lawsCheckHspec (Proxy @NotificationSettings)
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @MailLanguages)
|
||||
[ persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @Pseudonym)
|
||||
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, integralLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @AuthTag)
|
||||
@ -215,8 +269,6 @@ spec = do
|
||||
[ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @LecturerType)
|
||||
[ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, finiteLaws, jsonLaws, pathPieceLaws, persistFieldLaws ]
|
||||
lawsCheckHspec (Proxy @(ZIPArchiveName (CI Text)))
|
||||
[ eqLaws, ordLaws, showReadLaws, pathPieceLaws ]
|
||||
|
||||
describe "TermIdentifier" $ do
|
||||
it "has compatible encoding/decoding to/from Text" . property $
|
||||
|
||||
@ -33,6 +33,42 @@ instance Arbitrary EmailAddress where
|
||||
isEmail l d = Email.isValid (makeEmailLike l d)
|
||||
makeEmailLike l d = CBS.concat [l, CBS.singleton '@', d]
|
||||
|
||||
instance Arbitrary Course where
|
||||
arbitrary = genericArbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary Sheet where
|
||||
arbitrary = Sheet
|
||||
<$> arbitrary
|
||||
<*> (CI.mk . pack . getPrintableString <$> arbitrary)
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary Tutorial where
|
||||
arbitrary = Tutorial
|
||||
<$> (CI.mk . pack . getPrintableString <$> arbitrary)
|
||||
<*> arbitrary
|
||||
<*> (CI.mk . pack . getPrintableString <$> arbitrary)
|
||||
<*> (fmap getPositive <$> arbitrary)
|
||||
<*> (pack . getPrintableString <$> arbitrary)
|
||||
<*> arbitrary
|
||||
<*> (fmap (CI.mk . pack . getPrintableString) <$> arbitrary)
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
<*> arbitrary
|
||||
shrink = genericShrink
|
||||
|
||||
instance Arbitrary User where
|
||||
arbitrary = do
|
||||
userIdent <- CI.mk . pack <$> oneof
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user