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

Merge branch 'master' into 'live'

Browse Source 
Master

Closes #203, #193, #212, #118, #204, #207, #202, and #198

See merge request !82
This commit is contained in:
Gregor Kleen 2018-10-24 18:42:22 +02:00
commit be892afff5
115 changed files with 9350 additions and 651 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

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

16
.vscode/tasks.json vendored Normal file
View File

@ -0,0 +1,16 @@
{
// See https://go.microsoft.com/fwlink/?LinkId=733558
// for the documentation about the tasks.json format
"version": "2.0.0",
"tasks": [
{
"label": "echo",
"type": "shell",
"command": "echo Hello",
"group": {
"kind": "build",
"isDefault": true
}
}
]
}

8
ChangeLog.md
View File

@ -1,3 +1,11 @@
* Version 19.10.2018
Benutzer können sich in der Testphase komplett selbst löschen
Hilfe Widget
Benachrichtigungen per eMail für einige Ereignisse
* Version 18.09.2018
Tooltips funktionieren auch ohne JavaScript

4
README.md
View File

@ -83,6 +83,10 @@ The following Description applies to Ubuntu or similar.
ldap: https://wiki.ubuntuusers.de/OpenLDAP_ab_Precise/
Instead of run.sh, use:
stack build --flag uniworx:dev --flag uniworx:library-only
***
# PostgreSQL

19
app/DevelMain.hs
View File

@ -33,13 +33,15 @@ module DevelMain where
import Prelude
import Application (getApplicationRepl, shutdownApp)
import Control.Exception (finally)
import Control.Monad.Catch (finally)
import Control.Monad ((>=>))
import Control.Concurrent
import Data.IORef
import Foreign.Store
import Network.Wai.Handler.Warp
import GHC.Word
import Control.Monad.Trans.Resource
import Control.Monad.IO.Class
-- | Start or restart the server.
-- newStore is from foreign-store.
@ -71,13 +73,14 @@ update = do
-- | Start the server in a separate thread.
start :: MVar () -- ^ Written to when the thread is killed.
-> IO ThreadId
start done = do
(port, site, app) <- getApplicationRepl
forkIO (finally (runSettings (setPort port defaultSettings) app)
-- Note that this implies concurrency
-- between shutdownApp and the next app that is starting.
-- Normally this should be fine
(putMVar done () >> shutdownApp site))
start done = runResourceT $ do
(port, site, app) <- getApplicationRepl
resourceForkIO $ do
finally (liftIO $ runSettings (setPort port defaultSettings) app)
-- Note that this implies concurrency
-- between shutdownApp and the next app that is starting.
-- Normally this should be fine
(liftIO $ putMVar done () >> shutdownApp site)
-- | kill the server
shutdown :: IO ()

12
config/keter_testworx.yml
View File

@ -31,9 +31,21 @@ stanzas:
- DUMMY_LOGIN
- DETAILED_LOGGING
- LOG_ALL
- LOGLEVEL
- ALLOW_DEPRECATED
- PWFILE
- CRYPTOID_KEYFILE
- IP_FROM_HEADER
- MAILFROM_NAME
- MAILFROM_EMAIL
- MAILOBJECT_DOMAIN
- SMTPHOST
- SMTPPORT
- SMTPSSL
- SMTPUSER
- SMTPPASS
- SMTPTIMEOUT
- SMTPLIMIT
# Use the following to automatically copy your bundle upon creation via `yesod
# keter`. Uses `scp` internally, so you can set it to a remote destination

13
config/keter_uni2work.yml
View File

@ -30,9 +30,22 @@ stanzas:
- LDAPTIMEOUT
- DETAILED_LOGGING
- LOG_ALL
- LOGLEVEL
- ALLOW_DEPRECATED
- PWFILE
- CRYPTOID_KEYFILE
- IP_FROM_HEADER
- MAILFROM_NAME
- MAILFROM_EMAIL
- MAILOBJECT_DOMAIN
- SMTPHOST
- SMTPPORT
- SMTPSSL
- SMTPUSER
- SMTPPASS
- SMTPTIMEOUT
- SMTPLIMIT
# Use the following to automatically copy your bundle upon creation via `yesod
# keter`. Uses `scp` internally, so you can set it to a remote destination

41
config/settings.yml
View File

@ -8,10 +8,31 @@ host: "_env:HOST:*4" # any IPv4 host
port: "_env:PORT:3000"
ip-from-header: "_env:IP_FROM_HEADER:false"
approot: "_env:APPROOT:http://localhost:3000"
mail-from:
name: "_env:MAILFROM_NAME:Uni2Work"
email: "_env:MAILFROM_EMAIL:uniworx@localhost"
mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
mail-verp:
separator: "+"
at-replacement: "="
mail-support:
name: null
email: "uni2work@ifi.lmu.de"
detailed-logging: "_env:DETAILED_LOGGING:false"
should-log-all: "_env:LOG_ALL:false"
minimum-log-level: "_env:LOGLEVEL:warn"
job-workers: "_env:JOB_WORKERS:10"
job-flush-interval: "_env:JOB_FLUSH:30"
job-cron-interval: "_env:CRON_INTERVAL:60"
job-stale-threshold: 300
notification-rate-limit: 3600
notification-collate-delay: 300
notification-expiration: 259201
log-settings:
log-detailed: "_env:DETAILED_LOGGING:false"
log-all: "_env:LOG_ALL:false"
log-minimum-level: "_env:LOGLEVEL:warn"
# Debugging
auth-dummy-login: "_env:DUMMY_LOGIN:false"
allow-deprecated: "_env:ALLOW_DEPRECATED:false"
@ -44,6 +65,19 @@ ldap:
scope: "_env:LDAPSCOPE:WholeSubtree"
timeout: "_env:LDAPTIMEOUT:5"
smtp:
host: "_env:SMTPHOST:"
port: "_env:SMTPPORT:25"
ssl: "_env:SMTPSSL:starttls"
auth:
type: "login"
user: "_env:SMTPUSER:"
pass: "_env:SMTPPASS:"
pool:
stripes: "_env:SMTPSTRIPES:1"
timeout: "_env:SMTPTIMEOUT:20"
limit: "_env:SMTPLIMIT:10"
user-defaults:
max-favourites: 12
theme: Default
@ -53,3 +87,4 @@ user-defaults:
download-files: false
cryptoid-keyfile: "_env:CRYPTOID_KEYFILE:cryptoid_key.bf"
instance-idfile: "_env:INSTANCEID_FILE:instance"

4096
config/wordlist.txt Normal file
View File

File diff suppressed because it is too large Load Diff

108
db.hs
View File

@ -1,11 +1,12 @@
#!/usr/bin/env stack
-- stack runghc
-- stack runghc --package uniworx
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
import "uniworx" Import hiding (Option(..))
import "uniworx" Application (db, getAppDevSettings)
@ -20,6 +21,8 @@ import System.IO (hPutStrLn, stderr)
import qualified Data.ByteString as BS
import Database.Persist.Sql (toSqlKey)
import Data.Time
@ -62,6 +65,8 @@ fillDb = do
AppSettings{ appUserDefaults = UserDefaultConf{..}, .. } <- getsYesod appSettings
now <- liftIO getCurrentTime
let
insert' :: PersistRecordBackend r (YesodPersistBackend UniWorX) => r -> YesodDB UniWorX (Key r)
insert' = fmap (either entityKey id) . insertBy
summer2017 = TermIdentifier 2017 Summer
winter2017 = TermIdentifier 2017 Winter
summer2018 = TermIdentifier 2018 Summer
@ -78,6 +83,8 @@ fillDb = do
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userMailLanguages = MailLanguages ["en"]
, userNotificationSettings = def
}
fhamann <- insert User
{ userIdent = "felix.hamann@campus.lmu.de"
@ -92,6 +99,8 @@ fillDb = do
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userMailLanguages = MailLanguages ["de"]
, userNotificationSettings = def
}
jost <- insert User
{ userIdent = "jost@tcs.ifi.lmu.de"
@ -106,8 +115,10 @@ fillDb = do
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userMailLanguages = MailLanguages ["de"]
, userNotificationSettings = def
}
void . insert $ User
maxMuster <- insert User
{ userIdent = "max@campus.lmu.de"
, userAuthentication = AuthLDAP
, userMatrikelnummer = Nothing
@ -120,6 +131,8 @@ fillDb = do
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userMailLanguages = MailLanguages ["de"]
, userNotificationSettings = def
}
void . insert $ User
{ userIdent = "tester@campus.lmu.de"
@ -134,8 +147,10 @@ fillDb = do
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userMailLanguages = MailLanguages ["de"]
, userNotificationSettings = def
}
void . insert $ Term
void . repsert (TermKey summer2017) $ Term
{ termName = summer2017
, termStart = fromGregorian 2017 04 09
, termEnd = fromGregorian 2017 07 14
@ -144,7 +159,7 @@ fillDb = do
, termLectureEnd = fromGregorian 2018 07 14
, termActive = False
}
void . insert $ Term
void . repsert (TermKey winter2017) $ Term
{ termName = winter2017
, termStart = fromGregorian 2017 10 16
, termEnd = fromGregorian 2018 02 10
@ -153,7 +168,7 @@ fillDb = do
, termLectureEnd = fromGregorian 2018 02 10
, termActive = True
}
void . insert $ Term
void . repsert (TermKey summer2018) $ Term
{ termName = summer2018
, termStart = fromGregorian 2018 04 09
, termEnd = fromGregorian 2018 07 14
@ -162,22 +177,28 @@ fillDb = do
, termLectureEnd = fromGregorian 2018 07 14
, termActive = True
}
ifi <- insert $ School "Institut für Informatik" "IfI"
mi <- insert $ School "Institut für Mathematik" "MI"
void . insert $ UserAdmin gkleen ifi
void . insert $ UserAdmin gkleen mi
void . insert $ UserAdmin fhamann ifi
void . insert $ UserAdmin jost ifi
void . insert $ UserAdmin jost mi
void . insert $ UserLecturer gkleen ifi
void . insert $ UserLecturer fhamann ifi
void . insert $ UserLecturer jost ifi
sdBsc <- insert $ StudyDegree 82 (Just "BSc") (Just "Bachelor" )
sdMst <- insert $ StudyDegree 88 (Just "MSc") (Just "Master" )
sdInf <- insert $ StudyTerms 79 (Just "Inf") (Just "Informatik")
sdMath <- insert $ StudyTerms 105 (Just "M" ) (Just "Mathematik")
ifi <- insert' $ School "Institut für Informatik" "IfI"
mi <- insert' $ School "Institut für Mathematik" "MI"
void . insert' $ UserAdmin gkleen ifi
void . insert' $ UserAdmin gkleen mi
void . insert' $ UserAdmin fhamann ifi
void . insert' $ UserAdmin jost ifi
void . insert' $ UserAdmin jost mi
void . insert' $ UserLecturer gkleen ifi
void . insert' $ UserLecturer fhamann ifi
void . insert' $ UserLecturer jost ifi
let
sdBsc = StudyDegreeKey' 82
sdMst = StudyDegreeKey' 88
repsert sdBsc $ StudyDegree 82 (Just "BSc") (Just "Bachelor" )
repsert sdMst $ StudyDegree 88 (Just "MSc") (Just "Master" )
let
sdInf = StudyTermsKey' 79
sdMath = StudyTermsKey' 105
repsert sdInf $ StudyTerms 79 (Just "IfI") (Just "Institut für Informatik")
repsert sdMath $ StudyTerms 105 (Just "MI" ) (Just "Mathematisches Institut")
-- FFP
ffp <- insert Course
ffp <- insert' Course
{ courseName = "Fortgeschrittene Funktionale Programmierung"
, courseDescription = Nothing
, courseLinkExternal = Nothing
@ -186,7 +207,7 @@ fillDb = do
, courseSchool = ifi
, courseCapacity = Just 20
, courseRegisterFrom = Just now
, courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
, courseRegisterTo = Just (nominalDay `addUTCTime` now )
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing
, courseMaterialFree = True
@ -196,14 +217,14 @@ fillDb = do
void . insert $ DegreeCourse ffp sdMst sdInf
void . insert $ Lecturer jost ffp
void . insert $ Lecturer gkleen ffp
sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True)
sheetkey <- insert $ Sheet ffp "AdHoc-Gruppen" Nothing NotGraded (Arbitrary 3) Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
insert_ $ SheetEdit gkleen now sheetkey
sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True)
sheetkey <- insert $ Sheet ffp "Feste Gruppen" Nothing NotGraded RegisteredGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
insert_ $ SheetEdit gkleen now sheetkey
sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True)
sheetkey <- insert $ Sheet ffp "Keine Gruppen" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing (Upload True) UserSubmissions
insert_ $ SheetEdit gkleen now sheetkey
-- EIP
eip <- insert Course
eip <- insert' Course
{ courseName = "Einführung in die Programmierung"
, courseDescription = Nothing
, courseLinkExternal = Nothing
@ -218,10 +239,10 @@ fillDb = do
, courseMaterialFree = True
}
insert_ $ CourseEdit fhamann now eip
void . insert $ DegreeCourse eip sdBsc sdInf
void . insert $ Lecturer fhamann eip
void . insert' $ DegreeCourse eip sdBsc sdInf
void . insert' $ Lecturer fhamann eip
-- interaction design
ixd <- insert Course
ixd <- insert' Course
{ courseName = "Interaction Design (User Experience Design I & II)"
, courseDescription = Nothing
, courseLinkExternal = Nothing
@ -230,16 +251,16 @@ fillDb = do
, courseSchool = ifi
, courseCapacity = Just 20
, courseRegisterFrom = Just now
, courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now )
, courseRegisterTo = Just (nominalDay `addUTCTime` now )
, courseDeregisterUntil = Nothing
, courseRegisterSecret = Nothing
, courseMaterialFree = True
}
insert_ $ CourseEdit fhamann now ixd
void . insert $ DegreeCourse ixd sdBsc sdInf
void . insert $ Lecturer fhamann ixd
void . insert' $ DegreeCourse ixd sdBsc sdInf
void . insert' $ Lecturer fhamann ixd
-- concept development
ux3 <- insert Course
ux3 <- insert' Course
{ courseName = "Concept Development (User Experience Design III)"
, courseDescription = Nothing
, courseLinkExternal = Nothing
@ -254,10 +275,10 @@ fillDb = do
, courseMaterialFree = True
}
insert_ $ CourseEdit fhamann now ux3
void . insert $ DegreeCourse ux3 sdBsc sdInf
void . insert $ Lecturer fhamann ux3
void . insert' $ DegreeCourse ux3 sdBsc sdInf
void . insert' $ Lecturer fhamann ux3
-- promo
pmo <- insert Course
pmo <- insert' Course
{ courseName = "Programmierung und Modellierung"
, courseDescription = Nothing
, courseLinkExternal = Nothing
@ -284,6 +305,7 @@ fillDb = do
, sheetVisibleFrom = Just now
, sheetActiveFrom = now
, sheetActiveTo = (14 * nominalDay) `addUTCTime` now
, sheetSubmissionMode = CorrectorSubmissions
, sheetUploadMode = Upload True
, sheetHintFrom = Nothing
, sheetSolutionFrom = Nothing
@ -297,8 +319,14 @@ fillDb = do
void . insert $ SheetFile sh1 h102 SheetHint
void . insert $ SheetFile sh1 h103 SheetSolution
void . insert $ SheetFile sh1 pdf10 SheetExercise
--
sub1 <- insert $ Submission sh1 Nothing Nothing Nothing Nothing 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
-- datenbanksysteme
dbs <- insert Course
dbs <- insert' Course
{ courseName = "Datenbanksysteme"
, courseDescription = Nothing
, courseLinkExternal = Nothing
@ -313,7 +341,7 @@ fillDb = do
, courseMaterialFree = True
}
insert_ $ CourseEdit gkleen now dbs
void . insert $ DegreeCourse dbs sdBsc sdInf
void . insert $ DegreeCourse dbs sdBsc sdMath
void . insert $ Lecturer gkleen dbs
void . insert $ Lecturer jost dbs
void . insert' $ DegreeCourse dbs sdBsc sdInf
void . insert' $ DegreeCourse dbs sdBsc sdMath
void . insert' $ Lecturer gkleen dbs
void . insert' $ Lecturer jost dbs

2
ghci.sh
View File

@ -16,4 +16,4 @@ if [[ -d .stack-work-ghci ]]; then
trap move-back EXIT
fi
stack ghci --flag uniworx:dev --flag uniworx:library-only
stack ghci --flag uniworx:dev --flag uniworx:library-only ${@}

138
messages/uniworx/de.msg
View File

@ -16,7 +16,7 @@ WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year}
SummerTermShort year@Integer: SoSe #{display year}
WinterTermShort year@Integer: WiSe #{display year}/#{display $ mod (succ year) 100}
PSLimitNonPositive: “pagesize” muss größer als null sein
Page n@Int64: #{display n}
Page num@Int64: #{display num}
TermsHeading: Semesterübersicht
TermCurrent: Aktuelles Semester
@ -91,6 +91,7 @@ SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht w
SheetDelOk tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh}: #{sheetName} gelöscht.
SheetUploadMode: Abgabe von Dateien
SheetSubmissionMode: Abgabe-Modus
SheetExercise: Aufgabenstellung
SheetHint: Hinweis
SheetHintFrom: Hinweis ab
@ -111,6 +112,8 @@ SheetActiveTo: Abgabefrist
SheetHintFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
SheetSolutionFromTip: Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen
SheetMarkingTip: Hinweise zur Korrektur, sichtbar nur für Korrektoren
SheetPseudonym: Persönliches Abgabe-Pseudonym
SheetGeneratePseudonym: Generieren
SheetErrVisibility: Sichtbarkeit muss vor Beginn der Abgabefrist liegen
SheetErrDeadlineEarly: Ende der Abgabefrist muss nach deren Beginn liegen
@ -128,7 +131,7 @@ SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
SubmissionEditHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Abgabe editieren/anlegen
CorrectionHead tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{csh} #{sheetName}: Korrektur
SubmissionMember g@Int: Mitabgebende(r) ##{display g}
SubmissionMember n@Int: Mitabgebende(r) ##{display n}
SubmissionArchive: Zip-Archiv der Abgabedatei(en)
SubmissionFile: Datei zur Abgabe
SubmissionFiles: Abgegebene Dateien
@ -155,11 +158,15 @@ UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
UnauthorizedUserSubmission: Nutzer dürfen für dieses Übungsblatt keine Abgaben erstellen.
UnauthorizedCorrectorSubmission: Korrektoren dürfen für dieses Übungsblatt keine Abgaben erstellen.
OnlyUploadOneFile: Bitte nur eine Datei hochladen.
DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben.
MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar.
UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar.
UnsupportedAuthPredicate tag@String shownRoute@String: "!#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
EMail: E-Mail
@ -193,8 +200,10 @@ LoginTitle: Authentifizierung
ProfileHeading: Benutzereinstellungen
ProfileDataHeading: Gespeicherte Benutzerdaten
ImpressumHeading: Impressum
SystemMessageHeading: Uni2Work Statusmeldung
SystemMessageListHeading: Uni2Work Statusmeldungen
NumCourses n@Int64: #{display n} Kurse
NumCourses num@Int64: #{display num} Kurse
CloseAlert: Schliessen
Name: Name
@ -245,10 +254,13 @@ RatingComment: Kommentar
SubmissionUsers: Studenten
Rating: Korrektur
RatingPoints: Punkte
RatingDone: Bewertung fertiggestellt
RatingPercent: Erreicht
RatingFiles: Korrigierte Dateien
PointsNotPositive: Punktzahl darf nicht negativ sein
RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
ColumnRatingPointsDone: Punktzahl/Abgeschlossen
Pseudonyms: Pseudonyme
FileTitle: Dateiname
FileModified: Letzte Änderung
@ -274,6 +286,7 @@ DateFormat: Datumsformat
TimeFormat: Uhrzeitformat
DownloadFiles: Dateien automatisch herunterladen
DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden).
NotificationSettings: Erwünschte Benachrichtigungen
InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet
AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren
@ -305,7 +318,126 @@ UploadModeNone: Kein Upload
UploadModeUnpack: Upload, einzelne Datei
UploadModeNoUnpack: Upload, ZIP-Archive entpacken
SheetNoSubmission: Keine Abgabe
SheetCorrectorSubmissions: Abgaben durch Korrektoren
SheetUserSubmissions: Direkte Abgabe
SubmissionNoUploadExpected: Es ist keine Abgabe von Dateien vorgesehen.
FieldPrimary: Hauptfach
FieldSecondary: Nebenfach
MailTestFormEmail: Email-Addresse
MailTestFormLanguages: Spracheinstellungen
MailTestSubject: Uni2Work Test-Email
MailTestContent: Dies ist eine Test-Email versandt von Uni2Work. Von Ihrer Seite ist keine Handlung notwendig.
MailTestDateTime: Test der Datumsformattierung:
German: Deutsch
GermanGermany: Deutsch (Deutschland)
MailSubjectSubmissionRated csh@CourseShorthand: Ihre #{csh}-Abgabe wurde korrigiert
MailSubmissionRatedIntro courseName@Text termDesc@Text: Ihre Abgabe im Kurs #{courseName} (#{termDesc}) wurde korrigiert.
MailSubjectSheetActive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} wurde herausgegeben
MailSheetActiveIntro courseName@Text termDesc@Text sheetName@SheetName: Sie können nun #{sheetName} im Kurs #{courseName} (#{termDesc}) herunterladen.
MailSubjectSheetSoonInactive csh@CourseShorthand sheetName@SheetName: #{sheetName} in #{csh} kann nur noch kurze Zeit abgegeben werden
MailSheetSoonInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) endet in Kürze.
MailSubjectSheetInactive csh@CourseShorthand sheetName@SheetName: Abgabfristt für #{sheetName} in #{csh} abgelaufen
MailSheetInactiveIntro courseName@Text termDesc@Text sheetName@SheetName: Die Abgabefirst für #{sheetName} im Kurs #{courseName} (#{termDesc}) beendet.
MailCorrectionsAssignedIntro courseName@Text termDesc@Text sheetName@SheetName n@Int: #{display n} Abgaben wurden Ihnen zur Korrektur für #{sheetName} im Kurs #{courseName} (#{termDesc}) zugeteilt.
MailEditNotifications: Benachrichtigungen ein-/ausschalten
MailSubjectSupport: Supportanfrage
SheetTypeBonus: Bonus
SheetTypeNormal: Normal
SheetTypePass: Bestehen
SheetTypeNotGraded: Keine Wertung
SheetTypeBonus' maxPoints@Points: #{tshow maxPoints} Bonuspunkte
SheetTypeNormal' maxPoints@Points: #{tshow maxPoints} Punkte
SheetTypePass' maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
SheetTypeNotGraded': Nicht gewertet
SheetTypeMaxPoints: Maximalpunktzahl
SheetTypePassingPoints: Notwendig zum Bestehen
SheetGroupArbitrary: Arbiträre Gruppen
SheetGroupRegisteredGroups: Registrierte Gruppen
SheetGroupNoGroups: Keine Gruppenabgabe
SheetGroupMaxGroupsize: Maximale Gruppengröße
SheetFiles: Übungsblatt-Dateien
NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert
NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert
NotificationTriggerSheetActive: Ich kann ein neues Übungsblatt herunterladen
NotificationTriggerSheetSoonInactive: Ich kann ein Übungsblatt bald nicht mehr abgeben
NotificationTriggerSheetInactive: Abgabefrist eines meiner Übungsblätter ist abgelaufen
NotificationCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
CorrCreate: Abgaben erstellen
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
InvalidPseudonym pseudonym@Text: Invalides Pseudonym "#{pseudonym}"
UnknownPseudonym pseudonym@Text: Unbekanntes Pseudonym "#{pseudonym}"
CorrectionPseudonyms: Abgaben-Pseudonyme
CorrectionPseudonymsTip: Eine Abgabe pro Zeile, bei Gruppenabgaben mehrere Pseudonyme (komma-separiert) innerhalb einer Zeile
PseudonymSheet: Übungsblatt
CorrectionPseudonymSheet termDesc@Text csh@CourseShorthand shn@SheetName: #{termDesc} > #{csh} > #{shn}
SheetGroupTooLarge sheetGroupDesc@Text: Abgabegruppe zu groß: #{sheetGroupDesc}
SheetNoRegisteredGroup sheetGroupDesc@Text: "#{sheetGroupDesc}" sind nicht als Gruppe registriert
SheetAmbiguousRegisteredGroup sheetGroupDesc@Text: "#{sheetGroupDesc}" enthält Mitglieder aus verschiedenen registrierten Gruppen
SheetNoGroupSubmission sheetGroupDesc@Text: Gruppenabgabe ist für dieses Blatt nicht vorgesehen (#{sheetGroupDesc})
SheetDuplicatePseudonym: Folgende Pseudonyme kamen mehrfach vor; alle Vorkommen außer dem Ersten wurden ignoriert:
SheetCreateExisting: Folgende Pseudonyme haben bereits abgegeben:
CorrGrade: Korrekturen eintragen
UserAccountDeleted name@Text: Konto für #{name} wurde gelöscht!
HelpAnswer: Antworten an
HelpUser: Meinen Benutzeraccount
HelpAnonymous: Keine Antwort (Anonym)
HelpEMail: E-Mail
HelpRequest: Supportanfrage / Verbesserungsvorschlag
HelpProblemPage: Problematische Seite
HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten.
HelpSent: Ihre Supportanfrage wurde weitergeleitet.
SystemMessageFrom: Sichtbar ab
SystemMessageTo: Sichtbar bis
SystemMessageAuthenticatedOnly: Nur angemeldet
SystemMessageSeverity: Schwere
SystemMessageId: Id
SystemMessageSummaryContent: Zusammenfassung / Inhalt
SystemMessageSummary: Zusammenfassung
SystemMessageContent: Inhalt
SystemMessageLanguage: Sprache
SystemMessageDelete: Löschen
SystemMessageActivate: Sichtbar schalten
SystemMessageDeactivate: Unsichtbar schalten
SystemMessageTimestamp: Zeitpunkt
SystemMessagesDeleted: System-Nachrichten gelöscht:
SystemMessagesActivated: Aktivierungszeitpunkt folgender System-Nachrichten gesetzt:
SystemMessagesDeactivated: Deaktivierungszeitpunkt folgender System-Nachrichten gesetzt:
SystemMessageEmptySelection: Keine System-Nachrichten ausgewählt
SystemMessageAdded sysMsgId@CryptoUUIDSystemMessage: System-Nachricht hinzugefügt: #{toPathPiece sysMsgId}
SystemMessageEdit: Statusmeldung anpassen
SystemMessageEditTranslations: Übersetzungen anpassen
SystemMessageAddTranslation: Übersetzung hinzufügen
SystemMessageEditSuccess: Statusmeldung angepasst.
SystemMessageAddTranslationSuccess: Übersetzung hinzugefügt.
SystemMessageEditTranslationSuccess: Übersetzung angepasst.
SystemMessageDeleteTranslationSuccess: Übersetzung entfernt.
MessageError: Fehler
MessageWarning: Warnung
MessageInfo: Information
MessageSuccess: Erfolg
InvalidLangFormat: Ungültiger Sprach-Code (RFC1766)

39
models
View File

@ -11,6 +11,8 @@ User json
dateFormat DateTimeFormat "default='%d.%m.%Y'"
timeFormat DateTimeFormat "default='%R'"
downloadFiles Bool default=false
mailLanguages MailLanguages "default='[]'"
notificationSettings NotificationSettings
UniqueAuthentication ident
UniqueEmail email
deriving Show
@ -109,11 +111,18 @@ Sheet
hintFrom UTCTime Maybe
solutionFrom UTCTime Maybe
uploadMode UploadMode
submissionMode SheetSubmissionMode default='UserSubmissions'
CourseSheet course name
SheetEdit
user UserId
time UTCTime
sheet SheetId
SheetPseudonym
sheet SheetId
pseudonym Pseudonym
user UserId
UniqueSheetPseudonym sheet pseudonym
UniqueSheetPseudonymUser sheet user
SheetCorrector
user UserId
sheet SheetId
@ -150,7 +159,7 @@ SubmissionFile
isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector
UniqueSubmissionFile file submission isUpdate
deriving Show
SubmissionUser
SubmissionUser -- Actual submission participant
user UserId
submission SubmissionId
UniqueSubmissionUser user submission
@ -161,7 +170,7 @@ SubmissionGroupEdit
user UserId
time UTCTime
submissionGroup SubmissionGroupId
SubmissionGroupUser
SubmissionGroupUser -- Registered submission groups, independent of actual SubmissionUser
submissionGroup SubmissionGroupId
user UserId
UniqueSubmissionGroupUser submissionGroup user
@ -221,3 +230,29 @@ Exam
-- -- CONTINUE HERE: Include rating in this table or separately?
-- UniqueExamUser user examId
-- By default this file is used in Model.hs (which is imported by Foundation.hs)
QueuedJob
content Value
creationInstance InstanceId
creationTime UTCTime
lockInstance InstanceId Maybe
lockTime UTCTime Maybe
deriving Eq Read Show Generic Typeable
CronLastExec
job Value
time UTCTime
instance InstanceId
UniqueCronLastExec job
SystemMessage
from UTCTime Maybe
to UTCTime Maybe
authenticatedOnly Bool
severity MessageClass
defaultLanguage Lang
content Html
summary Html Maybe
SystemMessageTranslation
message SystemMessageId
language Lang
content Html
summary Html Maybe
UniqueSystemMessageTranslation message language

15
package.yaml
View File

@ -77,6 +77,9 @@ dependencies:
- parsec
- uuid
- exceptions
- stm
- stm-chans
- stm-conduit
- lens
- MonadRandom
- email-validate
@ -90,8 +93,20 @@ dependencies:
- connection
- universe
- universe-base
- random
- random-shuffle
- th-abstraction
- HaskellNet
- HaskellNet-SSL
- network
- resource-pool
- mime-mail
- hashable
- aeson-pretty
- resourcet
- postgresql-simple
- word24
- mmorph
# The library contains all of our application code. The executable
# defined below is just a thin wrapper.

14
routes
View File

@ -37,6 +37,7 @@
/admin/user/#CryptoUUIDUser AdminUserR GET
/admin/user/#CryptoUUIDUser/hijack AdminHijackUserR POST
/info VersionR GET !free
/help HelpR GET POST !free
/profile ProfileR GET POST !free !free
/profile/data ProfileDataR GET POST !free !free
@ -72,7 +73,7 @@
/edit SEditR GET POST
/delete SDelR GET POST
/subs SSubsR GET POST -- for lecturer only
/subs/new SubmissionNewR GET POST !timeANDregistered
/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions
/subs/own SubmissionOwnR GET !free -- just redirect
/sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead:
/ SubShowR GET POST !ownerANDtime !ownerANDisRead
@ -80,11 +81,18 @@
/correction CorrectionR GET POST !corrector !ownerANDisReadANDrated
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner
/correctors SCorrR GET POST
/pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions
!/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
/corrections CorrectionsR GET POST !corrector !lecturer
/corrections/upload CorrectionsUploadR GET POST !corrector !lecturer
/submissions CorrectionsR GET POST !corrector !lecturer
/submissions/upload CorrectionsUploadR GET POST !corrector !lecturer
/submissions/create CorrectionsCreateR GET POST !corrector !lecturer
/submissions/grade CorrectionsGradeR GET POST !corrector !lecturer
/msgs MessageListR GET POST
/msg/#{CryptoUUIDSystemMessage} MessageR GET POST !timeANDisReadANDauthentication
!/#UUID CryptoUUIDDispatchR GET !free -- just redirect

205
src/Application.hs
View File

@ -5,6 +5,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
( getApplicationDev, getAppDevSettings
@ -13,6 +14,7 @@ module Application
, makeFoundation
, makeLogWare
-- * for DevelMain
, foundationStoreNum
, getApplicationRepl
, shutdownApp
-- * for GHCI
@ -21,7 +23,7 @@ module Application
, addPWEntry
) where
import Control.Monad.Logger (liftLoc, runLoggingT)
import Control.Monad.Logger (liftLoc, LoggingT(..), MonadLoggerIO(..))
import Database.Persist.Postgresql (createPostgresqlPool, pgConnStr,
pgPoolSize, runSqlPool)
import Import
@ -38,12 +40,34 @@ import Network.Wai.Middleware.RequestLogger (Destination (Logger),
import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
toLogStr)
import Foreign.Store
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import System.Directory
import System.FilePath
import Jobs
import qualified Data.Text.Encoding as Text
import Yesod.Auth.Util.PasswordStore
import qualified Data.ByteString.Char8 as BS
import qualified Data.Yaml as Yaml
import qualified Data.ByteString.Lazy as LBS
import Network.HaskellNet.SSL hiding (Settings)
import Network.HaskellNet.SMTP.SSL as SMTP hiding (Settings)
import Data.Pool
import Control.Monad.Trans.Resource
import System.Log.FastLogger.Date
import qualified Yesod.Core.Types as Yesod (Logger(..))
import qualified Data.HashMap.Strict as HashMap
import Control.Lens ((&))
-- Import all relevant handler modules here.
-- (HPack takes care to add new modules to our cabal file nowadays.)
import Handler.Common
@ -58,6 +82,7 @@ import Handler.Sheet
import Handler.Submission
import Handler.Corrections
import Handler.CryptoIDDispatch
import Handler.SystemMessage
-- This line actually creates our YesodDispatch instance. It is the second half
@ -69,70 +94,140 @@ mkYesodDispatch "UniWorX" resourcesUniWorX
-- performs initialization and returns a foundation datatype value. This is also
-- the place to put your migrate statements to have automatic database
-- migrations handled by Yesod.
makeFoundation :: AppSettings -> IO UniWorX
makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX
makeFoundation appSettings@(AppSettings{..}) = do
-- Some basic initializations: HTTP connection manager, logger, and static
-- subsite.
appHttpManager <- newManager
appLogger <- newStdoutLoggerSet defaultBufSize >>= makeYesodLogger
appStatic <-
(if appMutableStatic then staticDevel else static)
appStaticDir
appLogger <- liftIO $ do
tgetter <- newTimeCache "%Y-%m-%d %T %z"
loggerSet <- newStdoutLoggerSet defaultBufSize
return $ Yesod.Logger loggerSet tgetter
appStatic <- liftIO $ bool static staticDevel appMutableStatic appStaticDir
appCryptoIDKey <- readKeyFile appCryptoIDKeyFile
appInstanceID <- liftIO $ maybe UUID.nextRandom readInstanceIDFile appInstanceIDFile
(appJobCtl, recvChans) <- fmap unzip . atomically . replicateM appJobWorkers $ do
chan <- newBroadcastTMChan
recvChan <- dupTMChan chan
return (chan, recvChan)
appLogSettings <- liftIO $ newTVarIO appInitialLogSettings
-- 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
-- logging function. To get out of this loop, we initially create a
-- temporary foundation without a real connection pool, get a log function
-- from there, and then create the real foundation.
let mkFoundation appConnPool = UniWorX {..}
let mkFoundation appConnPool appSmtpPool = UniWorX {..}
-- The UniWorX {..} syntax is an example of record wild cards. For more
-- information, see:
-- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
tempFoundation = mkFoundation $ error "connPool forced in tempFoundation"
tempFoundation = mkFoundation (error "connPool forced in tempFoundation") (error "smtpPool forced in tempFoundation")
logFunc = messageLoggerSource tempFoundation appLogger
-- Create the database connection pool
pool <- flip runLoggingT logFunc $ createPostgresqlPool
flip runLoggingT logFunc $ do
$logDebugS "InstanceID" $ UUID.toText appInstanceID
-- $logDebugS "Configuration" $ tshow appSettings
smtpPool <- traverse createSmtpPool appSmtpConf
-- Create the database connection pool
sqlPool <- createPostgresqlPool
(pgConnStr appDatabaseConf)
(pgPoolSize appDatabaseConf)
-- Perform database migration using our application's logging settings.
migrateAll `runSqlPool` sqlPool
-- Perform database migration using our application's logging settings.
runLoggingT (runSqlPool migrateAll pool) logFunc
handleJobs recvChans $ mkFoundation sqlPool smtpPool
-- Return the foundation
return $ mkFoundation pool
-- Return the foundation
return $ mkFoundation sqlPool smtpPool
readInstanceIDFile :: MonadIO m => FilePath -> m UUID
readInstanceIDFile idFile = liftIO . handle generateInstead $ LBS.readFile idFile >>= parseBS
where
parseBS :: LBS.ByteString -> IO UUID
parseBS = maybe (throwString "appInstanceIDFile does not contain an UUID encoded in network byte order") return . UUID.fromByteString
generateInstead :: IOException -> IO UUID
generateInstead e
| isDoesNotExistError e = do
createDirectoryIfMissing True $ takeDirectory idFile
instanceId <- UUID.nextRandom
LBS.writeFile idFile $ UUID.toByteString instanceId
return instanceId
| otherwise = throw e
createSmtpPool :: MonadLoggerIO m => SmtpConf -> m SMTPPool
createSmtpPool SmtpConf{ smtpPool = ResourcePoolConf{..}, .. } = do
logFunc <- askLoggerIO
let
withLogging :: LoggingT IO a -> IO a
withLogging = flip runLoggingT logFunc
mkConnection = withLogging $ do
$logInfoS "SMTP" "Opening new connection"
liftIO mkConnection'
mkConnection'
| SmtpSslNone <- smtpSsl = connectSMTPPort smtpHost smtpPort
| SmtpSslSmtps <- smtpSsl = connectSMTPSSLWithSettings smtpHost $ defaultSettingsWithPort smtpPort
| SmtpSslStarttls <- smtpSsl = connectSMTPSTARTTLSWithSettings smtpHost $ defaultSettingsWithPort smtpPort
reapConnection conn = withLogging $ do
$logDebugS "SMTP" "Closing connection"
liftIO $ closeSMTP conn
applyAuth :: SmtpAuthConf -> SMTPConnection -> IO SMTPConnection
applyAuth SmtpAuthConf{..} conn = withLogging $ do
$logDebugS "SMTP" "Doing authentication"
authSuccess <- liftIO $ SMTP.authenticate smtpAuthType smtpAuthUsername smtpAuthPassword conn
when (not authSuccess) $ do
fail "SMTP authentication failed"
return conn
liftIO $ createPool (mkConnection >>= maybe return applyAuth smtpAuth) reapConnection poolStripes poolTimeout poolLimit
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.
makeApplication :: UniWorX -> IO Application
makeApplication foundation = do
makeApplication :: MonadIO m => UniWorX -> m Application
makeApplication foundation = liftIO $ do
logWare <- makeLogWare foundation
-- Create the WAI application and apply middlewares
appPlain <- toWaiAppPlain foundation
return $ logWare $ defaultMiddlewaresNoLogging appPlain
makeLogWare :: UniWorX -> IO Middleware
makeLogWare foundation =
mkRequestLogger def
{ outputFormat =
if appDetailedRequestLogging $ appSettings foundation
then Detailed True
else Apache
(if appIpFromHeader $ appSettings foundation
then FromFallback
else FromSocket)
, destination = Logger $ loggerSet $ appLogger foundation
}
makeLogWare :: MonadIO m => UniWorX -> m Middleware
makeLogWare app = do
logWareMap <- liftIO $ newTVarIO HashMap.empty
let
mkLogWare ls@LogSettings{..} = do
logWare <- mkRequestLogger def
{ outputFormat = bool
(Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app)
(Detailed True)
logDetailed
, destination = Logger . loggerSet $ appLogger app
}
atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare
return logWare
void. liftIO $
mkLogWare =<< readTVarIO (appLogSettings app)
return $ \wai req fin -> do
lookupRes <- atomically $ do
ls <- readTVar $ appLogSettings app
existing <- HashMap.lookup ls <$> readTVar logWareMap
return $ maybe (Left ls) Right existing
logWare <- either mkLogWare return lookupRes
logWare wai req fin
-- | Warp settings for the given foundation value.
warpSettings :: UniWorX -> Settings
warpSettings foundation =
setPort (appPort $ appSettings foundation)
$ setHost (appHost $ appSettings foundation)
$ setOnException (\_req e ->
warpSettings foundation = defaultSettings
& setPort (appPort $ appSettings foundation)
& setHost (appHost $ appSettings foundation)
& setOnException (\_req e ->
when (defaultShouldDisplayException e) $ messageLoggerSource
foundation
(appLogger foundation)
@ -140,29 +235,30 @@ warpSettings foundation =
"yesod"
LevelError
(toLogStr $ "Exception from Warp: " ++ show e))
defaultSettings
-- | For yesod devel, return the Warp settings and WAI Application.
getApplicationDev :: IO (Settings, Application)
getApplicationDev :: (MonadResource m, MonadBaseControl IO m) => m (Settings, Application)
getApplicationDev = do
settings <- getAppDevSettings
foundation <- makeFoundation settings
wsettings <- getDevSettings $ warpSettings foundation
wsettings <- liftIO . getDevSettings $ warpSettings foundation
app <- makeApplication foundation
return (wsettings, app)
getAppDevSettings :: IO AppSettings
getAppDevSettings = loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
getAppDevSettings :: MonadIO m => m AppSettings
getAppDevSettings = liftIO $ loadYamlSettings [configSettingsYml] [configSettingsYmlValue] useEnv
-- | main function for use by yesod devel
develMain :: IO ()
develMain = develMainHelper getApplicationDev
develMain = runResourceT $
liftIO . develMainHelper . return =<< getApplicationDev
-- | The @main@ function for an executable running this site.
appMain :: IO ()
appMain = do
appMain :: MonadResourceBase m => m ()
appMain = runResourceT $ do
-- Get the settings from all relevant sources
settings <- loadYamlSettingsArgs
settings <- liftIO $
loadYamlSettingsArgs
-- fall back to compile-time values, set to [] to require values at runtime
[configSettingsYmlValue]
@ -176,22 +272,31 @@ appMain = do
app <- makeApplication foundation
-- Run the application with Warp
runSettings (warpSettings foundation) app
liftIO $ runSettings (warpSettings foundation) app
--------------------------------------------------------------
-- Functions for DevelMain.hs (a way to run the app from GHCi)
--------------------------------------------------------------
getApplicationRepl :: IO (Int, UniWorX, Application)
foundationStoreNum :: Word32
foundationStoreNum = 2
getApplicationRepl :: (MonadResource m, MonadBaseControl IO m) => m (Int, UniWorX, Application)
getApplicationRepl = do
settings <- getAppDevSettings
foundation <- makeFoundation settings
wsettings <- getDevSettings $ warpSettings foundation
wsettings <- liftIO . getDevSettings $ warpSettings foundation
app1 <- makeApplication foundation
let foundationStore = Store foundationStoreNum
liftIO $ deleteStore foundationStore
liftIO $ writeStore foundationStore foundation
return (getPort wsettings, foundation, app1)
shutdownApp :: UniWorX -> IO ()
shutdownApp _ = return ()
shutdownApp :: MonadIO m => UniWorX -> m ()
shutdownApp UniWorX{..} = do
liftIO . atomically $ mapM_ closeTMChan appJobCtl
---------------------------------------------
@ -200,7 +305,7 @@ shutdownApp _ = return ()
-- | Run a handler
handler :: Handler a -> IO a
handler h = getAppDevSettings >>= makeFoundation >>= flip unsafeHandler h
handler h = runResourceT $ getAppDevSettings >>= makeFoundation >>= liftIO . flip unsafeHandler h
-- | Run DB queries
db :: ReaderT SqlBackend (HandlerT UniWorX IO) a -> IO a
@ -209,7 +314,7 @@ db = handler . runDB
addPWEntry :: User
-> Text {-^ Password -}
-> IO ()
addPWEntry User{..} (Text.encodeUtf8 -> pw) = db $ do
addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db $ do
PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings
(AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
void $ insert User{..}

258
src/Cron.hs Normal file
View File

@ -0,0 +1,258 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, PatternGuards
, ViewPatterns
, DeriveFunctor
, TemplateHaskell
, NamedFieldPuns
#-}
module Cron
( CronNextMatch(..)
, nextCronMatch
, module Cron.Types
) where
import ClassyPrelude
import Prelude (lcm)
import Cron.Types
import Data.Time
import Data.Time.Calendar.OrdinalDate (toOrdinalDate, fromOrdinalDateValid)
import Data.Time.Calendar.WeekDate (toWeekDate, fromWeekDate, fromWeekDateValid)
import Data.Time.Zones
import Numeric.Natural
import Data.Ratio ((%))
import qualified Data.Set as Set
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Utils.Lens.TH
import Control.Lens
data CronDate = CronDate
{ cdYear, cdWeekOfYear, cdDayOfYear
, cdMonth, cdWeekOfMonth, cdDayOfMonth
, cdDayOfWeek
, cdHour, cdMinute, cdSecond :: Natural
} deriving (Eq, Show, Read)
makeLenses_ ''CronDate
evalCronMatch :: CronMatch -> Natural -> Bool
evalCronMatch CronMatchAny _ = True
evalCronMatch CronMatchNone _ = False
evalCronMatch (CronMatchSome set) x = Set.member x $ toNullable set
evalCronMatch (CronMatchStep step) x = (x `mod` step) == 0
evalCronMatch (CronMatchContiguous from to) x = from <= x && x <= to
evalCronMatch (CronMatchIntersect a b) x = evalCronMatch a x && evalCronMatch b x
evalCronMatch (CronMatchUnion a b) x = evalCronMatch a x || evalCronMatch b x
toCronDate :: LocalTime -> CronDate
toCronDate LocalTime{..} = CronDate{..}
where
(fromInteger -> cdYear, fromIntegral -> cdMonth, fromIntegral -> cdDayOfMonth)
= toGregorian localDay
(_, fromIntegral -> cdDayOfYear)
= toOrdinalDate localDay
(_, fromIntegral -> cdWeekOfYear, fromIntegral -> cdDayOfWeek)
= toWeekDate localDay
cdWeekOfMonth = go 1 localDay
where
go :: Natural -> Day -> Natural
go n day
| dow /= 4 = go n $ fromWeekDate y w 4 -- According to ISO week of month is determined by Thursday
| m == m' = go (succ n) day'
| otherwise = n
where
(y, w, dow) = toWeekDate day
day'
| w /= 0 = fromWeekDate y (pred w) dow
| otherwise = fromWeekDate (pred y) 53 dow
(_, m, _) = toGregorian day
(_, m', _) = toGregorian day'
TimeOfDay
{ todHour = fromIntegral -> cdHour
, todMin = fromIntegral -> cdMinute
, todSec = round -> cdSecond
} = localTimeOfDay
consistentCronDate :: CronDate -> Bool
consistentCronDate cd@CronDate{ cdWeekOfMonth = _, ..} = fromMaybe False $ do
gDay <- fromGregorianValid (fromIntegral cdYear) (fromIntegral cdMonth) (fromIntegral cdDayOfMonth)
wDay <- fromWeekDateValid (fromIntegral cdYear) (fromIntegral cdWeekOfYear) (fromIntegral cdDayOfWeek)
guard $ gDay == wDay
oDay <- fromOrdinalDateValid (fromIntegral cdYear) (fromIntegral cdDayOfYear)
guard $ wDay == oDay
guard $ ((==) `on` cdWeekOfMonth) cd (toCronDate $ LocalTime wDay (error "TimeOfDay inspected in toCronDate"))
return True
data CronNextMatch a = MatchAsap | MatchAt a | MatchNone
deriving (Eq, Ord, Show, Read, Functor)
instance Applicative CronNextMatch where
pure = MatchAt
_ <*> MatchNone = MatchNone
MatchNone <*> _ = MatchNone
_ <*> MatchAsap = MatchAsap
MatchAsap <*> _ = MatchAsap
MatchAt f <*> MatchAt x = MatchAt $ f x
instance Alternative CronNextMatch where
empty = MatchNone
x <|> MatchNone = x
MatchNone <|> x = x
_ <|> MatchAsap = MatchAsap
MatchAsap <|> _ = MatchAsap
(MatchAt a) <|> (MatchAt _) = MatchAt a
listToMatch :: [a] -> CronNextMatch a
listToMatch [] = MatchNone
listToMatch (t:_) = MatchAt t
genMatch :: Int -- ^ Period
-> Bool -- ^ Modular
-> Natural -- ^ Start value
-> CronMatch
-> [Natural]
genMatch p m st CronMatchAny = take p $ map (bool id (succ . (`mod` fromIntegral p)) m) [st..]
genMatch _ _ _ CronMatchNone = []
genMatch p m _ (CronMatchSome set) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) . Set.toAscList $ toNullable set
genMatch p m st (CronMatchStep step) = do
start <- [st..st + step]
guard $ (start `mod` step) == 0
take (ceiling $ fromIntegral p % step) $ map (bool id (succ . (`mod` fromIntegral p)) m) [start,start + step..]
genMatch p m st (CronMatchContiguous from to) = take p . map (bool id (succ . (`mod` fromIntegral p)) m) $ [max st from..to]
genMatch _ _ _ (CronMatchIntersect CronMatchNone _) = []
genMatch _ _ _ (CronMatchIntersect _ CronMatchNone) = []
genMatch p m st (CronMatchIntersect CronMatchAny other) = genMatch p m st other
genMatch p m st (CronMatchIntersect other CronMatchAny) = genMatch p m st other
genMatch p m st (CronMatchIntersect (CronMatchStep st1) (CronMatchStep st2))
= genMatch p m st . CronMatchStep $ lcm st1 st2
genMatch p m st (CronMatchIntersect aGen bGen)
| [] <- as' = []
| (a:as) <- as' = mergeAnd (a:as) (genMatch p m a bGen)
where
as' = genMatch p m st aGen
mergeAnd [] _ = []
mergeAnd _ [] = []
mergeAnd (a:as) (b:bs)
| a < b = mergeAnd as (b:bs)
| a == b = a : mergeAnd as bs
| a > b = mergeAnd (a:as) bs
genMatch p m st (CronMatchUnion CronMatchNone other) = genMatch p m st other
genMatch p m st (CronMatchUnion other CronMatchNone) = genMatch p m st other
genMatch p m st (CronMatchUnion CronMatchAny _) = genMatch p m st CronMatchAny
genMatch p m st (CronMatchUnion _ CronMatchAny) = genMatch p m st CronMatchAny
genMatch p m st (CronMatchUnion aGen bGen) = merge (genMatch p m st aGen) (genMatch p m st bGen)
where
merge [] bs = bs
merge as [] = as
merge (a:as) (b:bs)
| a < b = a : merge as (b:bs)
| a == b = a : merge as bs
| a > b = b : merge (a:as) bs
nextCronMatch :: TZ -- ^ Timezone of the `Cron`-Entry
-> Maybe UTCTime -- ^ Time of last execution of the job
-> UTCTime -- ^ Current time, used only for `CronCalendar`
-> Cron
-> CronNextMatch UTCTime
nextCronMatch tz mPrev now c@Cron{..} = case notAfter of
MatchAsap -> MatchNone
MatchAt ts
| MatchAt ts' <- nextMatch
, ts' <= ts -> MatchAt ts'
| MatchAsap <- nextMatch
, now <= ts -> MatchAsap
| otherwise -> MatchNone
MatchNone -> nextMatch
where
nextMatch = nextCronMatch' tz mPrev now c
notAfter
| Right c' <- cronNotAfter
, Just ref <- notAfterRef
= execRef' ref False c'
| Left diff <- cronNotAfter
, Just ref <- notAfterRef
= MatchAt $ diff `addUTCTime` ref
| otherwise = MatchNone
notAfterRef
| Just prevT <- mPrev = Just prevT
| otherwise = case execRef' now False cronInitial of
MatchAt t -> Just t
MatchNone -> Nothing
nextCronMatch' tz mPrev now c@Cron{..}
| isNothing mPrev
= execRef now False cronInitial
| Just prevT <- mPrev
= case cronRepeat of
CronRepeatOnChange
| not $ matchesCron tz Nothing prevT c
-> let
cutoffTime = addUTCTime cronRateLimit prevT
in case execRef now False cronInitial of
MatchAsap
| now < cutoffTime -> MatchAt cutoffTime
MatchAt ts
| ts < cutoffTime -> MatchAt cutoffTime
other -> other
CronRepeatScheduled cronNext
-> case cronNext of
CronAsap
| addUTCTime cronRateLimit prevT <= now
-> MatchAsap
| otherwise
-> MatchAt $ addUTCTime cronRateLimit prevT
cronNext
-> execRef (addUTCTime cronRateLimit prevT) True cronNext
_other -> MatchNone
execRef ref wasExecd cronAbsolute = case execRef' ref wasExecd cronAbsolute of
MatchAt t
| t <= ref -> MatchAsap
other -> other
execRef' ref wasExecd cronAbsolute = case cronAbsolute of
CronAsap -> MatchAt ref
CronTimestamp{ cronTimestamp = localTimeToUTCTZ tz -> ts }
| ref <= ts || not wasExecd -> MatchAt ts
| otherwise -> MatchNone
CronCalendar{..} -> listToMatch $ do
let CronDate{..} = toCronDate $ utcToLocalTimeTZ tz ref
cronYear <- genMatch 400 False cdYear cronYear
cronWeekOfYear <- genMatch 53 True cdWeekOfYear cronWeekOfYear
cronDayOfYear <- genMatch 366 True cdDayOfYear cronDayOfYear
cronMonth <- genMatch 12 True cdMonth cronMonth
cronWeekOfMonth <- genMatch 5 True cdWeekOfMonth cronWeekOfMonth
cronDayOfMonth <- genMatch 31 True cdDayOfMonth cronDayOfMonth
cronDayOfWeek <- genMatch 7 True cdDayOfWeek cronDayOfWeek
cronHour <- genMatch 24 True cdHour cronHour
cronMinute <- genMatch 60 True cdMinute cronMinute
cronSecond <- genMatch 60 True cdSecond cronSecond
guard $ consistentCronDate CronDate{..}
localDay <- maybeToList $ fromGregorianValid (fromIntegral cronYear) (fromIntegral cronMonth) (fromIntegral cronDayOfMonth)
let localTimeOfDay = TimeOfDay (fromIntegral cronHour) (fromIntegral cronMinute) (fromIntegral cronSecond)
return $ localTimeToUTCTZ tz LocalTime{..}
CronNotScheduled -> MatchNone
matchesCron :: TZ -- ^ Timezone of the `Cron`-Entry
-> Maybe UTCTime -- ^ Previous execution of the job
-> UTCTime -- ^ "Current" time
-> Cron
-> Bool
-- ^ @matchesCron tz prev prec now c@ determines whether the given `Cron`
-- specification @c@ should match @now@, under the assumption that the next
-- check will occur no earlier than @now + prec@.
matchesCron tz mPrev now cron = case nextCronMatch tz mPrev now cron of
MatchAsap -> True
MatchNone -> False
MatchAt ts -> ts <= now

66
src/Cron/Types.hs Normal file
View File

@ -0,0 +1,66 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
, DuplicateRecordFields
#-}
module Cron.Types
( Cron(..), Crontab
, CronMatch(..)
, CronAbsolute(..)
, CronRepeat(..)
) where
import ClassyPrelude
import Utils.Lens.TH
import Data.Time
import Numeric.Natural
import Data.HashMap.Strict (HashMap)
data CronMatch
= CronMatchAny
| CronMatchNone
| CronMatchSome (NonNull (Set Natural))
| CronMatchStep Natural
| CronMatchContiguous Natural Natural
| CronMatchIntersect CronMatch CronMatch
| CronMatchUnion CronMatch CronMatch
deriving (Eq, Show, Read)
data CronAbsolute
= CronAsap
| CronTimestamp
{ cronTimestamp :: LocalTime
}
| CronCalendar
{ cronYear, cronWeekOfYear, cronDayOfYear
, cronMonth, cronWeekOfMonth, cronDayOfMonth
, cronDayOfWeek
, cronHour, cronMinute, cronSecond :: CronMatch
}
| CronNotScheduled
deriving (Eq, Show, Read)
makeLenses_ ''CronAbsolute
data CronRepeat
= CronRepeatOnChange
| CronRepeatScheduled CronAbsolute
| CronRepeatNever
deriving (Eq, Show, Read)
data Cron = Cron
{ cronInitial :: CronAbsolute
, cronRepeat :: CronRepeat
, cronRateLimit :: NominalDiffTime
, cronNotAfter :: Either NominalDiffTime CronAbsolute
}
deriving (Eq, Show)
makeLenses_ ''Cron
type Crontab a = HashMap a Cron

3
src/CryptoID.hs
View File

@ -38,6 +38,9 @@ import qualified Data.CaseInsensitive as CI
decCryptoIDs [ ''SubmissionId
, ''FileId
, ''UserId
, ''SheetId
, ''SystemMessageId
, ''SystemMessageTranslationId
]
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where

16
src/Data/Universe/Instances/Reverse/Hashable.hs Normal file
View File

@ -0,0 +1,16 @@
{-# LANGUAGE NoImplicitPrelude
, ScopedTypeVariables
#-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Universe.Instances.Reverse.Hashable
(
) where
import ClassyPrelude
import Data.Universe
instance (Hashable a, Hashable b, Finite a) => Hashable (a -> b) where
hashWithSalt s f = s `hashWithSalt` [ (k, f k) | k <- universeF ]

30
src/Data/Universe/Instances/Reverse/JSON.hs Normal file
View File

@ -0,0 +1,30 @@
{-# LANGUAGE NoImplicitPrelude
, ScopedTypeVariables
#-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Data.Universe.Instances.Reverse.JSON
(
) where
import ClassyPrelude
import Data.Aeson
import Data.Aeson.Types (Parser)
import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
import Data.HashMap.Strict ((!))
import Data.Universe
instance (Eq a, Hashable a, Finite a, ToJSON b, ToJSONKey a) => ToJSON (a -> b) where
toJSON f = toJSON $ HashMap.fromList [(k, f k) | k <- universeF]
instance (Eq a, Hashable a, Finite a, FromJSON b, FromJSONKey a) => FromJSON (a -> b) where
parseJSON val = do
vMap <- parseJSON val :: Parser (HashMap a b)
unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $
fail "Not all required keys found"
return $ (vMap !)

329
src/Foundation.hs
View File

@ -20,12 +20,12 @@ import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Text.Hamlet (hamletFile)
import Text.Jasmine (minifym)
-- Used only when in "auth-dummy-login" setting is enabled.
import Yesod.Auth.Message
import Yesod.Auth.Dummy
import Auth.LDAP
import Auth.PWHash
import Auth.Dummy
import Jobs.Types
import qualified Network.Wai as W (requestMethod, pathInfo)
@ -56,9 +56,11 @@ import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map, (!?))
import qualified Data.Map as Map
import Data.List (findIndex)
import Data.Monoid (Any(..))
import Data.Pool
import Data.Conduit (($$))
import Data.Conduit.List (sourceList)
@ -67,7 +69,7 @@ import qualified Database.Esqueleto as E
import Control.Monad.Except (MonadError(..), runExceptT)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.Reader (runReader)
import Control.Monad.Trans.Reader (runReader, mapReaderT)
import Control.Monad.Trans.Writer (WriterT(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Catch (handleAll)
@ -81,13 +83,19 @@ import Control.Lens
import Utils
import Utils.Form
import Utils.Lens
import Utils.SystemMessage
import Data.Aeson hiding (Error)
import Data.Aeson hiding (Error, Success)
import Data.Aeson.TH
import qualified Data.Yaml as Yaml
import Text.Shakespeare.Text (st)
import Yesod.Form.I18n.German
import qualified Yesod.Auth.Message as Auth
import qualified Data.Conduit.List as C
instance DisplayAble b => DisplayAble (E.CryptoID a b) where
display = display . ciphertext
@ -112,11 +120,17 @@ data UniWorX = UniWorX
{ appSettings :: AppSettings
, appStatic :: Static -- ^ Settings for static file serving.
, appConnPool :: ConnectionPool -- ^ Database connection pool.
, appSmtpPool :: Maybe SMTPPool
, appHttpManager :: Manager
, appLogger :: Logger
, appLogSettings :: TVar LogSettings
, appCryptoIDKey :: CryptoIDKey
, appInstanceID :: InstanceId
, appJobCtl :: [TMChan JobCtl]
}
type SMTPPool = Pool SMTPConnection
-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/routing-and-handlers
@ -135,6 +149,7 @@ mkYesodData "UniWorX" $(parseRoutesFile "routes")
type DB a = YesodDB UniWorX a
type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
type MsgRenderer = MsgRendererS UniWorX -- see Utils
type MailM a = MailT (HandlerT UniWorX IO) a
-- Pattern Synonyms for convenience
pattern CSheetR tid ssh csh shn ptn
@ -146,9 +161,10 @@ pattern CSubmissionR tid ssh csh shn cid ptn
-- Menus and Favourites
data MenuItem = MenuItem
{ menuItemLabel :: Text
, menuItemIcon :: Maybe Text
, menuItemIcon :: Maybe Text -- currently from: https://fontawesome.com/icons?d=gallery
, menuItemRoute :: Route UniWorX
, menuItemAccessCallback' :: Handler Bool -- Check whether action is shown in ADDITION to authorization (which is always checked)
, menuItemModal :: Bool
}
menuItemAccessCallback :: MenuItem -> Handler Bool
@ -173,7 +189,7 @@ mkMessageVariant "UniWorX" "PWHash" "messages/pw-hash" "de"
-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.
instance RenderMessage UniWorX FormMessage where
renderMessage _ _ = defaultFormMessage
renderMessage _ _ = germanFormMessage -- TODO
instance RenderMessage UniWorX TermIdentifier where
renderMessage foundation ls TermIdentifier{..} = case season of
@ -182,10 +198,9 @@ instance RenderMessage UniWorX TermIdentifier where
where renderMessage' = renderMessage foundation ls
instance RenderMessage UniWorX StudyFieldType where
renderMessage foundation ls = \case
FieldPrimary -> renderMessage' MsgFieldPrimary
FieldSecondary -> renderMessage' MsgFieldSecondary
where renderMessage' = renderMessage foundation ls
renderMessage foundation ls = renderMessage foundation ls . \case
FieldPrimary -> MsgFieldPrimary
FieldSecondary -> MsgFieldSecondary
newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
deriving (Eq, Ord, Read, Show)
@ -200,32 +215,60 @@ instance RenderMessage UniWorX String where
renderMessage f ls str = renderMessage f ls $ Text.pack str
instance RenderMessage UniWorX SheetFileType where
renderMessage foundation ls = \case
SheetExercise -> renderMessage' MsgSheetExercise
SheetHint -> renderMessage' MsgSheetHint
SheetSolution -> renderMessage' MsgSheetSolution
SheetMarking -> renderMessage' MsgSheetMarking
where renderMessage' = renderMessage foundation ls
renderMessage foundation ls = renderMessage foundation ls . \case
SheetExercise -> MsgSheetExercise
SheetHint -> MsgSheetHint
SheetSolution -> MsgSheetSolution
SheetMarking -> MsgSheetMarking
instance RenderMessage UniWorX CorrectorState where
renderMessage foundation ls = \case
CorrectorNormal -> renderMessage' MsgCorrectorNormal
CorrectorMissing -> renderMessage' MsgCorrectorMissing
CorrectorExcused -> renderMessage' MsgCorrectorExcused
where renderMessage' = renderMessage foundation ls
renderMessage foundation ls = renderMessage foundation ls . \case
CorrectorNormal -> MsgCorrectorNormal
CorrectorMissing -> MsgCorrectorMissing
CorrectorExcused -> MsgCorrectorExcused
instance RenderMessage UniWorX Load where
renderMessage foundation ls = \case
(Load {byTutorial=Nothing , byProportion=p}) -> renderMessage' $ MsgCorByProportionOnly p
(Load {byTutorial=Just True , byProportion=p}) -> renderMessage' $ MsgCorByProportionIncludingTutorial p
(Load {byTutorial=Just False, byProportion=p}) -> renderMessage' $ MsgCorByProportionExcludingTutorial p
where renderMessage' = renderMessage foundation ls
renderMessage foundation ls = renderMessage foundation ls . \case
(Load {byTutorial=Nothing , byProportion=p}) -> MsgCorByProportionOnly p
(Load {byTutorial=Just True , byProportion=p}) -> MsgCorByProportionIncludingTutorial p
(Load {byTutorial=Just False, byProportion=p}) -> MsgCorByProportionExcludingTutorial p
instance RenderMessage UniWorX SheetType where
renderMessage foundation ls = renderMessage foundation ls . \case
Bonus{..} -> MsgSheetTypeBonus' maxPoints
Normal{..} -> MsgSheetTypeNormal' maxPoints
Pass{..} -> MsgSheetTypePass' maxPoints passingPoints
NotGraded{} -> MsgSheetTypeNotGraded'
newtype MsgLanguage = MsgLanguage Lang
deriving (Eq, Ord, Show, Read)
instance RenderMessage UniWorX MsgLanguage where
renderMessage foundation ls (MsgLanguage lang)
| lang == "de-DE" = mr MsgGermanGermany
| "de" `isPrefixOf` lang = mr MsgGerman
where
mr = renderMessage foundation ls
instance RenderMessage UniWorX NotificationTrigger where
renderMessage foundation ls = renderMessage foundation ls . \case
NTSubmissionRatedGraded -> MsgNotificationTriggerSubmissionRatedGraded
NTSubmissionRated -> MsgNotificationTriggerSubmissionRated
NTSheetActive -> MsgNotificationTriggerSheetActive
NTSheetSoonInactive -> MsgNotificationTriggerSheetSoonInactive
NTSheetInactive -> MsgNotificationTriggerSheetInactive
NTCorrectionsAssigned -> MsgNotificationCorrectionsAssigned
instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
instance RenderMessage UniWorX MessageClass where
renderMessage f ls = renderMessage f ls . \case
Error -> MsgMessageError
Warning -> MsgMessageWarning
Info -> MsgMessageInfo
Success -> MsgMessageSuccess
data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
deriving (Enum, Eq, Ord, Bounded, Read, Show)
@ -242,6 +285,23 @@ getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")])
appTZ :: TZ
appTZ = $(includeSystemTZ "Europe/Berlin")
appLanguages :: NonEmpty Lang
appLanguages = "de-DE" :| []
appLanguagesOpts :: ( MonadHandler m
, HandlerSite m ~ UniWorX
) => m (OptionList Lang)
-- ^ Authoritive list of supported Languages
appLanguagesOpts = do
mr <- getsYesod renderMessage
let mkOption l = Option
{ optionDisplay = mr (l : filter (/= l) (optionInternalValue <$> langOptions)) (MsgLanguage l)
, optionInternalValue = l
, optionExternalValue = l
}
langOptions = map mkOption $ toList appLanguages
return $ mkOptionList langOptions
-- Access Control
data AccessPredicate
@ -389,6 +449,14 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
&& NTop courseRegisterTo >= cTime
return Authorized
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
smId <- decrypt cID
SystemMessage{..} <- MaybeT $ get smId
cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop systemMessageFrom <= cTime
&& NTop systemMessageTo >= cTime
return Authorized
r -> $unsupportedAuthPredicate "time" r
)
,("registered", APDB $ \route _ -> case route of
@ -436,6 +504,31 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
return Authorized
r -> $unsupportedAuthPredicate "rated" r
)
,("user-submissions", APDB $ \route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == UserSubmissions
return Authorized
r -> $unsupportedAuthPredicate "user-submissions" r
)
,("corrector-submissions", APDB $ \route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
guard $ sheetSubmissionMode == CorrectorSubmissions
return Authorized
r -> $unsupportedAuthPredicate "corrector-submissions" r
)
,("authentication", APDB $ \route _ -> case route of
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
smId <- decrypt cID
SystemMessage{..} <- MaybeT $ get smId
isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
return Authorized
r -> $unsupportedAuthPredicate "authentication" r
)
,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite))
,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized))
]
@ -454,14 +547,14 @@ route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK
attrsAND = map splitAND $ Set.toList $ routeAttrs r
splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND"
evalAccessDB :: Route UniWorX -> Bool -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise
evalAccessDB r w = case route2ap r of
evalAccessDB :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise
evalAccessDB r w = mapReaderT liftHandlerT $ case route2ap r of
(APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer
(APHandler p) -> lift $ p r w
(APDB p) -> p r w
evalAccess :: Route UniWorX -> Bool -> Handler AuthResult
evalAccess r w = case route2ap r of
evalAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
evalAccess r w = liftHandlerT $ case route2ap r of
(APPure p) -> runReader (p r w) <$> getMsgRenderer
(APHandler p) -> p r w
(APDB p) -> runDB $ p r w
@ -537,6 +630,8 @@ instance Yesod UniWorX where
defaultLayout widget = do
master <- getYesod
let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master
applySystemMessages
mmsgs <- getMessages
mcurrentRoute <- getCurrentRoute
@ -549,7 +644,7 @@ instance Yesod UniWorX where
let menu = defaultLinks ++ maybe [] pageActions mcurrentRoute
menuTypes <- filterM (menuItemAccessCallback . menuItem) menu
menuTypes <- mapM (\x -> (x, ) <$> newIdent) =<< filterM (menuItemAccessCallback . menuItem) menu
isAuth <- isJust <$> maybeAuthId
@ -572,7 +667,7 @@ instance Yesod UniWorX where
let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents
navItems = map snd3 favourites ++ map (menuItemRoute . menuItem) menuTypes
navItems = map snd3 favourites ++ map (menuItemRoute . menuItem . fst) menuTypes
highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map snd3 favourites) crumbs
in \r -> Just r == highR
favouriteTerms :: [TermIdentifier]
@ -604,7 +699,7 @@ instance Yesod UniWorX where
isPageActionPrime (PageActionSecondary _) = True
isPageActionPrime _ = False
hasPageActions :: Bool
hasPageActions = any isPageActionPrime menuTypes
hasPageActions = any (isPageActionPrime . fst) menuTypes
pc <- widgetToPageContent $ do
addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900|Roboto:300,400,600"
@ -665,11 +760,37 @@ instance Yesod UniWorX where
-- What messages should be logged. The following includes all messages when
-- in development, and warnings and errors in production.
shouldLog app _source level = appShouldLogAll (appSettings app) || level >= appMinimumLogLevel (appSettings app)
shouldLog _ _ _ = error "Must use shouldLogIO"
shouldLogIO app _source level = do
LogSettings{..} <- readTVarIO $ appLogSettings app
return $ logAll || level >= logMinimumLevel
makeLogger = return . appLogger
applySystemMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => m ()
applySystemMessages = liftHandlerT . runDB . runConduit $ selectSource [] [] .| C.mapM_ applyMessage
where
applyMessage (Entity smId SystemMessage{..}) = maybeT_ $ do
cID <- encrypt smId
let sessionKey = "sm-" <> tshow (ciphertext cID)
assertM (== Authorized) . lift $ evalAccessDB (MessageR cID) False
assertM isNothing (lookupSessionJson sessionKey :: MaybeT (YesodDB UniWorX) (Maybe ()))
setSessionJson sessionKey ()
(SystemMessage{..}, smTrans) <- MaybeT $ getSystemMessage appLanguages smId
let
(summary, content) = case smTrans of
Nothing -> (systemMessageSummary, systemMessageContent)
Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
case summary of
Just s -> do
html <- withUrlRenderer [hamlet|
<a href=@{MessageR cID}>
#{s}
|]
addMessage systemMessageSeverity html
Nothing -> addMessage systemMessageSeverity content
-- Define breadcrumbs.
instance YesodBreadcrumbs UniWorX where
breadcrumb (AuthR _) = return ("Login" , Just HomeR)
@ -714,6 +835,12 @@ instance YesodBreadcrumbs UniWorX where
-- Others
breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR)
breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR)
breadcrumb (MessageR _) = do
mayList <- (== Authorized) <$> evalAccess MessageListR False
return $ if
| mayList -> ("Statusmeldung", Just MessageListR)
| otherwise -> ("Statusmeldung", Just HomeR)
breadcrumb (MessageListR) = return ("Statusmeldungen", Just HomeR)
breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all
submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId]
@ -737,54 +864,70 @@ defaultLinks = -- Define the menu items of the header.
{ menuItemLabel = "Home"
, menuItemIcon = Just "home"
, menuItemRoute = HomeR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, NavbarRight $ MenuItem
{ menuItemLabel = "Impressum"
, menuItemIcon = Just "book"
, menuItemRoute = VersionR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, NavbarRight $ MenuItem
{ menuItemLabel = "Profil"
{ menuItemLabel = "Hilfe"
, menuItemIcon = Just "question"
, menuItemRoute = HelpR
, menuItemModal = True -- TODO: Does not work yet, issue #212
, menuItemAccessCallback' = return True
}
, NavbarRight $ MenuItem
{ menuItemLabel = "Einstellungen"
, menuItemIcon = Just "cogs"
, menuItemRoute = ProfileR
, menuItemModal = False
, menuItemAccessCallback' = isJust <$> maybeAuthPair
}
, NavbarSecondary $ MenuItem
{ menuItemLabel = "Login"
, menuItemIcon = Just "sign-in-alt"
, menuItemRoute = AuthR LoginR
, menuItemModal = True -- TODO: Does not work yet, issue #212
, menuItemAccessCallback' = isNothing <$> maybeAuthPair
}
, NavbarSecondary $ MenuItem
{ menuItemLabel = "Logout"
, menuItemIcon = Just "sign-out-alt"
, menuItemRoute = AuthR LogoutR
, menuItemModal = False
, menuItemAccessCallback' = isJust <$> maybeAuthPair
}
, NavbarAside $ MenuItem
{ menuItemLabel = "Kurse"
, menuItemIcon = Just "calendar-alt"
, menuItemRoute = CourseListR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, NavbarAside $ MenuItem
{ menuItemLabel = "Semester"
, menuItemIcon = Just "graduation-cap"
, menuItemRoute = TermShowR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, NavbarAside $ MenuItem
{ menuItemLabel = "Korrekturen"
, menuItemIcon = Just "check"
, menuItemRoute = CorrectionsR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, NavbarAside $ MenuItem
{ menuItemLabel = "Benutzer"
, menuItemIcon = Just "users"
, menuItemRoute = UsersR
, menuItemModal = False
, menuItemAccessCallback' = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False
}
]
@ -810,14 +953,23 @@ pageActions (HomeR) =
{ menuItemLabel = "AdminDemo"
, menuItemIcon = Just "screwdriver"
, menuItemRoute = AdminTestR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, PageActionPrime $ MenuItem
{ menuItemLabel = "System-Nachrichten"
, menuItemIcon = Nothing
, menuItemRoute = MessageListR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
pageActions (ProfileR) =
[ PageActionPrime $ MenuItem
{ menuItemLabel = "Gespeicherte Daten anzeigen"
{ menuItemLabel = "Gespeicherte Daten"
, menuItemIcon = Just "book"
, menuItemRoute = ProfileDataR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
@ -826,6 +978,7 @@ pageActions TermShowR =
{ menuItemLabel = "Neues Semester anlegen"
, menuItemIcon = Nothing
, menuItemRoute = TermEditR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
@ -834,12 +987,14 @@ pageActions (TermCourseListR tid) =
{ menuItemLabel = "Neuen Kurs anlegen"
, menuItemIcon = Just "book"
, menuItemRoute = CourseNewR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, PageActionPrime $ MenuItem
{ menuItemLabel = "Semster editieren"
, menuItemIcon = Nothing
, menuItemRoute = TermEditExistR tid
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
@ -848,6 +1003,7 @@ pageActions (CourseListR) =
{ menuItemLabel = "Neuen Kurs anlegen"
, menuItemIcon = Just "book"
, menuItemRoute = CourseNewR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
@ -856,6 +1012,7 @@ pageActions (CourseR tid ssh csh CShowR) =
{ menuItemLabel = "Übungsblätter"
, menuItemIcon = Nothing
, menuItemRoute = CourseR tid ssh csh SheetListR
, menuItemModal = False
, menuItemAccessCallback' = do --TODO always show for lecturer
let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False)
muid <- maybeAuthId
@ -872,24 +1029,28 @@ pageActions (CourseR tid ssh csh CShowR) =
{ menuItemLabel = "Abgaben"
, menuItemIcon = Nothing
, menuItemRoute = CourseR tid ssh csh CCorrectionsR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, PageActionPrime $ MenuItem
{ menuItemLabel = "Neues Übungsblatt anlegen"
, menuItemIcon = Nothing
, menuItemRoute = CourseR tid ssh csh SheetNewR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, PageActionSecondary $ MenuItem
{ menuItemLabel = "Kurs editieren"
, menuItemIcon = Nothing
, menuItemRoute = CourseR tid ssh csh CEditR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, PageActionSecondary $ MenuItem
{ menuItemLabel = "Neuen Kurs klonen"
, menuItemIcon = Nothing
, menuItemRoute = CourseNewTemplateR (Just tid) (Just ssh) (Just csh)
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
@ -898,6 +1059,7 @@ pageActions (CourseR tid ssh csh SheetListR) =
{ menuItemLabel = "Neues Übungsblatt anlegen"
, menuItemIcon = Nothing
, menuItemRoute = CourseR tid ssh csh SheetNewR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
@ -906,6 +1068,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
{ menuItemLabel = "Abgabe anlegen"
, menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SubmissionNewR
, menuItemModal = True
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
uid <- MaybeT $ liftHandlerT maybeAuthId
submissions <- lift $ submissionList tid csh shn uid
@ -916,6 +1079,7 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
{ menuItemLabel = "Abgabe ansehen"
, menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SubmissionOwnR
, menuItemModal = False
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
uid <- MaybeT $ liftHandlerT maybeAuthId
submissions <- lift $ submissionList tid csh shn uid
@ -926,18 +1090,21 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
{ menuItemLabel = "Korrektoren"
, menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SCorrR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, PageActionPrime $ MenuItem
{ menuItemLabel = "Abgaben"
, menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SSubsR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, PageActionPrime $ MenuItem
{ menuItemLabel = "Blatt Editieren"
, menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SEditR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
@ -946,6 +1113,7 @@ pageActions (CSheetR tid ssh csh shn SSubsR) =
{ menuItemLabel = "Korrektoren"
, menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SCorrR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
@ -954,6 +1122,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
{ menuItemLabel = "Korrektur"
, menuItemIcon = Nothing
, menuItemRoute = CSubmissionR tid ssh csh shn cid CorrectionR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
@ -962,12 +1131,14 @@ pageActions (CSheetR tid ssh csh shn SCorrR) =
{ menuItemLabel = "Abgaben"
, menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SSubsR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, PageActionSecondary $ MenuItem
{ menuItemLabel = "Edit " <> (CI.original shn)
, menuItemIcon = Nothing
, menuItemRoute = CSheetR tid ssh csh shn SEditR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
@ -976,8 +1147,51 @@ pageActions (CorrectionsR) =
{ menuItemLabel = "Korrekturen hochladen"
, menuItemIcon = Nothing
, menuItemRoute = CorrectionsUploadR
, menuItemModal = True
, menuItemAccessCallback' = return True
}
, PageActionPrime $ MenuItem
{ menuItemLabel = "Abgaben erstellen"
, menuItemIcon = Nothing
, menuItemRoute = CorrectionsCreateR
, menuItemModal = True
, menuItemAccessCallback' = runDB $ do
uid <- liftHandlerT requireAuthId
[E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
return E.countRows
return $ (count :: Int) /= 0
}
, PageActionPrime $ MenuItem
{ menuItemLabel = "Korrekturen eintragen"
, menuItemIcon = Nothing
, menuItemRoute = CorrectionsGradeR
, menuItemModal = False
, menuItemAccessCallback' = return True
}
]
pageActions (CorrectionsGradeR) =
[ PageActionPrime $ MenuItem
{ menuItemLabel = "Korrekturen hochladen"
, menuItemIcon = Nothing
, menuItemRoute = CorrectionsUploadR
, menuItemModal = True
, menuItemAccessCallback' = return True
}
, PageActionPrime $ MenuItem
{ menuItemLabel = "Abgaben erstellen"
, menuItemIcon = Nothing
, menuItemRoute = CorrectionsCreateR
, menuItemModal = True
, menuItemAccessCallback' = runDB $ do
uid <- liftHandlerT requireAuthId
[E.Value count] <- E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
return E.countRows
return $ (count :: Int) /= 0
}
]
pageActions _ = []
@ -998,6 +1212,8 @@ pageHeading (AdminUserR _)
= Just $ [whamlet|User Display for Admin|]
pageHeading (VersionR)
= Just $ i18nHeading MsgImpressumHeading
pageHeading (HelpR)
= Just $ i18nHeading MsgHelpRequest
pageHeading ProfileR
= Just $ i18nHeading MsgProfileHeading
@ -1069,6 +1285,14 @@ pageHeading CorrectionsR
= Just $ i18nHeading MsgCorrectionsTitle
pageHeading CorrectionsUploadR
= Just $ i18nHeading MsgCorrUpload
pageHeading CorrectionsCreateR
= Just $ i18nHeading MsgCorrCreate
pageHeading CorrectionsGradeR
= Just $ i18nHeading MsgCorrGrade
pageHeading (MessageR _)
= Just $ i18nHeading MsgSystemMessageHeading
pageHeading MessageListR
= Just $ i18nHeading MsgSystemMessageListHeading
-- TODO: add headings for more single course- and single term-pages
pageHeading _
@ -1223,12 +1447,14 @@ instance YesodAuth UniWorX where
let
newUser = User
{ userMaxFavourites = userDefaultMaxFavourites
, userTheme = userDefaultTheme
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
{ userMaxFavourites = userDefaultMaxFavourites
, userTheme = userDefaultTheme
, userDateTimeFormat = userDefaultDateTimeFormat
, userDateFormat = userDefaultDateFormat
, userTimeFormat = userDefaultTimeFormat
, userDownloadFiles = userDefaultDownloadFiles
, userNotificationSettings = def
, userMailLanguages = def
, ..
}
userUpdate = [ UserMatrikelnummer =. userMatrikelnummer
@ -1271,6 +1497,8 @@ instance YesodAuth UniWorX where
authHttpManager = getHttpManager
renderAuthMessage _ _ = Auth.germanMessage -- TODO
instance YesodAuthPersist UniWorX
-- Useful when writing code that is re-usable outside of the Handler context.
@ -1283,6 +1511,25 @@ unsafeHandler :: UniWorX -> Handler a -> IO a
unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
instance YesodMail UniWorX where
defaultFromAddress = getsYesod $ appMailFrom . appSettings
mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings
mailVerp = getsYesod $ appMailVerp . appSettings
mailDateTZ = return appTZ
mailSmtp act = do
pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
withResource pool act
mailT ctx mail = defMailT ctx $ do
setMailObjectId
setDateCurrent
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
ret <- mail
setMailSmtpData
return ret
instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where
type MonadCryptoKey m = CryptoIDKey
cryptoIDKey f = getsYesod appCryptoIDKey >>= f

54
src/Handler/Admin.hs
View File

@ -7,11 +7,13 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
module Handler.Admin where
import Import
import Handler.Utils
import Jobs
-- import Data.Time
-- import qualified Data.Text as T
@ -20,6 +22,8 @@ import Handler.Utils
import Web.PathPieces (showToPathPiece, readFromPathPiece)
import Database.Persist.Sql (fromSqlKey)
-- import Colonnade hiding (fromMaybe)
-- import Yesod.Colonnade
@ -41,22 +45,54 @@ instance Button UniWorX CreateButton where
cssClass CreateInf = BCPrimary
-- END Button needed here
emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext)
emailTestForm = (,)
<$> areq emailField (fslI MsgMailTestFormEmail) Nothing
<*> ( MailContext
<$> (MailLanguages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
<*> (toMailDateTimeFormat
<$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
<*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
<*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing
)
)
<* submitButton
where
toMailDateTimeFormat dt d t = \case
SelFormatDateTime -> dt
SelFormatDate -> d
SelFormatTime -> t
getAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
getAdminTestR = do
(btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form CreateButton)
defaultLayout $ do
-- setTitle "Uni2work Admin Testpage"
$(widgetFile "adminTest")
postAdminTestR :: Handler Html
getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
getAdminTestR = postAdminTestR
postAdminTestR = do
((btnResult,_), _) <- runFormPost $ buttonForm
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form CreateButton)
case btnResult of
(FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt"
(FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
FormMissing -> return ()
_other -> addMessage Warning "KEIN Knopf erkannt"
getAdminTestR
((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm "email" $ renderAForm FormStandard emailTestForm
case emailResult of
(FormSuccess (email, ls)) -> do
jId <- runDB $ do
jId <- queueJob $ JobSendTestEmail email ls
addMessage Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
return jId
writeJobCtl $ JobCtlPerform jId
FormMissing -> return ()
(FormFailure errs) -> forM_ errs $ addMessage Error . toHtml
let emailWidget' = [whamlet|
<form method=post action=@{AdminTestR} enctype=#{emailEnctype}>
^{emailWidget}
|]
defaultLayout $ do
-- setTitle "Uni2work Admin Testpage"
$(widgetFile "adminTest")
getAdminUserR :: CryptoUUIDUser -> Handler Html

386
src/Handler/Corrections.hs
View File

@ -1,7 +1,6 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE MultiWayIf, LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
{-# LANGUAGE TemplateHaskell #-}
@ -21,11 +20,14 @@ module Handler.Corrections where
import Import
-- import System.FilePath (takeFileName)
import Jobs
import Handler.Utils
import Handler.Utils.Submission
import Handler.Utils.Table.Cells
-- import Handler.Utils.Zip
import Utils.Lens
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
@ -33,6 +35,8 @@ import qualified Data.Map as Map
import qualified Data.Text as Text
import Data.Semigroup (Sum(..))
-- import Data.Time
-- import qualified Data.Text as T
-- import Data.Function ((&))
@ -46,7 +50,6 @@ import Colonnade hiding (fromMaybe, singleton, bool)
import qualified Database.Esqueleto as E
-- import qualified Database.Esqueleto.Internal.Sql as E
import Control.Lens
-- import Control.Monad.Writer (MonadWriter(..), execWriterT)
-- import Network.Mime
@ -60,6 +63,20 @@ import Database.Persist.Sql (updateWhereCount)
import Data.List (genericLength)
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Control.Monad.Trans.Writer (Writer, WriterT(..), runWriter)
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Trans.RWS (RWST)
import Control.Monad.Trans.State (State, StateT(..), runState)
import qualified Control.Monad.State.Class as State
import Data.Foldable (foldrM)
import Data.Traversable (for)
type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) =>
@ -75,8 +92,11 @@ courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
sheetIs :: Key Sheet -> CorrectionsWhere
sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid
submissionModeIs :: SheetSubmissionMode -> CorrectionsWhere
submissionModeIs sMode (_course, sheet, _submission) = sheet E.^. SheetSubmissionMode E.==. E.val sMode
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId User)
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId (User, Maybe Pseudonym))
colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgTerm)
@ -128,13 +148,15 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp
tid = course ^. _3
ssh = course ^. _4
link cid = CourseR tid ssh csh $ CUserR cid
cell = listCell (Map.toList users) $ \(userId, User{..}) -> do
anchorCellM (link <$> encrypt userId) (nameWidget userDisplayName userSurname)
cell = listCell (Map.toList users) $ \(userId, (User{..}, mPseudo)) ->
anchorCellM (link <$> encrypt userId) $ case mPseudo of
Nothing -> nameWidget userDisplayName userSurname
Just p -> [whamlet|^{nameWidget userDisplayName userSurname} (#{review pseudonymText p})|]
in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
cell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
@ -156,13 +178,36 @@ colRated :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colRated = sortable (Just "ratingtime") (i18nCell MsgRatingTime) $ \DBRow{ dbrOutput=(Entity _subId Submission{..}, _sheet, _course, _, _) } ->
maybe mempty timeCell submissionRatingTime
colPseudonyms :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
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 _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, a, b))))
colRatedField = sortable Nothing (i18nCell MsgRatingDone) $ formCell
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ (submissionRatingDone -> done), _, _, _, _) } _ -> over (_1.mapped) (_1 .~) . over _2 fvInput <$> mreq checkBoxField "" (Just done))
colPointsField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, Maybe Points, b))))
colPointsField = sortable (Just "rating") (i18nCell MsgColumnRatingPointsDone) $ formCell
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ Submission{..}, Entity _ Sheet{..}, _, _, _) } _ -> case sheetType of
NotGraded -> over (_1.mapped) (_2 .~) <$> pure (FormSuccess Nothing, mempty)
_other -> over (_1.mapped) (_2 .~) . over _2 fvInput <$> mopt pointsField "" (Just submissionRatingPoints)
)
colCommentField :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData SubmissionId (a, b, Maybe Text))))
colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
(\DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> return subId)
(\DBRow{ dbrOutput=(Entity _ Submission{..}, _, _, _, _) } _ -> over (_1.mapped) ((_3 .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvInput <$> mopt textareaField "" (Just $ Textarea <$> submissionRatingComment))
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
=> _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
makeCorrectionsTable whereClause colChoices psValidator = do
=> _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x)
makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
@ -176,57 +221,64 @@ makeCorrectionsTable whereClause colChoices psValidator = do
)
return (submission, sheet, crse, corrector)
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
dbtProj = traverse $ \(submission@(Entity sId _), sheet, (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
submittors <- lift . E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
dbtProj = traverse $ \(submission@(Entity sId _), sheet@(Entity shId _), (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> 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)
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
E.orderBy [E.asc $ user E.^. UserId]
return user
return (user, pseudonym E.?. SheetPseudonymPseudonym)
let
submittorMap = foldr (\(Entity userId user) -> Map.insert userId user) Map.empty submittors
return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
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)
dbTable psValidator $ DBTable
{ dbtSQLQuery
, dbtColonnade = colChoices
, dbtColonnade
, dbtProj
, dbtSorting = [ ( "term"
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
)
, ( "course"
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
)
, ( "sheet"
, SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
)
, ( "corrector"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname
)
, ( "rating"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
)
]
, dbtFilter = [ ( "term"
, FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if
| Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
)
, ( "course"
, FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if
| Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs)
)
, ( "sheet"
, FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if
| Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns)
)
, ( "corrector"
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if
| Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails)
E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
)
]
, dbtSorting = Map.fromList
[ ( "term"
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
)
, ( "course"
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
)
, ( "sheet"
, SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
)
, ( "corrector"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserSurname
)
, ( "rating"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingPoints
)
, ( "ratingtime"
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` submission) `E.LeftOuterJoin` _) -> submission E.^. SubmissionRatingTime
)
]
, dbtFilter = Map.fromList
[ ( "term"
, FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if
| Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
)
, ( "course"
, FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if
| Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs)
)
, ( "sheet"
, FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if
| Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns)
)
, ( "corrector"
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if
| Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails)
E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
)
]
, dbtStyle = def
, dbtIdent = "corrections" :: Text
}
@ -248,12 +300,12 @@ data ActionCorrectionsData = CorrDownloadData
| CorrSetCorrectorData (Maybe UserId)
| CorrAutoSetCorrectorData SheetId
correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) -> Handler TypedContent
correctionsR :: _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerT UniWorX IO) ActionCorrectionsData) -> Handler TypedContent
correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator return
((actionRes, table), tableEncoding) <- runFormPost $ \csrf -> do
((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
(actionRes, action) <- multiAction actions
(actionRes, action) <- multiAction actions Nothing
return ((,) <$> actionRes <*> selectionRes, table <> action)
Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
@ -323,16 +375,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
$(widgetFile "corrections")
type ActionCorrections' = (ActionCorrections, MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget))
type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
downloadAction :: ActionCorrections'
downloadAction = ( CorrDownload
, return (pure CorrDownloadData, Nothing)
, pure CorrDownloadData
)
assignAction :: Either CourseId SheetId -> ActionCorrections'
assignAction selId = ( CorrSetCorrector
, over (mapped._2) Just $ do
, wFormToAForm $ do
correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
@ -346,14 +398,13 @@ assignAction selId = ( CorrSetCorrector
correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey
($ mempty) . renderAForm FormStandard . wFormToAForm $ do
cId <- wreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing
fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
cId <- wpreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing
fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
)
autoAssignAction :: SheetId -> ActionCorrections'
autoAssignAction shid = ( CorrAutoSetCorrector
, return (pure $ CorrAutoSetCorrectorData shid, Nothing)
, pure $ CorrAutoSetCorrectorData shid
)
getCorrectionsR, postCorrectionsR :: Handler TypedContent
@ -367,6 +418,7 @@ postCorrectionsR = do
, colTerm
, colCourse
, colSheet
, colPseudonyms
, colSubmissionLink
, colAssigned
, colRating
@ -449,9 +501,13 @@ postCorrectionR tid ssh csh shn cid = do
case results of
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
pointsForm = case sheetType of
NotGraded -> pure Nothing
_otherwise -> aopt pointsField (fslpI MsgRatingPoints "Punktezahl") (Just $ submissionRatingPoints)
((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,)
<$> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip MsgRatingPointsDone) (Just $ submissionRatingPoints)
((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,)
<$> areq checkBoxField (fslI MsgRatingDone) (Just $ submissionRatingDone Submission{..})
<*> pointsForm
<*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
<* submitButton
@ -462,12 +518,12 @@ postCorrectionR tid ssh csh shn cid = do
case corrResult of
FormMissing -> return ()
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess (ratingPoints, ratingComment) -> do
runDB $ do
FormSuccess (rated, ratingPoints, ratingComment) -> do
runDBJobs $ do
uid <- liftHandlerT requireAuthId
now <- liftIO getCurrentTime
let rated = isJust $ void ratingPoints <|> void ratingComment
Submission{submissionRatingTime} <- getJust sub
update sub [ SubmissionRatingBy =. (uid <$ guard rated)
-- SJ: I don't think we need to update AssignedTime here, since this is just for correction upload
@ -478,6 +534,11 @@ postCorrectionR tid ssh csh shn cid = do
]
addMessageI Success $ bool MsgRatingDeleted MsgRatingUpdated rated
when (rated && isNothing submissionRatingTime) $ do
$logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
case uploadResult of
@ -486,7 +547,7 @@ postCorrectionR tid ssh csh shn cid = do
FormSuccess fileSource -> do
uid <- requireAuthId
runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
runDBJobs . runConduit $ transPipe (lift . lift) fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
addMessageI Success MsgRatingFilesUpdated
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
@ -521,7 +582,7 @@ postCorrectionsUploadR = do
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess files -> do
uid <- requireAuthId
subs <- runDB . runConduit $ transPipe lift files .| extractRatingsMsg .| sinkMultiSubmission uid True
subs <- runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True
if
| null subs -> addMessageI Warning MsgNoCorrectionsUploaded
| otherwise -> do
@ -532,3 +593,190 @@ postCorrectionsUploadR = do
defaultLayout $ do
$(widgetFile "corrections-upload")
getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html
getCorrectionsCreateR = postCorrectionsCreateR
postCorrectionsCreateR = do
uid <- requireAuthId
let sheetOptions = mkOptList <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
E.&&. sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions
E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom]
return $ (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)
mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId)
mkOptList opts = do
opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts
MsgRenderer mr <- getMsgRenderer
return . mkOptionList $ do
(cID, (E.Value sid, E.Value tid, E.Value csh, E.Value shn)) <- opts'
let tid' = mr $ ShortTermIdentifier (unTermKey tid)
return Option
{ optionDisplay = mr $ MsgCorrectionPseudonymSheet tid' csh shn
, optionInternalValue = sid
, optionExternalValue = toPathPiece (cID :: CryptoUUIDSheet)
}
((pseudonymRes, pseudonymWidget), pseudonymEncoding) <- runFormPost . renderAForm FormStandard $ (,)
<$> areq (selectField sheetOptions) (fslI MsgPseudonymSheet) Nothing
<*> areq (checkMMap textToList textFromList textareaField) (fslpI MsgCorrectionPseudonyms "Pseudonyme" & setTooltip MsgCorrectionPseudonymsTip) Nothing
<* submitButton
case pseudonymRes of
FormMissing -> return ()
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
FormSuccess (sid, pss) -> do
now <- liftIO getCurrentTime
runDB $ do
Sheet{..} <- get404 sid
(sps, unknown) <- fmap partition . forM pss . mapM $ \p -> maybe (Left p) Right <$> getBy (UniqueSheetPseudonym sid p)
forM_ unknown $ addMessageI Error . MsgUnknownPseudonym . review pseudonymText
now <- liftIO getCurrentTime
let
sps' :: [[SheetPseudonym]]
duplicate :: Set Pseudonym
( sps'
, Map.keysSet . Map.filter (\(getSum -> n) -> n > 1) -> duplicate
) = flip runState Map.empty . forM sps . flip (foldrM :: (Entity SheetPseudonym -> [SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) -> [SheetPseudonym] -> [Entity SheetPseudonym] -> State (Map Pseudonym (Sum Integer)) [SheetPseudonym]) [] $ \(Entity _ p@SheetPseudonym{sheetPseudonymPseudonym}) ps -> do
known <- State.gets $ Map.member sheetPseudonymPseudonym
State.modify $ Map.insertWith (<>) sheetPseudonymPseudonym (Sum 1)
return $ bool (p :) id known ps
submission = Submission
{ submissionSheet = sid
, submissionRatingPoints = Nothing
, submissionRatingComment = Nothing
, submissionRatingBy = Just uid
, submissionRatingAssigned = Just now
, submissionRatingTime = Nothing
}
when (not $ null duplicate)
$(addMessageFile Warning "templates/messages/submissionCreateDuplicates.hamlet")
existingSubUsers <- E.select . E.from $ \submissionUser -> do
E.where_ $ submissionUser E.^. SubmissionUserUser `E.in_` E.valList (sheetPseudonymUser <$> concat sps')
return submissionUser
when (not $ null existingSubUsers) $ do
(Map.toList -> subs) <- foldrM (\(Entity _ SubmissionUser{..}) mp -> Map.insertWith (<>) <$> (encrypt submissionUserSubmission :: DB CryptoFileNameSubmission) <*> pure (Set.fromList . map sheetPseudonymPseudonym . filter (\SheetPseudonym{..} -> sheetPseudonymUser == submissionUserUser) $ concat sps') <*> pure mp) Map.empty existingSubUsers
$(addMessageFile Warning "templates/messages/submissionCreateExisting.hamlet")
let sps'' = filter (not . null) $ filter (\spGroup -> not . flip any spGroup $ \SheetPseudonym{sheetPseudonymUser} -> sheetPseudonymUser `elem` map (submissionUserUser . entityVal) existingSubUsers) sps'
forM_ sps'' $ \spGroup
-> let
sheetGroupDesc = Text.intercalate ", " $ map (review pseudonymText . sheetPseudonymPseudonym) spGroup
in case sheetGrouping of
Arbitrary maxSize
| genericLength sps > maxSize
-> addMessageI Error $ MsgSheetGroupTooLarge sheetGroupDesc
| otherwise
-> do
subId <- insert submission
void . insert $ SubmissionEdit uid now subId
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
{ submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId
}
RegisteredGroups -> do
groups <- E.select . E.from $ \submissionGroup -> do
E.where_ . E.exists . E.from $ \submissionGroupUser ->
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser `E.in_` E.valList (map sheetPseudonymUser spGroup)
return $ submissionGroup E.^. SubmissionGroupId
case (groups :: [E.Value SubmissionGroupId]) of
[x] -> do
subId <- insert submission
void . insert $ SubmissionEdit uid now subId
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
{ submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId
}
[] -> do
subId <- insert submission
void . insert $ SubmissionEdit uid now subId
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
{ submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId
}
addMessageI Warning $ MsgSheetNoRegisteredGroup sheetGroupDesc
_ -> addMessageI Error $ MsgSheetAmbiguousRegisteredGroup sheetGroupDesc
NoGroups
| [SheetPseudonym{sheetPseudonymUser}] <- spGroup
-> do
subId <- insert submission
void . insert $ SubmissionEdit uid now subId
insert_ SubmissionUser
{ submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId
}
| otherwise -> do
subId <- insert submission
void . insert $ SubmissionEdit uid now subId
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
{ submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId
}
addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
redirect CorrectionsGradeR
defaultLayout $ do
$(widgetFile "corrections-create")
where
partition :: [[Either a b]] -> ([[b]], [a])
partition = runWriter . mapM (WriterT . Identity . swap . partitionEithers)
textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]])
textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . Text.lines . unTextarea -> ws)
= let
invalid :: [Text]
valid :: [[Pseudonym]]
(valid, invalid) = partition $ map (map $ \w -> maybe (Left w) Right $ w ^? pseudonymText) ws
in case invalid of
(i:_) -> return . Left $ MsgInvalidPseudonym i
[] -> return $ Right valid
textFromList :: [[Pseudonym]] -> Textarea
textFromList = Textarea . Text.unlines . map (Text.intercalate ", " . map (review pseudonymText))
getCorrectionsGradeR, postCorrectionsGradeR :: Handler Html
getCorrectionsGradeR = postCorrectionsGradeR
postCorrectionsGradeR = do
uid <- requireAuthId
let whereClause = ratedBy uid
displayColumns = mconcat -- should match getSSubsR for consistent UX
[ dbRow
, colTerm
, colCourse
, colSheet
, colPseudonyms
, colSubmissionLink
, colRated
, colRatedField
, colPointsField
, colCommentField
] -- Continue here
psValidator = def
& defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text)))
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \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
(((fmap unFormResult -> tableRes), table), tableEncoding) <- runFormPost tableForm
case tableRes of
FormMissing -> return ()
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
FormSuccess resMap -> do
now <- liftIO getCurrentTime
subs <- fmap catMaybes . runDB . forM (Map.toList resMap) $ \(subId, (rated, mPoints, mComment)) -> do
s@Submission{..} <- get404 subId
if
| submissionRatingPoints /= mPoints || submissionRatingComment /= mComment || rated /= submissionRatingDone s
-> Just subId <$ update subId [ SubmissionRatingPoints =. mPoints
, SubmissionRatingComment =. mComment
, SubmissionRatingBy =. Just uid
, SubmissionRatingTime =. now <$ guard rated
]
| otherwise -> return $ Nothing
subs' <- traverse encrypt subs :: Handler [CryptoFileNameSubmission]
unless (null subs') $(addMessageFile Success "templates/messages/correctionsUploaded.hamlet")
defaultLayout $ do
$(widgetFile "corrections-grade")

113
src/Handler/Course.hs
View File

@ -15,7 +15,7 @@
module Handler.Course where
import Import
import Import hiding (catMaybes)
import Control.Lens
import Utils.Lens
@ -33,6 +33,9 @@ import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.CaseInsensitive as CI
import Colonnade hiding (fromMaybe,bool)
-- import Yesod.Colonnade
@ -317,6 +320,14 @@ postCRegisterR tid ssh csh = do
(_other) -> return () -- TODO check this!
redirect $ CourseR tid ssh csh CShowR
getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html
getCourseNewTemplateR mbTid mbSsh mbCsh =
redirect (CourseNewR, catMaybes [ ("tid",).termToText.unTermKey <$> mbTid
, ("ssh",).CI.original.unSchoolKey <$> mbSsh
, ("csh",).CI.original <$> mbCsh
])
getCourseNewR :: Handler Html -- call via toTextUrl
getCourseNewR = do
uid <- requireAuthId
@ -325,59 +336,55 @@ getCourseNewR = do
<*> iopt ciField "ssh"
<*> iopt ciField "csh"
let noTemplateAction = courseEditHandler True Nothing
case params of
case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty newCourseForm any more!
FormMissing -> noTemplateAction
FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml)
>> noTemplateAction
FormSuccess (mbTid,mbSsh,mbCsh) ->
getCourseNewTemplateR (TermKey <$> mbTid) (SchoolKey <$> mbSsh) mbCsh
getCourseNewTemplateR :: Maybe TermId -> Maybe SchoolId -> Maybe CourseShorthand -> Handler Html
getCourseNewTemplateR mbTid mbSsh mbCsh = do
uid <- requireAuthId
oldCourses <- runDB $ do
E.select $ E.from $ \course -> do
whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid
whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh
whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh
let lecturersCourse =
E.exists $ E.from $ \lecturer -> do
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
let lecturersSchool =
E.exists $ E.from $ \user -> do
E.where_ $ user E.^. UserLecturerUser E.==. E.val uid
E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
let courseCreated c =
E.sub_select . E.from $ \edit -> do -- oldest edit must be creation
E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
return $ E.min_ $ edit E.^. CourseEditTime
E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
, E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
, E.desc $ courseCreated course] -- most recent created course
E.limit 1
return course
template <- case listToMaybe oldCourses of
(Just oldTemplate) ->
let newTemplate = (courseToForm oldTemplate) in
return $ Just $ newTemplate
{ cfCourseId = Nothing
, cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
, cfRegFrom = Nothing
, cfRegTo = Nothing
, cfDeRegUntil = Nothing
}
Nothing -> do
(tidOk,sshOk,cshOk) <- runDB $ (,,)
<$> ifMaybeM mbTid True existsKey
<*> ifMaybeM mbSsh True existsKey
<*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise
unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
return Nothing
courseEditHandler True template
FormFailure msgs -> forM_ msgs ((addMessage Error) . toHtml) >>
noTemplateAction
FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
uid <- requireAuthId
oldCourses <- runDB $ do
E.select $ E.from $ \course -> do
whenIsJust mbTid $ \tid -> E.where_ $ course E.^. CourseTerm E.==. E.val tid
whenIsJust mbSsh $ \ssh -> E.where_ $ course E.^. CourseSchool E.==. E.val ssh
whenIsJust mbCsh $ \csh -> E.where_ $ course E.^. CourseShorthand E.==. E.val csh
let lecturersCourse =
E.exists $ E.from $ \lecturer -> do
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
let lecturersSchool =
E.exists $ E.from $ \user -> do
E.where_ $ user E.^. UserLecturerUser E.==. E.val uid
E.&&. user E.^. UserLecturerSchool E.==. course E.^. CourseSchool
let courseCreated c =
E.sub_select . E.from $ \edit -> do -- oldest edit must be creation
E.where_ $ edit E.^. CourseEditCourse E.==. c E.^. CourseId
return $ E.min_ $ edit E.^. CourseEditTime
E.orderBy [ E.desc $ E.case_ [(lecturersCourse, E.val (1 :: Int64))] (E.val 0) -- prefer courses from lecturer
, E.desc $ E.case_ [(lecturersSchool, E.val (1 :: Int64))] (E.val 0) -- prefer from schools of lecturer
, E.desc $ courseCreated course] -- most recent created course
E.limit 1
return course
template <- case listToMaybe oldCourses of
(Just oldTemplate) ->
let newTemplate = (courseToForm oldTemplate) in
return $ Just $ newTemplate
{ cfCourseId = Nothing
, cfTerm = TermKey $ TermIdentifier 0 Winter -- invalid, will be ignored; undefined won't work due to strictness
, cfRegFrom = Nothing
, cfRegTo = Nothing
, cfDeRegUntil = Nothing
}
Nothing -> do
(tidOk,sshOk,cshOk) <- runDB $ (,,)
<$> ifMaybeM mbTid True existsKey
<*> ifMaybeM mbSsh True existsKey
<*> ifMaybeM mbCsh True (\csh -> (not . null) <$> selectKeysList [CourseShorthand ==. csh] [LimitTo 1])
unless tidOk $ addMessageI Warning $ MsgNoSuchTerm $ fromJust mbTid -- safe, since tidOk==True otherwise
unless sshOk $ addMessageI Warning $ MsgNoSuchSchool $ fromJust mbSsh -- safe, since sshOk==True otherwise
unless cshOk $ addMessageI Warning $ MsgNoSuchCourseShorthand $ fromJust mbCsh
when (tidOk && sshOk && cshOk) $ addMessageI Warning MsgNoSuchCourse
return Nothing
courseEditHandler True template
postCourseNewR :: Handler Html
postCourseNewR = courseEditHandler False Nothing -- Note: Nothing is safe here, since we will create a new course.

105
src/Handler/Home.hs
View File

@ -2,6 +2,8 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE IncoherentInstances #-} -- why is this needed? Instance for "display deadline" ought to be clear
@ -16,7 +18,14 @@ import Handler.Utils
import qualified Data.Map as Map
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8')
import Data.Time hiding (formatTime)
import Data.Universe
import Data.Universe.Helpers
import Network.Wai (requestHeaderReferer)
-- import qualified Data.Text as T
-- import Yesod.Form.Bootstrap3
@ -27,6 +36,8 @@ import Data.Time hiding (formatTime)
-- import Yesod.Colonnade
import qualified Database.Esqueleto as E
import Jobs
-- import Text.Shakespeare.Text
import Development.GitRev
@ -106,10 +117,10 @@ homeAnonymous = do
, dbtStyle = def
, dbtIdent = "upcomingdeadlines" :: Text
}
let features = $(widgetFile "featureList")
addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!"
-- let features = $(widgetFile "featureList")
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!"
defaultLayout $ do
$(widgetFile "dsgvDisclaimer")
-- $(widgetFile "dsgvDisclaimer")
$(widgetFile "home")
homeUser :: Key User -> Handler Html
@ -117,10 +128,10 @@ homeUser uid = do
cTime <- liftIO getCurrentTime
let fTime = addUTCTime (offSheetDeadlines * nominalDay) cTime
tableData :: -- E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant))
-- (E.SqlExpr (Entity Course )))
-- (E.SqlExpr (Entity Sheet ))
_ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
tableData :: E.LeftOuterJoin
(E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet)))
(E.InnerJoin (E.SqlExpr (Maybe (Entity Submission))) (E.SqlExpr (Maybe (Entity SubmissionUser))))
-> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
, E.SqlExpr (E.Value SchoolId)
, E.SqlExpr (E.Value CourseShorthand)
, E.SqlExpr (E.Value SheetName)
@ -207,11 +218,11 @@ homeUser uid = do
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
, dbtIdent = "upcomingdeadlines" :: Text
}
addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
defaultLayout $ do
-- setTitle "Willkommen zum Uni2work Test!"
$(widgetFile "homeUser")
$(widgetFile "dsgvDisclaimer")
-- $(widgetFile "dsgvDisclaimer")
getVersionR :: Handler TypedContent
@ -224,3 +235,79 @@ getVersionR = selectRep $ do
$(widgetFile "versionHistory")
provideRep $
return ($gitDescribe :: Text)
data HelpIdentOptions = HIUser | HIEmail | HIAnonymous
deriving (Eq, Ord, Bounded, Enum, Show, Read)
$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
instance Universe HelpIdentOptions where universe = universeDef
instance Finite HelpIdentOptions
instance PathPiece HelpIdentOptions where
toPathPiece = $(nullaryToPathPiece ''HelpIdentOptions [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel])
fromPathPiece = finiteFromPathPiece
instance RenderMessage UniWorX HelpIdentOptions where
renderMessage foundation ls = renderMessage foundation ls . \case
HIUser -> MsgHelpUser
HIEmail -> MsgHelpEMail
HIAnonymous -> MsgHelpAnonymous
data HelpForm = HelpForm
{ hfReferer:: Maybe Text
, hfUserId :: Either (Maybe Email) UserId
, hfRequest:: Text
}
helpForm :: Maybe Text -> Maybe UserId -> AForm _ HelpForm
helpForm mReferer mUid = HelpForm
<$> maybe (pure Nothing) (fmap Just . aforced textField (fslI MsgHelpProblemPage)) mReferer
<*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid)
<*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing)
<* submitButton
where
identActions :: Map _ (AForm _ (Either (Maybe Email) UserId))
identActions = Map.fromList $ case mUid of
(Just uid) -> (HIUser, pure $ Right uid):defaultActions
Nothing -> defaultActions
defaultActions =
[ (HIEmail, Left . Just <$> apreq emailField (fslI MsgEMail) Nothing)
, (HIAnonymous, pure $ Left Nothing)
]
getHelpR :: Handler Html
getHelpR = postHelpR
postHelpR :: Handler Html
postHelpR = do
mUid <- maybeAuthId
mRefererBS <- requestHeaderReferer <$> waiRequest
let mReferer = maybeRight . decodeUtf8' =<< mRefererBS
((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid
case res of
FormSuccess (HelpForm{..}) -> do
now <- liftIO getCurrentTime
queueJob' $ JobHelpRequest { jSender = hfUserId
, jHelpRequest = hfRequest
, jRequestTime = now
, jReferer = hfReferer }
-- redirect $ HelpR
addMessageI Success MsgHelpSent
return ()
{-selectRep $ do
provideJson ()
provideRep (redirect $ HelpR :: Handler Html) -}
FormMissing -> return ()
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
defaultLayout $ do
setTitle "Hilfe" -- TODO: International
$(widgetFile "help")

174
src/Handler/Profile.hs
View File

@ -24,6 +24,8 @@ import Utils.Lens
-- import Yesod.Colonnade
import Data.Monoid (Any(..))
import qualified Data.Map as Map
import Data.Map ((!))
import qualified Data.Set as Set
-- import qualified Data.Set as Set
import qualified Database.Esqueleto as E
-- import Database.Esqueleto ((^.))
@ -37,6 +39,7 @@ data SettingsForm = SettingsForm
, stgDate :: DateTimeFormat
, stgTime :: DateTimeFormat
, stgDownloadFiles :: Bool
, stgNotificationSettings :: NotificationSettings
}
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
@ -53,13 +56,30 @@ makeSettingForm template = identForm FIDsettings $ \html -> do
<*> areq checkBoxField (fslI MsgDownloadFiles
& setTooltip MsgDownloadFilesTip
) (stgDownloadFiles <$> template)
<*> formToAForm (nsFieldView =<< renderAForm FormStandard nsForm mempty)
<* submitButton
return (result, widget) -- no validation required here
where
nsForm = fmap (\m -> NotificationSettings $ \nt -> m ! nt) . sequenceA . flip Map.fromSet (Set.fromList universeF) $ \nt ->
areq checkBoxField (fslI nt) (flip notificationAllowed nt . stgNotificationSettings <$> template)
nsFieldView :: (FormResult NotificationSettings, Widget) -> MForm Handler (FormResult NotificationSettings, [FieldView UniWorX])
nsFieldView (res, fvInput) = do
mr <- getMessageRender
let fvLabel = toHtml $ mr MsgNotificationSettings
fvTooltip = mempty
fvRequired = True
fvErrors
| FormFailure (err:_) <- res = Just $ toHtml err
| otherwise = Nothing
fvId <- newIdent
return (res, pure FieldView{..})
-- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
getProfileR :: Handler Html
getProfileR = do
getProfileR, postProfileR :: Handler Html
getProfileR = postProfileR
postProfileR = do
(uid, User{..}) <- requireAuthPair
let settingsTemplate = Just $ SettingsForm
{ stgMaxFavourties = userMaxFavourites
@ -68,6 +88,7 @@ getProfileR = do
, stgDate = userDateFormat
, stgTime = userTimeFormat
, stgDownloadFiles = userDownloadFiles
, stgNotificationSettings = userNotificationSettings
}
((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate
case res of
@ -79,6 +100,7 @@ getProfileR = do
, UserDateFormat =. stgDate
, UserTimeFormat =. stgTime
, UserDownloadFiles =. stgDownloadFiles
, UserNotificationSettings =. stgNotificationSettings
]
when (stgMaxFavourties < userMaxFavourites) $ do
-- prune Favourites to user-defined size
@ -93,52 +115,11 @@ getProfileR = do
(FormFailure msgs) -> forM_ msgs $ (addMessage Warning) . toHtml
_ -> return ()
(admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
(E.select $ E.from $ \(adright `E.InnerJoin` school) -> do
E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
)
<*>
(E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
)
<*>
(E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
)
<*>
(E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
return ( ( studydegree E.^. StudyDegreeName
, studydegree E.^. StudyDegreeKey
)
, ( studyterms E.^. StudyTermsName
, studyterms E.^. StudyTermsKey
)
, studyfeat E.^. StudyFeaturesType
, studyfeat E.^. StudyFeaturesSemester)
)
let formText = Just MsgSettings
actionUrl = ProfileR
settingsForm = $(widgetFile "formPageI18n")
let formText = Nothing :: Maybe UniWorXMessage
actionUrl = ProfileR
defaultLayout $ do
setTitle . toHtml $ userIdent <> "'s User page"
$(widgetFile "profile")
$(widgetFile "dsgvDisclaimer")
postProfileR :: Handler Html
postProfileR = do
-- TODO
getProfileR
$(widgetFile "formPageI18n")
postProfileDataR :: Handler Html
postProfileDataR = do
@ -146,17 +127,69 @@ postProfileDataR = do
case btnResult of
(FormSuccess BtnDelete) -> do
(uid, User{..}) <- requireAuthPair
addMessage Warning "Delete-Knopf gedrückt"
addMessage Error "Löschen der Daten wurde noch nicht implementiert."
-- first determine all submission that solely depend on this user:
-- SubmissionGroup / SubmissionGroupUser
-- Submission / SubmissionUser
-- runDB $ deleteCascade uid
clearCreds False -- Logout-User
((deletedSubmissions,groupSubmissions),deletedSubmissionGroups) <- runDB $ deleteUser uid
-- addMessageIHamlet
$(addMessageFile Success "templates/deletedUser.hamlet") -- USE THIS ONE
-- addMessageI Success $ MsgDeleteUser deletedSubmissions
-- when (groupSubmissions > 0) $ addMessageI Info $ MsgDeleteUserGroupSubmissions groupSubmissions
defaultLayout $ do
$(widgetFile "deletedUser")
(FormSuccess BtnAbort ) -> do
addMessageI Info MsgAborted
redirect ProfileDataR
_other -> return ()
getProfileDataR
_other -> getProfileDataR
deleteUser :: UserId -> DB ((Int,Int),Int64) -- TODO: Restrict deletions for lecturers, tutors and students in course that won't allow deregistration
deleteUser duid = do
-- E.deleteCount for submissions is not cascading, hence we first select and then delete manually
-- We delete all files tied to submissions where the user is the lone submissionUser
-- Do not deleteCascade submissions where duid is the corrector:
updateWhere [SubmissionRatingBy ==. Just duid] [SubmissionRatingBy =. Nothing]
groupSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.>. E.val (0::Int64))
singleSubmissions <- selectSubmissionsWhere (\numBuddies -> numBuddies E.==. E.val (0::Int64))
deleteCascade duid
forM_ singleSubmissions $ \(E.Value submissionId) -> do
deleteFileIds <- map E.unValue <$> getSubmissionFiles submissionId
deleteCascade submissionId
deleteCascadeWhere [FileId <-. deleteFileIds] -- TODO: throws exception for de-duplicated files
deletedSubmissionGroups <- deleteSingleSubmissionGroups
return ((length singleSubmissions, length groupSubmissions),deletedSubmissionGroups)
where
selectSubmissionsWhere :: (E.SqlExpr (E.Value Int64) -> E.SqlExpr (E.Value Bool)) -> DB [E.Value (Key Submission)]
selectSubmissionsWhere whereBuddies = E.select $ E.from $ \(submission `E.InnerJoin` suser) -> do
E.on $ submission E.^. SubmissionId E.==. suser E.^. SubmissionUserSubmission
let numBuddies = E.sub_select $ E.from $ \subUsers -> do
E.where_ $ subUsers E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.&&. subUsers E.^. SubmissionUserUser E.!=. E.val duid
return E.countRows
E.where_ $ suser E.^. SubmissionUserUser E.==. E.val duid
E.&&. (whereBuddies numBuddies)
return $ submission E.^. SubmissionId
getSubmissionFiles :: SubmissionId -> DB [E.Value (Key File)]
getSubmissionFiles subId = E.select $ E.from $ \file -> do
E.where_ $ E.exists $ E.from $ \submissionFile -> do
E.where_ $ submissionFile E.^. SubmissionFileSubmission E.==. E.val subId
E.&&. submissionFile E.^. SubmissionFileFile E.==. file E.^. FileId
return $ file E.^. FileId
deleteSingleSubmissionGroups = E.deleteCount $ E.from $ \submissionGroup -> do
E.where_ $ E.exists $ E.from $ \subGroupUser -> do
E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.==. E.val duid
E.where_ $ E.notExists $ E.from $ \subGroupUser -> do
E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid
@ -164,6 +197,39 @@ getProfileDataR :: Handler Html
getProfileDataR = do
(uid, User{..}) <- requireAuthPair
-- mr <- getMessageRender
(admin_rights,lecturer_rights,lecture_corrector,studies) <- runDB $ (,,,) <$>
(E.select $ E.from $ \(adright `E.InnerJoin` school) -> do
E.where_ $ adright E.^. UserAdminUser E.==. E.val uid
E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
)
<*>
(E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
)
<*>
(E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand)
)
<*>
(E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId
E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
return ( ( studydegree E.^. StudyDegreeName
, studydegree E.^. StudyDegreeKey
)
, ( studyterms E.^. StudyTermsName
, studyterms E.^. StudyTermsKey
)
, studyfeat E.^. StudyFeaturesType
, studyfeat E.^. StudyFeaturesSemester)
)
-- Tabelle mit eigenen Kursen
(hasRows, ownedCoursesTable) <- mkOwnedCoursesTable uid
-- Tabelle mit allen Teilnehmer: Kurs (link), Datum

107
src/Handler/Sheet.hs
View File

@ -1,6 +1,5 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
@ -14,6 +13,7 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE MultiWayIf, LambdaCase #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NamedFieldPuns #-}
module Handler.Sheet where
@ -48,6 +48,8 @@ import Control.Monad.Writer (MonadWriter(..), execWriterT)
-- import qualified Data.List as List
import Control.Monad.Trans.Except (ExceptT(..), runExceptT, mapExceptT, throwE)
import Network.Mime
import Data.Set (Set)
@ -57,11 +59,17 @@ import qualified Data.Map as Map
import Data.Map (Map, (!), (!?))
import qualified Data.Map as Map
import Data.Monoid (Sum(..))
import Data.Monoid (Sum(..), Any(..))
import Control.Lens
-- import Utils.Lens
import qualified Data.Text as Text
import qualified Data.Aeson as Aeson
import Control.Monad.Random.Class (MonadRandom(..))
import Utils.Sql
instance Eq (Unique Sheet) where
(CourseSheet cid1 name1) == (CourseSheet cid2 name2) =
@ -77,11 +85,11 @@ data SheetForm = SheetForm
{ sfName :: SheetName
, sfDescription :: Maybe Html
, sfType :: SheetType
, sfGrouping :: SheetGroup
, sfMarkingText :: Maybe Html
, sfGrouping :: SheetGroup
, sfVisibleFrom :: Maybe UTCTime
, sfActiveFrom :: UTCTime
, sfActiveTo :: UTCTime
, sfSubmissionMode :: SheetSubmissionMode
, sfUploadMode :: UploadMode
, sfSheetF :: Maybe (Source Handler (Either FileId File))
, sfHintFrom :: Maybe UTCTime
@ -89,6 +97,7 @@ data SheetForm = SheetForm
, sfSolutionFrom :: Maybe UTCTime
, sfSolutionF :: Maybe (Source Handler (Either FileId File))
, sfMarkingF :: Maybe (Source Handler (Either FileId File))
, sfMarkingText :: Maybe Html
-- Keine SheetId im Formular!
}
@ -111,8 +120,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
<$> areq ciField (fslI MsgSheetName) (sfName <$> template)
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
<*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template)
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
& setTooltip MsgSheetVisibleFromTip)
((sfVisibleFrom <$> template) <|> pure (Just ctime))
@ -120,6 +128,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
& setTooltip MsgSheetActiveFromTip)
(sfActiveFrom <$> template)
<*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template)
<*> areq submissionModeField (fslI MsgSheetSubmissionMode) ((sfSubmissionMode <$> template) <|> pure UserSubmissions)
<*> areq uploadModeField (fslI MsgSheetUploadMode) ((sfUploadMode <$> template) <|> pure (Upload True))
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
<*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
@ -131,6 +140,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
<* submitButton
return $ case result of
FormSuccess sheetResult
@ -149,7 +159,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
] ]
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetListR tid ssh csh = do
getSheetListR tid ssh csh = do
muid <- maybeAuthId
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
let
@ -244,6 +254,21 @@ getSheetListR tid ssh csh = do
$(widgetFile "sheetList")
$(widgetFile "widgets/sheetTypeSummary")
data ButtonGeneratePseudonym = BtnGenerate
deriving (Enum, Eq, Ord, Bounded, Read, Show)
instance Universe ButtonGeneratePseudonym
instance Finite ButtonGeneratePseudonym
$(return [])
instance PathPiece ButtonGeneratePseudonym where
toPathPiece = $(nullaryToPathPiece ''ButtonGeneratePseudonym [Text.unwords . drop 1 . splitCamel])
fromPathPiece = finiteFromPathPiece
instance Button UniWorX ButtonGeneratePseudonym where
label BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
cssClass BtnGenerate = BCDefault
-- Show single sheet
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSShowR tid ssh csh shn = do
@ -273,14 +298,14 @@ getSShowR tid ssh csh shn = do
-- return desired columns
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
let colonnadeFiles = widgetColonnade $ mconcat
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
, sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid ssh csh shn (SFileR fType fName))
(\(E.Value fName,_,_) -> str2widget fName)
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
]
let psValidator = def
& defaultSorting [("type", SortAsc), ("path", SortAsc)]
((), fileTable) <- dbTable psValidator $ DBTable
(Any hasFiles, fileTable) <- dbTable psValidator $ DBTable
{ dbtSQLQuery = fileData
, dbtColonnade = colonnadeFiles
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
@ -288,16 +313,17 @@ getSShowR tid ssh csh shn = do
, dbtStyle = def
, dbtFilter = Map.empty
, dbtIdent = "files" :: Text
, dbtSorting = [ ( "type"
, SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> sheetFile E.^. SheetFileType
)
, ( "path"
, SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
)
, ( "time"
, SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileModified
)
]
, dbtSorting = Map.fromList
[ ( "type"
, SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> sheetFile E.^. SheetFileType
)
, ( "path"
, SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
)
, ( "time"
, SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileModified
)
]
}
(hasHints, hasSolution) <- runDB $ do
hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
@ -307,6 +333,12 @@ getSShowR tid ssh csh shn = do
visibleFrom <- traverse (formatTime SelFormatDateTime) $ sheetVisibleFrom sheet
when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI Warning $
maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
mPseudonym <- runMaybeT $ do
uid <- MaybeT maybeAuthId
Entity _ SheetPseudonym{sheetPseudonymPseudonym} <- MaybeT . runDB . getBy $ UniqueSheetPseudonymUser sid uid
return . Text.unwords . map CI.original $ review pseudonymWords sheetPseudonymPseudonym
(generateWidget, generateEnctype) <- generateFormPost $ \csrf ->
over _2 ((toWidget csrf <>) . fvInput) <$> mreq (buttonField BtnGenerate) "" Nothing
defaultLayout $ do
setTitleI $ MsgSheetTitle tid ssh csh shn
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
@ -315,6 +347,32 @@ getSShowR tid ssh csh shn = do
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
$(widgetFile "sheetShow")
postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
getSPseudonymR = postSPseudonymR
postSPseudonymR tid ssh csh shn = do
uid <- requireAuthId
shId <- runDB $ fetchSheetId tid ssh csh shn
let
genPseudonym = do
inserted <- runExceptT . mapExceptT (runDB . setSerializable) $ do
candidate <- liftIO getRandom
existing <- lift . getBy $ UniqueSheetPseudonymUser shId uid
case existing of
Just (Entity _ SheetPseudonym{sheetPseudonymPseudonym}) -> throwE sheetPseudonymPseudonym
Nothing
-> lift $ fmap (const candidate) <$> insertUnique (SheetPseudonym shId candidate uid)
case inserted of
Right Nothing -> genPseudonym
Right (Just ps) -> return ps
Left ps -> return ps
ps <- genPseudonym
let ps' = Text.unwords . map CI.original $ review pseudonymWords ps
selectRep $ do
provideRep $ return ps'
provideJson ps
provideRep (redirect $ CSheetR tid ssh csh shn SShowR :#: ("pseudonym" :: Text) :: Handler Html)
getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
getSFileR tid ssh csh shn typ title = do
results <- runDB $ E.select $ E.from $
@ -361,11 +419,11 @@ getSheetNewR tid ssh csh = do
{ sfName = stepTextCounterCI sheetName
, sfDescription = sheetDescription
, sfType = sheetType
, sfGrouping = sheetGrouping
, sfMarkingText = sheetMarkingText
, sfGrouping = sheetGrouping
, sfVisibleFrom = addOneWeek <$> sheetVisibleFrom
, sfActiveFrom = addOneWeek sheetActiveFrom
, sfActiveTo = addOneWeek sheetActiveTo
, sfSubmissionMode = sheetSubmissionMode
, sfUploadMode = sheetUploadMode
, sfSheetF = Nothing
, sfHintFrom = addOneWeek <$> sheetHintFrom
@ -373,6 +431,7 @@ getSheetNewR tid ssh csh = do
, sfSolutionFrom = addOneWeek <$> sheetSolutionFrom
, sfSolutionF = Nothing
, sfMarkingF = Nothing
, sfMarkingText = sheetMarkingText
}
_other -> Nothing
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
@ -395,11 +454,11 @@ getSEditR tid ssh csh shn = do
{ sfName = sheetName
, sfDescription = sheetDescription
, sfType = sheetType
, sfGrouping = sheetGrouping
, sfMarkingText = sheetMarkingText
, sfGrouping = sheetGrouping
, sfVisibleFrom = sheetVisibleFrom
, sfActiveFrom = sheetActiveFrom
, sfActiveTo = sheetActiveTo
, sfSubmissionMode = sheetSubmissionMode
, sfUploadMode = sheetUploadMode
, sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
, sfHintFrom = sheetHintFrom
@ -407,6 +466,7 @@ getSEditR tid ssh csh shn = do
, sfSolutionFrom = sheetSolutionFrom
, sfSolutionF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution
, sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
, sfMarkingText = sheetMarkingText
}
let action newSheet = do
replaceRes <- myReplaceUnique sid $ newSheet
@ -441,6 +501,7 @@ handleSheetEdit tid ssh csh msId template dbAction = do
, sheetHintFrom = sfHintFrom
, sheetSolutionFrom = sfSolutionFrom
, sheetUploadMode = sfUploadMode
, sheetSubmissionMode = sfSubmissionMode
}
mbsid <- dbAction newSheet
case mbsid of

12
src/Handler/Submission.hs
View File

@ -20,6 +20,8 @@ module Handler.Submission where
import Import hiding (joinPath)
import Jobs
-- import Yesod.Form.Bootstrap3
import Handler.Utils
@ -72,7 +74,7 @@ makeSubmissionForm msmid uploadMode grouping buddies = identForm FIDsubmission $
flip (renderAForm FormStandard) html $ (,)
<$> fileUpload
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies ciField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
| g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile
| g <- [1..(max (fromIntegral groupNr) $ length buddies)] -- groupNr might have decreased meanwhile
| buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
])
<* submitButton
@ -178,7 +180,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
return (csheet,buddies,lastEdits)
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping buddies
mCID <- runDB $ do
mCID <- runDBJobs $ do
res' <- case res of
(FormMissing ) -> return $ FormMissing
(FormFailure failmsgs) -> return $ FormFailure failmsgs
@ -215,7 +217,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
(Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
(Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email
_other -> mempty
, case length participants `compare` maxParticipants of
, case fromIntegral (length participants) `compare` maxParticipants of
LT -> mempty
_ -> pure $ mr MsgTooManyParticipants
]
@ -232,8 +234,8 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
smid <- case (mFiles, msmid) of
(Nothing, Just smid) -- no new files, existing submission partners updated
-> return smid
(Just files, _) -- new files
-> runConduit $ transPipe lift files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
(Just files, _) -> -- new files
runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
(Nothing, Nothing) -- new submission, no file upload requested
-> insert Submission
{ submissionSheet = shid

243
src/Handler/SystemMessage.hs Normal file
View File

@ -0,0 +1,243 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, TemplateHaskell
, NamedFieldPuns
, RecordWildCards
, OverloadedStrings
, TypeFamilies
, ViewPatterns
, FlexibleContexts
, LambdaCase
, MultiParamTypeClasses
#-}
module Handler.SystemMessage where
import Import
import qualified Data.Map.Lazy as Map
import qualified Data.Text as Text
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NonEmpty
import Handler.Utils
import Utils.Lens
htmlField' :: Field (HandlerT UniWorX IO) Html
htmlField' = htmlField
{ fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis
}
getMessageR, postMessageR :: CryptoUUIDSystemMessage -> Handler Html
getMessageR = postMessageR
postMessageR cID = do
smId <- decrypt cID
(SystemMessage{..}, translation) <- runDB $ maybe notFound return =<< getSystemMessage appLanguages smId
let (summary, content) = case translation of
Nothing -> (systemMessageSummary, systemMessageContent)
Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
let
mkForm :: Handler (((FormResult SystemMessage, Widget), Enctype), Map Lang ((FormResult (Entity SystemMessageTranslation, [Maybe BtnSubmitDelete]), Widget), Enctype), ((FormResult SystemMessageTranslation, Widget), Enctype))
mkForm = do
modifyRes'@((modifyRes, _), _) <- runFormPost . identForm FIDSystemMessageModify . renderAForm FormStandard
$ SystemMessage
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) (Just systemMessageFrom)
<*> aopt utcTimeField (fslI MsgSystemMessageTo) (Just systemMessageTo)
<*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) (Just systemMessageAuthenticatedOnly)
<*> areq (selectField $ optionsFinite (id :: MessageClass -> MessageClass)) (fslI MsgSystemMessageSeverity) (Just systemMessageSeverity)
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageDefaultLanguage)
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageContent)
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageSummary)
<* submitButton
ts <- runDB $ selectList [ SystemMessageTranslationMessage ==. smId ] [Asc SystemMessageTranslationLanguage]
let ts' = Map.fromList $ (systemMessageTranslationLanguage . entityVal &&& id) <$> ts
modifyTranss' <- forM ts' $ \(Entity tId SystemMessageTranslation{..}) -> do
cID' <- encrypt tId
runFormPost . identForm (FIDSystemMessageModifyTranslation $ ciphertext cID') . renderAForm FormStandard
$ (,)
<$> ( fmap (Entity tId) $ SystemMessageTranslation
<$> pure systemMessageTranslationMessage
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just systemMessageTranslationLanguage)
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") (Just systemMessageTranslationContent)
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") (Just systemMessageTranslationSummary)
)
<*> combinedButtonField (universeF :: [BtnSubmitDelete])
let modifyTranss = Map.map (view $ _1._1) modifyTranss'
addTransRes'@((addTransRes, _), _) <- runFormPost . identForm FIDSystemMessageAddTranslation . renderAForm FormStandard
$ SystemMessageTranslation
<$> pure smId
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") Nothing
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing
<* submitButton
formResult modifyRes $ \SystemMessage{..} -> do
runDB $ update smId
[ SystemMessageFrom =. systemMessageFrom
, SystemMessageTo =. systemMessageTo
, SystemMessageAuthenticatedOnly =. systemMessageAuthenticatedOnly
, SystemMessageSeverity =. systemMessageSeverity
, SystemMessageDefaultLanguage =. systemMessageDefaultLanguage
, SystemMessageContent =. systemMessageContent
, SystemMessageSummary =. systemMessageSummary
]
addMessageI Success MsgSystemMessageEditSuccess
redirect $ MessageR cID
formResult addTransRes $ \smt -> do
runDB . void . insert $ smt
addMessageI Success MsgSystemMessageAddTranslationSuccess
redirect $ MessageR cID
forM_ modifyTranss . flip formResult $ \(Entity tId SystemMessageTranslation{..}, (catMaybes -> acts)) -> case acts of
[BtnDelete'] -> do
runDB $ delete tId
addMessageI Success MsgSystemMessageDeleteTranslationSuccess
redirect $ MessageR cID
_other -> do
runDB $ update tId
[ SystemMessageTranslationLanguage =. systemMessageTranslationLanguage
, SystemMessageTranslationContent =. systemMessageTranslationContent
, SystemMessageTranslationSummary =. systemMessageTranslationSummary
]
addMessageI Success MsgSystemMessageEditTranslationSuccess
redirect $ MessageR cID
return (modifyRes', modifyTranss', addTransRes')
maySubmit <- (== Authorized) <$> evalAccess (MessageR cID) True
forms <- traverse (const mkForm) $ () <$ guard maySubmit
defaultLayout $ do
$(widgetFile "system-message")
type MessageListData = DBRow (Entity SystemMessage, Maybe SystemMessageTranslation)
data ActionSystemMessage = SMDelete | SMActivate | SMDeactivate
deriving (Eq, Ord, Enum, Bounded, Show, Read)
instance Universe ActionSystemMessage
instance Finite ActionSystemMessage
$(return [])
instance PathPiece ActionSystemMessage where
toPathPiece = $(nullaryToPathPiece ''ActionSystemMessage [ Text.intercalate "-" . drop 1 . splitCamel ])
fromPathPiece = finiteFromPathPiece
instance RenderMessage UniWorX ActionSystemMessage where
renderMessage m ls = renderMessage m ls . \case
SMDelete -> MsgSystemMessageDelete
SMActivate -> MsgSystemMessageActivate
SMDeactivate -> MsgSystemMessageDeactivate
data ActionSystemMessageData = SMDDelete
| SMDActivate (Maybe UTCTime)
| SMDDeactivate (Maybe UTCTime)
deriving (Eq, Show, Read)
getMessageListR, postMessageListR :: Handler Html
getMessageListR = postMessageListR
postMessageListR = do
let
dbtSQLQuery = return
dbtColonnade = mconcat
[ dbSelect id $ \DBRow{ dbrOutput = (Entity smId _, _) } -> encrypt smId
, dbRow
, sortable Nothing (i18nCell MsgSystemMessageId) $ \DBRow{ dbrOutput = (Entity smId _, _) } -> anchorCellM' (encrypt smId) (\cID -> MessageR cID) (toWidget . tshow . ciphertext)
, sortable (Just "from") (i18nCell MsgSystemMessageFrom) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageFrom
, sortable (Just "to") (i18nCell MsgSystemMessageTo) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> cell $ maybe mempty (formatTimeW SelFormatDateTime) systemMessageTo
, sortable (Just "authenticated") (i18nCell MsgSystemMessageAuthenticatedOnly) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> tickmarkCell systemMessageAuthenticatedOnly
, sortable (Just "severity") (i18nCell MsgSystemMessageSeverity) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, _) } -> i18nCell systemMessageSeverity
, sortable Nothing (i18nCell MsgSystemMessageSummaryContent) $ \DBRow{ dbrOutput = (Entity _ SystemMessage{..}, smT) } -> let
(summary, content) = case smT of
Nothing -> (systemMessageSummary, systemMessageContent)
Just SystemMessageTranslation{..} -> (systemMessageTranslationSummary, systemMessageTranslationContent)
in cell . toWidget $ fromMaybe content summary
]
dbtProj DBRow{ dbrOutput = smE@(Entity smId _), .. } = do
Just (_, smT) <- lift $ getSystemMessage appLanguages smId
return $ DBRow
{ dbrOutput = (smE, smT)
, ..
}
psValidator = def :: PSValidator (MForm (HandlerT UniWorX IO)) (FormResult (DBFormResult MessageListData CryptoUUIDSystemMessage Bool))
tableForm <- dbTable psValidator $ DBTable
{ dbtSQLQuery
, dbtColonnade
, dbtProj
, dbtSorting = Map.fromList
[ -- TODO: from, to, authenticated, severity
]
, dbtFilter = Map.fromList
[
]
, dbtStyle = def
, dbtIdent = "messages" :: Text
}
((tableRes, tableView), tableEncoding) <- runFormPost . identForm FIDSystemMessageTable $ \csrf -> do
((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
now <- liftIO $ getCurrentTime
let actions = Map.fromList
[ (SMDelete, pure SMDDelete)
, (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
, (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing))
]
(actionRes, action) <- multiAction actions (Just SMActivate)
$logDebugS "SystemMessage" $ tshow (actionRes, selectionRes)
return ((,) <$> actionRes <*> selectionRes, table <> action)
case tableRes of
FormMissing -> return ()
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
FormSuccess (SMDDelete, selection)
| not $ null selection -> do
selection' <- traverse decrypt $ Set.toList selection
runDB $ deleteCascadeWhere [ SystemMessageId <-. selection' ]
$(addMessageFile Success "templates/messages/systemMessagesDeleted.hamlet")
redirect MessageListR
FormSuccess (SMDActivate ts, selection)
| not $ null selection -> do
selection' <- traverse decrypt $ Set.toList selection
runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageFrom =. ts ]
$(addMessageFile Success "templates/messages/systemMessagesSetFrom.hamlet")
redirect MessageListR
FormSuccess (SMDDeactivate ts, selection)
| not $ null selection -> do
selection' <- traverse decrypt $ Set.toList selection
runDB $ updateWhere [ SystemMessageId <-. selection' ] [ SystemMessageTo =. ts ]
$(addMessageFile Success "templates/messages/systemMessagesSetTo.hamlet")
redirect MessageListR
FormSuccess (_, selection)
| null selection -> addMessageI Error MsgSystemMessageEmptySelection
((addRes, addView), addEncoding) <- runFormPost . identForm FIDSystemMessageAdd . renderAForm FormStandard $ SystemMessage
<$> aopt utcTimeField (fslI MsgSystemMessageFrom) Nothing
<*> aopt utcTimeField (fslI MsgSystemMessageTo) Nothing
<*> areq checkBoxField (fslI MsgSystemMessageAuthenticatedOnly) Nothing
<*> areq (selectField $ optionsFinite (id :: MessageClass -> MessageClass)) (fslI MsgSystemMessageSeverity) Nothing
<*> areq (langField False) (fslpI MsgSystemMessageLanguage "RFC1766-Sprachcode") (Just $ NonEmpty.head appLanguages)
<*> areq htmlField' (fslpI MsgSystemMessageContent "HTML") Nothing
<*> aopt htmlField' (fslpI MsgSystemMessageSummary "HTML") Nothing
<* submitButton
case addRes of
FormMissing -> return ()
FormFailure errs -> forM_ errs $ addMessage Error . toHtml
FormSuccess sysMsg -> do
sId <- runDB $ insert sysMsg
cID <- encrypt sId :: Handler CryptoUUIDSystemMessage
addMessageI Success $ MsgSystemMessageAdded cID
redirect $ MessageR cID
defaultLayout $ do
$(widgetFile "system-message-list")

1
src/Handler/Utils.hs
View File

@ -25,6 +25,7 @@ import Handler.Utils.Rating as Handler.Utils hiding (extractRatings)
import Handler.Utils.Submission as Handler.Utils
import Handler.Utils.Sheet as Handler.Utils
import Handler.Utils.Templates as Handler.Utils
import Handler.Utils.Mail as Handler.Utils
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool

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

@ -11,6 +11,7 @@ module Handler.Utils.DateTime
, formatTime, formatTime', formatTimeW
, getTimeLocale, getDateTimeFormat
, validDateTimeFormats, dateTimeFormatOptions
, formatTimeMail
, addOneWeek
) where
@ -26,6 +27,8 @@ import qualified Data.Time.Format as Time
import Data.Set (Set)
import qualified Data.Set as Set
import Mail
utcToLocalTime :: UTCTime -> LocalTime
utcToLocalTime = TZ.utcToLocalTimeTZ appTZ
@ -58,6 +61,9 @@ formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeForm
formatTimeW :: (HasLocalTime t) => SelDateTimeFormat -> t -> Widget
formatTimeW s t = toWidget =<< formatTime s t
formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text
formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . mailLanguages <$> askMailLanguages) <*> (unDateTimeFormat <$> askMailDateTimeFormat sel) <*> pure (toLocalTime t)
getTimeLocale :: (MonadHandler m, HandlerSite m ~ UniWorX) => m TimeLocale
getTimeLocale = getTimeLocale' <$> languages

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

@ -25,7 +25,7 @@ import Handler.Utils.Templates
import Handler.Utils.DateTime
import qualified Data.Time as Time
import Import
import Import hiding (cons)
import qualified Data.Char as Char
import Data.String (IsString(..))
@ -60,6 +60,10 @@ import Data.Scientific (Scientific)
import Data.Ratio
import Text.Read (readMaybe)
import Data.Maybe (fromJust)
import Utils.Lens
----------------------------
-- Buttons (new version ) --
----------------------------
@ -104,6 +108,25 @@ instance Button UniWorX AdminHijackUserButton where
cssClass BtnHijack = BCDefault
data BtnSubmitDelete = BtnSubmit' | BtnDelete'
deriving (Enum, Eq, Ord, Bounded, Read, Show)
instance Universe BtnSubmitDelete
instance Finite BtnSubmitDelete
instance Button UniWorX BtnSubmitDelete where
label BtnSubmit' = [whamlet|_{MsgBtnSubmit}|]
label BtnDelete' = [whamlet|_{MsgBtnDelete}|]
cssClass BtnSubmit' = BCPrimary
cssClass BtnDelete' = BCDanger
$(return [])
instance PathPiece BtnSubmitDelete where
toPathPiece = $(nullaryToPathPiece ''BtnSubmitDelete [ T.intercalate "-" . drop 1 . splitCamel ])
fromPathPiece = finiteFromPathPiece
-- -- Looks like a button, but is just a link (e.g. for create course, etc.)
-- data LinkButton = LinkButton (Route UniWorX)
@ -121,37 +144,6 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
-- |]
-- <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
{-
combinedButtonField :: Button a => [a] -> Form m -> Form (a,m)
combinedButtonField btns inner csrf = do
buttonIdent <- newFormIdent
let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
(results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
(innerRes,innerWdgt) <- inner
let widget = do
[whamlet|
#{csrf}
^{innerWdgt}
<div .btn-group>
$forall bView <- btnViews
^{fvInput bView}
|]
let result = case (accResult result, innerRes) of
(FormSuccess b, FormSuccess i) -> FormSuccess (b,i)
_ -> FormFailure ["Something went wrong"] -- TODO
return (result,widget)
where
accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
accResult = Foldable.foldr accResult' FormMissing
accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
accResult' (FormSuccess (Just x)) _ = FormSuccess x
accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
accResult' (FormSuccess Nothing) x = x
accResult' FormMissing _ = FormMissing
accResult' (FormFailure errs) _ = FormFailure errs
-}
-- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
buttonForm :: (Button UniWorX a, Show a) => Form a
@ -165,18 +157,16 @@ buttonForm csrf = do
$forall bView <- btnViews
^{fvInput bView}
|]
$logDebugS "FormResult" $ tshow results
return (accResult results,widget)
where
accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
accResult = Foldable.foldr accResult' FormMissing
accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
-- TODO: Does not work for Forms with more than 3 buttons, since all deliver FormFailure except for one!
-- TODO: Maybe change buttonField?
-- Find the single FormSuccess Just _; Expected behaviour: all buttons deliver FormFailure, except for one.
accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
accResult' (FormSuccess (Just x)) _ = FormSuccess x
accResult' _ x@(FormSuccess _) = x --SJ: Is this safe? Shouldn't Failure override Success?
accResult' _ x@(FormSuccess _) = x --Safe: most buttons deliver FormFailure, one delivers FormSuccess
accResult' (FormSuccess Nothing) x = x
accResult' FormMissing _ = FormMissing
accResult' (FormFailure errs) _ = FormFailure errs
@ -257,6 +247,22 @@ uploadModeField = selectFieldList
, (MsgUploadModeUnpack , Upload True )
]
submissionModeField :: Field Handler SheetSubmissionMode
submissionModeField = selectFieldList
[ (MsgSheetNoSubmission, NoSubmissions)
, (MsgSheetCorrectorSubmissions, CorrectorSubmissions)
, (MsgSheetUserSubmissions, UserSubmissions)
]
pseudonymWordField :: Field Handler PseudonymWord
pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist)
where
doCheck (CI.mk -> w)
| Just w' <- find (== w) pseudonymWordlist
= return $ Right w'
| otherwise
= return . Left $ MsgUnknownPseudonymWord (CI.original w)
zipFileField :: Bool -- ^ Unpack zips?
-> Field Handler (Source Handler File)
zipFileField doUnpack = Field{..}
@ -321,23 +327,122 @@ multiFileField permittedFiles' = Field{..}
Right _ -> return ()
Left r -> yield r
sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
sheetTypeAFormReq d Nothing =
-- TODO, offer options to choose between Normal/Bonus/Pass
(Normal . toPoints) <$> areq (natField "Punkte") d Nothing
sheetTypeAFormReq d (Just (Normal p)) =
-- TODO, offer options to choose between Normal/Bonus/Pass
(Normal . toPoints) <$> areq (natField "Punkte") d (Just $ fromPoints p)
sheetTypeAFormReq d (Just (NotGraded)) = pure NotGraded
data SheetType' = Bonus' | Normal' | Pass' | NotGraded'
deriving (Eq, Ord, Read, Show, Enum, Bounded)
instance Universe SheetType'
instance Finite SheetType'
$(return [])
instance PathPiece SheetType' where
toPathPiece = $(nullaryToPathPiece ''SheetType' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
fromPathPiece = finiteFromPathPiece
instance RenderMessage UniWorX SheetType' where
renderMessage f ls = \case
Bonus' -> render MsgSheetTypeBonus
Normal' -> render MsgSheetTypeNormal
Pass' -> render MsgSheetTypePass
NotGraded' -> render MsgSheetTypeNotGraded
where
render = renderMessage f ls
data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
deriving (Eq, Ord, Read, Show, Enum, Bounded)
instance Universe SheetGroup'
instance Finite SheetGroup'
$(return [])
instance PathPiece SheetGroup' where
toPathPiece = $(nullaryToPathPiece ''SheetGroup' [intercalate "-" . splitCamel , fromJust . stripSuffix "'"])
fromPathPiece = finiteFromPathPiece
instance RenderMessage UniWorX SheetGroup' where
renderMessage f ls = \case
Arbitrary' -> render MsgSheetGroupArbitrary
RegisteredGroups' -> render MsgSheetGroupRegisteredGroups
NoGroups' -> render MsgSheetGroupNoGroups
where
render = renderMessage f ls
sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
sheetTypeAFormReq FieldSettings{..} template = formToAForm $ do
let
selOptions = Map.fromList
[ ( Bonus', Bonus <$> maxPointsReq )
, ( Normal', Normal <$> maxPointsReq )
, ( Pass', Pass
<$> maxPointsReq
<*> apreq pointsField (fslpI MsgSheetTypePassingPoints "Punkte" & noValidate) (preview _passingPoints =<< template)
)
, ( NotGraded', pure NotGraded )
]
(res, selView) <- multiAction selOptions (classify' <$> template)
fvId <- maybe newIdent return fsId
MsgRenderer mr <- getMsgRenderer
return (res,
[ FieldView
{ fvLabel = toHtml $ mr fsLabel
, fvTooltip = toHtml . mr <$> fsTooltip
, fvId
, fvInput = selView
, fvErrors = case res of
FormFailure [e] -> Just $ toHtml e
_ -> Nothing
, fvRequired = True
}
])
where
maxPointsReq = apreq pointsField (fslpI MsgSheetTypeMaxPoints "Punkte" & noValidate) (preview _maxPoints =<< template)
classify' :: SheetType -> SheetType'
classify' = \case
Bonus _ -> Bonus'
Normal _ -> Normal'
Pass _ _ -> Pass'
NotGraded -> NotGraded'
sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
sheetGroupAFormReq d (Just (Arbitrary n)) | n >= 1 =
-- TODO, offer options to choose between Arbitrary/Registered/NoGroups
Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just n)
sheetGroupAFormReq d _other = -- TODO
-- TODO, offer options to choose between Arbitrary/Registered/NoGroups
Arbitrary <$> areq (natField "Abgabegruppengröße") d (Just 1)
sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
let
selOptions = Map.fromList
[ ( Arbitrary', Arbitrary
<$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
)
, ( RegisteredGroups', pure RegisteredGroups )
, ( NoGroups', pure NoGroups )
]
(res, selView) <- multiAction selOptions (classify' <$> template)
fvId <- maybe newIdent return fsId
MsgRenderer mr <- getMsgRenderer
return (res,
[ FieldView
{ fvLabel = toHtml $ mr fsLabel
, fvTooltip = toHtml . mr <$> fsTooltip
, fvId
, fvInput = selView
, fvErrors = case res of
FormFailure [e] -> Just $ toHtml e
_ -> Nothing
, fvRequired = True
}
])
where
classify' :: SheetGroup -> SheetGroup'
classify' = \case
Arbitrary _ -> Arbitrary'
RegisteredGroups -> RegisteredGroups'
NoGroups -> NoGroups'
{-
dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime
@ -385,6 +490,11 @@ utcTimeField = Field
(Just (LTUAmbiguous _ _ _ _)) -> Left MsgAmbiguousUTCTime
Nothing -> Left MsgInvalidDateTimeFormat
langField :: Bool -- ^ Only allow values from `appLanguages`
-> Field (HandlerT UniWorX IO) Lang
langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages)
langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages
fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
fsm = bfs -- TODO: get rid of Bootstrap
@ -449,15 +559,61 @@ 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
fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } ))) $ mopt f fs (Just <$> 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
fmap (over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } )) $ mopt f fs (Just <$> mx)
multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (MForm (HandlerT UniWorX IO) (FormResult a, Maybe Widget))
=> Map action (AForm (HandlerT UniWorX IO) a)
-> Maybe action
-> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
multiAction acts = do
multiAction acts defAction = do
mr <- getMessageRender
let
options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
(actionRes, actionView) <- mreq (selectField $ return options) "" Nothing
results <- sequence acts
let actionWidgets = Map.foldrWithKey (\act -> \case (_, Just w) -> ($(widgetFile "widgets/multiAction") :); (_, Nothing) -> id) [] results
(actionRes, actionView) <- mreq (selectField $ return options) "" defAction
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
let mToWidget (_, []) = return Nothing
mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty
widgets <- mapM mToWidget results
let actionWidgets = Map.foldrWithKey accWidget [] widgets
accWidget act Nothing = id
accWidget act (Just w) = cons $(widgetFile "widgets/multiAction")
actionResults = Map.map fst results
return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> FieldSettings UniWorX
-> Map action (AForm (HandlerT UniWorX IO) a)
-> Maybe action
-> AForm (HandlerT UniWorX IO) a
multiActionA FieldSettings{..} acts defAction = formToAForm $ do
(res, selView) <- multiAction acts defAction
fvId <- maybe newIdent return fsId
MsgRenderer mr <- getMsgRenderer
return (res,
[ FieldView
{ fvLabel = toHtml $ mr fsLabel
, fvTooltip = toHtml . mr <$> fsTooltip
, fvId
, fvInput = selView
, fvErrors = case res of
FormFailure [e] -> Just $ toHtml e
_ -> Nothing
, fvRequired = True
}
])

80
src/Handler/Utils/Mail.hs Normal file
View File

@ -0,0 +1,80 @@
{-# LANGUAGE NoImplicitPrelude
, NamedFieldPuns
, TypeFamilies
, FlexibleContexts
, ViewPatterns
, LambdaCase
#-}
module Handler.Utils.Mail
( addRecipientsDB
, userMailT
, addFileDB
) where
import Import hiding ((.=))
import Utils.Lens hiding (snoc)
import qualified Data.CaseInsensitive as CI
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Conduit.List as C
import System.FilePath (takeBaseName)
import Network.Mime (defaultMimeLookup)
import Control.Monad.Trans.State (StateT)
addRecipientsDB :: ( MonadMail m
, MonadHandler m
, HandlerSite m ~ UniWorX
) => [Filter User] -> m ()
-- ^ @setRecipientId uid@ throws an exception if @uid@ does not refer to an existing user
addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectSource uFilter [Asc UserDisplayName]) .| C.mapM_ addRecipient
where
addRecipient (Entity _ User{userEmail, userDisplayName}) = do
let addr = Address (Just userDisplayName) $ CI.original userEmail
_mailTo %= flip snoc addr
userMailT :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadBaseControl IO m
, MonadLogger m
) => UserId -> MailT m a -> m a
userMailT uid mAct = do
User
{ userEmail
, userDisplayName
, userMailLanguages
, userDateTimeFormat
, userDateFormat
, userTimeFormat
} <- liftHandlerT . runDB $ getJust uid
let
addr = Address (Just userDisplayName) $ CI.original userEmail
ctx = MailContext
{ mcLanguages = userMailLanguages
, mcDateTimeFormat = \case
SelFormatDateTime -> userDateTimeFormat
SelFormatDate -> userDateFormat
SelFormatTime -> userTimeFormat
}
mailT ctx $ do
_mailTo .= pure addr
mAct
addFileDB :: ( MonadMail m
, MonadHandler m
, HandlerSite m ~ UniWorX
) => FileId -> m MailObjectId
addFileDB fId = do
File{fileTitle = pack . takeBaseName -> fileName, fileContent = Just fileContent} <- liftHandlerT . runDB $ getJust fId
addPart $ do
_partType .= decodeUtf8 (defaultMimeLookup fileName)
_partEncoding .= Base64
_partFilename .= Just fileName
_partContent .= LBS.fromStrict fileContent
setMailObjectId' fId :: StateT Part (HandlerT UniWorX IO) MailObjectId

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

@ -11,6 +11,7 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiWayIf #-}
module Handler.Utils.Submission
@ -25,6 +26,7 @@ module Handler.Utils.Submission
) where
import Import hiding ((.=), joinPath)
import Jobs
import Prelude (lcm)
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
@ -38,7 +40,7 @@ import Control.Monad.RWS.Lazy (RWST)
import qualified Control.Monad.Random as Rand
import qualified System.Random.Shuffle as Rand (shuffleM)
import Data.Maybe
import Data.Maybe ()
import qualified Data.List as List
import Data.Set (Set)
@ -279,6 +281,7 @@ submissionMultiArchive (Set.toList -> ids) = do
data SubmissionSinkState = SubmissionSinkState
{ sinkSeenRating :: Any
, sinkSubmissionTouched :: Any
, sinkSubmissionNotifyRating :: Any
, sinkFilenames :: Set FilePath
} deriving (Show, Eq, Generic, Typeable)
@ -333,7 +336,7 @@ extractRatingsMsg = do
sinkSubmission :: UserId
-> Either SheetId SubmissionId
-> Bool -- ^ Is this a correction
-> Sink SubmissionContent (YesodDB UniWorX) SubmissionId
-> Sink SubmissionContent (YesodJobDB UniWorX) SubmissionId
-- ^ Replace the currently saved files for the given submission (either
-- corrected files or original ones, depending on arguments) with the supplied
-- 'SubmissionContent'.
@ -365,7 +368,7 @@ sinkSubmission userId mExists isUpdate = do
sinkSubmission' :: SubmissionId
-> Bool -- ^ Is this a correction
-> Sink SubmissionContent (YesodDB UniWorX) ()
-> Sink SubmissionContent (YesodJobDB UniWorX) ()
sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
Left file@(File{..}) -> do
$logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
@ -463,18 +466,21 @@ sinkSubmission userId mExists isUpdate = do
-- The check whether the new version matches the underlying file is
-- more lenient, considering only filename and -content.
touchSubmission :: StateT SubmissionSinkState (YesodDB UniWorX) ()
touchSubmission :: StateT SubmissionSinkState (YesodJobDB UniWorX) ()
touchSubmission = do
alreadyTouched <- gets $ getAny . sinkSubmissionTouched
when (not alreadyTouched) $ do
now <- liftIO getCurrentTime
lift $ case isUpdate of
False -> insert_ $ SubmissionEdit userId now submissionId
True -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
-- TODO: Should submissionRatingAssigned change here if userId changes?
case isUpdate of
False -> lift . insert_ $ SubmissionEdit userId now submissionId
True -> do
Submission{submissionRatingTime} <- lift $ getJust submissionId
when (isNothing submissionRatingTime) $ tell mempty { sinkSubmissionNotifyRating = Any True }
lift $ update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ]
-- TODO: Should submissionRatingAssigned change here if userId changes?
tell $ mempty{ sinkSubmissionTouched = Any True }
finalize :: SubmissionSinkState -> YesodDB UniWorX ()
finalize :: SubmissionSinkState -> YesodJobDB UniWorX ()
finalize SubmissionSinkState{..} = do
missingFiles <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
E.on $ sf E.^. SubmissionFileFile E.==. f E.^. FileId
@ -509,13 +515,19 @@ sinkSubmission userId mExists isUpdate = do
update sfId [ SubmissionFileFile =. f, SubmissionFileIsDeletion =. True ]
deleteCascade fileId
when (isUpdate && not (getAny sinkSeenRating)) $
update submissionId
if
| isUpdate
, not $ getAny sinkSeenRating
-> update submissionId
[ SubmissionRatingTime =. Nothing
, SubmissionRatingPoints =. Nothing
, SubmissionRatingBy =. Nothing
, SubmissionRatingComment =. Nothing
]
| isUpdate
, getAny sinkSubmissionNotifyRating
-> queueDBJob . JobQueueNotification $ NotificationSubmissionRated submissionId
| otherwise -> return ()
data SubmissionMultiSinkException
= SubmissionSinkException
@ -529,7 +541,7 @@ instance Exception SubmissionMultiSinkException
sinkMultiSubmission :: UserId
-> Bool {-^ Are these corrections -}
-> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId)
-> Sink SubmissionContent (YesodJobDB UniWorX) (Set SubmissionId)
-- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'.
--
@ -543,8 +555,8 @@ sinkMultiSubmission userId isUpdate = do
-> RWST
()
_
(Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId))
(YesodDB UniWorX)
(Map SubmissionId (ResumableSink SubmissionContent (YesodJobDB UniWorX) SubmissionId))
(YesodJobDB UniWorX)
()
feed sId val = do
mSink <- gets $ Map.lookup sId
@ -593,10 +605,10 @@ sinkMultiSubmission userId isUpdate = do
when (not $ null ignored) $ do
mr <- (toHtml .) <$> getMessageRender
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionFilesIgnored.hamlet") mr)
fmap Map.keysSet . lift . sequence $ flip Map.mapWithKey sinks $ \sId sink -> do
lift . fmap Set.fromList . forM (Map.toList sinks) $ \(sId, sink) -> do
cID <- encrypt sId
handle (throwM . SubmissionSinkException cID Nothing) $
void $ closeResumableSink sink
closeResumableSink sink
where
handleHCError :: Either CryptoFileNameSubmission FilePath -> HandlerContents -> _ (Maybe a)
handleHCError ident (HCError NotFound) = Nothing <$ tell (Set.singleton ident)

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

@ -35,7 +35,7 @@ module Handler.Utils.Table.Pagination
, widgetColonnade, formColonnade, dbColonnade
, cell, textCell, stringCell, i18nCell
, anchorCell, anchorCell', anchorCellM, anchorCellM'
, tickmarkCell
, tickmarkCell, cellTooltip
, listCell
, formCell, DBFormResult, getDBFormResult
, dbRow, dbSelect
@ -339,8 +339,8 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost . identifyForm dbtIdent
dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> identifyForm dbtIdent form csrf
dbWidget DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
dbHandler DBTable{ dbtIdent = (toPathPiece -> dbtIdent) } f form = return $ \csrf -> over _2 f <$> form csrf
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
-- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
@ -499,6 +499,15 @@ tickmarkCell :: (IsDBTable m a) => Bool -> DBCell m a
tickmarkCell True = textCell (tickmark :: Text)
tickmarkCell False = mempty
cellTooltip :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a -> DBCell m a
cellTooltip msg cell = cell & cellContents.mapped %~ (<> tipWdgt)
where
tipWdgt = [whamlet|
<div .js-tooltip>
<div .tooltip__handle>
<div .tooltip__content>_{msg}
|]
anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
anchorCell = anchorCellM . return

1
src/Import.hs
View File

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

22
src/Import/NoFoundation.hs
View File

@ -1,9 +1,10 @@
{-# LANGUAGE CPP #-}
module Import.NoFoundation
( module Import
, MForm
) where
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI)
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm)
import Model as Import
import Model.Types.JSON as Import
import Model.Migration as Import
@ -13,6 +14,7 @@ import Yesod.Auth as Import
import Yesod.Core.Types as Import (loggerSet)
import Yesod.Default.Config2 as Import
import Utils as Import
import Yesod.Core.Json as Import (provideJson)
import Data.Fixed as Import
@ -25,3 +27,21 @@ import Text.Lucius as Import
import Text.Shakespeare.Text as Import hiding (text, stext)
import Data.Universe 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 Data.Hashable as Import
import Data.List.NonEmpty as Import (NonEmpty(..))
import Control.Monad.Morph as Import (MFunctor(..))
import Control.Monad.Trans.RWS (RWST)
type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m

298
src/Jobs.hs Normal file
View File

@ -0,0 +1,298 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, TemplateHaskell
, OverloadedStrings
, FlexibleContexts
, ViewPatterns
, TypeFamilies
, DeriveGeneric
, DeriveDataTypeable
, QuasiQuotes
, NamedFieldPuns
, MultiWayIf
#-}
module Jobs
( module Types
, module Jobs.Queue
, handleJobs
) where
import Import hiding (Proxy)
import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
import Jobs.Types (JobCtl(JobCtlQueue))
import Jobs.Queue
import Jobs.TH
import Jobs.Crontab
import Data.Conduit.TMChan
import qualified Data.Conduit.List as C
import qualified Data.Text.Lazy as LT
import Data.Aeson (fromJSON, toJSON)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import Database.Persist.Sql (fromSqlKey)
import Data.Semigroup (Max(..))
import Utils.Sql
import Control.Monad.Random (evalRand, mkStdGen)
import Cron
import qualified Data.HashMap.Strict as HashMap
import Data.HashMap.Strict (HashMap)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Foldable (foldrM)
import Control.Monad.Trans.Reader (mapReaderT)
import Control.Monad.Trans.State (StateT, evalStateT, mapStateT)
import qualified Control.Monad.State.Class as State
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Trans.Resource (MonadResourceBase, ResourceT, runResourceT, allocate)
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Logger
import Control.Monad.Random (MonadRandom(..), evalRand)
import Data.Time.Clock
import Data.Time.Zones
import Control.Concurrent.STM (retry)
import Jobs.Handler.SendNotification
import Jobs.Handler.SendTestEmail
import Jobs.Handler.QueueNotification
import Jobs.Handler.HelpRequest
import Jobs.Handler.SetLogSettings
data JobQueueException = JInvalid QueuedJobId QueuedJob
| JLocked QueuedJobId InstanceId UTCTime
| JNonexistant QueuedJobId
deriving (Read, Show, Eq, Generic, Typeable)
instance Exception JobQueueException
handleJobs :: (MonadResource m, MonadIO m) => [TMChan JobCtl] -> UniWorX -> m ()
-- | Read control commands from `appJobCtl` and address them as they come in
--
-- Uses `unsafeHandler`, as per documentation all HTTP-related fields of state/environment are meaningless placeholders.
-- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ...
handleJobs recvChans foundation@UniWorX{..} = do
jobCrontab <- liftIO $ newTVarIO HashMap.empty
jobConfirm <- liftIO $ newTVarIO HashMap.empty
forM_ (zip [1..] recvChans) $ \(n, chan) ->
let
logStart = $logDebugS ("Jobs #" <> tshow n) "Starting"
logStop = $logDebugS ("Jobs #" <> tshow n) "Stopping"
doFork = fork . unsafeHandler foundation . bracket_ logStart logStop . flip runReaderT JobContext{..} . runConduit $ sourceTMChan chan .| handleJobs' n
in void $ allocate (liftIO doFork) (\_ -> liftIO . atomically $ closeTMChan chan)
-- Start cron operation
void $ allocate (liftIO . fork . unsafeHandler foundation $ runReaderT execCrontab JobContext{..}) (liftIO . killThread)
liftIO . unsafeHandler foundation . flip runReaderT JobContext{..} $
writeJobCtlBlock JobCtlDetermineCrontab
execCrontab :: ReaderT JobContext (HandlerT UniWorX IO) ()
-- ^ Keeping a `HashMap` of the latest execution times of `JobCtl`s we have
-- seen, wait for the time of the next job and fire it
execCrontab = flip evalStateT HashMap.empty . forever $ do
mapStateT (liftHandlerT . runDB . setSerializable) $ do
let
merge (Entity leId CronLastExec{..})
| Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
= State.modify $ HashMap.insertWith (<>) (JobCtlQueue job) (Max cronLastExecTime)
| otherwise = lift $ delete leId
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
now <- liftIO getCurrentTime
(currentCrontab, (jobCtl, nextMatch)) <- mapStateT (mapReaderT $ liftIO . atomically) $ do
crontab <- liftBase . readTVar =<< asks jobCrontab
State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
prevExec <- State.get
case earliestJob prevExec crontab now of
Nothing -> liftBase retry
Just (_, MatchNone) -> liftBase retry
Just x -> return (crontab, x)
let doJob = mapStateT (mapReaderT $ liftHandlerT . runDBJobs . setSerializable) $ do
newCrontab <- lift . lift . hoist lift $ determineCrontab'
if
| ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
-> do
now <- liftIO $ getCurrentTime
instanceID <- getsYesod appInstanceID
State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
case jobCtl of
JobCtlQueue job -> do
lift . lift $ upsertBy
(UniqueCronLastExec $ toJSON job)
CronLastExec
{ cronLastExecJob = toJSON job
, cronLastExecTime = now
, cronLastExecInstance = instanceID
}
[ CronLastExecTime =. now ]
lift . lift $ queueDBJob job
other -> writeJobCtl other
| otherwise
-> lift . mapReaderT (liftIO . atomically) $
lift . flip writeTVar newCrontab =<< asks jobCrontab
case nextMatch of
MatchAsap -> doJob
MatchNone -> return ()
MatchAt nextTime -> do
JobContext{jobCrontab} <- ask
nextTime' <- applyJitter jobCtl nextTime
$logDebugS "Cron" [st|Waiting until #{tshow (utcToLocalTimeTZ appTZ nextTime')} to execute #{tshow jobCtl}|]
logFunc <- askLoggerIO
whenM (liftIO . flip runLoggingT logFunc $ waitUntil jobCrontab currentCrontab nextTime')
doJob
where
acc :: NominalDiffTime
acc = 1e-3
applyJitter :: (MonadHandler m, HandlerSite m ~ UniWorX, Hashable seed) => seed -> UTCTime -> m UTCTime
applyJitter seed t = do
appInstance <- getsYesod appInstanceID
let
halfRange = truncate $ 0.5 / acc
diff = evalRand ( (* acc) . fromInteger <$> getRandomR (- halfRange, halfRange)) $ mkStdGen (hash appInstance `hashWithSalt` seed)
return $ addUTCTime diff t
earliestJob :: HashMap JobCtl (Max UTCTime) -> Crontab JobCtl -> UTCTime -> Maybe (JobCtl, CronNextMatch UTCTime)
earliestJob lastTimes crontab now = foldr go Nothing $ HashMap.toList crontab
where
go (jobCtl, cron) mbPrev
| Just (_, t') <- mbPrev
, t' < t
= mbPrev
| otherwise
= Just (jobCtl, t)
where
t = nextCronMatch appTZ (getMax <$> HashMap.lookup jobCtl lastTimes) now cron
waitUntil :: (Eq a, MonadResourceBase m, MonadLogger m) => TVar a -> a -> UTCTime -> m Bool
waitUntil crontabTV crontab nextTime = runResourceT $ do
diffT <- diffUTCTime nextTime <$> liftIO getCurrentTime
let waitTime = fromInteger (truncate $ diffT / acc) * toRational acc
waitTime'
| diffT < acc = "Done"
| otherwise = tshow (realToFrac waitTime :: NominalDiffTime)
$logDebugS "waitUntil" [st|#{tshow diffT} (#{waitTime'})|]
if
| diffT < acc -> return True
| otherwise -> do
retVar <- liftIO newEmptyTMVarIO
void $ allocate (liftIO $ forkFinally (threadDelay . round $ waitTime * 1e6) $ atomically . putTMVar retVar) (liftIO . killThread)
let
awaitDelayThread = False <$ takeTMVar retVar
awaitCrontabChange = do
crontab' <- readTVar crontabTV
True <$ guard (crontab /= crontab')
crontabChanged <- liftIO . atomically $ awaitCrontabChange <|> awaitDelayThread
bool (waitUntil crontabTV crontab nextTime) (return False) crontabChanged
handleJobs' :: Int -> Sink JobCtl (ReaderT JobContext Handler) ()
handleJobs' wNum = C.mapM_ $ \jctl -> do
$logDebugS logIdent $ tshow jctl
resVars <- mapReaderT (liftIO . atomically) $
HashMap.lookup jctl <$> (lift . readTVar =<< asks jobConfirm)
res <- fmap (either Just $ const Nothing) . try $ handleCmd jctl
sentRes <- liftIO . atomically $ foldrM (\resVar -> bool (tryPutTMVar resVar res) $ return True) False (maybe [] NonEmpty.toList resVars)
case res of
Just err
| not sentRes -> $logErrorS logIdent $ tshow err
_other -> return ()
where
logIdent = "Jobs #" <> tshow wNum
handleQueueException :: MonadLogger m => JobQueueException -> m ()
handleQueueException (JInvalid jId j) = $logWarnS logIdent $ "Invalid QueuedJob (#" ++ tshow (fromSqlKey jId) ++ "): " ++ tshow j
handleQueueException (JNonexistant jId) = $logInfoS logIdent $ "Saw nonexistant queue id: " ++ tshow (fromSqlKey jId)
handleQueueException (JLocked jId lInstance lTime) = $logDebugS logIdent $ "Saw locked QueuedJob: " ++ tshow (fromSqlKey jId, lInstance, lTime)
handleCmd JobCtlFlush = void . lift . runDB . runConduit $ selectKeys [] [ Asc QueuedJobCreationTime ] .| C.mapM_ (writeJobCtl . JobCtlPerform)
handleCmd (JobCtlQueue job) = lift $ queueJob' job
handleCmd (JobCtlPerform jId) = lift . handle handleQueueException . jLocked jId $ \j@QueuedJob{..} -> do
content <- case fromJSON queuedJobContent of
Aeson.Success c -> return c
Aeson.Error t -> do
$logErrorS logIdent $ "Aeson decoding error: " <> pack t
throwM $ JInvalid jId j
$logDebugS logIdent . LT.toStrict . decodeUtf8 $ Aeson.encode content
performJob content
-- `performJob` is expected to throw an exception if it detects that the job was not done
runDB $ delete jId
handleCmd JobCtlDetermineCrontab = do
newCTab <- liftHandlerT . runDB $ setSerializable determineCrontab'
-- $logDebugS logIdent $ tshow newCTab
mapReaderT (liftIO . atomically) $
lift . flip writeTVar newCTab =<< asks jobCrontab
jLocked :: QueuedJobId -> (QueuedJob -> Handler a) -> Handler a
jLocked jId act = do
hasLock <- liftIO $ newTVarIO False
let
lock = runDB . setSerializable $ do
qj@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
instanceID <- getsYesod appInstanceID
threshold <- getsYesod $ appJobStaleThreshold . appSettings
now <- liftIO getCurrentTime
hadStale <- maybeT (return False) $ do
lockTime <- MaybeT $ return queuedJobLockTime
lockInstance <- MaybeT $ return queuedJobLockInstance
if
| lockInstance == instanceID
, diffUTCTime now lockTime >= threshold
-> return True
| otherwise
-> throwM $ JLocked jId lockInstance lockTime
when hadStale .
$logWarnS "Jobs" $ "Ignored stale lock: " <> tshow qj
val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID
, QueuedJobLockTime =. Just now
]
liftIO . atomically $ writeTVar hasLock True
return val
unlock = whenM (liftIO . atomically $ readTVar hasLock) $
runDB . setSerializable $
update jId [ QueuedJobLockInstance =. Nothing
, QueuedJobLockTime =. Nothing
]
bracket lock (const unlock) act
pruneLastExecs :: Crontab JobCtl -> DB ()
pruneLastExecs crontab = runConduit $ selectSource [] [] .| C.mapM_ ensureCrontab
where
ensureCrontab (Entity leId CronLastExec{..})
| Just job <- Aeson.parseMaybe parseJSON cronLastExecJob
, HashMap.member (JobCtlQueue job) crontab
= return ()
| otherwise = delete leId
determineCrontab' :: DB (Crontab JobCtl)
determineCrontab' = (\ct -> ct <$ pruneLastExecs ct) =<< determineCrontab
performJob :: Job -> HandlerT UniWorX IO ()
performJob = $(dispatchTH ''Job)

106
src/Jobs/Crontab.hs Normal file
View File

@ -0,0 +1,106 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, FlexibleContexts
, MultiWayIf
, NamedFieldPuns
, TypeFamilies
#-}
module Jobs.Crontab
( determineCrontab
) where
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
import Data.Time.Zones
import Control.Monad.Trans.Writer (execWriterT)
import Control.Monad.Writer.Class (MonadWriter(..))
import qualified Data.Conduit.List as C
determineCrontab :: DB (Crontab JobCtl)
-- ^ Extract all future jobs from the database (sheet deadlines, ...)
determineCrontab = execWriterT $ do
AppSettings{..} <- getsYesod appSettings
case appJobFlushInterval of
Just interval -> tell $ HashMap.singleton
JobCtlFlush
Cron
{ cronInitial = CronAsap
, cronRepeat = CronRepeatScheduled CronAsap
, cronRateLimit = interval
, cronNotAfter = Right CronNotScheduled
}
Nothing -> return ()
tell $ HashMap.singleton
JobCtlDetermineCrontab
Cron
{ cronInitial = CronAsap
, cronRepeat = CronRepeatScheduled CronAsap
, cronRateLimit = appJobCronInterval
, cronNotAfter = Right CronNotScheduled
}
let
sheetJobs (Entity nSheet Sheet{..}) = do
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetActive{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveFrom
, cronRepeat = CronRepeatNever
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
}
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetSoonInactive{..})
Cron
{ cronInitial = CronTimestamp . utcToLocalTimeTZ appTZ . max sheetActiveFrom $ addUTCTime (-nominalDay) sheetActiveTo
, cronRepeat = CronRepeatOnChange -- Allow repetition of the notification (if something changes), but wait at least an hour
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Right . CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
}
tell $ HashMap.singleton
(JobCtlQueue $ JobQueueNotification NotificationSheetInactive{..})
Cron
{ cronInitial = CronTimestamp $ utcToLocalTimeTZ appTZ sheetActiveTo
, cronRepeat = CronRepeatOnChange
, cronRateLimit = appNotificationRateLimit
, cronNotAfter = Left appNotificationExpiration
}
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

40
src/Jobs/Handler/HelpRequest.hs Normal file
View File

@ -0,0 +1,40 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
, RecordWildCards
, OverloadedStrings
#-}
module Jobs.Handler.HelpRequest
( dispatchJobHelpRequest
) where
import Import hiding ((.=))
import Text.Hamlet
import qualified Data.CaseInsensitive as CI
import Handler.Utils.DateTime
import Utils.Lens
import Data.Bitraversable
dispatchJobHelpRequest :: Either (Maybe Email) UserId
-> UTCTime
-> Text -- ^ Help Request
-> Maybe Text -- ^ Referer
-> Handler ()
dispatchJobHelpRequest jSender jRequestTime jHelpRequest jReferer = do
supportAddress <- getsYesod $ appMailSupport . appSettings
userInfo <- bitraverse return (runDB . getEntity) jSender
let userAddress = either (fmap $ Address Nothing)
(fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail))
userInfo
mailT def $ do
_mailTo .= [supportAddress]
whenIsJust userAddress $ addMailHeader "Reply-To" . renderAddress
setSubjectI MsgMailSubjectSupport
setDate jRequestTime
rtime <- formatTimeMail SelFormatDateTime jRequestTime
addPart ($(ihamletFile "templates/mail/support.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

62
src/Jobs/Handler/QueueNotification.hs Normal file
View File

@ -0,0 +1,62 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, NamedFieldPuns
#-}
module Jobs.Handler.QueueNotification
( dispatchJobQueueNotification
) where
import Import
import Jobs.Types
import qualified Database.Esqueleto as E
import Utils.Sql
import Jobs.Queue
dispatchJobQueueNotification :: Notification -> Handler ()
dispatchJobQueueNotification jNotification = runDBJobs . setSerializable $ do
candidates <- hoist lift $ determineNotificationCandidates jNotification
nClass <- hoist lift $ classifyNotification jNotification
mapM_ (queueDBJob . flip JobSendNotification jNotification) $ do
Entity uid User{userNotificationSettings} <- candidates
guard $ notificationAllowed userNotificationSettings nClass
return uid
determineNotificationCandidates :: Notification -> DB [Entity User]
determineNotificationCandidates NotificationSubmissionRated{..} = E.select . E.from $ \(user `E.InnerJoin` submissionUser) -> do
E.on $ user E.^. UserId E.==. submissionUser E.^. SubmissionUserUser
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val nSubmission
return user
determineNotificationCandidates NotificationSheetActive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user
determineNotificationCandidates NotificationSheetSoonInactive{..} = E.select . E.from $ \(user `E.InnerJoin` courseParticipant `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user
determineNotificationCandidates NotificationSheetInactive{..} = E.select . E.from $ \(user `E.InnerJoin` lecturer `E.InnerJoin` sheet) -> do
E.on $ lecturer E.^. LecturerCourse E.==. sheet E.^. SheetCourse
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ sheet E.^. SheetId E.==. E.val nSheet
return user
determineNotificationCandidates NotificationCorrectionsAssigned{..} = selectList [UserId ==. nUser] []
classifyNotification :: Notification -> DB NotificationTrigger
classifyNotification NotificationSubmissionRated{..} = do
Sheet{sheetType} <- belongsToJust submissionSheet =<< getJust nSubmission
return $ case sheetType of
NotGraded -> NTSubmissionRated
_other -> NTSubmissionRatedGraded
classifyNotification NotificationSheetActive{} = return NTSheetActive
classifyNotification NotificationSheetSoonInactive{} = return NTSheetSoonInactive
classifyNotification NotificationSheetInactive{} = return NTSheetInactive
classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned

22
src/Jobs/Handler/SendNotification.hs Normal file
View File

@ -0,0 +1,22 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
#-}
module Jobs.Handler.SendNotification
( dispatchJobSendNotification
) where
import Import
import Jobs.TH
import Jobs.Types
import Jobs.Handler.SendNotification.SubmissionRated
import Jobs.Handler.SendNotification.SheetActive
import Jobs.Handler.SendNotification.SheetInactive
import Jobs.Handler.SendNotification.CorrectionsAssigned
dispatchJobSendNotification :: UserId -> Notification -> Handler ()
dispatchJobSendNotification jRecipient jNotification = $(dispatchTH ''Notification) jNotification jRecipient

42
src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs Normal file
View File

@ -0,0 +1,42 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, NamedFieldPuns
, TemplateHaskell
, OverloadedStrings
#-}
module Jobs.Handler.SendNotification.CorrectionsAssigned
( dispatchNotificationCorrectionsAssigned
) where
import Import
import Utils.Lens
import Handler.Utils.Mail
import Text.Hamlet
import qualified Data.CaseInsensitive as CI
dispatchNotificationCorrectionsAssigned :: UserId -> SheetId -> UserId -> Handler ()
dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do
(Course{..}, Sheet{..}, nbrSubs) <- liftHandlerT . runDB $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
nbrSubs <- count [ SubmissionSheet ==. nSheet
, SubmissionRatingBy ==. Just nUser
, SubmissionRatingTime ==. Nothing
]
return (course, sheet, nbrSubs)
when (nbrSubs > 0) . userMailT jRecipient $ do
setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
tid = courseTerm
ssh = courseSchool
csh = courseShorthand
shn = sheetName
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
providePreferredAlternative ($(ihamletFile "templates/mail/correctionsAssigned.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

37
src/Jobs/Handler/SendNotification/SheetActive.hs Normal file
View File

@ -0,0 +1,37 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, NamedFieldPuns
, TemplateHaskell
, OverloadedStrings
#-}
module Jobs.Handler.SendNotification.SheetActive
( dispatchNotificationSheetActive
) where
import Import
import Utils.Lens
import Handler.Utils.Mail
import Text.Hamlet
import qualified Data.CaseInsensitive as CI
dispatchNotificationSheetActive :: SheetId -> UserId -> Handler ()
dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
(Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
return (course, sheet)
setSubjectI $ MsgMailSubjectSheetActive courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
tid = courseTerm
ssh = courseSchool
csh = courseShorthand
shn = sheetName
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

58
src/Jobs/Handler/SendNotification/SheetInactive.hs Normal file
View File

@ -0,0 +1,58 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, NamedFieldPuns
, TemplateHaskell
, OverloadedStrings
#-}
module Jobs.Handler.SendNotification.SheetInactive
( dispatchNotificationSheetSoonInactive
, dispatchNotificationSheetInactive
) where
import Import
import Utils.Lens
import Handler.Utils.Mail
import Text.Hamlet
import qualified Data.CaseInsensitive as CI
dispatchNotificationSheetSoonInactive :: SheetId -> UserId -> Handler ()
dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $ do
(Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
return (course, sheet)
setSubjectI $ MsgMailSubjectSheetSoonInactive courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
tid = courseTerm
ssh = courseSchool
csh = courseShorthand
shn = sheetName
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
providePreferredAlternative ($(ihamletFile "templates/mail/sheetSoonInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler ()
dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
(Course{..}, Sheet{..}) <- liftHandlerT . runDB $ do
sheet <- getJust nSheet
course <- belongsToJust sheetCourse sheet
return (course, sheet)
setSubjectI $ MsgMailSubjectSheetInactive courseShorthand sheetName
MsgRenderer mr <- getMailMsgRenderer
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
tid = courseTerm
ssh = courseSchool
csh = courseShorthand
shn = sheetName
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

59
src/Jobs/Handler/SendNotification/SubmissionRated.hs Normal file
View File

@ -0,0 +1,59 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, NamedFieldPuns
, TemplateHaskell
, OverloadedStrings
#-}
module Jobs.Handler.SendNotification.SubmissionRated
( dispatchNotificationSubmissionRated
) where
import Import
import Utils.Lens
import Handler.Utils.DateTime
import Handler.Utils.Mail
import Text.Hamlet
import qualified Data.Aeson as Aeson
import qualified Data.CaseInsensitive as CI
dispatchNotificationSubmissionRated :: SubmissionId -> UserId -> Handler ()
dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipient $ do
(Course{..}, Sheet{..}, Submission{..}, corrector) <- liftHandlerT . runDB $ do
submission@Submission{submissionRatingBy} <- getJust nSubmission
sheet <- belongsToJust submissionSheet submission
course <- belongsToJust sheetCourse sheet
corrector <- traverse getJust submissionRatingBy
return (course, sheet, submission, corrector)
setSubjectI $ MsgMailSubjectSubmissionRated courseShorthand
csid <- encrypt nSubmission
MsgRenderer mr <- getMailMsgRenderer
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
submissionRatingTime' <- traverse (formatTimeMail SelFormatDateTime) submissionRatingTime
let tid = courseTerm
ssh = courseSchool
csh = courseShorthand
shn = sheetName
-- TODO: provide convienience template-haskell for `addAlternatives`
addAlternatives $ do
provideAlternative $ Aeson.object
[ "submission" Aeson..= ciphertext csid
, "submission-rating-points" Aeson..= (guard (sheetType /= NotGraded) *> submissionRatingPoints)
, "submission-rating-comment" Aeson..= submissionRatingComment
, "submission-rating-time" Aeson..= submissionRatingTime
, "submission-rating-by" Aeson..= (userDisplayName <$> corrector)
, "submission-rating-passed" Aeson..= ((>=) <$> submissionRatingPoints <*> preview _passingPoints sheetType)
, "sheet-name" Aeson..= sheetName
, "sheet-type" Aeson..= sheetType
, "course-name" Aeson..= courseName
, "course-shorthand" Aeson..= courseShorthand
, "course-term" Aeson..= courseTerm
, "course-school" Aeson..= courseSchool
]
-- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
providePreferredAlternative ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

34
src/Jobs/Handler/SendTestEmail.hs Normal file
View File

@ -0,0 +1,34 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
, NamedFieldPuns
, QuasiQuotes
#-}
module Jobs.Handler.SendTestEmail
( dispatchJobSendTestEmail
) where
import Import hiding ((.=))
import Handler.Utils.DateTime
import Text.Shakespeare.Text
import Utils.Lens
dispatchJobSendTestEmail :: Email -> MailContext -> Handler ()
dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do
_mailTo .= [Address Nothing jEmail]
setSubjectI MsgMailTestSubject
now <- liftIO getCurrentTime
nDT <- formatTimeMail SelFormatDateTime now
nD <- formatTimeMail SelFormatDate now
nT <- formatTimeMail SelFormatTime now
addPart $ \(MsgRenderer mr) -> ([text|
#{mr MsgMailTestContent}
#{mr MsgMailTestDateTime}
* #{nDT}
* #{nD}
* #{nT}
|] :: TextUrl (Route UniWorX))

15
src/Jobs/Handler/SetLogSettings.hs Normal file
View File

@ -0,0 +1,15 @@
{-# LANGUAGE NoImplicitPrelude
#-}
module Jobs.Handler.SetLogSettings
( dispatchJobSetLogSettings
) where
import Import
dispatchJobSetLogSettings :: InstanceId -> LogSettings -> Handler ()
dispatchJobSetLogSettings jInstance jLogSettings = do
instanceId <- getsYesod appInstanceID
unless (instanceId == jInstance) $ fail "Incorrect instance"
lSettings <- getsYesod appLogSettings
atomically $ writeTVar lSettings jLogSettings

81
src/Jobs/Queue.hs Normal file
View File

@ -0,0 +1,81 @@
{-# LANGUAGE NoImplicitPrelude
, TypeFamilies
#-}
module Jobs.Queue
( writeJobCtl, writeJobCtlBlock
, queueJob, queueJob'
, YesodJobDB
, runDBJobs, queueDBJob
) where
import Import
import Utils.Sql
import Jobs.Types
import Control.Monad.Trans.Writer (WriterT, runWriterT)
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Trans.Reader (ReaderT, mapReaderT)
import qualified Data.Set as Set
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.HashMap.Strict as HashMap
import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen, uniform)
writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m ()
writeJobCtl cmd = do
tid <- liftIO myThreadId
chan <- flip evalRand (mkStdGen (hash tid `hashWithSalt` cmd)) . uniform <$> getsYesod appJobCtl
liftIO . atomically $ writeTMChan chan cmd
writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m ()
writeJobCtlBlock cmd = do
getResVar <- asks jobConfirm
resVar <- liftIO . atomically $ do
var <- newEmptyTMVar
modifyTVar' getResVar $ HashMap.insertWith (<>) cmd (pure var)
return var
lift $ writeJobCtl cmd
let
removeResVar = HashMap.update (NonEmpty.nonEmpty . NonEmpty.filter (/= resVar)) cmd
mExc <- liftIO . atomically $ takeTMVar resVar <* modifyTVar' getResVar removeResVar
maybe (return ()) throwM mExc
queueJobUnsafe :: Job -> YesodDB UniWorX QueuedJobId
queueJobUnsafe job = do
now <- liftIO getCurrentTime
self <- getsYesod appInstanceID
insert QueuedJob
{ queuedJobContent = toJSON job
, queuedJobCreationInstance = self
, queuedJobCreationTime = now
, queuedJobLockInstance = Nothing
, queuedJobLockTime = Nothing
}
-- We should not immediately notify a worker; instead wait for the transaction to finish first
-- writeJobCtl $ JobCtlPerform jId -- FIXME: Should do fancy load balancing across instances (or something)
-- return jId
queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe
queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
-- ^ `queueJob` followed by `JobCtlPerform`
queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform
type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO))
queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) ()
queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton
runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a
runDBJobs act = do
(ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
forM_ jIds $ writeJobCtl . JobCtlPerform
return ret

29
src/Jobs/TH.hs Normal file
View File

@ -0,0 +1,29 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
, QuasiQuotes
, RecordWildCards
#-}
module Jobs.TH
( dispatchTH
) where
import ClassyPrelude
import Language.Haskell.TH
import Language.Haskell.TH.Datatype
import Data.List (foldl)
dispatchTH :: Name -- ^ Datatype to pattern match
-> ExpQ
dispatchTH dType = do
DatatypeInfo{..} <- reifyDatatype dType
let
matches = map mkMatch datatypeCons
mkMatch ConstructorInfo{..} = do
pats <- forM constructorFields $ \_ -> newName "x"
let fName = mkName $ "dispatch" <> nameBase constructorName
match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) []
lamCaseE matches

66
src/Jobs/Types.hs Normal file
View File

@ -0,0 +1,66 @@
{-# LANGUAGE TemplateHaskell
, NoImplicitPrelude
, DeriveGeneric
, DeriveDataTypeable
#-}
module Jobs.Types
( Job(..), Notification(..)
, JobCtl(..)
, JobContext(..)
) where
import Import.NoFoundation
import Data.Aeson (defaultOptions, Options(..), SumEncoding(..))
import Data.Aeson.TH (deriveJSON)
import Data.List.NonEmpty (NonEmpty)
data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
| JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
| JobQueueNotification { jNotification :: Notification }
| JobHelpRequest { jSender :: Either (Maybe Email) UserId
, jRequestTime :: UTCTime
, jHelpRequest :: Text, jReferer :: Maybe Text }
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
| NotificationSheetActive { nSheet :: SheetId }
| NotificationSheetSoonInactive { nSheet :: SheetId }
| NotificationSheetInactive { nSheet :: SheetId }
| NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Hashable Job
instance Hashable Notification
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
, tagSingleConstructors = True
, sumEncoding = TaggedObject "job" "data"
} ''Job
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
, tagSingleConstructors = True
, sumEncoding = TaggedObject "notification" "data"
} ''Notification
data JobCtl = JobCtlFlush
| JobCtlPerform QueuedJobId
| JobCtlDetermineCrontab
| JobCtlQueue Job
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Hashable JobCtl
data JobContext = JobContext
{ jobCrontab :: TVar (Crontab JobCtl)
, jobConfirm :: TVar (HashMap JobCtl (NonEmpty (TMVar (Maybe SomeException))))
}

485
src/Mail.hs Normal file
View File

@ -0,0 +1,485 @@
{-# LANGUAGE NoImplicitPrelude
, GeneralizedNewtypeDeriving
, DerivingStrategies
, FlexibleInstances
, MultiParamTypeClasses
, UndecidableInstances
, DeriveGeneric
, TemplateHaskell
, OverloadedStrings
, RecordWildCards
, FlexibleContexts
, TypeFamilies
, ViewPatterns
, NamedFieldPuns
, MultiWayIf
, QuasiQuotes
, RankNTypes
, ScopedTypeVariables
, DeriveDataTypeable
#-}
module Mail
( -- * Structured MIME emails
module Network.Mail.Mime
-- * MailT
, MailT, defMailT
, MailSmtpData(..), MailContext(..), MailLanguages(..)
, MonadMail(..)
, getMailMessageRender, getMailMsgRenderer
-- * YesodMail
, VerpMode(..)
, YesodMail(..)
, MailException(..)
-- * Monadically constructing Mail
, PrioritisedAlternatives
, ToMailPart(..)
, addAlternatives, provideAlternative, providePreferredAlternative
, addPart
, MonadHeader(..)
, MailHeader
, MailObjectId
, replaceMailHeader, addMailHeader, removeMailHeader
, replaceMailHeaderI, addMailHeaderI
, setSubjectI, setMailObjectId, setMailObjectId'
, setDate, setDateCurrent
, setMailSmtpData
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailParts
, _partType, _partEncoding, _partFilename, _partHeaders, _partContent
) where
import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender)
import qualified ClassyPrelude.Yesod as Yesod (getMessageRender)
import Network.Mail.Mime hiding (addPart, addAttachment)
import qualified Network.Mail.Mime as Mime (addPart)
import Data.Monoid (Last(..))
import Control.Monad.Trans.RWS (RWST(..), execRWST)
import Control.Monad.Trans.State (StateT(..), execStateT, State, mapStateT)
import Control.Monad.Trans.Writer (execWriter, Writer)
import Control.Monad.RWS.Class (MonadWriter(..), MonadReader(..), MonadState(..), modify)
import Control.Monad.Fail
import GHC.Generics (Generic)
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Data (Data)
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Foldable as Foldable
import Data.Hashable
import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as LTB
import qualified Data.ByteString.Lazy as LBS
import Utils (MsgRendererS(..))
import Utils.Lens.TH
import Control.Lens
import Text.Blaze.Renderer.Utf8
import Data.UUID (UUID)
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Data.UUID.Cryptographic.ImplicitNamespace
import Data.Binary (Binary)
import GHC.TypeLits (KnownSymbol)
import Network.BSD (getHostName)
import Data.Time.Zones (TZ, utcTZ, utcToLocalTimeTZ, timeZoneForUTCTime)
import Data.Time.LocalTime (ZonedTime(..))
import Data.Time.Format
import Network.HaskellNet.SMTP (SMTPConnection)
import qualified Network.HaskellNet.SMTP as SMTP
import qualified Text.Hamlet as Hamlet (Translate)
import qualified Text.Shakespeare as Shakespeare (RenderUrl)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
import Data.Aeson (Options(..))
import Data.Aeson.TH
import Utils (MsgRendererS(..))
import Utils.PathPiece (splitCamel)
import Utils.DateTime
import Data.Universe.Instances.Reverse ()
import Data.Universe.Instances.Reverse.JSON ()
import Data.Universe.Instances.Reverse.Hashable ()
makeLenses_ ''Mail
makeLenses_ ''Part
newtype MailT m a = MailT { unMailT :: RWST MailContext MailSmtpData Mail m a }
deriving newtype ( MonadTrans, Monad, Functor, MonadFail, Applicative, Alternative, MonadPlus
, MonadIO, MonadHandler, MonadCatch, MonadThrow, MonadMask, MonadResource, MonadBase b
, MonadState Mail, MonadWriter MailSmtpData, MonadReader MailContext
)
instance {-# OVERLAPPING #-} (MonadCrypto m, MonadCryptoKey m ~ CryptoIDKey) => MonadCrypto (MailT m) where
type MonadCryptoKey (MailT m) = CryptoIDKey
cryptoIDKey f = lift (cryptoIDKey return) >>= f
data MailSmtpData = MailSmtpData
{ smtpEnvelopeFrom :: Last Text
, smtpRecipients :: Set Text
} deriving (Eq, Ord, Show, Read, Generic)
instance Monoid (MailSmtpData) where
mempty = memptydefault
mappend = mappenddefault
newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
deriving newtype (FromJSON, ToJSON)
instance Default MailLanguages where
def = MailLanguages []
instance Hashable MailLanguages
data MailContext = MailContext
{ mcLanguages :: MailLanguages
, mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
} ''MailContext
instance Hashable MailContext
instance Default MailContext where
def = MailContext { mcLanguages = def
, mcDateTimeFormat = def
}
makeLenses_ ''MailContext
class (MonadHandler m, MonadState Mail m) => MonadMail m where
askMailLanguages :: m MailLanguages
askMailDateTimeFormat :: SelDateTimeFormat -> m DateTimeFormat
tellMailSmtpData :: MailSmtpData -> m ()
instance MonadHandler m => MonadMail (MailT m) where
askMailLanguages = view _mcLanguages
askMailDateTimeFormat = (view _mcDateTimeFormat ??)
tellMailSmtpData = tell
data VerpMode = VerpNone
| Verp { verpSeparator, verpAtReplacement :: Char }
deriving (Eq, Show, Read)
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
, sumEncoding = UntaggedValue
} ''VerpMode
getMailMessageRender :: ( MonadMail m
, HandlerSite m ~ site
, RenderMessage site msg
) => m (msg -> Text)
getMailMessageRender = renderMessage <$> getYesod <*> (mailLanguages <$> askMailLanguages)
getMailMsgRenderer :: forall site m.
( MonadMail m
, HandlerSite m ~ site
) => m (MsgRendererS site)
getMailMsgRenderer = do
mr <- getMailMessageRender
return $ MsgRenderer (mr . SomeMessage :: RenderMessage site msg => msg -> Text)
data MailException = MailNotAvailable
| MailNoSenderSpecified
| MailNoRecipientsSpecified
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Exception MailException
class Yesod site => YesodMail site where
defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
defaultFromAddress = (Address Nothing . ("yesod@" <>) . pack) <$> liftIO getHostName
mailObjectIdDomain :: (MonadHandler m, HandlerSite m ~ site) => m Text
mailObjectIdDomain = pack <$> liftIO getHostName
mailDateTZ :: (MonadHandler m, HandlerSite m ~ site) => m TZ
mailDateTZ = return utcTZ
mailSmtp :: ( MonadHandler m
, HandlerSite m ~ site
, MonadBaseControl IO m
) => (SMTPConnection -> m a) -> m a
mailSmtp _ = throwM MailNotAvailable
mailVerp :: ( MonadHandler m
, HandlerSite m ~ site
) => m VerpMode
mailVerp = return VerpNone
mailT :: ( MonadHandler m
, HandlerSite m ~ site
, MonadBaseControl IO m
, MonadLogger m
) => MailContext -> MailT m a -> m a
mailT = defMailT
defaultMailLayout :: ( MonadHandler m
, HandlerSite m ~ site
) => WidgetT site IO () -> m Html
defaultMailLayout wgt = do
PageContent{..} <- liftHandlerT $ widgetToPageContent wgt
msgs <- getMessages
withUrlRenderer [hamlet|
$newline never
$doctype 5
<html>
<head>
<title>#{pageTitle}
^{pageHead}
<body>
$forall (status, msg) <- msgs
<p class="message #{status}">#{msg}
^{pageBody}
|]
defMailT :: ( MonadHandler m
, YesodMail (HandlerSite m)
, MonadBaseControl IO m
, MonadLogger m
) => MailContext
-> MailT m a
-> m a
defMailT ls (MailT mail) = do
fromAddress <- defaultFromAddress
(ret, mail, smtpData) <- runRWST mail ls (emptyMail fromAddress)
mail' <- liftIO $ LBS.toStrict <$> renderMail' mail
$logDebugS "Mail" $ "Rendered mail:\n" <> decodeUtf8 mail'
ret <$ case smtpData of
MailSmtpData{ smtpEnvelopeFrom = Last Nothing } -> throwM MailNoSenderSpecified
MailSmtpData{ smtpRecipients }
| Set.null smtpRecipients -> throwM MailNoRecipientsSpecified
MailSmtpData{ smtpEnvelopeFrom = Last (Just (unpack -> returnPath))
, smtpRecipients = (map unpack . toList -> recipients)
} -> mailSmtp $ \conn -> do
$logInfoS "Mail" $ "Submitting email: " <> tshow smtpData
liftIO $ SMTP.sendMail
returnPath
recipients
mail'
conn
data PrioritisedAlternatives m = PrioritisedAlternatives
{ preferredAlternative :: Last (m Part)
, otherAlternatives :: Seq (m Part)
} deriving (Generic)
instance Monoid (PrioritisedAlternatives m) where
mempty = memptydefault
mappend = mappenddefault
class YesodMail site => ToMailPart site a where
type MailPartReturn site a :: *
type MailPartReturn site a = ()
toMailPart :: (MonadMail m, HandlerSite m ~ site) => a -> StateT Part m (MailPartReturn site a)
instance YesodMail site => ToMailPart site (StateT Part (HandlerT site IO) a) where
type MailPartReturn site (StateT Part (HandlerT site IO) a) = a
toMailPart = mapStateT liftHandlerT
instance YesodMail site => ToMailPart site LT.Text where
toMailPart text = do
_partType .= "text/plain; charset=utf-8"
_partEncoding .= QuotedPrintableText
_partContent .= encodeUtf8 text
instance YesodMail site => ToMailPart site Text where
toMailPart = toMailPart . LT.fromStrict
instance YesodMail site => ToMailPart site LTB.Builder where
toMailPart = toMailPart . LTB.toLazyText
instance YesodMail site => ToMailPart site Html where
toMailPart html = do
_partType .= "text/html; charset=utf-8"
_partEncoding .= QuotedPrintableText
_partContent .= renderMarkup html
instance (ToMailPart site a, RenderMessage site msg) => ToMailPart site (Hamlet.Translate msg -> a) where
type MailPartReturn site (Hamlet.Translate msg -> a) = MailPartReturn site a
toMailPart act = do
mr <- lift getMailMessageRender
toMailPart $ act (toHtml . mr)
instance (ToMailPart site a, site ~ site') => ToMailPart site (MsgRendererS site' -> a) where
type MailPartReturn site (MsgRendererS site' -> a) = MailPartReturn site a
toMailPart act = do
mr <- lift getMailMsgRenderer
toMailPart $ act mr
instance ToMailPart site a => ToMailPart site (Shakespeare.RenderUrl (Route site) -> a) where
type MailPartReturn site (Shakespeare.RenderUrl (Route site) -> a) = MailPartReturn site a
toMailPart act = do
ur <- getUrlRenderParams
toMailPart $ act ur
instance YesodMail site => ToMailPart site Aeson.Value where
toMailPart val = do
_partType .= "application/json; charset=utf-8"
_partEncoding .= QuotedPrintableText
_partContent .= Aeson.encodePretty val
addAlternatives :: (MonadMail m)
=> Writer (PrioritisedAlternatives m) ()
-> m ()
addAlternatives provided = do
let PrioritisedAlternatives{..} = execWriter provided
alternatives <- sequence . Foldable.toList $ maybe id (flip (Seq.|>)) (getLast preferredAlternative) otherAlternatives
modify $ Mime.addPart alternatives
provideAlternative, providePreferredAlternative
:: (MonadMail m, HandlerSite m ~ site, ToMailPart site a)
=> a
-> Writer (PrioritisedAlternatives m) ()
provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart part) initialPart }
providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT (toMailPart part) initialPart }
addPart :: ( MonadMail m
, HandlerSite m ~ site
, ToMailPart site a
) => a -> m (MailPartReturn site a)
addPart part = do
(ret, part') <- runStateT (toMailPart part) initialPart
modify . Mime.addPart $ pure part'
return ret
initialPart :: Part
initialPart = Part
{ partType = "text/plain"
, partEncoding = None
, partFilename = Nothing
, partHeaders = []
, partContent = mempty
}
class MonadHandler m => MonadHeader m where
modifyHeaders :: (Headers -> Headers) -> m ()
objectIdHeader :: m MailHeader
instance MonadHandler m => MonadHeader (MailT m) where
modifyHeaders f = MailT . modify $ over _mailHeaders f
objectIdHeader = return "Message-ID"
instance MonadHandler m => MonadHeader (StateT Part m) where
modifyHeaders f = _partHeaders %= f
objectIdHeader = return "Content-ID"
type MailHeader = ByteString
type MailObjectId = Text
replaceMailHeader :: MonadHeader m => MailHeader -> Maybe Text -> m ()
replaceMailHeader header mC = removeMailHeader header >> maybe (return ()) (addMailHeader header) mC
addMailHeader :: MonadHeader m => MailHeader -> Text -> m ()
addMailHeader header c = modifyHeaders $ \mailHeaders -> mailHeaders `snoc` (header, c)
removeMailHeader :: MonadHeader m => MailHeader -> m ()
removeMailHeader header = modifyHeaders $ \mailHeaders -> filter ((/= header) . fst) mailHeaders
replaceMailHeaderI :: ( RenderMessage site msg
, MonadMail m
, HandlerSite m ~ site
, MonadHeader m
) => MailHeader -> msg -> m ()
replaceMailHeaderI header msg = removeMailHeader header >> addMailHeaderI header msg
addMailHeaderI :: ( RenderMessage site msg
, MonadMail m
, HandlerSite m ~ site
, MonadHeader m
) => MailHeader -> msg -> m ()
addMailHeaderI header msg = addMailHeader header =<< (getMailMessageRender <*> pure msg)
setSubjectI :: (RenderMessage site msg, MonadHandler m, HandlerSite m ~ site) => msg -> MailT m ()
setSubjectI = replaceMailHeaderI "Subject"
setMailObjectUUID :: ( MonadHeader m
, YesodMail (HandlerSite m)
) => UUID -> m MailObjectId
setMailObjectUUID uuid = do
domain <- mailObjectIdDomain
oidHeader <- objectIdHeader
let objectId = UUID.toText uuid <> "@" <> domain
replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">"
return objectId
setMailObjectId :: ( MonadHeader m
, YesodMail (HandlerSite m)
) => m MailObjectId
setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom
setMailObjectId' :: ( MonadHeader m
, YesodMail (HandlerSite m)
, MonadCrypto m
, HasCryptoUUID plain m
, MonadCryptoKey m ~ CryptoIDKey
, KnownSymbol (CryptoIDNamespace UUID plain)
, Binary plain
) => plain -> m MailObjectId
setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid
setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
setDateCurrent = setDate =<< liftIO getCurrentTime
setDate :: (MonadHandler m, YesodMail (HandlerSite m)) => UTCTime -> MailT m ()
setDate time = do
tz <- mailDateTZ
let timeStr = formatTime defaultTimeLocale "%a, %d %b %Y %T %z" $ ZonedTime (utcToLocalTimeTZ tz time) (timeZoneForUTCTime tz time)
replaceMailHeader "Date" . Just $ pack timeStr
setMailSmtpData :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()
setMailSmtpData = do
Address _ from <- use _mailFrom
recps <- Set.fromList . map addressEmail . concat <$> forM [_mailTo, _mailCc, _mailBcc] use
tell $ mempty { smtpRecipients = recps }
verpMode <- mailVerp
if
| Verp{..} <- verpMode
, [recp] <- Set.toList recps
-> let doVerp (Text.breakOn "@" -> (user, domain)) recp = mconcat
[ user
, Text.singleton verpSeparator
, Text.replace "@" (Text.singleton verpAtReplacement) recp
, domain
]
in tell $ mempty { smtpEnvelopeFrom = Last . Just $ doVerp from recp }
| otherwise
-> tell $ mempty { smtpEnvelopeFrom = Last $ Just from }

14
src/Model.hs
View File

@ -7,6 +7,8 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
@ -14,6 +16,7 @@
module Model
( module Model
, module Model.Types
, module Cron.Types
) where
import ClassyPrelude.Yesod
@ -21,11 +24,16 @@ import Database.Persist.Quasi
-- import Data.Time
-- import Data.ByteString
import Model.Types
import Data.Aeson.TH
import Cron.Types
import Data.Aeson (Value)
import Data.Aeson.TH (deriveJSON, defaultOptions)
import Data.CaseInsensitive (CI)
import Data.CaseInsensitive.Instances ()
import Utils.Message (MessageClass)
-- 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:
@ -35,7 +43,7 @@ share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll
-- (Eq Course) is impossible so we derive it for the Uniqueness Constraint only
deriving instance Eq (Unique Course)
data PWEntry = PWEntry
{ pwUser :: User
, pwHash :: Text
@ -43,4 +51,4 @@ data PWEntry = PWEntry
$(deriveJSON defaultOptions ''PWEntry)
submissionRatingDone :: Submission -> Bool
submissionRatingDone Submission{..} = isJust submissionRatingPoints
submissionRatingDone Submission{..} = isJust submissionRatingTime

7
src/Model/Migration.hs
View File

@ -189,6 +189,13 @@ customMigrations = Map.fromListWith (>>)
ALTER TABLE "user" ADD COLUMN "authentication" json DEFAULT '"ldap"';
|]
)
, ( AppliedMigrationKey [migrationVersion|4.0.0|] [version|5.0.0|]
, whenM (tableExists "user") $ do
[executeQQ|
ALTER TABLE "user" ADD COLUMN "notification_settings" json DEFAULT null;
UPDATE "user" SET "notification_settings" = (#{def :: NotificationSettings} :: json) WHERE "notification_settings" is null;
|]
)
]

228
src/Model/Types.hs
View File

@ -5,16 +5,25 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE BinaryLiterals #-}
{-# LANGUAGE MultiWayIf #-}
{-- # LANGUAGE ExistentialQuantification #-} -- for DA type
{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
module Model.Types where
module Model.Types
( module Model.Types
, module Numeric.Natural
, module Mail
, module Utils.DateTime
) where
import ClassyPrelude
import Utils
import Control.Lens
import Utils.Lens.TH
import Data.Set (Set)
import qualified Data.Set as Set
@ -26,6 +35,8 @@ import Data.Universe
import Data.Universe.Helpers
import Data.UUID.Types
import Data.Default
import Text.Read (readMaybe)
import Database.Persist.TH hiding (derivePersistFieldJSON)
@ -40,20 +51,40 @@ import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lens as Text
import qualified Data.HashMap.Strict as HashMap
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.CaseInsensitive.Instances ()
import Yesod.Core.Dispatch (PathPiece(..))
import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value())
import Data.Aeson.Types (toJSONKeyText)
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
import GHC.Generics (Generic)
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Data.Typeable (Typeable)
import Data.Universe.Instances.Reverse ()
import qualified Yesod.Auth.Util.PasswordStore as PWStore
import Mail (MailLanguages(..))
import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..))
import Numeric.Natural
import Data.Word.Word24 (Word24)
import Data.Bits
import Data.Ix
import Data.List (genericIndex, elemIndex)
import System.Random (Random(..))
import Data.Data (Data)
import Model.Types.Wordlist
instance PathPiece UUID where
fromPathPiece = Data.UUID.Types.fromString . unpack
@ -93,8 +124,9 @@ fromPoints = round
instance DisplayAble Points
data SheetType
= Bonus { maxPoints :: Points }
| Normal { maxPoints :: Points }
= Bonus { maxPoints :: Points } -- Erhöht nicht das Maximum, wird gutgeschrieben
| Normal { maxPoints :: Points } -- Erhöht das Maximum, wird gutgeschrieben
-- | Informational { maxPoints :: Points } -- Erhöht nicht das Maximum Keine Gutschrift
| Pass { maxPoints, passingPoints :: Points }
| NotGraded
deriving (Show, Read, Eq)
@ -108,6 +140,8 @@ instance DisplayAble SheetType where
deriveJSON defaultOptions ''SheetType
derivePersistFieldJSON ''SheetType
makeLenses_ ''SheetType
data SheetTypeSummary = SheetTypeSummary
{ sumBonusPoints :: Sum Points
, sumNormalPoints :: Sum Points
@ -130,13 +164,15 @@ sheetTypeSum (NotGraded, _ ) = mempty { numNotGraded = Sum 1 }
data SheetGroup
= Arbitrary { maxParticipants :: Int }
= Arbitrary { maxParticipants :: Natural }
| RegisteredGroups
| NoGroups
deriving (Show, Read, Eq)
deriveJSON defaultOptions ''SheetGroup
derivePersistFieldJSON ''SheetGroup
makeLenses_ ''SheetGroup
data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
deriving (Show, Read, Eq, Ord, Enum, Bounded)
derivePersistField "SheetFileType"
@ -201,6 +237,16 @@ data UploadMode = NoUpload | Upload { unpackZips :: Bool }
deriveJSON defaultOptions ''UploadMode
derivePersistFieldJSON ''UploadMode
data SheetSubmissionMode = NoSubmissions
| CorrectorSubmissions
| UserSubmissions
deriving (Show, Read, Eq, Ord, Enum, Bounded)
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . splitCamel
} ''SheetSubmissionMode
derivePersistField "SheetSubmissionMode"
data ExamStatus = Attended | NoShow | Voided
deriving (Show, Read, Eq, Ord, Enum, Bounded)
derivePersistField "ExamStatus"
@ -216,8 +262,6 @@ deriveJSON defaultOptions ''Load
derivePersistFieldJSON ''Load
instance Semigroup Load where
(Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
where
@ -332,7 +376,7 @@ instance PathPiece TermIdentifier where
toPathPiece = termToText
instance ToJSON TermIdentifier where
toJSON = String . termToText
toJSON = Aeson.String . termToText
instance FromJSON TermIdentifier where
parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
@ -355,6 +399,16 @@ data StudyFieldType = FieldPrimary | FieldSecondary
deriving (Eq, Ord, Enum, Show, Read, Bounded)
derivePersistField "StudyFieldType"
instance PersistField UUID where
toPersistValue = PersistDbSpecific . toASCIIBytes
fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ fromText t
fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ fromASCIIBytes bs
fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ fromASCIIBytes bs
fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x
instance PersistFieldSql UUID where
sqlType _ = SqlOther "uuid"
instance DisplayAble StudyFieldType
data Theme
@ -391,12 +445,6 @@ instance PathPiece obj => PathPiece (ZIPArchiveName obj) where
fromPathPiece = fmap ZIPArchiveName . fromPathPiece <=< (stripSuffix `on` CI.foldCase) ".zip"
toPathPiece = (<> ".zip") . toPathPiece . unZIPArchiveName
newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
deriving (Eq, Ord, Read, Show, ToJSON, FromJSON, PersistField, PersistFieldSql, IsString)
data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
deriving (Eq, Ord, Read, Show, Enum, Bounded)
data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused
deriving (Eq, Ord, Read, Show, Enum, Bounded)
@ -429,14 +477,160 @@ deriveJSON defaultOptions
derivePersistFieldJSON ''AuthenticationMode
derivePersistFieldJSON ''Value
-- ^ `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
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
instance ToJSON NotificationSettings where
toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF
instance FromJSON NotificationSettings where
parseJSON = 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
instance ToBackendKey SqlBackend record => Hashable (Key record) where
hashWithSalt s key = s `hashWithSalt` fromSqlKey key
derivePersistFieldJSON ''MailLanguages
newtype Pseudonym = Pseudonym Word24
deriving (Eq, Ord, Read, Show, Generic, Data)
deriving newtype (Bounded, Enum, Integral, Num, Real, Bits, FiniteBits, 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 (map CI.mk . Text.words -> ws))
= case preview pseudonymWords ws 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 preview pseudonymWords ws' of
Just p -> return p
Nothing -> fail "Could not parse pseudonym words"
instance ToJSON Pseudonym where
toJSON = toJSON . (review pseudonymWords :: Pseudonym -> [PseudonymWord])
pseudonymWordlist :: [PseudonymWord]
pseudonymWordlist = $(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 $ 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 = iso tFromWords tToWords . pseudonymWords
where
tFromWords :: Text -> [PseudonymWord]
tFromWords = map CI.mk . Text.words
tToWords :: [PseudonymWord] -> Text
tToWords = Text.unwords . map CI.original
-- Type synonyms
type PseudonymWord = CI Text
type Email = Text
type SchoolName = CI Text
type SchoolShorthand = CI Text
type CourseName = CI Text
type CourseShorthand = CI Text
type SheetName = CI Text
type UserEmail = CI Text
type UserEmail = CI Email
type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
type InstanceId = UUID

2
src/Model/Types/JSON.hs
View File

@ -50,7 +50,7 @@ derivePersistFieldJSON n = do
]
, instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
[ funD (mkName "sqlType")
[ clause [wildP] (normalB [e|SqlOther "json"|]) []
[ clause [wildP] (normalB [e|SqlOther "jsonb"|]) []
]
]
]

40
src/Model/Types/Wordlist.hs Normal file
View File

@ -0,0 +1,40 @@
{-# LANGUAGE NoImplicitPrelude
, TemplateHaskell
, ViewPatterns
, OverloadedStrings
#-}
module Model.Types.Wordlist (wordlist) where
import ClassyPrelude hiding (lift)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qAddDependentFile, Lift(..))
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.IO as Text
import qualified Data.CaseInsensitive as CI
wordlist :: FilePath -> ExpQ
wordlist file = do
qAddDependentFile file
wordlist' <- runIO $ filter ((||) <$> not . isComment <*> isWord) . Text.lines <$> Text.readFile file
listE $ map (\(Text.unpack -> word) -> [e|CI.mk $ Text.pack $(lift word)|]) wordlist'
isWord :: Text -> Bool
isWord t
| [w] <- Text.words t
, w == t
= True
| otherwise
= False
isComment :: Text -> Bool
isComment line = or
[ commentSymbol `Text.isPrefixOf` Text.stripStart line
, Text.null $ Text.strip line
]
where
commentSymbol = "#"

171
src/Settings.hs
View File

@ -1,9 +1,13 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- | Settings are centralized, as much as possible, into this file. This
-- includes database connection settings, static file locations, etc.
@ -15,7 +19,7 @@ module Settings where
import ClassyPrelude.Yesod
import qualified Control.Exception as Exception
import Data.Aeson (Result (..), fromJSON, withObject,
(.!=), (.:?))
(.!=), (.:?), withScientific)
import qualified Data.Aeson.Types as Aeson
import Data.Aeson.TH
import Data.FileEmbed (embedFile)
@ -29,6 +33,12 @@ import Yesod.Default.Util (WidgetFileSettings,
widgetFileReload)
import qualified Yesod.Auth.Util.PasswordStore as PWStore
import Data.Time (NominalDiffTime)
import Data.Scientific (toBoundedInteger)
import Data.Word (Word16)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Ldap.Client as Ldap
@ -39,6 +49,13 @@ import Control.Lens
import Data.Maybe (fromJust)
import qualified Data.Char as Char
import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
import qualified Network.Socket as HaskellNet (PortNumber(..), HostName)
import Network.Mail.Mime (Address)
import Mail (VerpMode)
import Model
-- | Runtime settings to configure this application. These settings can be
@ -51,6 +68,8 @@ data AppSettings = AppSettings
-- ^ Configuration settings for accessing the database.
, appLdapConf :: Maybe LdapConf
-- ^ Configuration settings for accessing the LDAP-directory
, appSmtpConf :: Maybe SmtpConf
-- ^ Configuration settings for accessing a SMTP Mailserver
, appRoot :: Maybe Text
-- ^ Base for all generated URLs. If @Nothing@, determined
-- from the request headers.
@ -61,11 +80,20 @@ data AppSettings = AppSettings
, appIpFromHeader :: Bool
-- ^ Get the IP address from the header when logging. Useful when sitting
-- behind a reverse proxy.
, appMailFrom :: Address
, appMailObjectDomain :: Text
, appMailVerp :: VerpMode
, appMailSupport :: Address
, appJobWorkers :: Int
, appJobFlushInterval :: Maybe NominalDiffTime
, appJobCronInterval :: NominalDiffTime
, appJobStaleThreshold :: NominalDiffTime
, appNotificationRateLimit :: NominalDiffTime
, appNotificationCollateDelay :: NominalDiffTime
, appNotificationExpiration :: NominalDiffTime
, appInitialLogSettings :: LogSettings
, appDetailedRequestLogging :: Bool
-- ^ Use detailed request logging system
, appShouldLogAll :: Bool
-- ^ Should all log messages be displayed?
, appReloadTemplates :: Bool
-- ^ Use the reload version of templates
, appMutableStatic :: Bool
@ -76,26 +104,38 @@ data AppSettings = AppSettings
-- ^ Indicate if auth dummy login should be enabled.
, appAllowDeprecated :: Bool
-- ^ Indicate if deprecated routes are accessible for everyone
, appMinimumLogLevel :: LogLevel
, appUserDefaults :: UserDefaultConf
, appAuthPWHash :: PWHashConf
, appCryptoIDKeyFile :: FilePath
}
, appInstanceIDFile :: Maybe FilePath
} deriving (Show)
data LogSettings = LogSettings
{ logAll, logDetailed :: Bool
, logMinimumLevel :: LogLevel
} deriving (Show, Read, Generic, Eq, Ord)
deriving instance Generic LogLevel
instance Hashable LogLevel
instance Hashable LogSettings
data UserDefaultConf = UserDefaultConf
{ userDefaultTheme :: Theme
, userDefaultMaxFavourites :: Int
, userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
, userDefaultDownloadFiles :: Bool
}
} deriving (Show)
data PWHashConf = PWHashConf
{ pwHashAlgorithm :: PWHashAlgorithm
, pwHashStrength :: Int
}
instance Show PWHashConf where
show PWHashConf{..} = "PWHashConf { pwHashStrength = " <> show pwHashStrength <> ", .. }"
instance FromJSON PWHashConf where
parseJSON = withObject "PWHashConf" $ \o -> do
pwHashAlgorithm' <- (o .: "algorithm" :: Aeson.Parser Text)
@ -113,8 +153,35 @@ data LdapConf = LdapConf
, ldapBase :: Ldap.Dn
, ldapScope :: Ldap.Scope
, ldapTimeout :: Int32
}
} deriving (Show)
data SmtpConf = SmtpConf
{ smtpHost :: HaskellNet.HostName
, smtpPort :: HaskellNet.PortNumber
, smtpAuth :: Maybe SmtpAuthConf
, smtpSsl :: SmtpSslMode
, smtpPool :: ResourcePoolConf
} deriving (Show)
data ResourcePoolConf = ResourcePoolConf
{ poolStripes :: Int
, poolTimeout :: NominalDiffTime
, poolLimit :: Int
} deriving (Show)
data SmtpSslMode = SmtpSslNone | SmtpSslSmtps | SmtpSslStarttls
deriving (Show)
data SmtpAuthConf = SmtpAuthConf
{ smtpAuthType :: HaskellNet.AuthType
, smtpAuthUsername :: HaskellNet.UserName
, smtpAuthPassword :: HaskellNet.Password
} deriving (Show)
deriveJSON defaultOptions
{ fieldLabelModifier = intercalate "-" . map toLower . splitCamel
} ''LogSettings
deriveFromJSON defaultOptions ''Ldap.Scope
deriveFromJSON defaultOptions
{ fieldLabelModifier = intercalate "-" . map toLower . drop 2 . splitCamel
@ -140,12 +207,64 @@ instance FromJSON LdapConf where
return LdapConf{..}
deriveFromJSON
defaultOptions
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
}
''ResourcePoolConf
deriveJSON
defaultOptions
{ constructorTagModifier = over (ix 1) Char.toLower . fromJust . stripPrefix "Level"
, sumEncoding = UntaggedValue
}
''LogLevel
instance FromJSON HaskellNet.PortNumber where
parseJSON = withScientific "PortNumber" $ \sciNum -> case toBoundedInteger sciNum of
Just int -> return $ fromIntegral (int :: Word16)
Nothing -> fail "Expected whole number of plausible size to denote port"
deriveFromJSON
defaultOptions
{ constructorTagModifier = unpack . intercalate "-" . Text.splitOn "_" . toLower . pack
, allNullaryToStringTag = True
}
''HaskellNet.AuthType
instance FromJSON SmtpConf where
parseJSON = withObject "SmtpConf" $ \o -> do
smtpHost <- o .: "host"
smtpPort <- o .: "port"
smtpAuth <- assertM (not . null . smtpAuthUsername) <$> o .:? "auth"
smtpSsl <- o .: "ssl"
smtpPool <- o .: "pool"
return SmtpConf{..}
deriveFromJSON
defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel
, allNullaryToStringTag = True
}
''SmtpSslMode
deriveFromJSON
defaultOptions
{ fieldLabelModifier = let
nameMap "username" = "user"
nameMap "password" = "pass"
nameMap x = x
in nameMap . intercalate "-" . map toLower . drop 2 . splitCamel
}
''SmtpAuthConf
deriveFromJSON
defaultOptions
{ fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
}
''Address
instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do
let defaultDev =
@ -160,24 +279,38 @@ instance FromJSON AppSettings where
Ldap.Tls host _ -> not $ null host
Ldap.Plain host -> not $ null host
appLdapConf <- assertM nonEmptyHost <$> o .:? "ldap"
appSmtpConf <- assertM (not . null . smtpHost) <$> o .:? "smtp"
appRoot <- o .:? "approot"
appHost <- fromString <$> o .: "host"
appPort <- o .: "port"
appIpFromHeader <- o .: "ip-from-header"
appDetailedRequestLogging <- o .:? "detailed-logging" .!= defaultDev
appShouldLogAll <- o .:? "should-log-all" .!= defaultDev
appMinimumLogLevel <- o .: "minimum-log-level"
appMailFrom <- o .: "mail-from"
appMailObjectDomain <- o .: "mail-object-domain"
appMailVerp <- o .: "mail-verp"
appMailSupport <- o .: "mail-support"
appJobWorkers <- o .: "job-workers"
appJobFlushInterval <- o .:? "job-flush-interval"
appJobCronInterval <- o .: "job-cron-interval"
appJobStaleThreshold <- o .: "job-stale-threshold"
appNotificationRateLimit <- o .: "notification-rate-limit"
appNotificationCollateDelay <- o .: "notification-collate-delay"
appNotificationExpiration <- o .: "notification-expiration"
appReloadTemplates <- o .:? "reload-templates" .!= defaultDev
appMutableStatic <- o .:? "mutable-static" .!= defaultDev
appSkipCombining <- o .:? "skip-combining" .!= defaultDev
appAuthDummyLogin <- o .:? "auth-dummy-login" .!= defaultDev
appAllowDeprecated <- o .:? "allow-deprecated" .!= defaultDev
appInitialLogSettings <- o .: "log-settings"
appUserDefaults <- o .: "user-defaults"
appAuthPWHash <- o .: "auth-pw-hash"
appCryptoIDKeyFile <- o .: "cryptoid-keyfile"
appInstanceIDFile <- o .:? "instance-idfile"
return AppSettings {..}

18
src/Utils.hs
View File

@ -21,11 +21,14 @@ import Data.Foldable as Fold hiding (length)
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import qualified Data.ByteString.Lazy as LBS
import Utils.DB as Utils
import Utils.TH as Utils
import Utils.DateTime as Utils
import Utils.PathPiece as Utils
import Utils.Message as Utils
import Utils.Lang as Utils
import Text.Blaze (Markup, ToMarkup)
@ -53,6 +56,8 @@ import Instances.TH.Lift ()
import Text.Shakespeare.Text (st)
import qualified Data.Aeson as Aeson
-----------
@ -312,6 +317,9 @@ maybeM dft act mb = mb >>= maybe dft act
maybeT :: Monad m => m a -> MaybeT m a -> m a
maybeT x m = runMaybeT m >>= maybe x return
maybeT_ :: Monad m => MaybeT m () -> m ()
maybeT_ = void . runMaybeT
catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
catchIfMaybeT p act = catchIf p (lift act) (const mzero)
@ -434,3 +442,13 @@ orM = Fold.foldr or2M (return False)
anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
anyM xs f = orM $ fmap f xs
--------------
-- Sessions --
--------------
setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m ()
setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val
lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key

2
src/Utils/DB.hs
View File

@ -15,7 +15,7 @@ import qualified Data.Set as Set
import qualified Database.Esqueleto as E
-- import Database.Persist -- currently not needed here
-- ezero = E.val (0 :: Int64)
emptyOrIn :: PersistField typ =>
E.SqlExpr (E.Value typ) -> Set typ -> E.SqlExpr (E.Value Bool)

51
src/Utils/DateTime.hs
View File

@ -2,7 +2,13 @@
, TemplateHaskell
, QuasiQuotes
, StandaloneDeriving
, DerivingStrategies
, DeriveLift
, DeriveDataTypeable
, DeriveGeneric
, GeneralizedNewtypeDeriving
, OverloadedStrings
, FlexibleInstances
#-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -10,6 +16,8 @@ module Utils.DateTime
( timeLocaleMap
, TimeLocale(..)
, currentYear
, DateTimeFormat(..)
, SelDateTimeFormat(..)
, module Data.Time.Zones
, module Data.Time.Zones.TH
) where
@ -20,14 +28,29 @@ import System.Locale.Read
import Data.Time (TimeZone(..), 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(..))
import Instances.TH.Lift ()
import Data.Data (Data)
import Data.Typeable (Typeable)
import Data.Universe
import Database.Persist.Sql (PersistField, PersistFieldSql)
import Data.Aeson.Types (toJSONKeyText)
import Data.Aeson
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
-- $(timeLocaleMap _) :: [Lang] -> TimeLocale
timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default
@ -63,3 +86,31 @@ currentYear = do
now <- runIO getCurrentTime
let (year, _, _) = toGregorian $ utctDay now
[e|year|]
newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
deriving newtype (ToJSON, FromJSON, PersistField, PersistFieldSql, IsString)
instance Hashable DateTimeFormat
data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable)
instance Universe SelDateTimeFormat
instance Finite SelDateTimeFormat
instance Hashable SelDateTimeFormat
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel
} ''SelDateTimeFormat
instance ToJSONKey SelDateTimeFormat where
toJSONKey = toJSONKeyText $ \v -> let String txt = toJSON v in txt
instance FromJSONKey SelDateTimeFormat where
fromJSONKey = FromJSONKeyTextParser $ parseJSON . String
instance {-# OVERLAPPING #-} Default (SelDateTimeFormat -> DateTimeFormat) where
def SelFormatDateTime = "%c"
def SelFormatDate = "%F"
def SelFormatTime = "%T"

83
src/Utils/Form.hs
View File

@ -9,11 +9,13 @@
, FlexibleContexts
, NamedFieldPuns
, ScopedTypeVariables
, MultiWayIf
, RecordWildCards
#-}
module Utils.Form where
import ClassyPrelude.Yesod
import ClassyPrelude.Yesod hiding (addMessage)
import Settings
import qualified Text.Blaze.Internal as Blaze (null)
@ -23,8 +25,18 @@ import qualified Data.Char as Char
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Map.Lazy ((!))
import qualified Data.Map.Lazy as Map
import qualified Data.Set as Set
import Data.List ((!!))
import Web.PathPieces
import Data.UUID
import Utils.Message
-------------------
-- Form Renderer --
-------------------
@ -121,8 +133,8 @@ setNameClass fs gName gClass = fs { fsName= Just gName, fsAttrs=("class",gClass)
setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }
addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => Field m a -> WidgetT (HandlerSite m) IO vals -> Field m a
addDatalist field mValues = field
addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => WidgetT (HandlerSite m) IO vals -> Field m a -> Field m a
addDatalist mValues field = field
{ fieldView = \fId fName fAttrs fRes fReq -> do
listId <- newIdent
values <- map toPathPiece . otoList <$> mValues
@ -135,12 +147,29 @@ addDatalist field mValues = field
|]
}
noValidate :: FieldSettings site -> FieldSettings site
noValidate = addAttr "formnovalidate" ""
------------------------------------------------
-- Unique Form Identifiers to avoid accidents --
------------------------------------------------
data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrection | FIDcorrectionsUpload | FIDcorrectionUpload
deriving (Enum, Eq, Ord, Bounded, Read, Show)
data FormIdentifier
= FIDcourse
| FIDsheet
| FIDsubmission
| FIDsettings
| FIDcorrectors
| FIDcorrectorTable
| FIDcorrection
| FIDcorrectionsUpload
| FIDcorrectionUpload
| FIDSystemMessageAdd
| FIDSystemMessageTable
| FIDSystemMessageModify
| FIDSystemMessageModifyTranslation UUID
| FIDSystemMessageAddTranslation
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where
fromPathPiece = readFromPathPiece
@ -195,7 +224,7 @@ buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
fieldParse [] _ = return $ Right Nothing
fieldParse [str] _
| str == toPathPiece btn = return $ Right $ Just btn
| otherwise = return $ Left "Wrong button value" -- SJ: Right Nothing?!
| otherwise = return $ Left "Wrong button value"
fieldParse _ _ = return $ Left "Multiple button values"
combinedButtonField :: (Button site a, Show (ButtonCssClass site)) => [a] -> AForm (HandlerT site IO) [Maybe a]
@ -216,3 +245,45 @@ ciField :: ( Textual t
, RenderMessage (HandlerSite m) FormMessage
) => Field m (CI t)
ciField = convertField (CI.mk . fromList . unpack) (pack . toList . CI.original) textField
reorderField :: ( MonadHandler m
, HandlerSite m ~ site
, Eq a
, Show a
) => HandlerT site IO (OptionList a) -> Field m [a]
-- ^ Allow the user to enter a /permutation/ of the given options (every option must occur exactly once in the result)
reorderField optList = Field{..}
where
fieldEnctype = UrlEncoded
fieldParse [] _ = return $ Right Nothing
fieldParse optlist _ = do
OptionList{..} <- liftHandlerT optList
let
olNum = fromIntegral $ length olOptions
selOptions = Map.fromList $ do
i <- [1..olNum]
(readMay -> Just (n :: Word), ('.' : extVal)) <- break (== '.') . unpack <$> optlist
guard $ i == n
Just val <- return . olReadExternal $ pack extVal
return (i, val)
return $ if
| Map.keysSet selOptions == Set.fromList [1..olNum]
-> Right . Just $ map (selOptions !) [1..fromIntegral olNum]
| otherwise
-> Left "Not a valid permutation"
fieldView theId name attrs val isReq = do
OptionList{..} <- liftHandlerT optList
let
isSel n = (==) (either (const $ map optionInternalValue olOptions) id val !! pred n) . optionInternalValue
nums = map (id &&& withNum theId) [1..length olOptions]
withNum t n = tshow n <> "." <> t
$(widgetFile "widgets/permutation")
---------------------
-- Form evaluation --
---------------------
formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
formResult (FormFailure errs) _ = forM_ errs $ addMessage Error . toHtml
formResult FormMissing _ = return ()
formResult (FormSuccess res) f = f res

39
src/Utils/Lang.hs Normal file
View File

@ -0,0 +1,39 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Utils.Lang where
import ClassyPrelude.Yesod
import qualified Data.List.NonEmpty as NonEmpty
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Text as Text
selectLanguage :: MonadHandler m
=> NonEmpty Lang -- ^ Available translations, first is default
-> m Lang
selectLanguage avL = selectLanguage' avL <$> languages
selectLanguage' :: NonEmpty Lang -- ^ Available translations, first is default
-> [Lang] -- ^ Languages in preference order
-> Lang
selectLanguage' (defL :| _) [] = defL
selectLanguage' avL (l:ls)
| not $ null l
, Just l' <- find (== l) (NonEmpty.toList avL)
= l'
| not $ null l
, Just lParts <- NonEmpty.nonEmpty $ Text.splitOn "-" l
, found <- find ((NonEmpty.toList lParts `isPrefixOf`) . Text.splitOn "-") avL
= case found of
Just l' -> l'
Nothing -> selectLanguage' avL $ Text.intercalate "-" (NonEmpty.tail lParts) : ls
| otherwise = selectLanguage' avL ls
langMatches :: Lang -- ^ Needle
-> Lang -- ^ Haystack
-> Bool
langMatches = isPrefixOf `on` Text.splitOn "-"

37
src/Utils/Message.hs
View File

@ -1,35 +1,62 @@
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveLift #-}
module Utils.Message
( MessageClass(..)
, addMessage, addMessageI
, addMessage, addMessageI, addMessageIHamlet, addMessageFile
) where
import Data.Text as Text (toLower)
import Data.Universe
import Utils.PathPiece (finiteFromPathPiece, nullaryToPathPiece)
import Data.Aeson
import Data.Aeson.TH
import qualified ClassyPrelude.Yesod (addMessage, addMessageI)
import ClassyPrelude.Yesod (PathPiece(..),MonadHandler,HandlerSite,RenderMessage,Html)
import ClassyPrelude.Yesod hiding (addMessage, addMessageI)
import Text.Hamlet
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift)
data MessageClass = Error | Warning | Info | Success
deriving (Eq,Ord,Enum,Bounded,Show,Read)
deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift)
instance Universe MessageClass
instance Finite MessageClass
$( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813
deriveJSON defaultOptions
{ constructorTagModifier = toLower
} ''MessageClass
instance PathPiece MessageClass where
toPathPiece = $(nullaryToPathPiece ''MessageClass [Text.toLower])
toPathPiece = $(nullaryToPathPiece ''MessageClass [toLower])
fromPathPiece = finiteFromPathPiece
derivePersistField "MessageClass"
addMessage :: MonadHandler m => MessageClass-> Html -> m ()
addMessage mc = ClassyPrelude.Yesod.addMessage (toPathPiece mc)
addMessageI :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => MessageClass -> msg -> m ()
addMessageI mc = ClassyPrelude.Yesod.addMessageI (toPathPiece mc)
addMessageIHamlet :: ( MonadHandler m
, RenderMessage (HandlerSite m) msg
, HandlerSite m ~ site
) => MessageClass -> HtmlUrlI18n msg (Route site) -> m ()
addMessageIHamlet mc iHamlet = do
mr <- getMessageRender
ClassyPrelude.Yesod.addMessage (toPathPiece mc) =<< withUrlRenderer (iHamlet $ toHtml . mr)
addMessageFile :: MessageClass -> FilePath -> ExpQ
addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|]

40
src/Utils/Sql.hs Normal file
View File

@ -0,0 +1,40 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NumDecimals #-}
{-# LANGUAGE FlexibleContexts #-}
module Utils.Sql
( setSerializable
) where
import ClassyPrelude.Yesod
import Database.Persist.Sql
import Database.PostgreSQL.Simple (sqlErrorHint)
import Control.Monad.Catch (handleIf)
import Data.Time.Clock
setSerializable :: (MonadLogger m, MonadCatch m, MonadBase IO m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a
setSerializable act = setSerializable' (0 :: Integer)
where
act' = [executeQQ|SET TRANSACTION ISOLATION LEVEL SERIALIZABLE|] *> act
setSerializable' (min 10 -> logBackoff) =
handleIf
(\e -> "The transaction might succeed if retried." `isInfixOf` sqlErrorHint e)
(\e -> do
let
delay :: NominalDiffTime
delay = 1e-3 * 2 ^ logBackoff
$logWarnS "Sql" $ tshow (delay, e)
transactionUndo
threadDelay . round $ delay * 1e6
setSerializable' (succ logBackoff)
)
act'

25
src/Utils/SystemMessage.hs Normal file
View File

@ -0,0 +1,25 @@
{-# LANGUAGE NoImplicitPrelude
, RecordWildCards
#-}
module Utils.SystemMessage where
import Import.NoFoundation
import qualified Data.List.NonEmpty as NonEmpty
import Data.List (findIndex)
import Control.Monad.Trans.Maybe (MaybeT(..))
getSystemMessage :: MonadHandler m
=> NonEmpty Lang -- ^ `appLanguages`
-> SystemMessageId
-> ReaderT SqlBackend m (Maybe (SystemMessage, Maybe SystemMessageTranslation))
getSystemMessage appLanguages smId = runMaybeT $ do
SystemMessage{..} <- MaybeT $ get smId
translations <- lift $ selectList [SystemMessageTranslationMessage ==. smId] []
let
avL = NonEmpty.sortWith (\l -> NTop $ findIndex (langMatches l) $ NonEmpty.toList appLanguages) $ systemMessageDefaultLanguage :| map (systemMessageTranslationLanguage . entityVal) translations
lang <- selectLanguage avL
return (SystemMessage{..}, find (langMatches lang . systemMessageTranslationLanguage) $ map entityVal translations)

2
src/Utils/TH.hs
View File

@ -1,11 +1,13 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Utils.TH where
-- Common Utility Functions that require TemplateHaskell
-- import Data.Char
import Prelude
import Language.Haskell.TH
-- import Control.Monad
-- import Control.Monad.Trans.Class

47
src/index.md
View File

@ -96,3 +96,50 @@ CryptoID
Model.Migration
: Manuelle Datenbank-Migration
Jobs
: `handleJobs` worker thread handling background jobs
`JobQueueException`
Jobs.Types
: `Job`, `Notification`, `JobCtl` Types of Jobs
Cron.Types
: Datentypen zur Spezifikation von Intervallen zu denen Jobs ausgeführt werden
können:
`Cron`, `CronMatch`, `CronAbsolute`, `CronRepeat`, `Crontab`
Cron
: Seiteneffektfreie Berechnungen auf Typen aus `Cron.Types`: `nextCronMatch`
Jobs.Queue
: Funktionen zum _anstoßen_ von Jobs und zur Kommunikation mit den
Worker-Threads
`writeJobCtl` schickt Nachricht an einen pseudo-Zufälligen worker-thread der
lokalen Instanz
`queueJob` und `queueJob'` schreiben neue Jobs in die Instanz-übergreifende
Job-Queue, `queueJob'` stößt außerdem einen lokalen worker-thread an sich
des Jobs anzunehmen
`runDBJobs` ersetzt `runDB` und erlaubt `queueDBJob` zu
benutzen. `queueDBJob` schreibt einen Job in die Queue; am Ende stößt
`runDBJobs` lokale worker-threads für alle mit `queueDBJobs` eingetragenen
Jobs an.
Jobs.TH
: Templatehaskell für den dispatch mechanismus für `Jobs`
Jobs.Crontab
: Generiert `Crontab JobCtl` aus der Datenbank (sammelt alle in den Daten aus
der Datenbank impliziten Jobs (notifications zu bestimmten zeiten,
aufräumaktionen, ...) ein)
Jobs.Handler.**
: Via `Jobs.TH` delegiert `Jobs` das Interpretieren und Ausführen eines Werts
aus `Jobs.Types` an einen dieser Handler
Mail
: Monadically constructing MIME emails

1
start.sh
View File

@ -3,6 +3,7 @@
unset HOST
export DETAILED_LOGGING=true
export LOG_ALL=true
export LOGLEVEL=info
export DUMMY_LOGIN=true
export ALLOW_DEPRECATED=true
export PWFILE=users.yml

2
templates/adminTest.hamlet
View File

@ -34,3 +34,5 @@
Modals:
^{modal "Klick mich für Ajax-Test" (Left UsersR)}
^{modal "Klick mich für Content-Test" (Right "Test Inhalt für Modal")}
<li>
^{modal "Email-Test" (Right emailWidget')}

3
templates/correction-user.cassius Normal file
View File

@ -0,0 +1,3 @@
.comment
white-space: pre-wrap
font-family: monospace

2
templates/correction-user.hamlet
View File

@ -36,4 +36,4 @@
$maybe comment <- ratingComment
<tr .table__row>
<th .table__th>_{MsgRatingComment}
<td .table__td style="white-space: pre;">#{comment}
<td .table__td .comment>#{comment}

17
templates/correction.hamlet
View File

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

2
templates/corrections-create.hamlet Normal file
View File

@ -0,0 +1,2 @@
<form method=post action=@{CorrectionsCreateR} enctype=#{pseudonymEncoding}>
^{pseudonymWidget}

5
templates/corrections-grade.hamlet Normal file
View File

@ -0,0 +1,5 @@
<div .container>
<form method=POST action=@{CorrectionsGradeR} enctype=#{tableEncoding}>
^{table}
<button type=submit>
_{MsgBtnSubmit}

25
templates/default-layout.lucius
View File

@ -185,6 +185,10 @@ h4 {
p {
margin: 10px 0;
}
p:last-child {
margin: 10px 0 0;
}
}
.logged-in {
@ -309,6 +313,10 @@ input[type="button"].btn-info:hover,
width: 100%;
}
.table:only-child {
margin: 0;
}
.table--striped {
.table__row:not(.no-stripe):nth-child(even) {
@ -502,3 +510,20 @@ input[type="button"].btn-info:hover,
padding-right: 15px;
}
}
section {
padding: 0 0 12px;
margin: 0 0 12px;
border-bottom: 1px solid #d3d3d3;
}
section:last-of-type {
padding: 0;
margin: 0;
border-bottom: none;
}
.pseudonym {
font-family: monospace;
}

16
templates/deletedUser.hamlet Normal file
View File

@ -0,0 +1,16 @@
<div .container>
<h1>
_{MsgUserAccountDeleted userDisplayName}
<div .container>
#{display deletedSubmissions} Abgaben wurden unwiederruflich gelöscht.
$if groupSubmissions > 0
<div .container>
#{display groupSubmissions} Gruppenabgaben verbleiben in der Datenbank,
aber die Zuordnung zum Benutzer wurden gelöscht.
Gruppenabgaben können dadurch zu Einzelabgaben werden,
welche dann vom letzten Benutzer gelöscht werden können.
$if deletedSubmissionGroups > 0
<div .container>
#{display deletedSubmissionGroups} benannte Abgabengruppen wurden gelöscht, da diese dadurch leer wurden.
<div .container>
Good Bye!

4
templates/help.hamlet Normal file
View File

@ -0,0 +1,4 @@
_{MsgHelpIntroduction}
<form method=post action=@{HelpR} enctype=#{formEnctype}>
^{formWidget}

8
templates/home.hamlet
View File

@ -1,11 +1,5 @@
<div .container>
<h1>
<h2>
Kurse mit offener Registrierung
<div .container>
^{courseTable}
<h3>
Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
^{features}

8
templates/homeUser.hamlet
View File

@ -1,13 +1,10 @@
<div .container>
<h3>
Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>
<div .container>
<h1>
<h2>
Anstehende Übungsblätter
<div .container>
^{sheetTable}
<!--
<div .container>
<h1>
Anstehende Klausuren
@ -17,3 +14,4 @@
<h1>
Anstehende Kursanmeldungen
TODO
-->

18
templates/mail/correctionsAssigned.hamlet Normal file
View File

@ -0,0 +1,18 @@
$newline never
\<!doctype html>
<html>
<head>
<meta charset="UTF-8">
<style>
h1 {
font-size: 1.25em;
font-variant: small-caps;
font-weight: normal;
}
<body>
<h1>
_{MsgMailCorrectionsAssignedIntro (CI.original courseName) termDesc sheetName nbrSubs}
<p>
<a href=@{CorrectionsR}>
_{MsgCorrectionsTitle}
^{editNotifications}

4
templates/mail/editNotifications.hamlet Normal file
View File

@ -0,0 +1,4 @@
<p>
<a href=@{ProfileR}>
_{MsgProfileHeading}
\ _{MsgMailEditNotifications}

18
templates/mail/sheetActive.hamlet Normal file
View File

@ -0,0 +1,18 @@
$newline never
\<!doctype html>
<html>
<head>
<meta charset="UTF-8">
<style>
h1 {
font-size: 1.25em;
font-variant: small-caps;
font-weight: normal;
}
<body>
<h1>
_{MsgMailSheetActiveIntro (CI.original courseName) termDesc sheetName}
<p>
<a href=@{CSheetR tid ssh csh shn SShowR}>
#{sheetName}
^{editNotifications}

18
templates/mail/sheetInactive.hamlet Normal file
View File

@ -0,0 +1,18 @@
$newline never
\<!doctype html>
<html>
<head>
<meta charset="UTF-8">
<style>
h1 {
font-size: 1.25em;
font-variant: small-caps;
font-weight: normal;
}
<body>
<h1>
_{MsgMailSheetInactiveIntro (CI.original courseName) termDesc sheetName}
<p>
<a href=@{CSheetR tid ssh csh shn SShowR}>
#{sheetName}
^{editNotifications}

18
templates/mail/sheetSoonInactive.hamlet Normal file
View File

@ -0,0 +1,18 @@
$newline never
\<!doctype html>
<html>
<head>
<meta charset="UTF-8">
<style>
h1 {
font-size: 1.25em;
font-variant: small-caps;
font-weight: normal;
}
<body>
<h1>
_{MsgMailSheetSoonInactiveIntro (CI.original courseName) termDesc sheetName}
<p>
<a href=@{CSheetR tid ssh csh shn SShowR}>
#{sheetName}
^{editNotifications}

66
templates/mail/submissionRated.hamlet Normal file
View File

@ -0,0 +1,66 @@
$newline never
\<!doctype html>
<html>
<head>
<meta charset="UTF-8">
<style>
h1 {
font-size: 1.25em;
font-variant: small-caps;
font-weight: normal;
}
.comment {
white-space: pre-wrap;
font-family: monospace;
}
<body>
<h1>
_{MsgMailSubmissionRatedIntro (CI.original courseName) termDesc}
<dl>
<dt>
_{MsgSubmission}
<dd>
<a href=@{CSubmissionR tid ssh csh shn csid SubShowR}>
#{display csid}
$maybe User{..} <- corrector
<dt>
_{MsgRatingBy}
<dd>
#{display userDisplayName}
$maybe time <- submissionRatingTime'
<dt>
_{MsgRatingTime}
<dd>
#{time}
$maybe points <- submissionRatingPoints
$case sheetType
$of Bonus{..}
<dt>
_{MsgAchievedBonusPoints}
<dd>
_{MsgAchievedOf points maxPoints}
$of Normal{..}
<dt>
_{MsgAchievedNormalPoints}
<dd>
_{MsgAchievedOf points maxPoints}
$of Pass{..}
<dt>
_{MsgPassedResult}
<dd>
$if points >= passingPoints
_{MsgPassed}
$else
_{MsgNotPassed}
<dt>
_{MsgAchievedPassPoints}
<dd>
_{MsgPassAchievedOf points passingPoints maxPoints}
$of NotGraded
$maybe comment <- submissionRatingComment
<dt>
_{MsgRatingComment}
<dd .comment>
#{comment}
^{editNotifications}

1
templates/mail/submissionRated.txt Normal file
View File

@ -0,0 +1 @@
#{mr (MsgMailSubmissionRatedIntro (CI.original courseName) termDesc)}

29
templates/mail/support.hamlet Normal file
View File

@ -0,0 +1,29 @@
$newline never
\<!doctype html>
<html>
<head>
<meta charset="UTF-8">
<body>
<dl>
$case userInfo
$of Left (Just email)
<dt> E-Mail
<dd> #{email}
$of Left Nothing
$of Right Nothing
<dt> Ungültige UserId erhalten!
$of Right (Just (Entity _ User{..}))
<dt> Name
<dd> #{userDisplayName}
<dt> E-Mail
<dd> #{userEmail}
$maybe matrnr <- userMatrikelnummer
<dt> Matrikelnummer
<dd> #{matrnr}
<dt> E-Mail Sprachen
$forall lang <- mailLanguages userMailLanguages
<dd> #{lang}
<dt> Zeit
<dd> #{rtime}
<p style="white-space: pre">
#{jHelpRequest}

6
templates/messages/submissionCreateDuplicates.hamlet Normal file
View File

@ -0,0 +1,6 @@
_{MsgSheetDuplicatePseudonym}
<ul>
$forall p <- duplicate
<li .pseudonym>
#{review pseudonymText p}

9
templates/messages/submissionCreateExisting.hamlet Normal file
View File

@ -0,0 +1,9 @@
_{MsgSheetCreateExisting}
<dl>
$forall (subId, pseudos) <- subs
<dt>#{toPathPiece subId}
<dd>
<ul>
$forall p <- pseudos
<li .pseudonym>#{review pseudonymText p}

6
templates/messages/systemMessagesDeleted.hamlet Normal file
View File

@ -0,0 +1,6 @@
_{MsgSystemMessagesDeleted}
<ul>
$forall sel <- selection
<li style="white-space: nowrap">
#{toPathPiece sel}

6
templates/messages/systemMessagesSetFrom.hamlet Normal file
View File

@ -0,0 +1,6 @@
_{MsgSystemMessagesActivated}
<ul>
$forall sel <- selection
<li style="white-space: nowrap">
#{toPathPiece sel}

6
templates/messages/systemMessagesSetTo.hamlet Normal file
View File

@ -0,0 +1,6 @@
_{MsgSystemMessagesDeactivated}
<ul>
$forall sel <- selection
<li style="white-space: nowrap">
#{toPathPiece sel}

60
templates/profile.hamlet
View File

@ -1,62 +1,2 @@
<div .profile>
<dl .deflist.profile-dl>
<dt .deflist__dt> _{MsgName}
<dd .deflist__dd> ^{nameWidget userDisplayName userSurname}
$maybe matnr <- userMatrikelnummer
<dt .deflist__dt> _{MsgMatrikelNr}
<dd .deflist__dd> #{matnr}
<dt .deflist__dt> _{MsgEMail}
<dd .deflist__dd> #{display userEmail}
<dt .deflist__dt> _{MsgIdent}
<dd .deflist__dd> #{display userIdent}
$if not $ null admin_rights
<dt .deflist__dt> Administrator
<dd .deflist__dd>
<ul .list-ul>
$forall (E.Value institute) <- admin_rights
<li .list-ul__item>
<a href=@{SchoolShowR $ SchoolKey institute}>
#{display institute}
$if not $ null lecturer_rights
<dt .deflist__dt> Lehrberechtigt
<dd .deflist__dd>
<ul .list-ul>
$forall (E.Value institute) <- lecturer_rights
<li .list-ul__item>
<a href=@{SchoolShowR $ SchoolKey institute}>
#{display institute}
$if not $ null lecture_corrector
<dt .deflist__dt> Korrektor
<dd .deflist__dd>
<ul .list-ul>
$forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_corrector
<li .list-ul__item>
<a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
$if not $ null studies
<dt .deflist__dt> Studiengänge
<dd .deflist__dd>
<div .scrolltable>
<table .table.table--striped.table--hover.table--condensed>
<tr .table__row>
<th .table__th> Abschluss
<th .table__th> Studiengang
<th .table__th> Studienart
<th .table__th> Semester
$forall ((degree, degreeKey),(field, fieldKey),fieldtype,semester) <- studies
<tr.table__row>
<td .table__td>
$maybe name <- E.unValue degree
#{display name}
$nothing
#{display degreeKey}
<td .table__td>
$maybe name <- E.unValue field
#{display name}
$nothing
#{display fieldKey}
<td .table__td>_{E.unValue fieldtype}
<td .table__td>#{display semester}
^{settingsForm}

71
templates/profileData.hamlet
View File

@ -1,9 +1,70 @@
<div .container>
$if hasRows
<div .container>
<h2> Eigene Kurse
<div .profile>
<dl .deflist.profile-dl>
<dt .deflist__dt> _{MsgName}
<dd .deflist__dd> ^{nameWidget userDisplayName userSurname}
$maybe matnr <- userMatrikelnummer
<dt .deflist__dt> _{MsgMatrikelNr}
<dd .deflist__dd> #{matnr}
<dt .deflist__dt> _{MsgEMail}
<dd .deflist__dd> #{display userEmail}
<dt .deflist__dt> _{MsgIdent}
<dd .deflist__dd> #{display userIdent}
$if not $ null admin_rights
<dt .deflist__dt> Administrator
<dd .deflist__dd>
<ul .list-ul>
$forall (E.Value institute) <- admin_rights
<li .list-ul__item>
<a href=@{SchoolShowR $ SchoolKey institute}>
#{display institute}
$if not $ null lecturer_rights
<dt .deflist__dt> Lehrberechtigt
<dd .deflist__dd>
<ul .list-ul>
$forall (E.Value institute) <- lecturer_rights
<li .list-ul__item>
<a href=@{SchoolShowR $ SchoolKey institute}>
#{display institute}
$if not $ null lecture_corrector
<dt .deflist__dt> Korrektor
<dd .deflist__dd>
<ul .list-ul>
$forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_corrector
<li .list-ul__item>
<a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
$if not $ null studies
<dt .deflist__dt> Studiengänge
<dd .deflist__dd>
<div .scrolltable>
<table .table.table--striped.table--hover.table--condensed>
<tr .table__row>
<th .table__th> Abschluss
<th .table__th> Studiengang
<th .table__th> Studienart
<th .table__th> Semester
$forall ((degree, degreeKey),(field, fieldKey),fieldtype,semester) <- studies
<tr.table__row>
<td .table__td>
$maybe name <- E.unValue degree
#{display name}
$nothing
#{display degreeKey}
<td .table__td>
$maybe name <- E.unValue field
#{display name}
$nothing
#{display fieldKey}
<td .table__td>_{E.unValue fieldtype}
<td .table__td>#{display semester}
<div .container>
$if hasRows
<div .container>
^{ownedCoursesTable}
<h2> Eigene Kurse
<div .container>
^{ownedCoursesTable}
<div .container>
<h2> Kursanmeldungen

61
templates/sheetShow.hamlet
View File

@ -1,33 +1,34 @@
<div .container>
$maybe descr <- sheetDescription sheet
<h2 #description>Hinweise
<p> #{descr}
<h3>Bewertung
<p>
#{display $ sheetType sheet}
$maybe marking <- sheetMarkingText sheet
$newline never
$maybe descr <- sheetDescription sheet
<section>
<h2 #description>_{MsgSheetDescription}
<p>
#{marking}
#{descr}
<p>
Download und Abgabe freigeschaltet ab
#{sheetFrom}
<section>
<dl .deflist>
<dt .deflist__dt>_{MsgSheetActiveFrom}
<dd .deflist__dd>#{sheetFrom}
<dt .deflist__dt>_{MsgSheetActiveTo}
<dd .deflist__dd>#{sheetTo}
$maybe hints <- hintsFrom <* guard hasHints
<dt .deflist__dt>_{MsgSheetHintFrom}
<dd .deflist__dd>#{hints}
$maybe solution <- solutionFrom <* guard hasSolution
<dt .deflist__dt>_{MsgSheetSolutionFrom}
<dd .deflist__dd>#{solution}
<dt .deflist__dt>_{MsgSheetType}
<dd .deflist__dd>_{sheetType sheet}
$if CorrectorSubmissions == sheetSubmissionMode sheet
<dt .deflist__dt>_{MsgSheetPseudonym}
<dd .deflist__dd #pseudonym>
$maybe pseudonym <- mPseudonym
<span .pseudonym>#{pseudonym}
$nothing
<form method=post action=@{CSheetR tid ssh csh shn SPseudonymR} enctype=#{generateEnctype}>
^{generateWidget}
<p>
Abgabe bis
#{sheetTo}
$maybe hints <- hintsFrom <* guard hasHints
<p>
Hinweise ab
#{hints}
$maybe solution <- solutionFrom <* guard hasSolution
<p>
Lösung ab
#{solution}
<h2>Dateien
^{fileTable}
$if hasFiles
<section>
<h2>_{MsgSheetFiles}
^{fileTable}

4
templates/standalone/alerts.lucius
View File

@ -82,6 +82,10 @@
transition: margin-bottom .2s ease-out;
}
.alert a {
color: var(--color-lightwhite);
}
@keyframes slide-in-alert {
from {
transform: translateY(120%);

1
templates/standalone/modal.julius
View File

@ -56,6 +56,7 @@
if (modal.dataset.dynamic === 'True') {
var dynamicContentURL = trigger.getAttribute('href');
console.log(dynamicContentURL);
if (dynamicContentURL.length > 0) {
fetch(dynamicContentURL, {
credentials: 'same-origin',

2
templates/standalone/modal.lucius
View File

@ -16,11 +16,13 @@
overflow: auto;
opacity: 0;
transition: all .15s ease;
pointer-events: none;
&.modal--open {
opacity: 1;
z-index: 200;
transform: translate(-50%, -50%) scale(1, 1);
pointer-events: all;
}
}

Some files were not shown because too many files have changed in this diff Show More