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

Merge branch 'master' into 155-zentralanmeldungen

Browse Source
This commit is contained in:
Gregor Kleen 2019-07-30 13:05:22 +02:00
commit bf56081576
71 changed files with 4667 additions and 3281 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

34
CHANGELOG.md
View File

@ -2,6 +2,40 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [4.6.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.5.0...v4.6.0) (2019-07-26)
### Features
* **exam-users:** allow missing columns in csv import ([e242013](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e242013))
## [4.5.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.4.0...v4.5.0) (2019-07-26)
### Bug Fixes
* fix merge ([38afa90](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/38afa90))
* **csv-import:** fix incorrect map merge ([0d283fd](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0d283fd))
* **dbtable-ui:** fix position of submit button for pagesize ([cf35118](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/cf35118))
* **merge:** fix build ([0bd0260](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/0bd0260))
### Features
* **alert-icons:** add custom icons for alerts ([bc67500](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/bc67500))
* **alerticons:** allow alerts to have custom icons ([d70a958](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/d70a958))
* **alerts js:** support custom icons in Alerts HTTP-Header ([8833cb5](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/8833cb5))
* **corrections assignment:** add convenience to table header ([56c2fcc](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/56c2fcc))
* **course enrolement:** show proper icons in alerts ([b2b3895](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b2b3895))
* **exam-users:** provide better table defaults ([a689d19](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a689d19))
* **exams:** csv-based grade upload ([932145c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/932145c))
* **exams:** show exam results ([b8b308d](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/b8b308d))
* **users:** store first names and titles ([ceed070](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/ceed070))
## [4.4.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v4.3.0...v4.4.0) (2019-07-24)

21
is-clean.sh Executable file
View File

@ -0,0 +1,21 @@
#!/usr/bin/env bash
set -e
if [ -n "$(git status --porcelain)" ]; then
echo "Working directory isn't clean" >&2
exit 1
fi
if [ "$(git rev-parse --abbrev-ref HEAD)" != "master" ]; then
echo "Not on master" >&2
exit 1
fi
ourHash=$(git rev-parse HEAD)
theirHash=$(git ls-remote origin -h refs/heads/master | awk '{ print $1; }')
if [ "$theirHash" != "$ourHash" ]; then
echo "Local HEAD is not up to date with remote master" >&2
exit 1
fi

80
messages/uniworx/de.msg
View File

@ -312,6 +312,10 @@ UnauthorizedTutorialTutor: Sie sind nicht Tutor für dieses Tutorium.
UnauthorizedCourseTutor: Sie sind nicht Tutor für diesen Kurs.
UnauthorizedTutor: Sie sind nicht Tutor.
UnauthorizedTutorialRegisterGroup: Sie sind bereits in einem Tutorium mit derselben Registrierungs-Gruppe.
UnauthorizedLDAP: Angegebener Nutzer meldet sich nicht mit Campus-Kennung an.
UnauthorizedPWHash: Angegebener Nutzer meldet sich nicht mit Uni2work-Kennung an.
UnauthorizedPasswordResetToken: Dieses Authorisierungs-Token kann nicht mehr zum Passwort ändern benutzt werden
EMail: E-Mail
EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
@ -502,7 +506,9 @@ NoUpcomingExams: In den nächsten 14 Tagen gibt es keine Klausur mit offener Reg
AdminHeading: Administration
AdminUserHeading: Benutzeradministration
AccessRightsFor: Berechtigungen für
AdminUserRightsHeading: Benutzerrechte
AdminUserAuthHeading: Benutzer-Authentifizierung
AdminUserHeadingFor: Benuterprofil für
AdminFor: Administrator
LecturerFor: Dozent
LecturersFor: Dozenten
@ -651,6 +657,13 @@ MailUserRightsIntro name@Text email@UserEmail: #{name} <#{email}> hat folgende U
MailNoLecturerRights: Sie haben derzeit keine Dozenten-Rechte.
MailLecturerRights n@Int: Als Dozent dürfen Sie Veranstaltungen innerhalb #{pluralDE n "Ihres Instituts" "Ihrer Institute"} anlegen.
MailSubjectUserAuthModeUpdate: Änderung Ihres Uni2work-Anmeldemodus
UserAuthModePWHashChangedToLDAP: Sie melden sich nun mit Ihrer Campus-Kennung an
UserAuthModeLDAPChangedToPWHash: Sie melden sich nun mit einer Uni2work-internen Kennung an
NewPasswordLinkTip: Das Passwort Ihrer Uni2work-internen Kennung können Sie auf der folgenden Seite setzen:
NewPasswordLink: Neues Passwort setzen
AuthPWHashTip: Sie müssen nun das mit "Uni2work-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden.
PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie, aus Sicherheitsgründen, in einer separaten E-Mail.
MailEditNotifications: Benachrichtigungen ein-/ausschalten
MailSubjectSupport: Supportanfrage
@ -672,6 +685,8 @@ MailSubjectExamRegistrationInvitation tid@TermId ssh@SchoolId csh@CourseShorthan
MailSubjectSubmissionUserInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{tid}-#{ssh}-#{csh}] Einladung zu einer Abgabe für #{shn}
MailSubjectPasswordReset: Uni2work-Passwort ändern bzw. setzen
SheetGrading: Bewertung
SheetGradingPoints maxPoints@Points: #{maxPoints} Punkte
SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{passingPoints} von #{maxPoints} Punkten
@ -720,6 +735,13 @@ NotificationTriggerSheetInactive: Abgabezeitraum eines meiner Übungsblätter is
NotificationTriggerCorrectionsAssigned: Mir wurden Abgaben zur Korrektur zugeteilt
NotificationTriggerCorrectionsNotDistributed: Nicht alle Abgaben eines meiner Übungsblätter konnten einem Korrektor zugeteilt werden
NotificationTriggerUserRightsUpdate: Meine Berechtigungen wurden geändert
NotificationTriggerUserAuthModeUpdate: Mein Anmelde-Modus wurde geändert
NotificationTriggerKindAll: Für alle Benutzer
NotificationTriggerKindCourseParticipant: Für Kursteilnehmer
NotificationTriggerKindCorrector: Für Korrektoren
NotificationTriggerKindLecturer: Für Dozenten
NotificationTriggerKindAdmin: Für Administratoren
CorrCreate: Abgaben erstellen
UnknownPseudonymWord pseudonymWord@Text: Unbekanntes Pseudonym-Wort "#{pseudonymWord}"
@ -836,6 +858,7 @@ MenuTermShow: Semester
MenuSubmissionDelete: Abgabe löschen
MenuUsers: Benutzer
MenuUserNotifications: Benachrichtigungs-Einstellungen
MenuUserPassword: Passwort
MenuAdminTest: Admin-Demo
MenuMessageList: Systemnachrichten
MenuAdminErrMsg: Fehlermeldung entschlüsseln
@ -882,6 +905,7 @@ MenuExamNew: Neue Klausur anlegen
MenuExamEdit: Bearbeiten
MenuExamUsers: Teilnehmer
MenuExamAddMembers: Klausurteilnehmer hinzufügen
MenuLecturerInvite: Dozenten hinzufügen
AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
AuthPredsActive: Aktive Authorisierungsprädikate
@ -909,6 +933,8 @@ AuthTagRated: Korrektur ist bewertet
AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer
AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
AuthTagSelf: Nutzer greift nur auf eigene Daten zu
AuthTagIsLDAP: Nutzer meldet sich mit Campus-Kennung an
AuthTagIsPWHash: Nutzer meldet sich mit Uni2work-Kennung an
AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich
AuthTagRead: Zugriff ist nur lesend
AuthTagWrite: Zugriff ist i.A. schreibend
@ -1239,8 +1265,9 @@ Proportion c@Text of@Text prop@Rational: #{c}/#{of} (#{rationalToFixed2 (100 * p
CsvColumnsExplanationsLabel: Spalten
CsvColumnsExplanationsTip: Bedeutung der in der CSV-Datei enthaltenen Spalten
CsvColumnExamUserSurname: Nachname des Teilnehmers
CsvColumnExamUserName: Voller Name des Teilnehmers (inkl. Nachname)
CsvColumnExamUserSurname: Nachname(n) des Teilnehmers
CsvColumnExamUserFirstName: Vorname(n) des Teilnehmers
CsvColumnExamUserName: Voller Name des Teilnehmers (gewöhnlicherweise inkl. Vor- und Nachname(n))
CsvColumnExamUserMatriculation: Matrikelnummer des Teilnehmers
CsvColumnExamUserField: Hauptfach, mit dem der Teilnehmer seine Kursanmeldung assoziiert hat
CsvColumnExamUserDegree: Abschluss, den der Teilnehmer im assoziierten Hauptfach anstrebt
@ -1250,6 +1277,7 @@ CsvColumnExamUserExercisePoints: Anzahl von Punkten, die der Teilnehmer im Übun
CsvColumnExamUserExercisePointsMax: Maximale Anzahl von Punkten, die der Teilnehmer im Übungsbetrieb bis zu seinem Klausurtermin erreichen hätte können
CsvColumnExamUserExercisePasses: Anzahl von Übungsblättern, die der Teilnehmer bestanden hat
CsvColumnExamUserExercisePassesMax: Maximale Anzahl von Übungsblättern, die der Teilnehmer bis zu seinem Klausurtermin bestehen hätte können
CsvColumnExamUserResult: Erreichte Klausurleistung; "passed", "failed", "no-show", "voided", oder eine Note ("1.0", "1.3", "1.7", ..., "4.0", "5.0")
Action: Aktion
@ -1263,6 +1291,7 @@ ExamUserCsvRegister: Kursteilnehmer zur Klausur anmelden
ExamUserCsvAssignOccurrence: Teilnehmern einen anderen Termin/Raum zuweisen
ExamUserCsvDeregister: Teilnehmer von der Klausur abmelden
ExamUserCsvSetCourseField: Kurs-assoziiertes Hauptfach ändern
ExamUserCsvSetResult: Ergebnis eintragen
ExamUserCsvExceptionNoMatchingUser: Kursteilnehmer konnte nicht eindeutig identifiziert werden
ExamUserCsvExceptionNoMatchingStudyFeatures: Das angegebene Studienfach konnte keinem Hauptfach des Kursteilnehmers zugeordnet werden
@ -1270,4 +1299,47 @@ ExamUserCsvExceptionNoMatchingOccurrence: Raum/Termin konnte nicht eindeutig ide
TableHeadingFilter: Filter
TableHeadingCsvImport: CSV-Import
TableHeadingCsvExport: CSV-Export
TableHeadingCsvExport: CSV-Export
ExamResultAttended: Teilgenommen
ExamResultNoShow: Nicht erschienen
ExamResultVoided: Entwertet
ExamResultNone: Kein Klausurergebnis
BtnAuthLDAP: Auf Campus-Kennung umstellen
BtnAuthPWHash: Auf Uni2work-Kennung umstellen
BtnPasswordReset: Passwort zurücksetzen
AuthLDAPLookupFailed: Nutzer konnte aufgrund eines LDAP-Fehlers nicht nachgeschlagen werden
AuthLDAPInvalidLookup: Bestehender Nutzer konnte nicht eindeutig einem LDAP-Eintrag zugeordnet werden
AuthLDAPAlreadyConfigured: Nutzer meldet sich bereits per Campus-Kennung an
AuthLDAPConfigured: Nutzer meldet sich nun per Campus-Kennung an
AuthPWHashAlreadyConfigured: Nutzer meldet sich bereits per Uni2work-Kennung an
AuthPWHashConfigured: Nutzer meldet sich nun per Uni2work-Kennung an
PasswordResetQueued: Link zum Passwort-Zurücksetzen versandt
ResetPassword: Uni2work-Passwort ändern bzw. setzen
AuthMode: Authentifizierung
AuthLDAP: Campus
AuthPWHash pwHash@Text: Uni2work
CurrentPassword: Aktuelles Passwort
NewPassword: Neues Passwort
NewPasswordRepeat: Wiederholung
CurrentPasswordInvalid: Aktuelles Passwort ist inkorrekt
PasswordRepeatInvalid: Wiederholung stimmt nicht mit neuem Passwort überein
UserPasswordHeadingFor: Passwort ändern für
PasswordChangedSuccess: Passwort erfolgreich geändert
LecturerInviteSchool: Institut
LecturerInviteField: Einzuladende EMail Addressen
LecturerInviteHeading: Dozenten hinzufügen
LecturersInvited n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} per EMail eingeladen
LecturersAdded n@Int: #{n} #{pluralDE n "Dozent" "Dozenten"} eingetragen
MailSubjectSchoolLecturerInvitation school@SchoolName: Einladung zum Dozent für „#{school}“
MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent für „#{school}“
SchoolLecturerInviteExplanation: Sie wurden eingeladen, Dozent für ein Institut zu sein. Sie können, nachdem Sie die Einladung annehmen, eigenständig neue Kurse anlegen.
SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen

2
models/users
View File

@ -16,6 +16,8 @@ User json -- Each Uni2work user has a corresponding row in this table; create
email (CI Text) -- Case-insensitive eMail address
displayName Text -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
surname Text -- Display user names always through 'nameWidget displayName surname'
firstName Text -- For export in tables, pre-split firstName from displayName
title Text Maybe -- For upcoming name customisation
maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined
theme Theme default='Default' -- Color-theme of the frontend; user-defined
dateTimeFormat DateTimeFormat "default='%a %d %b %Y %R'" -- preferred Date+Time display format for user; user-defined

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "4.4.0",
"version": "4.6.0",
"lockfileVersion": 1,
"requires": true,
"dependencies": {

4
package.json
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "4.4.0",
"version": "4.6.0",
"description": "",
"keywords": [],
"author": "",
@ -20,7 +20,7 @@
"frontend:test:watch": "karma start --conf karma.conf.js --single-run false",
"frontend:build": "webpack",
"frontend:build:watch": "webpack --watch",
"prerelease": "npm run test",
"prerelease": "./is-clean.sh && npm run test",
"release": "standard-version -a",
"postrelease": "git push --follow-tags origin master"
},

3
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx
version: 4.4.0
version: 4.6.0
dependencies:
# Due to a bug in GHC 8.0.1, we block its usage
@ -133,6 +133,7 @@ dependencies:
- cassava
- cassava-conduit
- constraints
- memory
other-extensions:
- GeneralizedNewtypeDeriving

6
routes
View File

@ -24,6 +24,9 @@
-- !capacity -- course this route is associated with has at least one unit of participant capacity
-- !empty -- course this route is associated with has no participants whatsoever
--
-- !is-ldap -- user has authentication mode set to LDAP
-- !is-pw-hash -- user has authentication mode set to PWHash
--
-- !materials -- only if course allows all materials to be free (no meaning outside of courses)
-- !time -- access depends on time somehow
-- !read -- only if it is read-only access (i.e. GET but not POST)
@ -45,6 +48,9 @@
/users/#CryptoUUIDUser/delete AdminUserDeleteR POST
/users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation
/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self
/users/#CryptoUUIDUser/password UserPasswordR GET POST !selfANDis-pw-hash
!/users/lecturer-invite/new AdminNewLecturerInviteR GET POST
!/users/lecturer-invite AdminLecturerInviteR GET POST
/admin AdminR GET
/admin/features AdminFeaturesR GET POST
/admin/test AdminTestR GET POST

12
src/Control/Concurrent/Async/Lifted/Safe/Utils.hs
View File

@ -1,15 +1,17 @@
module Control.Concurrent.Async.Lifted.Safe.Utils
( allocateLinkedAsync
( allocateAsync, allocateLinkedAsync
) where
import ClassyPrelude hiding (cancel)
import Control.Lens
import Control.Concurrent.Async.Lifted.Safe
import Control.Monad.Trans.Resource
allocateLinkedAsync :: forall m a.
MonadResource m
=> IO a -> m (Async a)
allocateLinkedAsync act = allocate (async act) cancel >>= (\(_k, a) -> a <$ link a)
allocateLinkedAsync, allocateAsync :: forall m a.
MonadResource m
=> IO a -> m (Async a)
allocateAsync = fmap (view _2) . flip allocate cancel . async
allocateLinkedAsync = uncurry (<$) . (id &&& link) <=< allocateAsync

21
src/Database/Esqueleto/Utils.hs
View File

@ -11,8 +11,10 @@ module Database.Esqueleto.Utils
, mkContainsFilter, mkContainsFilterWith
, mkExistsFilter
, anyFilter, allFilter
, orderByList
, orderByOrd, orderByEnum
, lower, ciEq
, selectExists
) where
@ -171,12 +173,16 @@ allFilter fltrs needle criterias = F.foldr aux true fltrs
aux fltr acc = fltr needle criterias E.&&. acc
orderByList :: PersistField a => [a] -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
orderByList vals
= let sortUni = zip [1..] vals -- memoize this, might not work due to polymorphism
in \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val . succ $ List.length vals)
orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
orderByOrd = let sortUni = zip [1..] $ List.sort universeF in -- memoize this, might not work due to polymorphism
\x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val (-1))
orderByOrd = orderByList $ List.sort universeF
orderByEnum :: (Enum a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
orderByEnum x = E.case_ [ (x E.==. E.val u, E.val $ fromEnum u) | u <- universeF ] (E.val (-1))
orderByEnum = orderByList $ List.sortOn fromEnum universeF
lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)
@ -184,3 +190,12 @@ lower = E.unsafeSqlFunction "LOWER"
ciEq :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value Bool)
ciEq a b = lower a E.==. lower b
selectExists :: forall m a. MonadIO m => E.SqlQuery a -> E.SqlReadT m Bool
selectExists query = do
res <- E.select . return . E.exists $ void query
case res of
[E.Value b] -> return b
_other -> error "SELECT EXISTS ... returned zero or more than one rows"

89
src/Foundation.hs
View File

@ -33,6 +33,7 @@ import qualified Data.ByteString.Base64.URL as Base64 (encode)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as Lazy.ByteString
import qualified Data.ByteString as ByteString
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
@ -295,6 +296,7 @@ embedRenderMessage ''UniWorX ''UploadModeDescr id
embedRenderMessage ''UniWorX ''SecretJSONFieldException id
embedRenderMessage ''UniWorX ''AFormMessage $ concat . drop 2 . splitCamel
embedRenderMessage ''UniWorX ''AuthenticationMode id
newtype SheetTypeHeader = SheetTypeHeader SheetType
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
@ -334,6 +336,23 @@ instance RenderMessage UniWorX StudyDegreeTerm where
instance RenderMessage UniWorX ExamGrade where
renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade
instance RenderMessage UniWorX ExamPassed where
renderMessage foundation ls = \case
ExamPassed True -> mr MsgExamPassed
ExamPassed False -> mr MsgExamNotPassed
where
mr :: RenderMessage UniWorX msg => msg -> Text
mr = renderMessage foundation ls
instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where
renderMessage foundation ls = \case
ExamAttended{..} -> mr examResult
ExamNoShow -> mr MsgExamResultNoShow
ExamVoided -> mr MsgExamResultVoided
where
mr :: RenderMessage UniWorX msg => msg -> Text
mr = renderMessage foundation ls
-- ToMessage instances for converting raw numbers to Text (no internationalization)
@ -983,6 +1002,7 @@ tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return ret
AdminUserDeleteR cID -> return cID
AdminHijackUserR cID -> return cID
UserNotificationR cID -> return cID
UserPasswordR cID -> return cID
CourseR _ _ _ (CUserR cID) -> return cID
_other -> throwError =<< $unsupportedAuthPredicate AuthSelf route
referencedUser' <- decrypt referencedUser
@ -991,6 +1011,34 @@ tagAccessPredicate AuthSelf = APHandler $ \mAuthId route _ -> exceptT return ret
| uid == referencedUser' -> return Authorized
Nothing -> return AuthenticationRequired
_other -> unauthorizedI MsgUnauthorizedSelf
tagAccessPredicate AuthIsLDAP = APDB $ \_ route _ -> exceptT return return $ do
referencedUser <- case route of
AdminUserR cID -> return cID
AdminUserDeleteR cID -> return cID
AdminHijackUserR cID -> return cID
UserNotificationR cID -> return cID
UserPasswordR cID -> return cID
CourseR _ _ _ (CUserR cID) -> return cID
_other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route
referencedUser' <- decrypt referencedUser
maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do
User{..} <- MaybeT $ get referencedUser'
guard $ userAuthentication == AuthLDAP
return Authorized
tagAccessPredicate AuthIsPWHash = APDB $ \_ route _ -> exceptT return return $ do
referencedUser <- case route of
AdminUserR cID -> return cID
AdminUserDeleteR cID -> return cID
AdminHijackUserR cID -> return cID
UserNotificationR cID -> return cID
UserPasswordR cID -> return cID
CourseR _ _ _ (CUserR cID) -> return cID
_other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route
referencedUser' <- decrypt referencedUser
maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do
User{..} <- MaybeT $ get referencedUser'
guard $ is _AuthPWHash userAuthentication
return Authorized
tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
smId <- decrypt cID
@ -1784,8 +1832,18 @@ pageActions (AdminR) =
, menuItemAccessCallback' = return True
}
]
pageActions (AdminUserR cID) = [
MenuItem
pageActions (UsersR) =
[ MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuLecturerInvite
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute AdminNewLecturerInviteR
, menuItemModal = True
, menuItemAccessCallback' = return True
}
]
pageActions (AdminUserR cID) =
[ MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuUserNotifications
, menuItemIcon = Nothing
@ -1793,6 +1851,17 @@ pageActions (AdminUserR cID) = [
, menuItemModal = True
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuUserPassword
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ UserPasswordR cID
, menuItemModal = True
, menuItemAccessCallback' = do
uid <- decrypt cID
User{userAuthentication} <- runDB $ get404 uid
return $ is _AuthPWHash userAuthentication
}
]
pageActions (InfoR) = [
MenuItem
@ -2731,7 +2800,9 @@ instance YesodAuth UniWorX where
userMatrikelnummer' = lookup (Attr "LMU-Stud-Matrikelnummer") ldapData
userEmail' = lookup (Attr "mail") ldapData
userDisplayName' = lookup (Attr "displayName") ldapData
userFirstName' = lookup (Attr "givenName") ldapData
userSurname' = lookup (Attr "sn") ldapData
userTitle' = lookup (Attr "title") ldapData
userAuthentication
| isPWHash = error "PWHash should only work for users that are already known"
@ -2750,12 +2821,26 @@ instance YesodAuth UniWorX where
-> return userDisplayName
| otherwise
-> throwError $ ServerError "Could not retrieve user name"
userFirstName <- if
| Just [bs] <- userFirstName'
, Right userFirstName <- Text.decodeUtf8' bs
-> return userFirstName
| otherwise
-> throwError $ ServerError "Could not retrieve user given name"
userSurname <- if
| Just [bs] <- userSurname'
, Right userSurname <- Text.decodeUtf8' bs
-> return userSurname
| otherwise
-> throwError $ ServerError "Could not retrieve user surname"
userTitle <- if
| maybe True (all ByteString.null) userTitle'
-> return Nothing
| Just [bs] <- userTitle'
, Right userTitle <- Text.decodeUtf8' bs
-> return $ Just userTitle
| otherwise
-> throwError $ ServerError "Could not retrieve user title"
userMatrikelnummer <- if
| Just [bs] <- userMatrikelnummer'
, Right userMatrikelnummer <- Text.decodeUtf8' bs

1662
src/Handler/Course.hs
View File

File diff suppressed because it is too large Load Diff

71
src/Handler/Course/Communication.hs Normal file
View File

@ -0,0 +1,71 @@
module Handler.Course.Communication
( postCCommR, getCCommR
) where
import Import
import Handler.Utils
import Handler.Utils.Communication
import qualified Data.CaseInsensitive as CI
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
getCCommR, postCCommR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCCommR = postCCommR
postCCommR tid ssh csh = do
jSender <- requireAuthId
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
commR CommunicationRoute
{ crHeading = SomeMessage . prependCourseTitle tid ssh csh $ SomeMessage MsgCommCourseHeading
, crUltDest = SomeRoute $ CourseR tid ssh csh CCommR
, crJobs = \Communication{..} -> do
let jSubject = cSubject
jMailContent = cBody
jCourse = cid
allRecipients = Set.toList $ Set.insert (Right jSender) cRecipients
jMailObjectUUID <- liftIO getRandom
jAllRecipientAddresses <- lift . fmap Set.fromList . forM allRecipients $ \case
Left email -> return . Address Nothing $ CI.original email
Right rid -> userAddress <$> getJust rid
forM_ allRecipients $ \jRecipientEmail ->
yield JobSendCourseCommunication{..}
, crRecipients = Map.fromList
[ ( RGCourseParticipants
, E.from $ \(user `E.InnerJoin` participant) -> do
E.on $ user E.^. UserId E.==. participant E.^. CourseParticipantUser
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
return user
)
, ( RGCourseLecturers
, E.from $ \(user `E.InnerJoin` lecturer) -> do
E.on $ user E.^. UserId E.==. lecturer E.^. LecturerUser
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
return user
)
, ( RGCourseCorrectors
, E.from $ \user -> do
E.where_ $ E.exists $ E.from $ \(sheet `E.InnerJoin` corrector) -> do
E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
E.&&. user E.^. UserId E.==. corrector E.^. SheetCorrectorUser
return user
)
, ( RGCourseTutors
, E.from $ \user -> do
E.where_ $ E.exists $ E.from $ \(tutorial `E.InnerJoin` tutor) -> do
E.on $ tutorial E.^. TutorialId E.==. tutor E.^. TutorTutorial
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
E.&&. user E.^. UserId E.==. tutor E.^. TutorUser
return user
)
]
, crRecipientAuth = Just $ \uid -> do
cID <- encrypt uid
evalAccessDB (CourseR tid ssh csh $ CUserR cID) False
}

20
src/Handler/Course/Delete.hs Normal file
View File

@ -0,0 +1,20 @@
module Handler.Course.Delete
( getCDeleteR, postCDeleteR
) where
import Import
import Handler.Utils.Course
import Handler.Utils.Delete
import qualified Data.Set as Set
getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCDeleteR = postCDeleteR
postCDeleteR tid ssh csh = do
Entity cId _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
deleteR $ (courseDeleteRoute $ Set.singleton cId)
{ drAbort = SomeRoute $ CourseR tid ssh csh CShowR
, drSuccess = SomeRoute $ TermSchoolCourseListR tid ssh
}

400
src/Handler/Course/Edit.hs Normal file
View File

@ -0,0 +1,400 @@
module Handler.Course.Edit
( getCourseNewR, postCourseNewR
, getCEditR, postCEditR
) where
import Import
import Utils.Lens
import Utils.Form
import Handler.Utils
import Handler.Utils.Invitations
import qualified Data.CaseInsensitive as CI
import Data.Function ((&))
import Data.Maybe (fromJust)
import qualified Data.Set as Set
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
import Jobs.Queue
import Handler.Course.LecturerInvite
data CourseForm = CourseForm
{ cfCourseId :: Maybe CourseId
, cfName :: CourseName
, cfDesc :: Maybe Html
, cfLink :: Maybe Text
, cfShort :: CourseShorthand
, cfTerm :: TermId
, cfSchool :: SchoolId
, cfCapacity :: Maybe Int
, cfSecret :: Maybe Text
, cfMatFree :: Bool
, cfRegFrom :: Maybe UTCTime
, cfRegTo :: Maybe UTCTime
, cfDeRegUntil :: Maybe UTCTime
, cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
}
courseToForm :: Entity Course -> [Lecturer] -> [(UserEmail, InvitationDBData Lecturer)] -> CourseForm
courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm
{ cfCourseId = Just cid
, cfName = courseName
, cfDesc = courseDescription
, cfLink = courseLinkExternal
, cfShort = courseShorthand
, cfTerm = courseTerm
, cfSchool = courseSchool
, cfCapacity = courseCapacity
, cfSecret = courseRegisterSecret
, cfMatFree = courseMaterialFree
, cfRegFrom = courseRegisterFrom
, cfRegTo = courseRegisterTo
, cfDeRegUntil = courseDeregisterUntil
, cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs]
++ [Left (email, mType) | (email, InvDBDataLecturer mType) <- lecInvites ]
}
makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm
makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do
-- TODO: Refactor to avoid the four repeated calls to liftHandlerT and three runDBs
-- let editCid = cfCourseId =<< template -- possible start for refactoring
MsgRenderer mr <- getMsgRenderer
uid <- liftHandlerT requireAuthId
(lecSchools, admSchools) <- liftHandlerT . runDB $ (,)
<$> (map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] )
<*> (map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] )
let userSchools = lecSchools ++ admSchools
termsField <- case template of
-- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
(Just cform) | (Just cid) <- cfCourseId cform -> liftHandlerT $ do -- edit existing course
_courseOld@Course{..} <- runDB $ get404 cid
mayEditTerm <- isAuthorized TermEditR True
mayDelete <- isAuthorized (CourseR courseTerm courseSchool courseShorthand CDeleteR) True
return $ if
| (mayEditTerm == Authorized) || (mayDelete == Authorized) -> termsAllowedField
| otherwise -> termsSetField [cfTerm cform]
_allOtherCases -> return termsAllowedField
let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
miAdd _ _ nudge btn = Just $ \csrf -> do
(addRes, addView) <- mpreq emailField ("" & addName (nudge "user")) Nothing
addRes' <- for addRes $ liftHandlerT . runDB . getKeyBy . UniqueEmail . CI.mk
let addRes'' = case (,) <$> addRes <*> addRes' of
FormSuccess (CI.mk -> email, mLid) ->
let new = maybe (Left email) Right mLid
in FormSuccess $ \prev -> if
| new `elem` Map.elems prev -> FormFailure [ mr $ MsgCourseLecturerAlreadyAdded email ] -- Since there is only ever one email address associated with any user, the case where a @Left email@ corresponds to a @Right lid@ can never occur (at least logically; might still be the same person, of course)
| otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) new
FormFailure errs -> FormFailure errs
FormMissing -> FormMissing
addView' = $(widgetFile "course/lecturerMassInput/add")
return (addRes'', addView')
miCell :: ListPosition -> Either UserEmail UserId -> Maybe (Maybe LecturerType) -> (Text -> Text) -> Form (Maybe LecturerType)
miCell _ (Right lid) defType nudge = \csrf -> do
(lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) (join defType)
User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ get404 lid
let lrwView' = $(widgetFile "course/lecturerMassInput/cellKnown")
return (Just <$> lrwRes,lrwView')
miCell _ (Left lEmail) defType nudge = \csrf -> do
(lrwRes,lrwView) <- mopt (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType
let lrwView' = $(widgetFile "course/lecturerMassInput/cellInvitation")
return (lrwRes,lrwView')
miDelete :: Map ListPosition (Either UserEmail UserId) -- ^ Current shape
-> ListPosition -- ^ Coordinate to delete
-> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition)
miDelete = miDeleteList
miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool
miAllowAdd _ _ _ = True
miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition
miAddEmpty _ _ _ = Set.empty
miLayout :: ListLength
-> Map ListPosition (Either UserEmail UserId, FormResult (Maybe LecturerType)) -- ^ massInput state
-> Map ListPosition Widget -- ^ Cell widgets
-> Map ListPosition (FieldView UniWorX) -- ^ Deletion buttons
-> Map (Natural, ListPosition) Widget -- ^ Addition widgets
-> Widget
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "course/lecturerMassInput/layout")
miIdent :: Text
miIdent = "lecturers"
lecturerForm :: AForm Handler [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)]
lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) (map liftEither . Map.elems) $ massInput
MassInput{..}
(fslI MsgCourseLecturers & setTooltip (UniWorXMessages [SomeMessage MsgCourseLecturerRightsIdentical, SomeMessage MsgMassInputTip]))
True
(Just . Map.fromList . zip [0..] $ maybe [(Right uid, Just CourseLecturer)] (map unliftEither . cfLecturers) template)
mempty
where
liftEither :: (Either UserEmail UserId, Maybe LecturerType) -> Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)
liftEither (Right lid , Just lType) = Right (lid , lType )
liftEither (Left lEmail, mLType ) = Left (lEmail, mLType)
liftEither _ = error "liftEither: lecturerForm produced output it should not have been able to"
unliftEither :: Either (UserEmail, Maybe LecturerType) (UserId, LecturerType) -> (Either UserEmail UserId, Maybe LecturerType)
unliftEither (Right (lid , lType )) = (Right lid , Just lType)
unliftEither (Left (lEmail, mLType)) = (Left lEmail, mLType )
(newRegFrom,newRegTo,newDeRegUntil) <- case template of
(Just cform) | (Just _cid) <- cfCourseId cform -> return (Nothing,Nothing,Nothing)
_allIOtherCases -> do
mbLastTerm <- liftHandlerT $ runDB $ selectFirst [TermActive ==. True] [Desc TermName]
return ( (Just . toMidnight . termStart . entityVal) <$> mbLastTerm
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm
, (Just . beforeMidnight . termEnd . entityVal) <$> mbLastTerm )
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
<$> pure (cfCourseId =<< template)
<*> areq ciField (fslI MsgCourseName) (cfName <$> template)
<*> aopt htmlField (fslpI MsgCourseDescription "Bitte mindestens die Modulbeschreibung angeben"
& setTooltip MsgCourseDescriptionTip) (cfDesc <$> template)
<*> aopt urlField (fslpI MsgCourseHomepageExternal "Optionale externe URL")
(cfLink <$> template)
<*> areq ciField (fslI MsgCourseShorthand
-- & addAttr "disabled" "disabled"
& setTooltip MsgCourseShorthandUnique) (cfShort <$> template)
<*> areq termsField (fslI MsgCourseSemester) (cfTerm <$> template)
<*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
<*> aopt (natFieldI MsgCourseCapacity) (fslI MsgCourseCapacity
& setTooltip MsgCourseCapacityTip) (cfCapacity <$> template)
<*> aopt textField (fslpI MsgCourseSecret (mr MsgCourseSecretFormat)
& setTooltip MsgCourseSecretTip) (cfSecret <$> template)
<*> areq checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template)
<*> aopt utcTimeField (fslpI MsgRegisterFrom (mr MsgDate)
& setTooltip MsgCourseRegisterFromTip) (deepAlt (cfRegFrom <$> template) newRegFrom)
<*> aopt utcTimeField (fslpI MsgRegisterTo (mr MsgDate)
& setTooltip MsgCourseRegisterToTip) (deepAlt (cfRegTo <$> template) newRegTo)
<*> aopt utcTimeField (fslpI MsgDeRegUntil (mr MsgDate)
& setTooltip MsgCourseDeregisterUntilTip) (deepAlt (cfDeRegUntil <$> template) newDeRegUntil)
<*> lecturerForm
errorMsgs' <- traverse validateCourse result
return $ case errorMsgs' of
FormSuccess errorMsgs
| not $ null errorMsgs ->
(FormFailure errorMsgs,
[whamlet|
<div class="alert alert-danger">
<div class="alert__content">
<h4> Fehler:
<ul>
$forall errmsg <- errorMsgs
<li> #{errmsg}
^{widget}
|]
)
_ -> (result, widget)
validateCourse :: (MonadHandler m, HandlerSite m ~ UniWorX) => CourseForm -> m [Text]
validateCourse CourseForm{..} = do
uid <- liftHandlerT requireAuthId
userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route
MsgRenderer mr <- getMsgRenderer
return
[ mr msg | (False, msg) <-
[
( NTop cfRegFrom <= NTop cfRegTo
, MsgCourseRegistrationEndMustBeAfterStart
)
,
( NTop cfRegFrom <= NTop cfDeRegUntil
, MsgCourseDeregistrationEndMustBeAfterStart
)
, ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin
, MsgCourseUserMustBeLecturer
)
] ]
getCourseNewR :: Handler Html -- call via toTextUrl
getCourseNewR = do
uid <- requireAuthId
params <- runInputGetResult $ (,,) --TODO: change to AForm, which is used in Course-Copy-Button
<$> iopt termNewField "tid"
<*> iopt ciField "ssh"
<*> iopt ciField "csh"
let courseEditHandler' = courseEditHandler $ \p -> Just . SomeRoute $ (CourseNewR, getParams) :#: p
getParams = concat
[ [ ("tid", toPathPiece tid) | FormSuccess (Just tid, _, _) <- [params] ]
, [ ("ssh", toPathPiece ssh) | FormSuccess (_, Just ssh, _) <- [params] ]
, [ ("csh", toPathPiece csh) | FormSuccess (_, _, Just csh) <- [params] ]
]
let noTemplateAction = courseEditHandler' Nothing
case params of -- DO NOT REMOVE: without this distinction, lecturers would never see an empty makeCourseForm any more!
FormMissing -> noTemplateAction
FormFailure msgs -> forM_ msgs (addMessage Error . toHtml) >>
noTemplateAction
FormSuccess (Nothing, Nothing, Nothing) -> noTemplateAction
FormSuccess (fmap TermKey -> mbTid, fmap SchoolKey -> mbSsh, mbCsh) -> do
oldCourses <- runDB $
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 ->
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId
let lecturersSchool =
E.exists $ E.from $ \user ->
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' template
postCourseNewR :: Handler Html
postCourseNewR = courseEditHandler (\p -> Just . SomeRoute $ CourseNewR :#: p) Nothing -- Note: Nothing is safe here, since we will create a new course.
getCEditR, postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCEditR = pgCEditR
postCEditR = pgCEditR
pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
pgCEditR tid ssh csh = do
courseData <- runDB $ do
mbCourse <- getBy (TermSchoolCourseShort tid ssh csh)
mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType]
mbLecInvites <- for mbCourse $ sourceInvitationsList . entityKey
return $ (,,) <$> mbCourse <*> mbLecs <*> mbLecInvites
-- IMPORTANT: both GET and POST Handler must use the same template,
-- since an Edit is identified via CourseID, which is not embedded in the received form data for security reasons.
courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData
-- | Course Creation and Editing
-- | IMPORTANT: in case of Edit, Post/Get Request is provided with the same CourseForm template (cannot be Nothing),
-- | since an edit is identified via cfCourseId which is not contained in the received form data for security reasons!
courseEditHandler :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Handler Html
courseEditHandler miButtonAction mbCourseForm = do
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
((result, formWidget), formEnctype) <- runFormPost $ makeCourseForm miButtonAction mbCourseForm
formResult result $ \case
res@CourseForm
{ cfCourseId = Nothing
, cfShort = csh
, cfSchool = ssh
, cfTerm = tid
} -> do -- create new course
now <- liftIO getCurrentTime
insertOkay <- runDBJobs $ do
insertOkay <- insertUnique Course
{ courseName = cfName res
, courseDescription = cfDesc res
, courseLinkExternal = cfLink res
, courseShorthand = cfShort res
, courseTerm = cfTerm res
, courseSchool = cfSchool res
, courseCapacity = cfCapacity res
, courseRegisterSecret = cfSecret res
, courseMaterialFree = cfMatFree res
, courseRegisterFrom = cfRegFrom res
, courseRegisterTo = cfRegTo res
, courseDeregisterUntil = cfDeRegUntil res
}
whenIsJust insertOkay $ \cid -> do
let (invites, adds) = partitionEithers $ cfLecturers res
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
insert_ $ CourseEdit aid now cid
return insertOkay
case insertOkay of
Just _ -> do
-- addMessageI Info $ MsgCourseNewOk tid ssh csh
redirect $ CourseR tid ssh csh CShowR
Nothing ->
addMessageI Warning $ MsgCourseNewDupShort tid ssh csh
res@CourseForm
{ cfCourseId = Just cid
, cfShort = csh
, cfSchool = ssh
, cfTerm = tid
} -> do -- edit existing course
now <- liftIO getCurrentTime
-- addMessage "debug" [shamlet| #{show res}|]
success <- runDBJobs $ do
old <- get cid
case old of
Nothing -> addMessageI Error MsgInvalidInput $> False
(Just _) -> do
updOkay <- myReplaceUnique cid Course
{ courseName = cfName res
, courseDescription = cfDesc res
, courseLinkExternal = cfLink res
, courseShorthand = cfShort res
, courseTerm = cfTerm res -- dangerous
, courseSchool = cfSchool res
, courseCapacity = cfCapacity res
, courseRegisterSecret = cfSecret res
, courseMaterialFree = cfMatFree res
, courseRegisterFrom = cfRegFrom res
, courseRegisterTo = cfRegTo res
, courseDeregisterUntil = cfDeRegUntil res
}
case updOkay of
(Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False
Nothing -> do
deleteWhere [LecturerCourse ==. cid]
deleteWhere [InvitationFor ==. invRef @Lecturer cid, InvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)]
let (invites, adds) = partitionEithers $ cfLecturers res
insertMany_ $ map (\(lid, lty) -> Lecturer lid cid lty) adds
sinkInvitationsF lecturerInvitationConfig $ map (\(lEmail, mLty) -> (lEmail, cid, (InvDBDataLecturer mLty, InvTokenDataLecturer))) invites
insert_ $ CourseEdit aid now cid
addMessageI Success $ MsgCourseEditOk tid ssh csh
return True
when success $ redirect $ CourseR tid ssh csh CShowR
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
defaultLayout $ do
setTitleI MsgCourseEditTitle
wrapForm formWidget def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = formEnctype
}

86
src/Handler/Course/LecturerInvite.hs Normal file
View File

@ -0,0 +1,86 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Course.LecturerInvite
( lecturerInvitationConfig
, getCLecInviteR, postCLecInviteR
, InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
) where
import Import
import Utils.Lens
import Utils.Form
import Handler.Utils.Invitations
import qualified Data.CaseInsensitive as CI
import Data.Function ((&))
import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)
instance IsInvitableJunction Lecturer where
type InvitationFor Lecturer = Course
data InvitableJunction Lecturer = JunctionLecturer
{ jLecturerType :: LecturerType
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationDBData Lecturer = InvDBDataLecturer
{ invDBLecturerType :: Maybe LecturerType
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationTokenData Lecturer = InvTokenDataLecturer
deriving (Eq, Ord, Read, Show, Generic, Typeable)
_InvitableJunction = iso
(\Lecturer{..} -> (lecturerUser, lecturerCourse, JunctionLecturer lecturerType))
(\(lecturerUser, lecturerCourse, JunctionLecturer lecturerType) -> Lecturer{..})
instance ToJSON (InvitableJunction Lecturer) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction Lecturer) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance ToJSON (InvitationDBData Lecturer) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationDBData Lecturer) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
instance ToJSON (InvitationTokenData Lecturer) where
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationTokenData Lecturer) where
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
lecturerInvitationConfig :: InvitationConfig Lecturer
lecturerInvitationConfig = InvitationConfig{..}
where
invitationRoute (Entity _ Course{..}) _ = return . CourseR courseTerm courseSchool courseShorthand $ CLecInviteR
invitationResolveFor _ = do
Just (CourseR tid csh ssh CLecInviteR) <- getCurrentRoute
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseLecInviteHeading $ CI.original courseName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseLecInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ (InvDBDataLecturer mlType, _) _ = hoistAForm liftHandlerT $ toJunction <$> case mlType of
Nothing -> areq (selectField optionsFinite) lFs Nothing
Just lType -> aforced (selectField optionsFinite) lFs lType
where
toJunction jLecturerType = (JunctionLecturer{..}, ())
lFs = fslI MsgLecturerType & setTooltip MsgCourseLecturerRightsIdentical
invitationInsertHook _ _ _ _ = id
invitationSuccessMsg (Entity _ Course{..}) (Entity _ Lecturer{..}) = do
MsgRenderer mr <- getMsgRenderer
return . SomeMessage $ MsgLecturerInvitationAccepted (mr lecturerType) courseShorthand
invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCLecInviteR = postCLecInviteR
postCLecInviteR = invitationR lecturerInvitationConfig

260
src/Handler/Course/List.hs Normal file
View File

@ -0,0 +1,260 @@
module Handler.Course.List
( makeCourseTable
, getCourseListR
, getTermCurrentR
, getTermSchoolCourseListR
, getTermCourseListR
) where
import Import
import Utils.Lens
import Utils.Form
-- import Utils.DB
import Handler.Utils
import Handler.Utils.Table.Cells
import Data.Function ((&))
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
-- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method.
type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School)
colCourse :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
[whamlet|_{courseName}|]
-- colCourseDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
-- colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ do
-- course <- view $ _dbrOutput . _1 . _entityVal
-- return $ courseCell course
colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colDescription = sortable Nothing mempty
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
case courseDescription of
Nothing -> mempty
(Just descr) -> cell $ modal (toWidget $ hasComment True) (Right $ toWidget descr)
colCShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|_{courseShorthand}|]
-- colCShortDescr :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
-- colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
-- $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } -> mappend
-- ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
-- ( case courseDescription of
-- Nothing -> mempty
-- (Just descr) -> cell
-- [whamlet|
-- $newline never
-- <div>
-- ^{modal "Beschreibung" (Right $ toWidget descr)}
-- |]
-- )
colTerm :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgTerm)
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
anchorCell (TermCourseListR courseTerm) [whamlet|#{courseTerm}|]
-- colSchool :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
-- colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
-- $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
-- anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolName}|]
colSchoolShort :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|_{schoolShorthand}|]
colRegFrom :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
maybe mempty dateTimeCell courseRegisterFrom
-- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
colRegTo :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
$ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, _) } ->
maybe mempty dateTimeCell courseRegisterTo
colMembers :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colMembers = sortable (Just "members") (i18nCell MsgCourseMembers)
$ \DBRow{ dbrOutput=(Entity _ Course{..}, currentParticipants, _, _) } -> i18nCell $ case courseCapacity of
Nothing -> MsgCourseMembersCount currentParticipants
Just limit -> MsgCourseMembersCountLimited currentParticipants limit
colRegistered :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
$ \DBRow{ dbrOutput=(_, _, registered, _) } -> tickmarkCell registered
type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int)
course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
return (E.countRows :: E.SqlExpr (E.Value Int))
course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h, DBResult m x ~ ((), Widget) )
=> _ -> Colonnade h CourseTableData (DBCell m x) -> PSValidator m x -> DB Widget
makeCourseTable whereClause colChoices psValidator = do
muid <- lift maybeAuthId
let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
dbtSQLQuery qin@(course `E.InnerJoin` school) = do
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
let participants = course2Participants qin
let registered = course2Registered muid qin
E.where_ $ whereClause (course, participants, registered)
return (course, participants, registered, school)
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
snd <$> dbTable psValidator DBTable
{ dbtSQLQuery
, dbtRowKey = \(course `E.InnerJoin` _) -> course E.^. CourseId
, dbtColonnade = colChoices
, dbtProj
, dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here
[ ( "course", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseName)
, ( "cshort", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseShorthand)
, ( "term" , SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseTerm)
, ( "school", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolName)
, ( "schoolshort", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand)
, ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom)
, ( "register-to", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo)
, ( "members", SortColumn course2Participants )
, ( "registered", SortColumn $ course2Registered muid)
]
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here
[ ( "course", FilterColumn $ \(course `E.InnerJoin` _school:: CourseTableExpr) criterias -> if
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseName `E.in_` E.valList (Set.toList criterias)
)
, ( "cshort", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList criterias)
)
, ( "term" , FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias)
)
-- , ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
-- | Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
-- | otherwise -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias)
-- )
, ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) ->
emptyOrIn $ school E.^. SchoolName -- TODO: Refactor all?!
)
, ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias)
)
, ( "registered", FilterColumn $ \tExpr criterion -> case getLast (criterion :: Last Bool) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just needle -> course2Registered muid tExpr E.==. E.val needle
)
, ( "search", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterion -> case getLast (criterion :: Last Text) of
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
Just needle -> (E.castString (course E.^. CourseName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
E.||. (E.castString (course E.^. CourseShorthand) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
E.||. (E.castString (course E.^. CourseDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
)
]
, dbtFilterUI = \mPrev -> mconcat $ catMaybes
[ Just $ prismAForm (singletonFilter "search") mPrev $ aopt textField (fslI MsgCourseFilterSearch)
, muid $> prismAForm (singletonFilter "registered" . maybePrism _PathPiece) mPrev (aopt boolField (fslI MsgCourseFilterRegistered))
]
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
, dbtParams = def
, dbtIdent = "courses" :: Text
, dbtCsvEncode = noCsvEncode
, dbtCsvDecode = Nothing
}
getCourseListR :: Handler Html
getCourseListR = do
muid <- maybeAuthId
let colonnade = widgetColonnade $ mconcat
[ colCourse -- colCourseDescr
, colDescription
, colSchoolShort
, colTerm
, colCShort
, maybe mempty (const colRegistered) muid
]
whereClause = const $ E.val True
validator = def
& defaultSorting [SortDescBy "term",SortAscBy "course"]
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
defaultLayout $ do
setTitleI MsgCourseListTitle
$(widgetFile "courses")
getTermCurrentR :: Handler Html
getTermCurrentR = do
termIds <- runDB $ selectKeysList [TermActive ==. True] [Desc TermName]
case fromNullable termIds of
Nothing -> notFound
(Just (maximum -> tid)) ->
redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc.
getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html
getTermSchoolCourseListR tid ssh = do
void . runDB $ get404 tid -- Just ensure the term exists
School{schoolName=school} <- runDB $ get404 ssh -- Just ensure the term exists
muid <- maybeAuthId
let colonnade = widgetColonnade $ mconcat
[ dbRow
, colCShort
, colDescription
, colRegFrom
, colRegTo
, colMembers
, maybe mempty (const colRegistered) muid
]
whereClause (course, _, _) =
course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
validator = def
& defaultSorting [SortAscBy "cshort"]
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
defaultLayout $ do
setTitleI $ MsgTermSchoolCourseListTitle tid school
$(widgetFile "courses")
getTermCourseListR :: TermId -> Handler Html
getTermCourseListR tid = do
void . runDB $ get404 tid -- Just ensure the term exists
muid <- maybeAuthId
let colonnade = widgetColonnade $ mconcat
[ dbRow
, colCShort
, colDescription
, colSchoolShort
, colRegFrom
, colRegTo
, colMembers
, maybe mempty (const colRegistered) muid
]
whereClause (course, _, _) = course E.^. CourseTerm E.==. E.val tid
validator = def
& defaultSorting [SortAscBy "cshort"]
coursesTable <- runDB $ makeCourseTable whereClause colonnade validator
defaultLayout $ do
setTitleI . MsgTermCourseListTitle $ tid
$(widgetFile "courses")

174
src/Handler/Course/ParticipantInvite.hs Normal file
View File

@ -0,0 +1,174 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Course.ParticipantInvite
( InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
, getCInviteR, postCInviteR
, getCAddUserR, postCAddUserR
) where
import Import
import Utils.Lens
import Utils.Form
import Handler.Utils
import Handler.Utils.Invitations
import qualified Data.CaseInsensitive as CI
import Data.Function ((&))
import qualified Data.Set as Set
import Jobs.Queue
import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)
import Control.Monad.Trans.Writer (WriterT, execWriterT)
import Control.Monad.Except (MonadError(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
-- Invitations for ordinary participants of this course
instance IsInvitableJunction CourseParticipant where
type InvitationFor CourseParticipant = Course
data InvitableJunction CourseParticipant = JunctionParticipant
{ jParticipantRegistration :: UTCTime
, jParticipantField :: Maybe StudyFeaturesId
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationDBData CourseParticipant = InvDBDataParticipant
-- no data needed in DB to manage participant invitation
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationTokenData CourseParticipant = InvTokenDataParticipant
deriving (Eq, Ord, Read, Show, Generic, Typeable)
_InvitableJunction = iso
(\CourseParticipant{..} -> (courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField))
(\(courseParticipantUser, courseParticipantCourse, JunctionParticipant courseParticipantRegistration courseParticipantField) -> CourseParticipant{..})
instance ToJSON (InvitableJunction CourseParticipant) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction CourseParticipant) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance ToJSON (InvitationDBData CourseParticipant) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationDBData CourseParticipant) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
instance ToJSON (InvitationTokenData CourseParticipant) where
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationTokenData CourseParticipant) where
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
participantInvitationConfig :: InvitationConfig CourseParticipant
participantInvitationConfig = InvitationConfig{..}
where
invitationRoute (Entity _ Course{..}) _ = return $ CourseR courseTerm courseSchool courseShorthand CInviteR
invitationResolveFor _ = do
Just (CourseR tid csh ssh CInviteR) <- getCurrentRoute
getKeyBy404 $ TermSchoolCourseShort tid csh ssh
invitationSubject (Entity _ Course{..}) _ = return . SomeMessage $ MsgMailSubjectParticipantInvitation courseTerm courseSchool courseShorthand
invitationHeading (Entity _ Course{..}) _ = return . SomeMessage $ MsgCourseParticipantInviteHeading $ CI.original courseName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgCourseParticipantInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm (Entity _ Course{..}) _ uid = hoistAForm lift . wFormToAForm $ do
now <- liftIO getCurrentTime
studyFeatures <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid)
(fslI MsgCourseStudyFeature & setTooltip MsgCourseStudyFeatureTooltip) Nothing
return . fmap (, ()) $ JunctionParticipant <$> pure now <*> studyFeatures
invitationInsertHook _ _ _ _ = id
invitationSuccessMsg (Entity _ Course{..}) _ =
return . SomeMessage $ MsgCourseParticipantInvitationAccepted (CI.original courseName)
invitationUltDest (Entity _ Course{..}) _ = return . SomeRoute $ CourseR courseTerm courseSchool courseShorthand CShowR
data AddRecipientsResult = AddRecipientsResult
{ aurAlreadyRegistered
, aurNoUniquePrimaryField
, aurSuccess :: [UserEmail]
} deriving (Read, Show, Generic, Typeable)
instance Monoid AddRecipientsResult where
mempty = memptydefault
mappend = mappenddefault
getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCAddUserR = postCAddUserR
postCAddUserR tid ssh csh = do
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
enlist <- wreq checkBoxField (fslI MsgCourseParticipantEnlistDirectly) (Just False)
wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
(fslI MsgCourseParticipantInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
formResultModal usersToEnlist (CourseR tid ssh csh CUsersR) $ processUsers cid
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
siteLayoutMsg heading $ do
setTitleI heading
wrapForm formWgt def
{ formEncoding
, formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR
}
where
processUsers :: CourseId -> Set (Either UserEmail UserId) -> WriterT [Message] Handler ()
processUsers cid users = do
let (emails,uids) = partitionEithers $ Set.toList users
AddRecipientsResult{..} <- lift . runDBJobs $ do
-- send Invitation eMails to unkown users
sinkInvitationsF participantInvitationConfig [(mail,cid,(InvDBDataParticipant,InvTokenDataParticipant)) | mail <- emails]
-- register known users
execWriterT $ mapM (registerUser cid) uids
when (not $ null emails) $
tell . pure <=< messageI Success . MsgCourseParticipantsInvited $ length emails
when (not $ null aurAlreadyRegistered) $ do
let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|]
modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered")
tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent)
when (not $ null aurNoUniquePrimaryField) $ do
let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}|]
modalContent = $(widgetFile "messages/courseInvitationRegisteredWithoutField")
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
when (not $ null aurSuccess) $
tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurSuccess
registerUser :: CourseId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
registerUser cid uid = exceptT tell tell $ do
User{..} <- lift . lift $ getJust uid
whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $
throwError $ mempty { aurAlreadyRegistered = pure userEmail }
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
let courseParticipantField
| [f] <- features = Just f
| otherwise = Nothing
courseParticipantRegistration <- liftIO getCurrentTime
void . lift . lift . insert $ CourseParticipant
{ courseParticipantCourse = cid
, courseParticipantUser = uid
, ..
}
return $ case courseParticipantField of
Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
Just _ -> mempty { aurSuccess = pure userEmail }
getCInviteR, postCInviteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCInviteR = postCInviteR
postCInviteR = invitationR participantInvitationConfig

96
src/Handler/Course/Register.hs Normal file
View File

@ -0,0 +1,96 @@
module Handler.Course.Register
( ButtonCourseRegister(..)
, courseRegisterForm
, getCRegisterR, postCRegisterR
) where
import Import
import Utils.Form
import Handler.Utils
import Data.Function ((&))
-- Dedicated CourseRegistrationButton
data ButtonCourseRegister = BtnCourseRegister | BtnCourseDeregister
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonCourseRegister
instance Finite ButtonCourseRegister
nullaryPathPiece ''ButtonCourseRegister $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonCourseRegister id
instance Button UniWorX ButtonCourseRegister where
btnClasses BtnCourseRegister = [BCIsButton, BCPrimary]
btnClasses BtnCourseDeregister = [BCIsButton, BCDanger]
btnLabel BtnCourseRegister = [whamlet|#{iconEnrol True} _{MsgBtnCourseRegister}|]
btnLabel BtnCourseDeregister = [whamlet|#{iconEnrol False} _{MsgBtnCourseDeregister}|]
-- | Registration button with maybe a userid if logged in
-- , maybe existing features if already registered
-- , maybe some default study features
-- , maybe a course secret
courseRegisterForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool)
-- unfinished WIP: must take study features if registred and show as mforced field
courseRegisterForm loggedin participant defSFid msecret = identifyForm FIDcourseRegister $ \extra -> do
-- secret fields
(msecretRes', msecretView) <- case msecret of
(Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
_ -> return (Nothing,Nothing)
-- study features
(msfRes', msfView) <- case loggedin of
Nothing -> return (Nothing,Nothing)
Just _ -> bimap Just Just <$> case participant of
Just CourseParticipant{courseParticipantField=Just sfid}
-> mforced (studyFeaturesPrimaryFieldFor False [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid)
_other -> mreq (studyFeaturesPrimaryFieldFor False [ ] loggedin) (fslI MsgCourseStudyFeature
& setTooltip MsgCourseStudyFeatureTooltip) (Just defSFid)
-- button de-/register
(btnRes, btnView) <- mreq (buttonField $ bool BtnCourseRegister BtnCourseDeregister isRegistered) "buttonField ignores settings anyway" Nothing
let widget = $(widgetFile "widgets/register-form/register-form")
let msecretRes | Just res <- msecretRes' = Just <$> res
| otherwise = FormSuccess Nothing
let msfRes | Just res <- msfRes' = res
| otherwise = FormSuccess Nothing
-- checks that correct button was pressed, and ignores result of btnRes
let formRes = (,) <$ btnRes <*> msfRes <*> ((==msecret) <$> msecretRes)
return (formRes, widget)
where
isRegistered = isJust participant
-- | Workaround for klicking register button without being logged in.
-- After log in, the user sees a "get request not supported" error.
getCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCRegisterR tid ssh csh = do
muid <- maybeAuthId
case muid of
Nothing -> addMessageI Info MsgLoginNecessary
(Just uid) -> runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
registration <- getBy (UniqueParticipant uid cid)
when (isNothing registration) $ addMessageI Warning MsgRegisterRetry
redirect $ CourseR tid ssh csh CShowR
postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCRegisterR tid ssh csh = do
aid <- requireAuthId
(cid, course, registration) <- runDB $ do
(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
registration <- getBy (UniqueParticipant aid cid)
return (cid, course, entityVal <$> registration)
let isRegistered = isJust registration
((regResult,_), _) <- runFormPost $ courseRegisterForm (Just aid) registration Nothing $ courseRegisterSecret course
formResult regResult $ \(mbSfId,codeOk) -> if
| isRegistered -> do
runDB $ deleteBy $ UniqueParticipant aid cid
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
| codeOk -> do
actTime <- liftIO getCurrentTime
regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId
when (isJust regOk) $ addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
| otherwise -> addMessageI Warning MsgCourseSecretWrong
-- addMessage Info $ toHtml $ show regResult -- For debugging only
redirect $ CourseR tid ssh csh CShowR

221
src/Handler/Course/Show.hs Normal file
View File

@ -0,0 +1,221 @@
module Handler.Course.Show
( getCShowR
) where
import Import
import Utils.Form
import Handler.Utils
import Handler.Utils.Table.Cells
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
import qualified Data.CaseInsensitive as CI
import Data.Function ((&))
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
import Handler.Course.Register
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do
mbAid <- maybeAuthId
(cid,course,schoolName,participants,registration,defSFid,lecturers,assistants,correctors,tutors) <- runDB . maybeT notFound $ do
[(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
<- lift . E.select . E.from $
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse
E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.limit 1 -- we know that there is at most one match, but we tell the DB this info too
let numParticipants = E.sub_select . E.from $ \part -> do
E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
return ( E.countRows :: E.SqlExpr (E.Value Int))
return (course,school E.^. SchoolName, numParticipants, participant)
defSFid <- ifMaybeM mbAid Nothing $ \uid -> lift $ selectFirst [StudyFeaturesUser ==. uid, StudyFeaturesType ==. FieldPrimary, StudyFeaturesValid ==. True] [Desc StudyFeaturesUpdated, Desc StudyFeaturesDegree, Desc StudyFeaturesField] -- sorting by degree & field is an heuristic only, but this is okay for a default suggestion
staff <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
return ( lecturer E.^. LecturerType
, user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
let partStaff :: (LecturerType, UserEmail, Text, Text) -> Either (UserEmail, Text, Text) (UserEmail, Text, Text)
partStaff (CourseLecturer ,name,surn,mail) = Right (name,surn,mail)
partStaff (_courseAssistant,name,surn,mail) = Left (name,surn,mail)
(assistants,lecturers) = partitionWith partStaff $ map $(unValueN 4) staff
correctors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
tutors <- fmap (map $(unValueN 3)) . lift . E.select $ E.from $ \(tutorial `E.InnerJoin` tutor `E.InnerJoin` user) -> E.distinctOnOrderBy [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName, E.asc $ user E.^. UserEmail ] $ do
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
E.on $ tutor E.^. TutorTutorial E.==. tutorial E.^. TutorialId
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
return ( user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname )
return (cid,course,schoolName,participants,registration,entityKey <$> defSFid,lecturers,assistants,correctors,tutors)
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
(regWidget, regEnctype) <- generateFormPost $ courseRegisterForm mbAid registration defSFid $ courseRegisterSecret course
let regForm = wrapForm regWidget def
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CRegisterR
, formEncoding = regEnctype
, formSubmit = FormNoSubmit
}
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
let
tutorialDBTable = DBTable{..}
where
dbtSQLQuery tutorial = do
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
return tutorial
dbtRowKey = (E.^. TutorialId)
dbtProj = return
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just "type") (i18nCell MsgTutorialType) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell $ CI.original tutorialType
, sortable (Just "name") (i18nCell MsgTutorialName) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> indicatorCell <> anchorCell (CTutorialR tid ssh csh tutorialName TUsersR) [whamlet|#{tutorialName}|]
, sortable Nothing (i18nCell MsgTutorialTutors) $ \DBRow{ dbrOutput = Entity tutid _ } -> sqlCell $ do
tutTutors <- fmap (map $(unValueN 3)) . E.select . E.from $ \(tutor `E.InnerJoin` user) -> do
E.on $ tutor E.^. TutorUser E.==. user E.^. UserId
E.where_ $ tutor E.^. TutorTutorial E.==. E.val tutid
return (user E.^. UserEmail, user E.^. UserDisplayName, user E.^. UserSurname)
return [whamlet|
$newline never
<ul .list--iconless .list--inline .list--comma-separated>
$forall tutor <- tutTutors
<li>
^{nameEmailWidget' tutor}
|]
, sortable (Just "room") (i18nCell MsgTutorialRoom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> textCell tutorialRoom
, sortable Nothing (i18nCell MsgTutorialTime) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> occurrencesCell tutorialTime
, sortable (Just "register-from") (i18nCell MsgTutorialRegisterFrom) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterFrom
, sortable (Just "register-to") (i18nCell MsgTutorialRegisterTo) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialRegisterTo
, sortable (Just "deregister-until") (i18nCell MsgTutorialDeregisterUntil) $ \DBRow{ dbrOutput = Entity _ Tutorial{..} } -> maybeDateTimeCell tutorialDeregisterUntil
, sortable Nothing (i18nCell MsgTutorialFreeCapacity) $ \DBRow{ dbrOutput = Entity tutid Tutorial{..} } -> case tutorialCapacity of
Nothing -> mempty
Just tutorialCapacity' -> sqlCell $ do
[E.Value freeCapacity] <- E.select $ let numParticipants = E.sub_select . E.from $ \participant -> do
E.where_ $ participant E.^. TutorialParticipantTutorial E.==. E.val tutid
return E.countRows :: E.SqlQuery (E.SqlExpr (E.Value Int))
in return $ E.val tutorialCapacity' E.-. numParticipants
return . toWidget . tshow $ max 0 freeCapacity
, sortable Nothing mempty $ \DBRow{ dbrOutput = Entity tutId Tutorial{..} } -> sqlCell $ do
mayRegister <- (== Authorized) <$> evalAccessDB (CTutorialR tid ssh csh tutorialName TRegisterR) True
isRegistered <- case mbAid of
Nothing -> return False
Just uid -> existsBy $ UniqueTutorialParticipant tutId uid
if
| mayRegister -> do
(tutRegisterForm, tutRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered
return $ wrapForm tutRegisterForm def
{ formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TRegisterR
, formEncoding = tutRegisterEnctype
, formSubmit = FormNoSubmit
}
| isRegistered -> return [whamlet|_{MsgTutorialRegistered}|]
| otherwise -> return mempty
]
dbtSorting = Map.fromList
[ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType )
, ("name", SortColumn $ \tutorial -> tutorial E.^. TutorialName )
, ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom )
, ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom )
, ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo )
, ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil )
]
dbtFilter = Map.empty
dbtFilterUI = const mempty
dbtStyle = def
dbtParams = def
dbtIdent :: Text
dbtIdent = "tutorials"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
tutorialDBTableValidator = def
& defaultSorting [SortAscBy "type", SortAscBy "name"]
(Any hasTutorials, tutorialTable) <- runDB $ dbTable tutorialDBTableValidator tutorialDBTable
let
examDBTable = DBTable{..}
where
dbtSQLQuery exam = do
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
return exam
dbtRowKey = (E.^. ExamId)
dbtProj r@DBRow{ dbrOutput = Entity _ Exam{..} } = do
guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
return r
dbtColonnade = dbColonnade $ mconcat
[ sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> indicatorCell <> anchorCell (CExamR tid ssh csh examName EShowR) examName
, sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
, sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
, sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
, sortable (Just "registered") (i18nCell MsgExamRegistration ) $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
isRegistered <- case mbAid of
Nothing -> return False
Just uid -> existsBy $ UniqueExamRegistration eId uid
let label = bool MsgExamNotRegistered MsgExamRegistered isRegistered
examUrl = CExamR tid ssh csh examName EShowR
if | mayRegister -> return $ simpleLinkI (SomeMessage label) examUrl
| otherwise -> return [whamlet|_{label}|]
-- , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity eId Exam{..} } -> sqlCell $ do
-- mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
-- isRegistered <- case mbAid of
-- Nothing -> return False
-- Just uid -> existsBy $ UniqueExamRegistration eId uid
-- if
-- | mayRegister -> do
-- (examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
-- return $ wrapForm examRegisterForm def
-- { formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
-- , formEncoding = examRegisterEnctype
-- , formSubmit = FormNoSubmit
-- }
-- | isRegistered -> return [whamlet|_{MsgExamRegistered}|]
-- | otherwise -> return mempty
]
dbtSorting = Map.fromList
[ ("name", SortColumn $ \exam -> exam E.^. ExamName )
, ("time", SortColumn $ \exam -> exam E.^. ExamStart )
, ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
, ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
, ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
, ("registered", SortColumn $ \exam ->
case mbAid of
Nothing -> E.false
Just uid ->
E.exists $ E.from $ \reg -> do
E.where_ $ reg E.^. ExamRegistrationUser E.==. E.val uid
E.where_ $ reg E.^. ExamRegistrationExam E.==. exam E.^. ExamId
)
]
dbtFilter = Map.empty
dbtFilterUI = const mempty
dbtStyle = def
dbtParams = def
dbtIdent :: Text
dbtIdent = "exams"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
examDBTableValidator = def
& defaultSorting [SortAscBy "time"]
(Any hasExams, examTable) <- runDB $ dbTable examDBTableValidator examDBTable
siteLayout (toWgt $ courseName course) $ do
setTitleI $ prependCourseTitle tid ssh csh (""::Text)
$(widgetFile "course")

162
src/Handler/Course/User.hs Normal file
View File

@ -0,0 +1,162 @@
module Handler.Course.User
( getCUserR, postCUserR
) where
import Import
import Utils.Lens
import Utils.Form
import Handler.Utils
import Database.Esqueleto.Utils.TH
import Data.Function ((&))
import qualified Database.Esqueleto as E
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Handler.Course.Register
getCUserR, postCUserR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDUser -> Handler Html
getCUserR = postCUserR
postCUserR tid ssh csh uCId = do
-- Has authorization checks (OR):
--
-- - User is current member of course
-- - User has submitted in course
-- - User is member of registered group for course
-- - User is member of a tutorial for course
-- - User is corrector for course
-- - User is a tutor for course
-- - User is a lecturer for course
let currentRoute = CourseR tid ssh csh (CUserR uCId)
dozentId <- requireAuthId
uid <- decrypt uCId
-- DB reads
(cid, User{..}, mRegistration, thisUniqueNote, noteText, noteEdits, studies) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-- Abfrage Benutzerdaten
user <- get404 uid
registration <- getBy (UniqueParticipant uid cid)
-- Abfrage Teilnehmernotiz
let thisUniqueNote = UniqueCourseUserNote uid cid
mbNoteEnt <- getBy thisUniqueNote
(noteText,noteEdits) <- case mbNoteEnt of
Nothing -> return (Nothing,[])
(Just (Entity noteKey CourseUserNote{courseUserNoteNote})) -> do
noteEdits <- E.select $ E.from $ \(edit `E.InnerJoin` usr) -> do
E.on $ edit E.^. CourseUserNoteEditUser E.==. usr E.^. UserId
E.where_ $ edit E.^. CourseUserNoteEditNote E.==. E.val noteKey
E.orderBy [E.desc $ edit E.^. CourseUserNoteEditTime]
E.limit 1 -- more will be shown, if changed here
return (edit E.^. CourseUserNoteEditTime, usr E.^. UserEmail, usr E.^. UserDisplayName, usr E.^. UserSurname)
return (Just courseUserNoteNote, $(unValueN 4) <$> noteEdits)
-- Abfrage Studiengänge
studies <- 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 (studyfeat, studydegree, studyterms)
return (cid, user, registration, thisUniqueNote, noteText, noteEdits, studies)
let editByWgt = [whamlet|
$forall (etime,_eemail,ename,_esurname) <- noteEdits
<br>
_{MsgLastEdit} ^{editedByW SelFormatDateTime etime ename}
|] -- _{MsgLastEdit} ^{formatTimeW SelFormatDateTime etime} ^{nameWidget ename esurname}
((noteRes, noteView), noteEnctype) <- runFormPost . identifyForm FIDcUserNote . renderAForm FormStandard $
aopt (annotateField editByWgt htmlField') (fslpI MsgCourseUserNote "HTML" & setTooltip MsgCourseUserNoteTooltip) (Just noteText)
let noteFrag :: Text
noteFrag = "notes"
noteWidget = wrapForm noteView FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ currentRoute :#: noteFrag
, formEncoding = noteEnctype
, formAttrs = []
, formSubmit = FormSubmit
, formAnchor = Just noteFrag
}
formResult noteRes $ \mbNote -> do
now <- liftIO getCurrentTime
runDB $ case mbNote of
Nothing -> do
-- must delete all edits due to foreign key constraints, which does not make sense -> refactor!
maybeM (return ()) (\nk -> deleteWhere [CourseUserNoteEditNote ==. nk]) (getKeyBy thisUniqueNote)
deleteBy thisUniqueNote
addMessageI Info MsgCourseUserNoteDeleted
_ | (renderHtml <$> mbNote) == (renderHtml <$> noteText) -> return () -- no changes
(Just note) -> do
(Entity noteKey _) <- upsertBy thisUniqueNote (CourseUserNote cid uid note) [CourseUserNoteNote =. note]
void . insert $ CourseUserNoteEdit dozentId now noteKey
addMessageI Success MsgCourseUserNoteSaved
redirect $ currentRoute :#: noteFrag -- reload page after post
((regFieldRes, regFieldView), regFieldEnctype) <- runFormPost . identifyForm FIDcRegField $ \csrf ->
let currentField :: Maybe (Maybe StudyFeaturesId)
currentField = courseParticipantField . entityVal <$> mRegistration
in over _2 ((toWidget csrf <>) . fvInput) <$> mreq (studyFeaturesPrimaryFieldFor True (maybeToList $ join currentField) $ Just uid) ("" & addAutosubmit) currentField
let registrationFieldFrag :: Text
registrationFieldFrag = "registration-field"
regFieldWidget = wrapForm regFieldView FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ currentRoute :#: registrationFieldFrag
, formEncoding = regFieldEnctype
, formAttrs = []
, formSubmit = FormAutoSubmit
, formAnchor = Just registrationFieldFrag
}
for_ mRegistration $ \(Entity pId CourseParticipant{..}) ->
formResult regFieldRes $ \courseParticipantField' -> do
runDB $ do
update pId [ CourseParticipantField =. courseParticipantField' ]
addMessageI Success MsgCourseStudyFeatureUpdated
redirect $ currentRoute :#: registrationFieldFrag
let regButton
| Just _ <- mRegistration = BtnCourseDeregister
| otherwise = BtnCourseRegister
((regButtonRes, regButtonView), regButtonEnctype) <- runFormPost . identifyForm FIDcRegButton $ buttonForm' [regButton]
let registrationButtonFrag :: Text
registrationButtonFrag = "registration-button"
regButtonWidget = wrapForm regButtonView FormSettings
{ formMethod = POST
, formAction = Just . SomeRoute $ currentRoute :#: registrationButtonFrag
, formEncoding = regButtonEnctype
, formAttrs = []
, formSubmit = FormNoSubmit
, formAnchor = Just registrationButtonFrag
}
formResult regButtonRes $ \case
BtnCourseDeregister
| Just (Entity pId _) <- mRegistration
-> do
runDB $ delete pId
addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
redirect $ CourseR tid ssh csh CUsersR
| otherwise
-> invalidArgs ["User not registered"]
BtnCourseRegister -> do
now <- liftIO getCurrentTime
let primaryField
| [(Entity featId _, _, _)] <- filter (\(Entity _ StudyFeatures{..}, _, _) -> studyFeaturesType == FieldPrimary && studyFeaturesValid) studies
= Just featId
| otherwise
= Nothing
pId <- runDB . insertUnique $ CourseParticipant cid uid now primaryField
case pId of
Just _ -> do
addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
redirect currentRoute
Nothing -> invalidArgs ["User already registered"]
mRegAt <- for (courseParticipantRegistration . entityVal <$> mRegistration) $ formatTime SelFormatDateTime
-- generate output
let headingLong = [whamlet|^{nameWidget userDisplayName userSurname} - _{MsgCourseMemberOf} #{csh} #{tid}|]
headingShort = prependCourseTitle tid ssh csh $ SomeMessage userDisplayName
siteLayout headingLong $ do
setTitleI headingShort
$(widgetFile "course-user")

264
src/Handler/Course/Users.hs Normal file
View File

@ -0,0 +1,264 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Course.Users
( queryUser
, makeCourseUserTable
, postCUsersR, getCUsersR
, colUserDegreeShort, colUserField, colUserSemester
) where
import Import
import Utils.Lens
import Utils.Form
import Handler.Utils
import Handler.Utils.Database
import Handler.Utils.Table.Cells
import Handler.Utils.Table.Columns
import Database.Persist.Sql (deleteWhereCount)
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
import Data.Function ((&))
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
type UserTableExpr = (E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity CourseUserNote))
`E.LeftOuterJoin`
(E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms)))
-- forceUserTableType :: (UserTableExpr -> a) -> (UserTableExpr -> a)
-- forceUserTableType = id
-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions)
-- This ought to ease refactoring the query
queryUser :: UserTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
queryParticipant :: UserTableExpr -> E.SqlExpr (Entity CourseParticipant)
queryParticipant = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
queryUserNote :: UserTableExpr -> E.SqlExpr (Maybe (Entity CourseUserNote))
queryUserNote = $(sqlLOJproj 3 2)
queryFeaturesStudy :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
queryFeaturesStudy = $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
queryFeaturesDegree :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
queryFeaturesDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
queryFeaturesField :: UserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
queryFeaturesField = $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)
userTableQuery :: CourseId -> UserTableExpr -> E.SqlQuery ( E.SqlExpr (Entity User)
, E.SqlExpr (E.Value UTCTime)
, E.SqlExpr (E.Value (Maybe (Key CourseUserNote)))
, StudyFeaturesDescription')
userTableQuery cid ((user `E.InnerJoin` participant) `E.LeftOuterJoin` note `E.LeftOuterJoin` studyFeatures) = do
-- Note that order of E.on for nested joins is seemingly right-to-left, ignoring nesting paranthesis
features <- studyFeaturesQuery' (participant E.^. CourseParticipantField) studyFeatures
E.on $ (note E.?. CourseUserNoteUser E.==. E.just (participant E.^. CourseParticipantUser))
E.&&. (note E.?. CourseUserNoteCourse E.==. E.just (E.val cid))
E.on $ participant E.^. CourseParticipantUser E.==. user E.^. UserId
E.where_ $ participant E.^. CourseParticipantCourse E.==. E.val cid
return (user, participant E.^. CourseParticipantRegistration, note E.?. CourseUserNoteId, features)
type UserTableData = DBRow (Entity User, UTCTime, Maybe CourseUserNoteId, (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms))
instance HasEntity UserTableData User where
hasEntity = _dbrOutput . _1
instance HasUser UserTableData where
-- hasUser = _entityVal
hasUser = _dbrOutput . _1 . _entityVal
_userTableRegistration :: Lens' UserTableData UTCTime
_userTableRegistration = _dbrOutput . _2
_userTableNote :: Lens' UserTableData (Maybe CourseUserNoteId)
_userTableNote = _dbrOutput . _3
_userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms)
_userTableFeatures = _dbrOutput . _4
_rowUserSemester :: Traversal' UserTableData Int
_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester
colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c)
colUserComment tid ssh csh =
sortable (Just "note") (i18nCell MsgCourseUserNote)
$ \DBRow{ dbrOutput=(Entity uid _, _, mbNoteKey,_) } ->
maybeEmpty mbNoteKey $ const $
anchorCellM (courseLink <$> encrypt uid) (hasComment True)
where
courseLink = CourseR tid ssh csh . CUserR
colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserSemester = sortable (Just "semesternr") (i18nCell MsgStudyFeatureAge) $
foldMap numCell . preview _rowUserSemester
colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserField = sortable (Just "field") (i18nCell MsgCourseStudyFeature) $
foldMap i18nCell . view (_userTableFeatures . _3)
-- colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
-- colUserFieldShort = sortable (Just "field-short") (i18nCell MsgCourseStudyFeature) $
-- foldMap (i18nCell . ShortStudyTerms) . view (_userTableFeatures . _3)
-- colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
-- colUserDegree = sortable (Just "degree") (i18nCell MsgStudyFeatureDegree) $
-- foldMap i18nCell . preview (_userTableFeatures . _2 . _Just)
colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c)
colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
data CourseUserAction = CourseUserSendMail | CourseUserDeregister
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe CourseUserAction
instance Finite CourseUserAction
nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''CourseUserAction id
makeCourseUserTable :: forall h act.
( Functor h, ToSortable h
, RenderMessage UniWorX act, Eq act, PathPiece act, Finite act)
=> CourseId
-> (UserTableExpr -> E.SqlExpr (E.Value Bool))
-> Colonnade h UserTableData (DBCell (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData)))
-> PSValidator (MForm Handler) (FormResult (First act, DBFormResult UserId Bool UserTableData))
-> DB (FormResult (act, Set UserId), Widget)
makeCourseUserTable cid restrict colChoices psValidator = do
Just currentRoute <- liftHandlerT getCurrentRoute
-- -- psValidator has default sorting and filtering
let dbtIdent = "courseUsers" :: Text
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtSQLQuery q = userTableQuery cid q <* E.where_ (restrict q)
dbtRowKey = queryUser >>> (E.^. UserId)
dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
dbtColonnade = colChoices
dbtSorting = Map.fromList
[ sortUserNameLink queryUser -- slower sorting through clicking name column header
, sortUserSurname queryUser -- needed for initial sorting
, sortUserDisplayName queryUser -- needed for initial sorting
, sortUserEmail queryUser
, sortUserMatriclenr queryUser
, ("degree" , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
, ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
, ("field" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsName))
, ("field-short" , SortColumn $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
, ("semesternr" , SortColumn $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
, ("registration", SortColumn $ queryParticipant >>> (E.^. CourseParticipantRegistration))
, ("note" , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
E.sub_select . E.from $ \edit -> do
E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
return . E.max_ $ edit E.^. CourseUserNoteEditTime
)
]
dbtFilter = Map.fromList
[ fltrUserNameLink queryUser
, fltrUserEmail queryUser
, fltrUserMatriclenr queryUser
, fltrUserNameEmail queryUser
, ("field-name" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
, ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
, ("field-key" , FilterColumn $ E.mkExactFilter $ queryFeaturesField >>> (E.?. StudyTermsKey))
, ("field" , FilterColumn $ E.anyFilter
[ E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsName)
, E.mkContainsFilterWith Just $ queryFeaturesField >>> E.joinV . (E.?. StudyTermsShorthand)
, E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
] )
, ("degree" , FilterColumn $ E.anyFilter
[ E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeName)
, E.mkContainsFilterWith Just $ queryFeaturesDegree >>> E.joinV . (E.?. StudyDegreeShorthand)
, E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
] )
, ("semesternr" , FilterColumn $ E.mkExactFilter $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
, ("tutorial" , FilterColumn $ E.mkExistsFilter $ \row criterion ->
E.from $ \(tutorial `E.InnerJoin` tutorialParticipant) -> do
E.on $ tutorial E.^. TutorialId E.==. tutorialParticipant E.^. TutorialParticipantTutorial
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
E.&&. E.hasInfix (tutorial E.^. TutorialName) (E.val criterion :: E.SqlExpr (E.Value (CI Text)))
E.&&. tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser row E.^. UserId
)
-- , ("course-registration", error "TODO") -- TODO
-- , ("course-user-note", error "TODO") -- TODO
]
dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailUI mPrev
, fltrUserMatriclenrUI mPrev
, prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgStudyFeatureDegree)
, prismAForm (singletonFilter "field") mPrev $ aopt textField (fslI MsgCourseStudyFeature)
, prismAForm (singletonFilter "tutorial") mPrev $ aopt textField (fslI MsgCourseTutorial)
]
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just $ SomeRoute currentRoute
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional = \csrf -> do
(res,vw) <- mreq (selectField optionsFinite) "" Nothing
let formWgt = toWidget csrf <> fvInput vw
formRes = (, mempty) . First . Just <$> res
return (formRes,formWgt)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
over _1 postprocess <$> dbTable psValidator DBTable{..}
where
postprocess :: FormResult (First act, DBFormResult UserId Bool UserTableData) -> FormResult (act, Set UserId)
postprocess inp = do
(First (Just act), usrMap) <- inp
let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
return (act, usrSet)
getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCUsersR = postCUsersR
postCUsersR tid ssh csh = do
(Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
let colChoices = mconcat
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, colUserNameLink (CourseR tid ssh csh . CUserR)
, colUserEmail
, colUserMatriclenr
, colUserDegreeShort
, colUserField
, colUserSemester
, sortable (Just "registration") (i18nCell MsgRegisteredSince) (dateCell . view _userTableRegistration)
, colUserComment tid ssh csh
]
psValidator = def & defaultSortingByName
ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
numParticipants <- count [CourseParticipantCourse ==. cid]
table <- makeCourseUserTable cid (const E.true) colChoices psValidator
return (ent, numParticipants, table)
formResult participantRes $ \case
(CourseUserSendMail, selectedUsers) -> do
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
redirect (CourseR tid ssh csh CCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
(CourseUserDeregister,selectedUsers) -> do
nrDel <- runDB $ deleteWhereCount
[ CourseParticipantCourse ==. cid
, CourseParticipantUser <-. Set.toList selectedUsers
]
addMessageI Success $ MsgCourseUsersDeregistered nrDel
redirect $ CourseR tid ssh csh CUsersR
let headingLong = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{tid}|]
headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
siteLayout headingLong $ do
setTitleI headingShort
$(widgetFile "course-participants")

1544
src/Handler/Exam.hs
View File

File diff suppressed because it is too large Load Diff

154
src/Handler/Exam/AddUser.hs Normal file
View File

@ -0,0 +1,154 @@
module Handler.Exam.AddUser
( getEAddUserR, postEAddUserR
) where
import Import hiding (Option(..))
import Handler.Exam.RegistrationInvite
import Handler.Utils
import Handler.Utils.Exam
import Handler.Utils.Invitations
import Utils.Lens
import qualified Data.Set as Set
import Data.Semigroup (Option(..))
import Control.Monad.Trans.Writer (WriterT, execWriterT)
import Control.Monad.Error.Class (MonadError(..))
import Jobs.Queue
import Generics.Deriving.Monoid
data AddRecipientsResult = AddRecipientsResult
{ aurAlreadyRegistered
, aurNoUniquePrimaryField
, aurNoCourseRegistration
, aurSuccess :: [UserEmail]
} deriving (Read, Show, Generic, Typeable)
instance Monoid AddRecipientsResult where
mempty = memptydefault
mappend = mappenddefault
getEAddUserR, postEAddUserR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEAddUserR = postEAddUserR
postEAddUserR tid ssh csh examn = do
eEnt@(Entity eid Exam{..}) <- runDB $ fetchExam tid ssh csh examn
((usersToEnlist,formWgt),formEncoding) <- runFormPost . renderWForm FormStandard $ do
now <- liftIO getCurrentTime
occurrences <- liftHandlerT . runDB $ selectList [ExamOccurrenceExam ==. eid] []
let
localNow = utcToLocalTime now
tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of
LTUUnique utc' _ -> utc'
_other -> UTCTime (addDays 2 $ utctDay now) 0
earliestDate = getOption . fmap getMin $ mconcat
[ Option $ Min <$> examStart
, foldMap (Option . Just . Min . examOccurrenceStart . entityVal) occurrences
]
modifiedEarliestDate = earliestDate <&> \earliestDate'@(utcToLocalTime -> localEarliestDate')
-> case localTimeToUTC (LocalTime (addDays (-1) $ localDay localEarliestDate') midnight) of
LTUUnique utc' _ -> utc'
_other -> UTCTime (addDays (-1) $ utctDay earliestDate') 0
defDeadline
| Just registerTo <- examRegisterTo
, registerTo > now
= registerTo
| Just earliestDate' <- modifiedEarliestDate
= max tomorrowEndOfDay earliestDate'
| otherwise
= tomorrowEndOfDay
deadline <- wreq utcTimeField (fslI MsgExamRegistrationInviteDeadline) (Just defDeadline)
enlist <- wpopt checkBoxField (fslI MsgExamRegistrationEnlistDirectly) (Just False)
registerCourse <- wpopt checkBoxField (fslI MsgExamRegistrationRegisterCourse & setTooltip MsgExamRegistrationRegisterCourseTip) (Just False)
occurrence <- wopt (examOccurrenceField eid) (fslI MsgExamOccurrence) Nothing
users <- wreq (multiUserField (maybe True not $ formResultToMaybe enlist) Nothing)
(fslI MsgExamRegistrationInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
return $ (,,,) <$> deadline <*> registerCourse <*> occurrence <*> users
formResultModal usersToEnlist (CExamR tid ssh csh examn EUsersR) $ processUsers eEnt
let heading = prependCourseTitle tid ssh csh MsgExamParticipantsRegisterHeading
siteLayoutMsg heading $ do
setTitleI heading
wrapForm formWgt def
{ formEncoding
, formAction = Just . SomeRoute $ CExamR tid ssh csh examn EAddUserR
}
where
processUsers :: Entity Exam -> (UTCTime, Bool, Maybe ExamOccurrenceId, Set (Either UserEmail UserId)) -> WriterT [Message] Handler ()
processUsers (Entity eid Exam{..}) (deadline, registerCourse, occId, users) = do
let (emails,uids) = partitionEithers $ Set.toList users
AddRecipientsResult alreadyRegistered registeredNoField noCourseRegistration registeredOneField <- lift . runDBJobs $ do
-- send Invitation eMails to unkown users
sinkInvitationsF examRegistrationInvitationConfig [(mail,eid,(InvDBDataExamRegistration occId deadline registerCourse, InvTokenDataExamRegistration)) | mail <- emails]
-- register known users
execWriterT $ mapM (registerUser examCourse eid registerCourse occId) uids
unless (null emails) $
tell . pure <=< messageI Success . MsgExamParticipantsInvited $ length emails
unless (null alreadyRegistered) $
tell . pure <=< messageI Success . MsgExamRegistrationParticipantsRegistered $ length registeredOneField
unless (null registeredNoField) $ do
let modalTrigger = [whamlet|_{MsgExamRegistrationRegisteredWithoutField (length registeredNoField)}|]
modalContent = $(widgetFile "messages/examRegistrationInvitationRegisteredWithoutField")
tell . pure <=< messageWidget Warning $ msgModal modalTrigger (Right modalContent)
unless (null noCourseRegistration) $ do
let modalTrigger = [whamlet|_{MsgExamRegistrationNotRegisteredWithoutCourse (length noCourseRegistration)}|]
modalContent = $(widgetFile "messages/examRegistrationInvitationNotRegisteredWithoutCourse")
tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent)
unless (null registeredOneField) $
tell . pure <=< messageI Success . MsgExamRegistrationAndCourseParticipantsRegistered $ length registeredOneField
registerUser :: CourseId -> ExamId -> Bool -> Maybe ExamOccurrenceId -> UserId -> WriterT AddRecipientsResult (YesodJobDB UniWorX) ()
registerUser cid eid registerCourse occId uid = exceptT tell tell $ do
User{..} <- lift . lift $ getJust uid
now <- liftIO getCurrentTime
let
examRegister :: YesodJobDB UniWorX ()
examRegister = do
insert_ $ ExamRegistration eid uid occId now
audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
whenM (lift . lift . existsBy $ UniqueExamRegistration eid uid) $
throwError $ mempty { aurAlreadyRegistered = pure userEmail }
whenM (lift . lift . existsBy $ UniqueParticipant uid cid) $ do
lift $ lift examRegister
throwError $ mempty { aurSuccess = pure userEmail }
unless registerCourse $
throwError $ mempty { aurNoCourseRegistration = pure userEmail }
features <- lift . lift $ selectKeysList [ StudyFeaturesUser ==. uid, StudyFeaturesValid ==. True, StudyFeaturesType ==. FieldPrimary ] []
let courseParticipantField
| [f] <- features = Just f
| otherwise = Nothing
lift . lift . insert_ $ CourseParticipant
{ courseParticipantCourse = cid
, courseParticipantUser = uid
, courseParticipantRegistration = now
, ..
}
lift $ lift examRegister
return $ case courseParticipantField of
Nothing -> mempty { aurNoUniquePrimaryField = pure userEmail }
Just _ -> mempty { aurSuccess = pure userEmail }

80
src/Handler/Exam/CorrectorInvite.hs Normal file
View File

@ -0,0 +1,80 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Exam.CorrectorInvite
( InvitableJunction(..)
, InvitationDBData(..)
, InvitationTokenData(..)
, examCorrectorInvitationConfig
, getECInviteR, postECInviteR
) where
import Import
import Handler.Utils.Invitations
import Handler.Utils.Exam
import Utils.Lens
import Text.Hamlet (ihamlet)
import Data.Aeson hiding (Result(..))
instance IsInvitableJunction ExamCorrector where
type InvitationFor ExamCorrector = Exam
data InvitableJunction ExamCorrector = JunctionExamCorrector
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationDBData ExamCorrector = InvDBDataExamCorrector
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationTokenData ExamCorrector = InvTokenDataExamCorrector
deriving (Eq, Ord, Read, Show, Generic, Typeable)
_InvitableJunction = iso
(\ExamCorrector{..} -> (examCorrectorUser, examCorrectorExam, JunctionExamCorrector))
(\(examCorrectorUser, examCorrectorExam, JunctionExamCorrector) -> ExamCorrector{..})
instance ToJSON (InvitableJunction ExamCorrector) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction ExamCorrector) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance ToJSON (InvitationDBData ExamCorrector) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationDBData ExamCorrector) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance ToJSON (InvitationTokenData ExamCorrector) where
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationTokenData ExamCorrector) where
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
examCorrectorInvitationConfig :: InvitationConfig ExamCorrector
examCorrectorInvitationConfig = InvitationConfig{..}
where
invitationRoute (Entity _ Exam{..}) _ = do
Course{..} <- get404 examCourse
return $ CExamR courseTerm courseSchool courseShorthand examName ECInviteR
invitationResolveFor _ = do
Just (CExamR tid csh ssh examn ECInviteR) <- getCurrentRoute
fetchExamId tid csh ssh examn
invitationSubject (Entity _ Exam{..}) _ = do
Course{..} <- get404 examCourse
return . SomeMessage $ MsgMailSubjectExamCorrectorInvitation courseTerm courseSchool courseShorthand examName
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInviteHeading examName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamCorrectorInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure (JunctionExamCorrector, ())
invitationInsertHook _ _ _ _ = id
invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamCorrectorInvitationAccepted examName
invitationUltDest (Entity _ Exam{..}) _ = do
Course{..} <- get404 examCourse
return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR
getECInviteR, postECInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getECInviteR = postECInviteR
postECInviteR = invitationR examCorrectorInvitationConfig

133
src/Handler/Exam/Edit.hs Normal file
View File

@ -0,0 +1,133 @@
module Handler.Exam.Edit
( getEEditR, postEEditR
) where
import Import
import Handler.Exam.Form
import Handler.Exam.CorrectorInvite
import Utils.Lens
import qualified Data.Set as Set
import Handler.Utils
import Handler.Utils.Exam
import Handler.Utils.Invitations
import Jobs.Queue
getEEditR, postEEditR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEEditR = postEEditR
postEEditR tid ssh csh examn = do
(cid, eId, template) <- runDB $ do
(cid, exam@(Entity eId _)) <- fetchCourseIdExam tid ssh csh examn
template <- examFormTemplate exam
return (cid, eId, template)
((editExamResult, editExamWidget), editExamEnctype) <- runFormPost . validateForm validateExam . examForm $ Just template
formResult editExamResult $ \ExamForm{..} -> do
insertRes <- runDBJobs $ do
insertRes <- myReplaceUnique eId Exam
{ examCourse = cid
, examName = efName
, examGradingRule = efGradingRule
, examBonusRule = efBonusRule
, examOccurrenceRule = efOccurrenceRule
, examVisibleFrom = efVisibleFrom
, examRegisterFrom = efRegisterFrom
, examRegisterTo = efRegisterTo
, examDeregisterUntil = efDeregisterUntil
, examPublishOccurrenceAssignments = efPublishOccurrenceAssignments
, examStart = efStart
, examEnd = efEnd
, examFinished = efFinished
, examClosed = efClosed
, examPublicStatistics = efPublicStatistics
, examShowGrades = efShowGrades
, examDescription = efDescription
}
when (is _Nothing insertRes) $ do
occIds <- fmap catMaybes . forM (Set.toList efOccurrences) $ traverse decrypt . eofId
deleteWhere [ ExamOccurrenceExam ==. eId, ExamOccurrenceId /<-. occIds ]
forM_ (Set.toList efOccurrences) $ \case
ExamOccurrenceForm{ eofId = Nothing, .. } -> insert_
ExamOccurrence
{ examOccurrenceExam = eId
, examOccurrenceName = eofName
, examOccurrenceRoom = eofRoom
, examOccurrenceCapacity = eofCapacity
, examOccurrenceStart = eofStart
, examOccurrenceEnd = eofEnd
, examOccurrenceDescription = eofDescription
}
ExamOccurrenceForm{ .. } -> void . runMaybeT $ do
cID <- hoistMaybe eofId
eofId' <- decrypt cID
oldOcc <- MaybeT $ get eofId'
guard $ examOccurrenceExam oldOcc == eId
lift $ replace eofId' ExamOccurrence
{ examOccurrenceExam = eId
, examOccurrenceName = eofName
, examOccurrenceRoom = eofRoom
, examOccurrenceCapacity = eofCapacity
, examOccurrenceStart = eofStart
, examOccurrenceEnd = eofEnd
, examOccurrenceDescription = eofDescription
}
pIds <- fmap catMaybes . forM (Set.toList efExamParts) $ traverse decrypt . epfId
deleteWhere [ ExamPartExam ==. eId, ExamPartId /<-. pIds ]
forM_ (Set.toList efExamParts) $ \case
ExamPartForm{ epfId = Nothing, .. } -> insert_
ExamPart
{ examPartExam = eId
, examPartName = epfName
, examPartMaxPoints = epfMaxPoints
, examPartWeight = epfWeight
}
ExamPartForm{ .. } -> void . runMaybeT $ do
cID <- hoistMaybe epfId
epfId' <- decrypt cID
oldPart <- MaybeT $ get epfId'
guard $ examPartExam oldPart == eId
lift $ replace epfId' ExamPart
{ examPartExam = eId
, examPartName = epfName
, examPartMaxPoints = epfMaxPoints
, examPartWeight = epfWeight
}
let (invites, adds) = partitionEithers $ Set.toList efCorrectors
deleteWhere [ ExamCorrectorExam ==. eId ]
insertMany_ $ map (ExamCorrector eId) adds
deleteWhere [ InvitationFor ==. invRef @ExamCorrector eId, InvitationEmail /<-. invites ]
sinkInvitationsF examCorrectorInvitationConfig $ map (, eId, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
return insertRes
case insertRes of
Just _ -> addMessageI Error $ MsgExamNameTaken efName
Nothing -> do
addMessageI Success $ MsgExamEdited efName
redirect $ CExamR tid ssh csh efName EShowR
let heading = prependCourseTitle tid ssh csh . MsgExamEditHeading $ efName template
siteLayoutMsg heading $ do
setTitleI heading
let
editExamForm = wrapForm editExamWidget def
{ formMethod = POST
, formAction = Just . SomeRoute $ CExamR tid ssh csh examn EEditR
, formEncoding = editExamEnctype
}
$(widgetFile "exam-edit")

361
src/Handler/Exam/Form.hs Normal file
View File

@ -0,0 +1,361 @@
module Handler.Exam.Form
( ExamForm(..)
, ExamOccurrenceForm(..)
, ExamPartForm(..)
, examForm
, examFormTemplate, examTemplate
, validateExam
) where
import Import
import Utils.Lens hiding (parts)
import Handler.Exam.CorrectorInvite
import Handler.Utils
import Handler.Utils.Invitations
import Data.Map ((!))
import qualified Data.Set as Set
import qualified Database.Esqueleto as E
import qualified Control.Monad.State.Class as State
import Text.Blaze.Html.Renderer.String (renderHtml)
data ExamForm = ExamForm
{ efName :: ExamName
, efDescription :: Maybe Html
, efStart :: Maybe UTCTime
, efEnd :: Maybe UTCTime
, efVisibleFrom :: Maybe UTCTime
, efRegisterFrom :: Maybe UTCTime
, efRegisterTo :: Maybe UTCTime
, efDeregisterUntil :: Maybe UTCTime
, efPublishOccurrenceAssignments :: Maybe UTCTime
, efFinished :: Maybe UTCTime
, efClosed :: Maybe UTCTime
, efOccurrences :: Set ExamOccurrenceForm
, efShowGrades :: Bool
, efPublicStatistics :: Bool
, efGradingRule :: ExamGradingRule
, efBonusRule :: ExamBonusRule
, efOccurrenceRule :: ExamOccurrenceRule
, efCorrectors :: Set (Either UserEmail UserId)
, efExamParts :: Set ExamPartForm
}
data ExamOccurrenceForm = ExamOccurrenceForm
{ eofId :: Maybe CryptoUUIDExamOccurrence
, eofName :: ExamOccurrenceName
, eofRoom :: Text
, eofCapacity :: Natural
, eofStart :: UTCTime
, eofEnd :: Maybe UTCTime
, eofDescription :: Maybe Html
} deriving (Read, Show, Eq, Ord, Generic, Typeable)
data ExamPartForm = ExamPartForm
{ epfId :: Maybe CryptoUUIDExamPart
, epfName :: ExamPartName
, epfMaxPoints :: Maybe Points
, epfWeight :: Rational
} deriving (Read, Show, Eq, Ord, Generic, Typeable)
makeLenses_ ''ExamForm
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
} ''ExamPartForm
deriveJSON defaultOptions
{ fieldLabelModifier = camelToPathPiece' 1
} ''ExamOccurrenceForm
examForm :: Maybe ExamForm -> Form ExamForm
examForm template html = do
MsgRenderer mr <- getMsgRenderer
flip (renderAForm FormStandard) html $ ExamForm
<$> areq ciField (fslpI MsgExamName (mr MsgExamName) & setTooltip MsgExamNameTip) (efName <$> template)
<*> (assertM (not . null . renderHtml) <$> aopt htmlField (fslpI MsgExamDescription "Html") (efDescription <$> template))
<* aformSection MsgExamFormTimes
<*> aopt utcTimeField (fslpI MsgExamStart (mr MsgDate) & setTooltip MsgExamTimeTip) (efStart <$> template)
<*> aopt utcTimeField (fslpI MsgExamEnd (mr MsgDate) & setTooltip MsgExamTimeTip) (efEnd <$> template)
<*> aopt utcTimeField (fslpI MsgExamVisibleFrom (mr MsgDate) & setTooltip MsgExamVisibleFromTip) (efVisibleFrom <$> template)
<*> aopt utcTimeField (fslpI MsgExamRegisterFrom (mr MsgDate) & setTooltip MsgExamRegisterFromTip) (efRegisterFrom <$> template)
<*> aopt utcTimeField (fslpI MsgExamRegisterTo (mr MsgDate)) (efRegisterTo <$> template)
<*> aopt utcTimeField (fslpI MsgExamDeregisterUntil (mr MsgDate)) (efDeregisterUntil <$> template)
<*> aopt utcTimeField (fslpI MsgExamPublishOccurrenceAssignments (mr MsgDate) & setTooltip MsgExamPublishOccurrenceAssignmentsTip) (efPublishOccurrenceAssignments <$> template)
<*> aopt utcTimeField (fslpI MsgExamFinished (mr MsgDate) & setTooltip MsgExamFinishedTip) (efFinished <$> template)
<*> aopt utcTimeField (fslpI MsgExamClosed (mr MsgDate) & setTooltip MsgExamClosedTip) (efClosed <$> template)
<* aformSection MsgExamFormOccurrences
<*> examOccurrenceForm (efOccurrences <$> template)
<* aformSection MsgExamFormAutomaticFunctions
<*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamShowGrades & setTooltip MsgExamShowGradesTip) (Just . efShowGrades <$> template))
<*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamPublicStatistics & setTooltip MsgExamPublicStatisticsTip) (Just . efPublicStatistics <$> template))
<*> examGradingRuleForm (efGradingRule <$> template)
<*> examBonusRuleForm (efBonusRule <$> template)
<*> examOccurrenceRuleForm (efOccurrenceRule <$> template)
<* aformSection MsgExamFormCorrection
<*> examCorrectorsForm (efCorrectors <$> template)
<* aformSection MsgExamFormParts
<*> examPartsForm (efExamParts <$> template)
examCorrectorsForm :: Maybe (Set (Either UserEmail UserId)) -> AForm Handler (Set (Either UserEmail UserId))
examCorrectorsForm mPrev = wFormToAForm $ do
MsgRenderer mr <- getMsgRenderer
Just currentRoute <- getCurrentRoute
uid <- liftHandlerT requireAuthId
let
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
miAdd' :: (Text -> Text) -> FieldView UniWorX -> Form ([Either UserEmail UserId] -> FormResult [Either UserEmail UserId])
miAdd' nudge submitView csrf = do
(addRes, addView) <- mpreq (multiUserField False $ Just corrUserSuggestions) ("" & addName (nudge "email")) Nothing
let
addRes'
| otherwise
= addRes <&> \newDat oldDat -> if
| existing <- newDat `Set.intersection` Set.fromList oldDat
, not $ Set.null existing
-> FormFailure [mr MsgExamCorrectorAlreadyAdded]
| otherwise
-> FormSuccess $ Set.toList newDat
return (addRes', $(widgetFile "widgets/massinput/examCorrectors/add"))
corrUserSuggestions :: E.SqlQuery (E.SqlExpr (Entity User))
corrUserSuggestions = E.from $ \(lecturer `E.InnerJoin` course `E.InnerJoin` exam `E.InnerJoin` corrector `E.InnerJoin` corrUser) -> do
E.on $ corrUser E.^. UserId E.==. corrector E.^. ExamCorrectorUser
E.on $ corrector E.^. ExamCorrectorExam E.==. exam E.^. ExamId
E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
return corrUser
miCell' :: Either UserEmail UserId -> Widget
miCell' (Left email) =
$(widgetFile "widgets/massinput/examCorrectors/cellInvitation")
miCell' (Right userId) = do
User{..} <- liftHandlerT . runDB $ get404 userId
$(widgetFile "widgets/massinput/examCorrectors/cellKnown")
miLayout' :: MassInputLayout ListLength (Either UserEmail UserId) ()
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examCorrectors/layout")
fmap Set.fromList <$> massInputAccumW miAdd' miCell' miButtonAction' miLayout' ("correctors" :: Text) (fslI MsgExamCorrectors & setTooltip MsgMassInputTip) False (Set.toList <$> mPrev)
examOccurrenceForm :: Maybe (Set ExamOccurrenceForm) -> AForm Handler (Set ExamOccurrenceForm)
examOccurrenceForm prev = wFormToAForm $ do
Just currentRoute <- getCurrentRoute
let
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamOccurrences & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
where
examOccurrenceForm' nudge mPrev csrf = do
(eofIdRes, eofIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ eofId =<< mPrev)
(eofNameRes, eofNameView) <- mpreq ciField ("" & addName (nudge "name")) (eofName <$> mPrev)
(eofRoomRes, eofRoomView) <- mpreq textField ("" & addName (nudge "room")) (eofRoom <$> mPrev)
(eofCapacityRes, eofCapacityView) <- mpreq (natFieldI MsgExamRoomCapacityNegative) ("" & addName (nudge "capacity")) (eofCapacity <$> mPrev)
(eofStartRes, eofStartView) <- mpreq utcTimeField ("" & addName (nudge "start")) (eofStart <$> mPrev)
(eofEndRes, eofEndView) <- mopt utcTimeField ("" & addName (nudge "end")) (eofEnd <$> mPrev)
(eofDescRes, eofDescView) <- mopt htmlFieldSmall ("" & addName (nudge "description")) (eofDescription <$> mPrev)
return ( ExamOccurrenceForm
<$> eofIdRes
<*> eofNameRes
<*> eofRoomRes
<*> eofCapacityRes
<*> eofStartRes
<*> eofEndRes
<*> (assertM (not . null . renderHtml) <$> eofDescRes)
, $(widgetFile "widgets/massinput/examRooms/form")
)
miAdd' nudge submitView csrf = do
MsgRenderer mr <- getMsgRenderer
(res, formWidget) <- examOccurrenceForm' nudge Nothing csrf
let
addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
| newDat `Set.member` oldDat -> FormFailure [mr MsgExamRoomAlreadyExists]
| otherwise -> FormSuccess $ pure newDat
return (addRes, $(widgetFile "widgets/massinput/examRooms/add"))
miCell' nudge dat = examOccurrenceForm' nudge (Just dat)
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examRooms/layout")
miIdent' :: Text
miIdent' = "exam-occurrences"
examPartsForm :: Maybe (Set ExamPartForm) -> AForm Handler (Set ExamPartForm)
examPartsForm prev = wFormToAForm $ do
Just currentRoute <- getCurrentRoute
let
miButtonAction' :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction' frag = Just . SomeRoute $ currentRoute :#: frag
fmap (fmap Set.fromList) . massInputAccumEditW miAdd' miCell' miButtonAction' miLayout' miIdent' (fslI MsgExamParts & setTooltip MsgMassInputTip) False $ Set.toList <$> prev
where
examPartForm' nudge mPrev csrf = do
(epfIdRes, epfIdView) <- mopt hiddenField ("" & addName (nudge "id")) (Just $ epfId =<< mPrev)
(epfNameRes, epfNameView) <- mpreq ciField ("" & addName (nudge "name")) (epfName <$> mPrev)
(epfMaxPointsRes, epfMaxPointsView) <- mopt pointsField ("" & addName (nudge "max-points")) (epfMaxPoints <$> mPrev)
(epfWeightRes, epfWeightView) <- mpreq (checkBool (>= 0) MsgExamPartWeightNegative rationalField) ("" & addName (nudge "weight")) (epfWeight <$> mPrev <|> Just 1)
return ( ExamPartForm
<$> epfIdRes
<*> epfNameRes
<*> epfMaxPointsRes
<*> epfWeightRes
, $(widgetFile "widgets/massinput/examParts/form")
)
miAdd' nudge submitView csrf = do
MsgRenderer mr <- getMsgRenderer
(res, formWidget) <- examPartForm' nudge Nothing csrf
let
addRes = res <&> \newDat (Set.fromList -> oldDat) -> if
| any (((==) `on` epfName) newDat) oldDat -> FormFailure [mr MsgExamPartAlreadyExists]
| otherwise -> FormSuccess $ pure newDat
return (addRes, $(widgetFile "widgets/massinput/examParts/add"))
miCell' nudge dat = examPartForm' nudge (Just dat)
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/examParts/layout")
miIdent' :: Text
miIdent' = "exam-parts"
examFormTemplate :: Entity Exam -> DB ExamForm
examFormTemplate (Entity eId Exam{..}) = do
parts <- selectList [ ExamPartExam ==. eId ] []
occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
correctors <- selectList [ ExamCorrectorExam ==. eId ] []
invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId
parts' <- forM parts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part
occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ
return ExamForm
{ efName = examName
, efGradingRule = examGradingRule
, efBonusRule = examBonusRule
, efOccurrenceRule = examOccurrenceRule
, efVisibleFrom = examVisibleFrom
, efRegisterFrom = examRegisterFrom
, efRegisterTo = examRegisterTo
, efDeregisterUntil = examDeregisterUntil
, efPublishOccurrenceAssignments = examPublishOccurrenceAssignments
, efStart = examStart
, efEnd = examEnd
, efFinished = examFinished
, efClosed = examClosed
, efShowGrades = examShowGrades
, efPublicStatistics = examPublicStatistics
, efDescription = examDescription
, efOccurrences = Set.fromList $ do
(Just -> eofId, ExamOccurrence{..}) <- occurrences'
return ExamOccurrenceForm
{ eofId
, eofName = examOccurrenceName
, eofRoom = examOccurrenceRoom
, eofCapacity = examOccurrenceCapacity
, eofStart = examOccurrenceStart
, eofEnd = examOccurrenceEnd
, eofDescription = examOccurrenceDescription
}
, efExamParts = Set.fromList $ do
(Just -> epfId, ExamPart{..}) <- parts'
return ExamPartForm
{ epfId
, epfName = examPartName
, epfMaxPoints = examPartMaxPoints
, epfWeight = examPartWeight
}
, efCorrectors = Set.unions
[ Set.fromList $ map Left invitations
, Set.fromList . map Right $ do
Entity _ ExamCorrector{..} <- correctors
return examCorrectorUser
]
}
examTemplate :: CourseId -> DB (Maybe ExamForm)
examTemplate cid = runMaybeT $ do
newCourse <- MaybeT $ get cid
[(Entity _ oldCourse, Entity _ oldExam)] <- lift . E.select . E.from $ \(course `E.InnerJoin` exam) -> do
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
E.where_ $ ( course E.^. CourseShorthand E.==. E.val (courseShorthand newCourse)
E.||. course E.^. CourseName E.==. E.val (courseName newCourse)
)
E.&&. course E.^. CourseSchool E.==. E.val (courseSchool newCourse)
E.where_ . E.not_ . E.exists . E.from $ \exam' -> do
E.where_ $ exam' E.^. ExamCourse E.==. E.val cid
E.where_ $ exam E.^. ExamName E.==. exam' E.^. ExamName
E.where_ . E.not_ . E.isNothing $ exam E.^. ExamVisibleFrom
E.limit 1
E.orderBy [ E.desc $ course E.^. CourseTerm, E.asc $ exam E.^. ExamVisibleFrom ]
return (course, exam)
oldTerm <- MaybeT . get $ courseTerm oldCourse
newTerm <- MaybeT . get $ courseTerm newCourse
let
dateOffset = over _utctDay . addDays $ (diffDays `on` termLectureEnd) newTerm oldTerm
return ExamForm
{ efName = examName oldExam
, efGradingRule = examGradingRule oldExam
, efBonusRule = examBonusRule oldExam
, efOccurrenceRule = examOccurrenceRule oldExam
, efVisibleFrom = dateOffset <$> examVisibleFrom oldExam
, efRegisterFrom = dateOffset <$> examRegisterFrom oldExam
, efRegisterTo = dateOffset <$> examRegisterTo oldExam
, efDeregisterUntil = dateOffset <$> examDeregisterUntil oldExam
, efPublishOccurrenceAssignments = dateOffset <$> examPublishOccurrenceAssignments oldExam
, efStart = dateOffset <$> examStart oldExam
, efEnd = dateOffset <$> examEnd oldExam
, efFinished = dateOffset <$> examFinished oldExam
, efClosed = dateOffset <$> examClosed oldExam
, efShowGrades = examShowGrades oldExam
, efPublicStatistics = examPublicStatistics oldExam
, efDescription = examDescription oldExam
, efOccurrences = Set.empty
, efExamParts = Set.empty
, efCorrectors = Set.empty
}
validateExam :: (MonadHandler m, HandlerSite m ~ UniWorX) => FormValidator ExamForm m ()
validateExam = do
ExamForm{..} <- State.get
guardValidation MsgExamRegisterToMustBeAfterRegisterFrom $ NTop efRegisterTo >= NTop efRegisterFrom
guardValidation MsgExamDeregisterUntilMustBeAfterRegisterFrom $ NTop efDeregisterUntil >= NTop efRegisterFrom
guardValidation MsgExamStartMustBeAfterPublishOccurrenceAssignments . fromMaybe True $ (>=) <$> efStart <*> efPublishOccurrenceAssignments
guardValidation MsgExamEndMustBeAfterStart $ NTop efEnd >= NTop efStart
guardValidation MsgExamFinishedMustBeAfterEnd . fromMaybe True $ (>=) <$> efFinished <*> efEnd
guardValidation MsgExamFinishedMustBeAfterStart $ NTop efFinished >= NTop efStart
guardValidation MsgExamClosedMustBeAfterFinished . fromMaybe True $ (>=) <$> efClosed <*> efFinished
guardValidation MsgExamClosedMustBeAfterStart $ NTop efClosed >= NTop efStart
guardValidation MsgExamClosedMustBeAfterEnd . fromMaybe True $ (>=) <$> efClosed <*> efEnd
forM_ efOccurrences $ \ExamOccurrenceForm{..} -> do
guardValidation (MsgExamOccurrenceEndMustBeAfterStart eofName) $ NTop eofEnd >= NTop (Just eofStart)
guardValidation (MsgExamOccurrenceStartMustBeAfterExamStart eofName) $ NTop (Just eofStart) >= NTop efStart
guardValidation (MsgExamOccurrenceEndMustBeBeforeExamEnd eofName) $ NTop eofEnd <= NTop efEnd
forM_ [ (a, b) | a <- Set.toAscList efOccurrences, b <- Set.toAscList efOccurrences, b > a ] $ \(a, b) -> do
eofRange' <- formatTimeRange SelFormatDateTime (eofStart a) (eofEnd a)
guardValidation (MsgExamOccurrenceDuplicate (eofRoom a) eofRange') $ any (\f -> f a b)
[ (/=) `on` eofRoom
, (/=) `on` eofStart
, (/=) `on` eofEnd
, (/=) `on` fmap renderHtml . eofDescription
]
guardValidation (MsgExamOccurrenceDuplicateName $ eofName a) $ ((/=) `on` eofName) a b

60
src/Handler/Exam/List.hs Normal file
View File

@ -0,0 +1,60 @@
module Handler.Exam.List
( getCExamListR
) where
import Import
import Handler.Utils
import Handler.Utils.Table.Cells
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
getCExamListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCExamListR tid ssh csh = do
Entity cid Course{..} <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
now <- liftIO getCurrentTime
mayCreate <- hasWriteAccessTo $ CourseR tid ssh csh CExamNewR
let
examDBTable = DBTable{..}
where
dbtSQLQuery exam = do
E.where_ $ exam E.^. ExamCourse E.==. E.val cid
return exam
dbtRowKey = (E.^. ExamId)
dbtProj x@DBRow{ dbrOutput = Entity _ Exam{..} } = do
guardM . hasReadAccessTo $ CExamR tid ssh csh examName EShowR
return x
dbtColonnade = dbColonnade . mconcat $ catMaybes
[ Just . sortable (Just "name") (i18nCell MsgExamName) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> anchorCell (CExamR tid ssh csh examName EShowR) examName
, (<$ guard mayCreate) . sortable (Just "visible") (i18nCell MsgExamVisibleFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty (dateTimeCellVisible now) examVisibleFrom
, Just . sortable (Just "register-from") (i18nCell MsgExamRegisterFrom) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterFrom
, Just . sortable (Just "register-to") (i18nCell MsgExamRegisterTo) $ \DBRow { dbrOutput = Entity _ Exam{..} } -> maybe mempty dateTimeCell examRegisterTo
, Just . sortable (Just "time") (i18nCell MsgExamTime) $ \DBRow{ dbrOutput = Entity _ Exam{..} } -> maybe mempty (cell . flip (formatTimeRangeW SelFormatDateTime) examEnd) examStart
]
dbtSorting = Map.fromList
[ ("name", SortColumn $ \exam -> exam E.^. ExamName )
, ("time", SortColumn $ \exam -> exam E.^. ExamStart )
, ("register-from", SortColumn $ \exam -> exam E.^. ExamRegisterFrom )
, ("register-to", SortColumn $ \exam -> exam E.^. ExamRegisterTo )
, ("visible", SortColumn $ \exam -> exam E.^. ExamVisibleFrom )
]
dbtFilter = Map.empty
dbtFilterUI = const mempty
dbtStyle = def
dbtParams = def
dbtIdent :: Text
dbtIdent = "exams"
dbtCsvEncode = noCsvEncode
dbtCsvDecode = Nothing
examDBTableValidator = def
& defaultSorting [SortAscBy "time"]
((), examTable) <- runDB $ dbTable examDBTableValidator examDBTable
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamsHeading) $ do
setTitleI $ prependCourseTitle tid ssh csh MsgExamsHeading
$(widgetFile "exam-list")

93
src/Handler/Exam/New.hs Normal file
View File

@ -0,0 +1,93 @@
module Handler.Exam.New
( getCExamNewR, postCExamNewR
) where
import Import
import Handler.Exam.Form
import Handler.Exam.CorrectorInvite
import qualified Data.Set as Set
import Handler.Utils
import Handler.Utils.Invitations
import Jobs.Queue
getCExamNewR, postCExamNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCExamNewR = postCExamNewR
postCExamNewR tid ssh csh = do
(cid, template) <- runDB $ do
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
template <- examTemplate cid
return (cid, template)
((newExamResult, newExamWidget), newExamEnctype) <- runFormPost . validateForm validateExam $ examForm template
formResult newExamResult $ \ExamForm{..} -> do
insertRes <- runDBJobs $ do
insertRes <- insertUnique Exam
{ examName = efName
, examCourse = cid
, examGradingRule = efGradingRule
, examBonusRule = efBonusRule
, examOccurrenceRule = efOccurrenceRule
, examVisibleFrom = efVisibleFrom
, examRegisterFrom = efRegisterFrom
, examRegisterTo = efRegisterTo
, examDeregisterUntil = efDeregisterUntil
, examPublishOccurrenceAssignments = efPublishOccurrenceAssignments
, examStart = efStart
, examEnd = efEnd
, examFinished = efFinished
, examClosed = efClosed
, examShowGrades = efShowGrades
, examPublicStatistics = efPublicStatistics
, examDescription = efDescription
}
whenIsJust insertRes $ \examid -> do
insertMany_
[ ExamPart{..}
| ExamPartForm{..} <- Set.toList efExamParts
, let examPartExam = examid
examPartName = epfName
examPartMaxPoints = epfMaxPoints
examPartWeight = epfWeight
]
insertMany_
[ ExamOccurrence{..}
| ExamOccurrenceForm{..} <- Set.toList efOccurrences
, let examOccurrenceExam = examid
examOccurrenceName = eofName
examOccurrenceRoom = eofRoom
examOccurrenceCapacity = eofCapacity
examOccurrenceStart = eofStart
examOccurrenceEnd = eofEnd
examOccurrenceDescription = eofDescription
]
let (invites, adds) = partitionEithers $ Set.toList efCorrectors
insertMany_ [ ExamCorrector{..}
| examCorrectorUser <- adds
, let examCorrectorExam = examid
]
sinkInvitationsF examCorrectorInvitationConfig $ map (, examid, (InvDBDataExamCorrector, InvTokenDataExamCorrector)) invites
return insertRes
case insertRes of
Nothing -> addMessageI Error $ MsgExamNameTaken efName
Just _ -> do
addMessageI Success $ MsgExamCreated efName
redirect $ CourseR tid ssh csh CExamListR
let heading = prependCourseTitle tid ssh csh MsgExamNew
siteLayoutMsg heading $ do
setTitleI heading
let
newExamForm = wrapForm newExamWidget def
{ formMethod = POST
, formAction = Just . SomeRoute $ CourseR tid ssh csh CExamNewR
, formEncoding = newExamEnctype
}
$(widgetFile "exam-new")

52
src/Handler/Exam/Register.hs Normal file
View File

@ -0,0 +1,52 @@
module Handler.Exam.Register
( ButtonExamRegister(..)
, postERegisterR
) where
import Import
import Handler.Utils
import Handler.Utils.Exam
-- Dedicated ExamRegistrationButton
data ButtonExamRegister = BtnExamRegister | BtnExamDeregister
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonExamRegister
instance Finite ButtonExamRegister
nullaryPathPiece ''ButtonExamRegister $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonExamRegister id
instance Button UniWorX ButtonExamRegister where
btnClasses BtnExamRegister = [BCIsButton, BCPrimary]
btnClasses BtnExamDeregister = [BCIsButton, BCDanger]
btnLabel BtnExamRegister = [whamlet|#{iconExamRegister True} _{MsgBtnExamRegister}|]
btnLabel BtnExamDeregister = [whamlet|#{iconExamRegister False} _{MsgBtnExamDeregister}|]
postERegisterR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
postERegisterR tid ssh csh examn = do
Entity uid User{..} <- requireAuth
Entity eId Exam{..} <- runDB $ fetchExam tid ssh csh examn
((btnResult, _), _) <- runFormPost buttonForm
formResult btnResult $ \case
BtnExamRegister -> do
runDB $ do
now <- liftIO getCurrentTime
insert_ $ ExamRegistration eId uid Nothing now
audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
addMessageIconI Success IconExamRegisterTrue $ MsgExamRegisteredSuccess examn
redirect $ CExamR tid ssh csh examn EShowR
BtnExamDeregister -> do
runDB $ do
deleteBy $ UniqueExamRegistration eId uid
audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
addMessageIconI Info IconExamRegisterFalse $ MsgExamDeregisteredSuccess examn
-- yes, it's a success message, but it should be visually different from a positive success, since most will just note the positive green color! See discussion on commit 5f4925a4
redirect $ CExamR tid ssh csh examn EShowR
invalidArgs ["Register/Deregister button required"]

112
src/Handler/Exam/RegistrationInvite.hs Normal file
View File

@ -0,0 +1,112 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Exam.RegistrationInvite
( InvitableJunction(..)
, InvitationDBData(..)
, InvitationTokenData(..)
, examRegistrationInvitationConfig
, getEInviteR, postEInviteR
) where
import Import
import Handler.Utils
import Handler.Utils.Exam
import Handler.Utils.Invitations
import qualified Data.Set as Set
import Text.Hamlet (ihamlet)
import Utils.Lens
import Data.Aeson hiding (Result(..))
instance IsInvitableJunction ExamRegistration where
type InvitationFor ExamRegistration = Exam
data InvitableJunction ExamRegistration = JunctionExamRegistration
{ jExamRegistrationOccurrence :: Maybe ExamOccurrenceId
, jExamRegistrationTime :: UTCTime
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationDBData ExamRegistration = InvDBDataExamRegistration
{ invDBExamRegistrationOccurrence :: Maybe ExamOccurrenceId
, invDBExamRegistrationDeadline :: UTCTime
, invDBExamRegistrationCourseRegister :: Bool
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationTokenData ExamRegistration = InvTokenDataExamRegistration
deriving (Eq, Ord, Read, Show, Generic, Typeable)
_InvitableJunction = iso
(\ExamRegistration{..} -> (examRegistrationUser, examRegistrationExam, JunctionExamRegistration examRegistrationOccurrence examRegistrationTime))
(\(examRegistrationUser, examRegistrationExam, JunctionExamRegistration examRegistrationOccurrence examRegistrationTime) -> ExamRegistration{..})
instance ToJSON (InvitableJunction ExamRegistration) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction ExamRegistration) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
instance ToJSON (InvitationDBData ExamRegistration) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationDBData ExamRegistration) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
instance ToJSON (InvitationTokenData ExamRegistration) where
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
instance FromJSON (InvitationTokenData ExamRegistration) where
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
examRegistrationInvitationConfig :: InvitationConfig ExamRegistration
examRegistrationInvitationConfig = InvitationConfig{..}
where
invitationRoute (Entity _ Exam{..}) _ = do
Course{..} <- get404 examCourse
return $ CExamR courseTerm courseSchool courseShorthand examName EInviteR
invitationResolveFor _ = do
Just (CExamR tid csh ssh examn EInviteR) <- getCurrentRoute
fetchExamId tid csh ssh examn
invitationSubject (Entity _ Exam{..}) _ = do
Course{..} <- get404 examCourse
return . SomeMessage $ MsgMailSubjectExamRegistrationInvitation courseTerm courseSchool courseShorthand examName
invitationHeading (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInviteHeading examName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgExamRegistrationInviteExplanation}|]
invitationTokenConfig _ (InvDBDataExamRegistration{..}, _) = do
itAuthority <- liftHandlerT requireAuthId
let itExpiresAt = Just $ Just invDBExamRegistrationDeadline
itAddAuth
| not invDBExamRegistrationCourseRegister
= Just . PredDNF . Set.singleton . impureNonNull . Set.singleton $ PLVariable AuthCourseRegistered
| otherwise
= Nothing
itStartsAt = Nothing
return InvitationTokenConfig{..}
invitationRestriction _ _ = return Authorized
invitationForm (Entity _ Exam{..}) (InvDBDataExamRegistration{..}, _) uid = hoistAForm liftHandlerT . wFormToAForm $ do
isRegistered <- fmap (is _Just) . liftHandlerT . runDB . getBy $ UniqueParticipant uid examCourse
now <- liftIO getCurrentTime
case (isRegistered, invDBExamRegistrationCourseRegister) of
(False, False) -> permissionDeniedI MsgUnauthorizedParticipant
(False, True ) -> do
fieldRes <- wreq (studyFeaturesPrimaryFieldFor False [] $ Just uid) (fslI MsgCourseStudyFeature) Nothing
return $ (JunctionExamRegistration invDBExamRegistrationOccurrence now, ) . Just <$> fieldRes
(True , _ ) -> return $ pure (JunctionExamRegistration invDBExamRegistrationOccurrence now, Nothing)
invitationInsertHook (Entity _ Exam{..}) _ ExamRegistration{..} mField act = do
whenIsJust mField $
insert_ . CourseParticipant examCourse examRegistrationUser examRegistrationTime
Course{..} <- get404 examCourse
User{..} <- get404 examRegistrationUser
let doAudit = audit' $ TransactionExamRegister (unTermKey courseTerm) (unSchoolKey courseSchool) courseShorthand examName userIdent
act <* doAudit
invitationSuccessMsg (Entity _ Exam{..}) _ = return . SomeMessage $ MsgExamRegistrationInvitationAccepted examName
invitationUltDest (Entity _ Exam{..}) _ = do
Course{..} <- get404 examCourse
return . SomeRoute $ CExamR courseTerm courseSchool courseShorthand examName EShowR
getEInviteR, postEInviteR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEInviteR = postEInviteR
postEInviteR _ _ _ _ = invitationR' examRegistrationInvitationConfig

106
src/Handler/Exam/Show.hs Normal file
View File

@ -0,0 +1,106 @@
module Handler.Exam.Show
( getEShowR
) where
import Import
import Handler.Exam.Register
import Utils.Lens hiding (parts)
import Data.Map ((!?))
import qualified Data.Map as Map
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import qualified Data.CaseInsensitive as CI
import Handler.Utils
import Handler.Utils.Exam
getEShowR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEShowR tid ssh csh examn = do
cTime <- liftIO getCurrentTime
mUid <- maybeAuthId
(Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do
exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
let gradingVisible = NTop (Just cTime) >= NTop examFinished
gradingShown <- or2M (return gradingVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
resultsRaw <- for mUid $ \uid ->
E.select . E.from $ \examPartResult -> do
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid
E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey parts)
return examPartResult
let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw
result <- fmap join . for mUid $ getBy . UniqueExamResult eId
occurrencesRaw <- E.select . E.from $ \examOccurrence -> do
E.where_ $ examOccurrence E.^. ExamOccurrenceExam E.==. E.val eId
let
registered
| Just uid <- mUid
= E.exists . E.from $ \examRegistration ->
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eId
E.&&. examRegistration E.^. ExamRegistrationUser E.==. E.val uid
E.&&. examRegistration E.^. ExamRegistrationOccurrence E.==. E.just (examOccurrence E.^. ExamOccurrenceId)
| otherwise = E.false
E.orderBy [E.desc registered, E.asc $ examOccurrence E.^. ExamOccurrenceStart, E.asc $ examOccurrence E.^. ExamOccurrenceRoom]
return (examOccurrence, registered)
let occurrences = map (over _2 E.unValue) occurrencesRaw
registered <- for mUid $ existsBy . UniqueExamRegistration eId
mayRegister <- (== Authorized) <$> evalAccessDB (CExamR tid ssh csh examName ERegisterR) True
occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown)
let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
registerWidget
| Just isRegistered <- registered
, mayRegister = Just $ do
(examRegisterForm, examRegisterEnctype) <- liftHandlerT . generateFormPost . buttonForm' $ bool [BtnExamRegister] [BtnExamDeregister] isRegistered
[whamlet|
<p>
$if isRegistered
_{MsgExamRegistered}
$else
_{MsgExamNotRegistered}
|]
wrapForm examRegisterForm def
{ formAction = Just . SomeRoute $ CExamR tid ssh csh examName ERegisterR
, formEncoding = examRegisterEnctype
, formSubmit = FormNoSubmit
}
| fromMaybe False registered = Just [whamlet|_{MsgExamRegistered}|]
| otherwise = Nothing
let heading = prependCourseTitle tid ssh csh $ CI.original examName
siteLayoutMsg heading $ do
setTitleI heading
let
gradingKeyW :: [Points] -> Widget
gradingKeyW bounds
= let boundWidgets :: [Widget]
boundWidgets = toWidget . (pack :: String -> Text) . showFixed True <$> 0 : bounds
grades :: [ExamGrade]
grades = universeF
in $(widgetFile "widgets/gradingKey")
examBonusW :: ExamBonusRule -> Widget
examBonusW bonusRule = $(widgetFile "widgets/bonusRule")
$(widgetFile "exam-show")

619
src/Handler/Exam/Users.hs Normal file
View File

@ -0,0 +1,619 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Exam.Users
( getEUsersR, postEUsersR
) where
import Import
import Utils.Lens
import Handler.Utils
import Handler.Utils.Exam
import Handler.Utils.Table.Columns
import Handler.Utils.Table.Cells
import Handler.Utils.Csv
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH
import qualified Data.Csv as Csv
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Lens as Text
import qualified Data.Conduit.List as C
import qualified Data.CaseInsensitive as CI
import Numeric.Lens (integral)
import Control.Arrow (Kleisli(..))
import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult))
type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult))
instance HasEntity ExamUserTableData User where
hasEntity = _dbrOutput . _2
instance HasUser ExamUserTableData where
hasUser = _dbrOutput . _2 . _entityVal
_userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
_userTableOccurrence = _dbrOutput . _3
queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 4 1)
queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3)
queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
queryExamOccurrence = $(sqlLOJproj 4 2)
queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3)
queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3)
queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult))
queryExamResult = $(sqlLOJproj 4 4)
resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration)
resultExamRegistration = _dbrOutput . _1
resultUser :: Lens' ExamUserTableData (Entity User)
resultUser = _dbrOutput . _2
resultStudyFeatures :: Traversal' ExamUserTableData (Entity StudyFeatures)
resultStudyFeatures = _dbrOutput . _4 . _Just
resultStudyDegree :: Traversal' ExamUserTableData (Entity StudyDegree)
resultStudyDegree = _dbrOutput . _5 . _Just
resultStudyField :: Traversal' ExamUserTableData (Entity StudyTerms)
resultStudyField = _dbrOutput . _6 . _Just
resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
resultExamOccurrence = _dbrOutput . _3 . _Just
resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
resultExamResult = _dbrOutput . _7 . _Just
data ExamUserTableCsv = ExamUserTableCsv
{ csvEUserSurname :: Maybe Text
, csvEUserFirstName :: Maybe Text
, csvEUserName :: Maybe Text
, csvEUserMatriculation :: Maybe Text
, csvEUserField :: Maybe Text
, csvEUserDegree :: Maybe Text
, csvEUserSemester :: Maybe Int
, csvEUserOccurrence :: Maybe (CI Text)
, csvEUserExercisePoints :: Maybe Points
, csvEUserExerciseNumPasses :: Maybe Int
, csvEUserExercisePointsMax :: Maybe Points
, csvEUserExerciseNumPassesMax :: Maybe Int
, csvEUserExamResult :: Maybe (Either ExamResultPassed ExamResultGrade)
}
deriving (Generic)
makeLenses_ ''ExamUserTableCsv
examUserTableCsvOptions :: Csv.Options
examUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3 }
instance ToNamedRecord ExamUserTableCsv where
toNamedRecord = Csv.genericToNamedRecord examUserTableCsvOptions
instance FromNamedRecord ExamUserTableCsv where
parseNamedRecord csv -- Manually defined awaiting issue #427
= ExamUserTableCsv
<$> csv .:? "surname"
<*> csv .:? "first-name"
<*> csv .:? "name"
<*> csv .:? "matriculation"
<*> csv .:? "field"
<*> csv .:? "degree"
<*> csv .:? "semester"
<*> csv .:? "occurrence"
<*> csv .:? "exercise-points"
<*> csv .:? "exercise-num-passes"
<*> csv .:? "exercise-points-max"
<*> csv .:? "exercise-num-passes-max"
<*> csv .:? "exam-result"
where
(.:?) :: FromField (Maybe a) => Csv.NamedRecord -> ByteString -> Csv.Parser (Maybe a)
m .:? name = Csv.lookup m name <|> return Nothing
instance DefaultOrdered ExamUserTableCsv where
headerOrder = Csv.genericHeaderOrder examUserTableCsvOptions
instance CsvColumnsExplained ExamUserTableCsv where
csvColumnsExplanations = genericCsvColumnsExplanations examUserTableCsvOptions $ Map.fromList
[ ('csvEUserSurname , MsgCsvColumnExamUserSurname )
, ('csvEUserFirstName , MsgCsvColumnExamUserFirstName )
, ('csvEUserName , MsgCsvColumnExamUserName )
, ('csvEUserMatriculation , MsgCsvColumnExamUserMatriculation )
, ('csvEUserField , MsgCsvColumnExamUserField )
, ('csvEUserDegree , MsgCsvColumnExamUserDegree )
, ('csvEUserSemester , MsgCsvColumnExamUserSemester )
, ('csvEUserOccurrence , MsgCsvColumnExamUserOccurrence )
, ('csvEUserExercisePoints , MsgCsvColumnExamUserExercisePoints )
, ('csvEUserExerciseNumPasses , MsgCsvColumnExamUserExercisePasses )
, ('csvEUserExercisePointsMax , MsgCsvColumnExamUserExercisePointsMax )
, ('csvEUserExerciseNumPassesMax, MsgCsvColumnExamUserExercisePassesMax )
, ('csvEUserExamResult , MsgCsvColumnExamUserResult )
]
data ExamUserAction = ExamUserDeregister
| ExamUserAssignOccurrence
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe ExamUserAction
instance Finite ExamUserAction
nullaryPathPiece ''ExamUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''ExamUserAction id
data ExamUserActionData = ExamUserDeregisterData
| ExamUserAssignOccurrenceData (Maybe ExamOccurrenceId)
data ExamUserCsvActionClass
= ExamUserCsvCourseRegister
| ExamUserCsvRegister
| ExamUserCsvAssignOccurrence
| ExamUserCsvSetCourseField
| ExamUserCsvDeregister
| ExamUserCsvSetResult
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
embedRenderMessage ''UniWorX ''ExamUserCsvActionClass id
data ExamUserCsvAction
= ExamUserCsvCourseRegisterData
{ examUserCsvActUser :: UserId
, examUserCsvActCourseField :: Maybe StudyFeaturesId
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
}
| ExamUserCsvRegisterData
{ examUserCsvActUser :: UserId
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
}
| ExamUserCsvAssignOccurrenceData
{ examUserCsvActRegistration :: ExamRegistrationId
, examUserCsvActOccurrence :: Maybe ExamOccurrenceId
}
| ExamUserCsvSetCourseFieldData
{ examUserCsvActCourseParticipant :: CourseParticipantId
, examUserCsvActCourseField :: Maybe StudyFeaturesId
}
| ExamUserCsvDeregisterData
{ examUserCsvActRegistration :: ExamRegistrationId
}
| ExamUserCsvSetResultData
{ examUserCsvActUser :: UserId
, examUserCsvActExamResult :: Maybe (Either ExamResultPassed ExamResultGrade)
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveJSON defaultOptions
{ constructorTagModifier = over Text.packed $ Text.intercalate "-" . map Text.toLower . drop 3 . dropEnd 1 . splitCamel
, fieldLabelModifier = camelToPathPiece' 3
, sumEncoding = TaggedObject "action" "data"
} ''ExamUserCsvAction
data ExamUserCsvException
= ExamUserCsvExceptionNoMatchingUser
| ExamUserCsvExceptionNoMatchingStudyFeatures
| ExamUserCsvExceptionNoMatchingOccurrence
deriving (Show, Generic, Typeable)
instance Exception ExamUserCsvException
embedRenderMessage ''UniWorX ''ExamUserCsvException id
getEUsersR, postEUsersR :: TermId -> SchoolId -> CourseShorthand -> ExamName -> Handler Html
getEUsersR = postEUsersR
postEUsersR tid ssh csh examn = do
(registrationResult, examUsersTable) <- runDB $ do
exam@(Entity eid Exam{..}) <- fetchExam tid ssh csh examn
bonus <- examBonus exam
let
allBoni = (mappend <$> normalSummary <*> bonusSummary) $ fold bonus
showPasses = numSheetsPasses allBoni /= 0
showPoints = getSum (numSheetsPoints allBoni) /= 0
resultView :: ExamResultGrade -> Either ExamResultPassed ExamResultGrade
resultView = bool (Left . over _examResult (view passingGrade)) Right examShowGrades
let
examUsersDBTable = DBTable{..}
where
dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult) = do
E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId)
E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid)
E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
E.on $ courseParticipant E.?. CourseParticipantCourse E.==. E.just (E.val examCourse)
E.&&. courseParticipant E.?. CourseParticipantUser E.==. E.just (user E.^. UserId)
E.on $ occurrence E.?. ExamOccurrenceExam E.==. E.just (E.val eid)
E.&&. occurrence E.?. ExamOccurrenceId E.==. examRegistration E.^. ExamRegistrationOccurrence
E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult)
dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
dbtProj = return
dbtColonnade = mconcat $ catMaybes
[ pure $ dbSelect (applying _2) id $ return . view (resultExamRegistration . _entityKey)
, pure $ colUserNameLink (CourseR tid ssh csh . CUserR)
, pure colUserMatriclenr
, pure $ colField resultStudyField
, pure $ colDegreeShort resultStudyDegree
, pure $ colFeaturesSemester resultStudyFeatures
, pure $ sortable (Just "occurrence") (i18nCell MsgExamOccurrence) $ maybe mempty (anchorCell' (\n -> CExamR tid ssh csh examn EShowR :#: [st|exam-occurrence__#{n}|]) id . examOccurrenceName . entityVal) . view _userTableOccurrence
, guardOn showPasses $ sortable Nothing (i18nCell MsgAchievedPasses) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
SheetGradeSummary{achievedPasses} <- examBonusAchieved uid bonus
SheetGradeSummary{numSheetsPasses} <- examBonusPossible uid bonus
return $ propCell (getSum achievedPasses) (getSum numSheetsPasses)
, guardOn showPoints $ sortable Nothing (i18nCell MsgAchievedPoints) $ \(view $ resultUser . _entityKey -> uid) -> fromMaybe mempty $ do
SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus
SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus
return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints)
, guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult)
, guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade))
]
dbtSorting = Map.fromList
[ sortUserNameLink queryUser
, sortUserMatriclenr queryUser
, sortField queryStudyField
, sortDegreeShort queryStudyDegree
, sortFeaturesSemester queryStudyFeatures
, ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
, ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult))
, ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50])
]
dbtFilter = Map.fromList
[ fltrUserNameEmail queryUser
, fltrUserMatriclenr queryUser
, fltrField queryStudyField
, fltrDegree queryStudyDegree
, fltrFeaturesSemester queryStudyFeatures
, ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
, ("result", FilterColumn . E.mkExactFilterWith Just $ queryExamResult >>> (E.?. ExamResultResult))
, ( "result-bool"
, FilterColumn $ \row criteria -> if
| Set.null criteria -> E.true
| otherwise -> let passed :: [ExamResultGrade]
passed = filter (\res -> preview (_examResult . passingGrade) res == Just (ExamPassed True)) universeF
criteria' = Set.map (fmap $ review passingGrade) criteria
criteria''
| ExamAttended (ExamPassed True) `Set.member` criteria
= criteria' `Set.union` Set.fromList passed
| otherwise
= criteria'
in queryExamResult row E.?. ExamResultResult `E.in_` E.valList (Just <$> Set.toList criteria'')
)
]
dbtFilterUI mPrev = mconcat $ catMaybes
[ Just $ fltrUserNameEmailUI mPrev
, Just $ fltrUserMatriclenrUI mPrev
, Just $ fltrFieldUI mPrev
, Just $ fltrDegreeUI mPrev
, Just $ fltrFeaturesSemesterUI mPrev
, Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence)
, guardOn examShowGrades $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examGradeField) (fslI MsgExamResult)
, guardOn (not examShowGrades) $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examPassedField) (fslI MsgExamResult)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
dbtParams = DBParamsForm
{ dbParamsFormMethod = POST
, dbParamsFormAction = Just . SomeRoute $ CExamR tid ssh csh examn EUsersR
, dbParamsFormAttrs = []
, dbParamsFormSubmit = FormSubmit
, dbParamsFormAdditional = \csrf -> do
let
actionMap :: Map ExamUserAction (AForm Handler ExamUserActionData)
actionMap = Map.fromList
[ ( ExamUserDeregister
, pure ExamUserDeregisterData
)
, ( ExamUserAssignOccurrence
, ExamUserAssignOccurrenceData
<$> aopt (examOccurrenceField eid) (fslI MsgExamOccurrence) (Just Nothing)
)
]
(res, formWgt) <- multiActionM actionMap (fslI MsgAction) Nothing csrf
let formRes = (, mempty) . First . Just <$> res
return (formRes, formWgt)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormResult = id
, dbParamsFormIdent = def
}
dbtIdent :: Text
dbtIdent = "exam-users"
dbtCsvEncode :: DBTCsvEncode ExamUserTableData ExamUserTableCsv
dbtCsvEncode = DictJust . C.map $ ExamUserTableCsv
<$> view (resultUser . _entityVal . _userSurname . to Just)
<*> view (resultUser . _entityVal . _userFirstName . to Just)
<*> view (resultUser . _entityVal . _userDisplayName . to Just)
<*> view (resultUser . _entityVal . _userMatrikelnummer)
<*> preview (resultStudyField . _entityVal . to (\StudyTerms{..} -> studyTermsName <|> studyTermsShorthand <|> Just (tshow studyTermsKey)) . _Just)
<*> preview (resultStudyDegree . _entityVal . to (\StudyDegree{..} -> studyDegreeName <|> studyDegreeShorthand <|> Just (tshow studyDegreeKey)) . _Just)
<*> preview (resultStudyFeatures . _entityVal . _studyFeaturesSemester)
<*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
<*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPoints . _Wrapped)
<*> preview (resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _Just . _achievedPasses . _Wrapped . integral)
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _sumSheetsPoints . _Wrapped)
<*> preview (resultUser . _entityKey . to (examBonusPossible ?? bonus) . _Just . _numSheetsPasses . _Wrapped . integral)
<*> preview (resultExamResult . _entityVal . _examResultResult . to resultView)
dbtCsvDecode = Just DBTCsvDecode
{ dbtCsvRowKey = \csv -> do
uid <- lift $ view _2 <$> guessUser csv
fmap E.Value . MaybeT . getKeyBy $ UniqueExamRegistration eid uid
, dbtCsvComputeActions = \case
DBCsvDiffMissing{dbCsvOldKey}
-> yield . ExamUserCsvDeregisterData $ E.unValue dbCsvOldKey
DBCsvDiffNew{dbCsvNewKey = Just _}
-> fail "An UniqueExamRegistration could be found, but the ExamRegistrationKey is not among the existing keys"
DBCsvDiffNew{dbCsvNewKey = Nothing, dbCsvNew} -> do
(isPart, uid) <- lift $ guessUser dbCsvNew
if
| isPart -> do
yieldM $ ExamUserCsvRegisterData <$> pure uid <*> lookupOccurrence dbCsvNew
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
Just (Entity cpId CourseParticipant{ courseParticipantField = oldFeatures }) <- lift . getBy $ UniqueParticipant uid examCourse
when (newFeatures /= oldFeatures) $
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
| otherwise ->
yieldM $ ExamUserCsvCourseRegisterData uid <$> lookupStudyFeatures dbCsvNew <*> lookupOccurrence dbCsvNew
when (is _Just $ csvEUserExamResult dbCsvNew) $
yield . ExamUserCsvSetResultData uid $ csvEUserExamResult dbCsvNew
DBCsvDiffExisting{..} -> do
newOccurrence <- lift $ lookupOccurrence dbCsvNew
when (newOccurrence /= dbCsvOld ^? resultExamOccurrence . _entityKey) $
yield $ ExamUserCsvAssignOccurrenceData (E.unValue dbCsvOldKey) newOccurrence
newFeatures <- lift $ lookupStudyFeatures dbCsvNew
when (newFeatures /= dbCsvOld ^? resultStudyFeatures . _entityKey) $ do
Just (Entity cpId _) <- lift . getBy . flip UniqueParticipant examCourse $ dbCsvOld ^. resultUser . _entityKey
yield $ ExamUserCsvSetCourseFieldData cpId newFeatures
when (csvEUserExamResult dbCsvNew /= dbCsvOld ^? resultExamResult . _entityVal . _examResultResult . to resultView) $
yield . ExamUserCsvSetResultData (dbCsvOld ^. resultUser . _entityKey) $ csvEUserExamResult dbCsvNew
, dbtCsvClassifyAction = \case
ExamUserCsvCourseRegisterData{} -> ExamUserCsvCourseRegister
ExamUserCsvRegisterData{} -> ExamUserCsvRegister
ExamUserCsvDeregisterData{} -> ExamUserCsvDeregister
ExamUserCsvAssignOccurrenceData{} -> ExamUserCsvAssignOccurrence
ExamUserCsvSetCourseFieldData{} -> ExamUserCsvSetCourseField
ExamUserCsvSetResultData{} -> ExamUserCsvSetResult
, dbtCsvCoarsenActionClass = \case
ExamUserCsvCourseRegister -> DBCsvActionNew
ExamUserCsvRegister -> DBCsvActionNew
ExamUserCsvDeregister -> DBCsvActionMissing
_other -> DBCsvActionExisting
, dbtCsvExecuteActions = do
C.mapM_ $ \case
ExamUserCsvCourseRegisterData{..} -> do
now <- liftIO getCurrentTime
insert_ CourseParticipant
{ courseParticipantCourse = examCourse
, courseParticipantUser = examUserCsvActUser
, courseParticipantRegistration = now
, courseParticipantField = examUserCsvActCourseField
}
User{userIdent} <- getJust examUserCsvActUser
audit' $ TransactionExamRegister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
insert_ ExamRegistration
{ examRegistrationExam = eid
, examRegistrationUser = examUserCsvActUser
, examRegistrationOccurrence = examUserCsvActOccurrence
, examRegistrationTime = now
}
ExamUserCsvRegisterData{..} -> do
examRegistrationTime <- liftIO getCurrentTime
insert_ ExamRegistration
{ examRegistrationExam = eid
, examRegistrationUser = examUserCsvActUser
, examRegistrationOccurrence = examUserCsvActOccurrence
, ..
}
ExamUserCsvAssignOccurrenceData{..} ->
update examUserCsvActRegistration [ ExamRegistrationOccurrence =. examUserCsvActOccurrence ]
ExamUserCsvSetCourseFieldData{..} ->
update examUserCsvActCourseParticipant [ CourseParticipantField =. examUserCsvActCourseField ]
ExamUserCsvSetResultData{..} -> case examUserCsvActExamResult of
Nothing -> deleteBy $ UniqueExamResult eid examUserCsvActUser
Just res -> let res' = either (over _examResult $ review passingGrade) id res
in void $ upsert
(ExamResult eid examUserCsvActUser res')
[ ExamResultResult =. res'
]
ExamUserCsvDeregisterData{..} -> do
ExamRegistration{examRegistrationUser} <- getJust examUserCsvActRegistration
User{userIdent} <- getJust examRegistrationUser
audit' $ TransactionExamDeregister (unTermKey tid) (unSchoolKey ssh) csh examn userIdent
delete examUserCsvActRegistration
return $ CExamR tid ssh csh examn EUsersR
, dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
ExamUserCsvCourseRegisterData{..} -> do
(User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
$maybe features <- examUserCsvActCourseField
, ^{studyFeaturesWidget features}
$nothing
, _{MsgCourseStudyFeatureNone}
$maybe ExamOccurrence{examOccurrenceName} <- occ
\ (#{examOccurrenceName})
$nothing
\ (_{MsgExamNoOccurrence})
|]
ExamUserCsvRegisterData{..} -> do
(User{..}, occ) <- liftHandlerT . runDB $ (,) <$> getJust examUserCsvActUser <*> for examUserCsvActOccurrence getJust
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
$maybe ExamOccurrence{examOccurrenceName} <- occ
\ (#{examOccurrenceName})
$nothing
\ (_{MsgExamNoOccurrence})
|]
ExamUserCsvAssignOccurrenceData{..} -> do
occ <- for examUserCsvActOccurrence $ liftHandlerT . runDB . getJust
[whamlet|
$newline never
^{registeredUserName' examUserCsvActRegistration}
$maybe ExamOccurrence{examOccurrenceName} <- occ
\ (#{examOccurrenceName})
$nothing
\ (_{MsgExamNoOccurrence})
|]
ExamUserCsvSetCourseFieldData{..} -> do
User{..} <- liftHandlerT . runDB $ getJust . courseParticipantUser =<< getJust examUserCsvActCourseParticipant
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
$maybe features <- examUserCsvActCourseField
, ^{studyFeaturesWidget features}
$nothing
, _{MsgCourseStudyFeatureNone}
|]
ExamUserCsvSetResultData{..} -> do
User{..} <- liftHandlerT . runDB $ getJust examUserCsvActUser
[whamlet|
$newline never
^{nameWidget userDisplayName userSurname}
$maybe newResult <- examUserCsvActExamResult
$case newResult
$of Left pResult
, _{pResult}
$of Right gResult
, _{gResult}
$nothing
, _{MsgExamResultNone}
|]
ExamUserCsvDeregisterData{..}
-> registeredUserName' examUserCsvActRegistration
, dbtCsvRenderActionClass = toWidget <=< ap getMessageRender . pure
, dbtCsvRenderException = ap getMessageRender . pure :: ExamUserCsvException -> DB Text
}
where
studyFeaturesWidget :: StudyFeaturesId -> Widget
studyFeaturesWidget featId = do
(StudyFeatures{studyFeaturesSemester}, (degree, terms)) <- liftHandlerT . runDB . ($ featId) . runKleisli $ Kleisli getJust >>> Kleisli return &&& Kleisli (getJust . studyFeaturesDegree) &&& Kleisli (getJust . studyFeaturesField)
[whamlet|
$newline never
_{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
|]
registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget
registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
where
Entity _ User{..} = view resultUser $ existing ! registration
guessUser :: ExamUserTableCsv -> DB (Bool, UserId)
guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do
users <- E.select . E.from $ \user -> do
E.where_ . E.and $ catMaybes
[ (user E.^. UserMatrikelnummer E.==.) . E.val . Just <$> csvEUserMatriculation
, (user E.^. UserDisplayName E.==.) . E.val <$> csvEUserName
, (user E.^. UserSurname E.==.) . E.val <$> csvEUserSurname
, (user E.^. UserFirstName E.==.) . E.val <$> csvEUserFirstName
]
let isCourseParticipant = E.exists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse
E.&&. courseParticipant E.^. CourseParticipantUser E.==. user E.^. UserId
E.limit 2
return (isCourseParticipant, user E.^. UserId)
case users of
(filter . view $ _1 . _Value -> [(E.Value isPart, E.Value uid)])
-> return (isPart, uid)
[(E.Value isPart, E.Value uid)]
-> return (isPart, uid)
_other
-> throwM ExamUserCsvExceptionNoMatchingUser
lookupOccurrence :: ExamUserTableCsv -> DB (Maybe ExamOccurrenceId)
lookupOccurrence ExamUserTableCsv{..} = $cachedHereBinary (CI.foldedCase <$> csvEUserOccurrence) . for csvEUserOccurrence $ \occName -> do
occIds <- selectKeysList [ ExamOccurrenceName ==. occName, ExamOccurrenceExam ==. eid ] []
case occIds of
[occId] -> return occId
_other -> throwM ExamUserCsvExceptionNoMatchingOccurrence
lookupStudyFeatures :: ExamUserTableCsv -> DB (Maybe StudyFeaturesId)
lookupStudyFeatures csv@ExamUserTableCsv{..} = do
uid <- view _2 <$> guessUser csv
studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> do
E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
E.where_ . E.and $ catMaybes
[ do
field <- csvEUserField
return . E.or $ catMaybes
[ Just $ studyTerms E.^. StudyTermsName `E.ciEq` E.just (E.val field)
, Just $ studyTerms E.^. StudyTermsShorthand `E.ciEq` E.just (E.val field)
, (studyTerms E.^. StudyTermsKey E.==.) . E.val <$> readMay field
]
, do
degree <- csvEUserDegree
return . E.or $ catMaybes
[ Just $ studyDegree E.^. StudyDegreeName `E.ciEq` E.just (E.val degree)
, Just $ studyDegree E.^. StudyDegreeShorthand `E.ciEq` E.just (E.val degree)
, (studyDegree E.^. StudyDegreeKey E.==.) . E.val <$> readMay degree
]
, (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester
]
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
E.&&. studyFeatures E.^. StudyFeaturesType E.==. E.val FieldPrimary
E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True
E.limit 2
return $ studyFeatures E.^. StudyFeaturesId
case studyFeatures of
[E.Value fid] -> return $ Just fid
_other
| is _Nothing csvEUserField
, is _Nothing csvEUserDegree
, is _Nothing csvEUserSemester
-> return Nothing
_other -> throwM ExamUserCsvExceptionNoMatchingStudyFeatures
examUsersDBTableValidator = def & defaultSorting [SortAscBy "user-name"]
& defaultPagesize PagesizeAll
postprocess :: FormResult (First ExamUserActionData, DBFormResult ExamRegistrationId Bool ExamUserTableData) -> FormResult (ExamUserActionData, Set ExamRegistrationId)
postprocess inp = do
(First (Just act), regMap) <- inp
let regSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) regMap
return (act, regSet)
over _1 postprocess <$> dbTable examUsersDBTableValidator examUsersDBTable
formResult registrationResult $ \case
(ExamUserDeregisterData, selectedRegistrations) -> do
nrDel <- runDB $ deleteWhereCount
[ ExamRegistrationId <-. Set.toList selectedRegistrations
]
addMessageI Success $ MsgExamUsersDeregistered nrDel
redirect $ CExamR tid ssh csh examn EUsersR
(ExamUserAssignOccurrenceData occId, selectedRegistrations) -> do
nrUpdated <- runDB $ updateWhereCount
[ ExamRegistrationId <-. Set.toList selectedRegistrations
]
[ ExamRegistrationOccurrence =. occId
]
addMessageI Success $ MsgExamUsersOccurrenceUpdated nrUpdated
redirect $ CExamR tid ssh csh examn EUsersR
siteLayoutMsg (prependCourseTitle tid ssh csh MsgExamUsersHeading) $ do
setTitleI $ prependCourseTitle tid ssh csh MsgExamUsersHeading
$(widgetFile "exam-users")

73
src/Handler/Profile.hs
View File

@ -9,9 +9,11 @@ import Utils.Lens
-- import Colonnade hiding (fromMaybe, singleton)
-- import Yesod.Colonnade
import Data.Monoid (Any(..))
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E
-- import Database.Esqueleto ((^.))
@ -26,6 +28,14 @@ data SettingsForm = SettingsForm
, stgNotificationSettings :: NotificationSettings
}
data NotificationTriggerKind = NTKAll | NTKCourseParticipant | NTKCorrector | NTKLecturer | NTKAdmin
deriving (Eq, Ord, Enum, Bounded, Generic, Typeable)
instance Universe NotificationTriggerKind
instance Finite NotificationTriggerKind
embedRenderMessage ''UniWorX ''NotificationTriggerKind $ ("NotificationTriggerKind" <>) . mconcat . drop 1 . splitCamel
makeSettingForm :: Maybe SettingsForm -> Form SettingsForm
makeSettingForm template html = do
(result, widget) <- flip (renderAForm FormStandard) html $ SettingsForm
@ -38,7 +48,7 @@ makeSettingForm template html = do
<*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) (stgDate <$> template)
<*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) (stgTime <$> template)
<* aformSection MsgFormBehaviour
<*> areq checkBoxField (fslI MsgDownloadFiles
<*> apopt checkBoxField (fslI MsgDownloadFiles
& setTooltip MsgDownloadFilesTip
) (stgDownloadFiles <$> template)
<* aformSection MsgFormNotifications
@ -76,9 +86,64 @@ makeSettingForm template html = do
-- nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings
notificationForm template = NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True
where
nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt <$> template)
notificationForm template = wFormToAForm $ do
mbUid <- liftHandlerT maybeAuthId
isAdmin <- hasReadAccessTo AdminR
let
sectionIsHidden :: NotificationTriggerKind -> DB Bool
sectionIsHidden nt
| isAdmin
= return False
| Just uid <- mbUid
, NTKAdmin <- nt
= E.selectExists . E.from $ \userAdmin ->
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
| Just uid <- mbUid
, NTKLecturer <- nt
= E.selectExists . E.from $ \userLecturer ->
E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
| Just uid <- mbUid
, NTKCorrector <- nt
= E.selectExists . E.from $ \sheetCorrector ->
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val uid
| Just uid <- mbUid
, NTKCourseParticipant <- nt
= E.selectExists . E.from $ \courseParticipant ->
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid
| otherwise
= return False
ntHidden <- liftHandlerT . runDB
$ Set.fromList universeF
& Map.fromSet sectionIsHidden
& sequenceA
& fmap (!)
let
nsForm nt
| maybe False ntHidden $ ntSection nt
= pure $ notificationAllowed def nt
| nt `elem` forcedTriggers
= aforced checkBoxField (fslI nt) (notificationAllowed def nt)
| otherwise
= apopt checkBoxField (fslI nt) (flip notificationAllowed nt <$> template)
ntSection = \case
NTSubmissionRatedGraded -> Just NTKCourseParticipant
NTSubmissionRated -> Just NTKCourseParticipant
NTSheetActive -> Just NTKCourseParticipant
NTSheetSoonInactive -> Just NTKCourseParticipant
NTSheetInactive -> Just NTKLecturer
NTCorrectionsAssigned -> Just NTKCorrector
NTCorrectionsNotDistributed -> Just NTKLecturer
NTUserRightsUpdate -> Just NTKAll
NTUserAuthModeUpdate -> Just NTKAll
-- _other -> Nothing
forcedTriggers = [NTUserRightsUpdate, NTUserAuthModeUpdate]
aFormToWForm $ NotificationSettings <$> sectionedFuncForm ntSection nsForm (fslI MsgNotificationSettings) False
data ButtonResetTokens = BtnResetTokens

2
src/Handler/Sheet.hs
View File

@ -899,7 +899,7 @@ correctorInvitationConfig = InvitationConfig{..}
invitationRoute (Entity _ Sheet{..}) _ = do
Course{..} <- get404 sheetCourse
return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
invitationResolveFor = do
invitationResolveFor _ = do
Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute
fetchSheetId tid csh ssh shn
invitationSubject (Entity _ Sheet{..}) _ = do

2
src/Handler/Submission.hs
View File

@ -89,7 +89,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
Course{..} <- getJust sheetCourse
cID <- encrypt subId
return $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SInviteR
invitationResolveFor = do
invitationResolveFor _ = do
Just (CSubmissionR _tid _ssh _csh _shn cID SInviteR) <- getCurrentRoute
subId <- decrypt cID
bool notFound (return subId) =<< existsKey subId

8
src/Handler/Tutorial.hs
View File

@ -1,6 +1,8 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Tutorial where
module Handler.Tutorial
( module Handler.Tutorial
) where
import Import
import Handler.Utils
@ -28,6 +30,8 @@ import Utils.Lens
import Data.Aeson hiding (Result(..))
import Text.Hamlet (ihamlet)
import Handler.Tutorial.Users as Handler.Tutorial
{-# ANN module ("Hlint: ignore Redundant void" :: String) #-}
@ -249,7 +253,7 @@ tutorInvitationConfig = InvitationConfig{..}
invitationRoute (Entity _ Tutorial{..}) _ = do
Course{..} <- get404 tutorialCourse
return $ CTutorialR courseTerm courseSchool courseShorthand tutorialName TInviteR
invitationResolveFor = do
invitationResolveFor _ = do
Just (CTutorialR tid csh ssh tutn TInviteR) <- getCurrentRoute
fetchTutorialId tid csh ssh tutn
invitationSubject (Entity _ Tutorial{..}) _ = do

73
src/Handler/Tutorial/Users.hs Normal file
View File

@ -0,0 +1,73 @@
module Handler.Tutorial.Users
( getTUsersR, postTUsersR
) where
import Import
import Utils.Lens
import Utils.Form
-- import Utils.DB
import Handler.Utils
import Handler.Utils.Tutorial
import Handler.Utils.Table.Columns
import Database.Persist.Sql (deleteWhereCount)
import qualified Data.CaseInsensitive as CI
import Data.Function ((&))
import qualified Data.Set as Set
import qualified Database.Esqueleto as E
import Handler.Course.Users
data TutorialUserAction = TutorialUserSendMail | TutorialUserDeregister
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe TutorialUserAction
instance Finite TutorialUserAction
nullaryPathPiece ''TutorialUserAction $ camelToPathPiece' 2
embedRenderMessage ''UniWorX ''TutorialUserAction id
getTUsersR, postTUsersR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html
getTUsersR = postTUsersR
postTUsersR tid ssh csh tutn = do
(Entity tutid Tutorial{..}, (participantRes, participantTable)) <- runDB $ do
tut@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
let colChoices = mconcat
[ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
, colUserName
, colUserEmail
, colUserMatriclenr
, colUserDegreeShort
, colUserField
, colUserSemester
]
psValidator = def
& defaultSortingByName
& restrictSorting (\name _ -> none (== name) ["note"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
isInTut q = E.exists . E.from $ \tutorialParticipant ->
E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
table <- makeCourseUserTable cid isInTut colChoices psValidator
return (tut, table)
formResult participantRes $ \case
(TutorialUserSendMail, selectedUsers) -> do
cids <- traverse encrypt $ Set.toList selectedUsers :: Handler [CryptoUUIDUser]
redirect (CTutorialR tid ssh csh tutn TCommR, [(toPathPiece GetRecipient, toPathPiece cID) | cID <- cids])
(TutorialUserDeregister,selectedUsers) -> do
nrDel <- runDB $ deleteWhereCount
[ TutorialParticipantTutorial ==. tutid
, TutorialParticipantUser <-. Set.toList selectedUsers
]
addMessageI Success $ MsgTutorialUsersDeregistered nrDel
redirect $ CTutorialR tid ssh csh tutn TUsersR
let heading = prependCourseTitle tid ssh csh $ CI.original tutorialName
siteLayoutMsg heading $ do
setTitleI heading
$(widgetFile "tutorial-participants")

259
src/Handler/Users.hs
View File

@ -1,3 +1,5 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Handler.Users where
import Import
@ -5,6 +7,11 @@ import Import
import Jobs
-- import Data.Text
import Handler.Utils
import Handler.Utils.Tokens
import Handler.Utils.Users
import Handler.Utils.Invitations
import qualified Auth.LDAP as Auth
import Utils.Lens
@ -18,6 +25,13 @@ import qualified Database.Esqueleto.Utils as E
import Handler.Profile (makeProfileData)
import qualified Yesod.Auth.Util.PasswordStore as PWStore
import qualified Data.ByteString.Base64 as Base64
import Text.Hamlet (ihamlet)
import Data.Aeson hiding (Result(..))
hijackUserForm :: CryptoUUIDUser -> Form ()
hijackUserForm cID csrf = do
@ -45,6 +59,7 @@ getUsersR = do
-- , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
-- (AdminUserR <$> encrypt uid)
-- (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
, sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
, sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do
E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool
@ -106,6 +121,9 @@ getUsersR = do
, ( "matriculation"
, SortColumn $ \user -> user E.^. UserMatrikelnummer
)
, ( "auth-ldap"
, SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP
)
]
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates
[ ( "user-search", FilterColumn $ \user (criteria :: Set.Set Text) ->
@ -117,6 +135,12 @@ getUsersR = do
| Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
| otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria
)
, ( "auth-ldap", FilterColumn $ \user (criterion :: Last Bool) -> if
| Just crit <- getLast criterion
-> (user E.^. UserAuthentication E.==. E.val AuthLDAP) E.==. E.val crit
| otherwise
-> E.true
)
, ( "school", FilterColumn $ \user criterion -> if
| Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> let schools = E.valList (Set.toList criterion) in
@ -134,7 +158,7 @@ getUsersR = do
[ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName)
-- , prismAForm (singletonFilter "matriculation" ) mPrev $ aopt textField (fslI MsgMatrikelNr)
, prismAForm (singletonFilter "matriculation" ) mPrev $ aopt matriculationField (fslI MsgMatrikelNr)
, prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` radioFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)
, prismAForm (singletonFilter "school" ) mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
]
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
@ -160,6 +184,18 @@ postAdminHijackUserR cID = do
maybe (redirect UsersR) return ret
data ButtonAuthMode = BtnAuthLDAP | BtnAuthPWHash | BtnPasswordReset
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe ButtonAuthMode
instance Finite ButtonAuthMode
nullaryPathPiece ''ButtonAuthMode $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonAuthMode id
instance Button UniWorX ButtonAuthMode where
btnClasses _ = [BCIsButton]
getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
getAdminUserR = postAdminUserR
postAdminUserR uuid = do
@ -196,9 +232,13 @@ postAdminUserR uuid = do
let result = forM boxRights $ \(Entity sid _, (resAdmin,_), (resLecturer, _)) ->
(,,) <$> pure sid <*> resAdmin <*> resLecturer
return (result,$(widgetFile "widgets/user-rights-form/user-rights-form"))
userAuthenticationForm :: Form ButtonAuthMode
userAuthenticationForm = buttonForm' $ if
| userAuthentication == AuthLDAP -> [BtnAuthPWHash]
| otherwise -> [BtnAuthLDAP, BtnPasswordReset]
let userRightsAction changes = do
void . runDB $
forM changes $ \(sid, userAdmin, userLecturer) ->
runDBJobs $ do
forM_ changes $ \(sid, userAdmin, userLecturer) ->
if Set.notMember sid adminSchools
then return ()
else do
@ -209,21 +249,70 @@ postAdminUserR uuid = do
then void . insertUnique $ UserLecturer uid sid
else deleteBy $ UniqueSchoolLecturer uid sid
-- Note: deleteWhere would not work well here since we filter by adminSchools
queueJob' . JobQueueNotification $ NotificationUserRightsUpdate uid (over _1 (schoolShorthand . entityVal) <$> userRights) -- original rights to check for difference
queueDBJob . JobQueueNotification $ NotificationUserRightsUpdate uid (over _1 (schoolShorthand . entityVal) <$> userRights) -- original rights to check for difference
addMessageI Info MsgAccessRightsSaved
((result, formWidget),formEnctype) <- runFormPost userRightsForm
let form = wrapForm formWidget def
redirect $ AdminUserR uuid
userAuthenticationAction = \case
BtnAuthLDAP -> do
let
campusHandler :: MonadPlus m => Auth.CampusUserException -> m a
campusHandler _ = mzero
campusResult <- runMaybeT . handle campusHandler $ do
(Just pool, Just conf) <- getsYesod $ (,) <$> view _appLdapPool <*> view _appLdapConf
let
campusLogin :: AuthPlugin UniWorX
campusLogin = Auth.campusLogin conf pool
void . Auth.campusUser conf pool $ Creds (apName campusLogin) (CI.original userIdent) []
case campusResult of
Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
_other
| is _AuthLDAP userAuthentication
-> addMessageI Info MsgAuthLDAPAlreadyConfigured
Just () -> do
runDBJobs $ do
update uid [ UserAuthentication =. AuthLDAP ]
queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication
addMessageI Success MsgAuthLDAPConfigured
redirect $ AdminUserR uuid
BtnAuthPWHash -> do
if
| is _AuthPWHash userAuthentication
-> addMessageI Info MsgAuthPWHashAlreadyConfigured
| otherwise
-> do
runDBJobs $ do
update uid [ UserAuthentication =. AuthPWHash "" ]
queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication
queueDBJob $ JobSendPasswordReset uid
addMessageI Success MsgAuthPWHashConfigured
redirect $ AdminUserR uuid
BtnPasswordReset -> do
queueJob' $ JobSendPasswordReset uid
addMessageI Success MsgPasswordResetQueued
redirect $ AdminUserR uuid
((rightsResult, rightsFormWidget),rightsFormEnctype) <- runFormPost userRightsForm
((authResult, authFormWidget),authFormEnctype) <- runFormPost userAuthenticationForm
let rightsForm = wrapForm rightsFormWidget def
{ formAction = Just . SomeRoute $ AdminUserR uuid
, formEncoding = formEnctype
, formEncoding = rightsFormEnctype
}
formResult result userRightsAction
authForm = wrapForm authFormWidget def
{ formAction = Just . SomeRoute $ AdminUserR uuid
, formEncoding = authFormEnctype
, formSubmit = FormNoSubmit
}
formResult rightsResult userRightsAction
formResult authResult userAuthenticationAction
let heading =
[whamlet|_{MsgAccessRightsFor} ^{nameWidget userDisplayName userSurname}|]
[whamlet|_{MsgAdminUserHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|]
-- Delete Button needed in data-delete
(btnWgt, btnEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete)
let btnForm = wrapForm btnWgt def
(deleteWgt, deleteEnctype) <- generateFormPost (identifyForm FIDUserDelete buttonForm :: Form ButtonDelete)
let deleteForm = wrapForm deleteWgt def
{ formAction = Just $ SomeRoute $ AdminUserDeleteR uuid
, formEncoding = btnEnctype
, formEncoding = deleteEnctype
, formSubmit = FormNoSubmit
}
userDataWidget <- runDB $ makeProfileData $ Entity uid user
@ -300,3 +389,149 @@ deleteUser duid = do
E.where_ $ subGroupUser E.^. SubmissionGroupUserSubmissionGroup E.==. submissionGroup E.^. SubmissionGroupId
E.&&. subGroupUser E.^. SubmissionGroupUserUser E.!=. E.val duid
getUserPasswordR, postUserPasswordR :: CryptoUUIDUser -> Handler Html
getUserPasswordR = postUserPasswordR
postUserPasswordR cID = do
tUid <- decrypt cID
User{..} <- runDB $ get404 tUid
PWHashConf{..} <- getsYesod $ view _appAuthPWHash
isModal <- hasCustomHeader HeaderIsModal
isAdmin <- hasWriteAccessTo $ AdminUserR cID
requireCurrent <- maybeT (return True) $ asum
[ False <$ guard (isn't _AuthPWHash userAuthentication)
, False <$ guard isAdmin
, do
authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentTokenRestrictions
unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $
invalidArgsI [MsgUnauthorizedPasswordResetToken]
return False
]
((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . wFormToAForm $ do
currentResult <- if
| AuthPWHash (encodeUtf8 -> pwHash) <- userAuthentication
, requireCurrent
-> wreq
(checkMap (bool (Left MsgCurrentPasswordInvalid) (Right ()) . flip (PWStore.verifyPasswordWith pwHashAlgorithm (2^)) pwHash . encodeUtf8) (const "") passwordField)
(fslI MsgCurrentPassword)
Nothing
| otherwise
-> return $ FormSuccess ()
newResult <- do
resA <- wreq passwordField (fslI MsgNewPassword) Nothing
wreq (checkBool ((== resA) . FormSuccess) MsgPasswordRepeatInvalid passwordField) (fslI MsgNewPasswordRepeat) Nothing
return . fmap encodeUtf8 $ currentResult *> newResult
formResultModal passResult (bool ProfileR (UserPasswordR cID) isAdmin) $ \newPass -> do
newHash <- fmap decodeUtf8 . liftIO $ PWStore.makePasswordWith pwHashAlgorithm newPass pwHashStrength
liftHandlerT . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ]
tell . pure =<< messageI Success MsgPasswordChangedSuccess
siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{nameEmailWidget userEmail userDisplayName userSurname}|] $
wrapForm passFormWidget def
{ formAction = Just . SomeRoute $ UserPasswordR cID
, formEncoding = passEnctype
, formAttrs = [ asyncSubmitAttr | isModal ]
}
instance IsInvitableJunction UserLecturer where
type InvitationFor UserLecturer = School
data InvitableJunction UserLecturer = JunctionUserLecturer
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationDBData UserLecturer = InvDBDataUserLecturer
deriving (Eq, Ord, Read, Show, Generic, Typeable)
data InvitationTokenData UserLecturer = InvTokenDataUserLecturer
{ invTokenUserLecturerSchool :: SchoolShorthand
}
deriving (Eq, Ord, Read, Show, Generic, Typeable)
_InvitableJunction = iso
(\UserLecturer{..} -> (userLecturerUser, userLecturerSchool, JunctionUserLecturer))
(\(userLecturerUser, userLecturerSchool, JunctionUserLecturer) -> UserLecturer{..})
instance ToJSON (InvitableJunction UserLecturer) where
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
instance FromJSON (InvitableJunction UserLecturer) where
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 }
instance ToJSON (InvitationDBData UserLecturer) where
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationDBData UserLecturer) where
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 }
instance ToJSON (InvitationTokenData UserLecturer) where
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
instance FromJSON (InvitationTokenData UserLecturer) where
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 }
lecturerInvitationConfig :: InvitationConfig UserLecturer
lecturerInvitationConfig = InvitationConfig{..}
where
invitationRoute _ _ = return AdminLecturerInviteR
invitationResolveFor InvTokenDataUserLecturer{..} = return $ SchoolKey invTokenUserLecturerSchool
invitationSubject (Entity _ School{..}) _ = return . SomeMessage $ MsgMailSubjectSchoolLecturerInvitation schoolName
invitationHeading (Entity _ School{..}) _ = return . SomeMessage $ MsgMailSchoolLecturerInviteHeading schoolName
invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSchoolLecturerInviteExplanation}|]
invitationTokenConfig _ _ = do
itAuthority <- liftHandlerT requireAuthId
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
invitationRestriction _ _ = return Authorized
invitationForm _ _ _ = pure $ (JunctionUserLecturer, ())
invitationInsertHook _ _ _ _ = id
invitationSuccessMsg (Entity _ School{..}) _ = return . SomeMessage $ MsgSchoolLecturerInvitationAccepted schoolName
invitationUltDest (Entity ssh _) _ = do
currentTerm <- E.select . E.from $ \term -> do
E.where_ $ term E.^. TermActive
E.orderBy [E.desc $ term E.^. TermName]
E.limit 1
return $ term E.^. TermId
return . SomeRoute $ case currentTerm of
[E.Value tid] -> TermSchoolCourseListR tid ssh
_other -> CourseListR
getAdminNewLecturerInviteR, postAdminNewLecturerInviteR :: Handler Html
getAdminNewLecturerInviteR = postAdminNewLecturerInviteR
postAdminNewLecturerInviteR = do
uid <- requireAuthId
userSchools <- runDB . E.select . E.from $ \userAdmin -> do
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
return $ userAdmin E.^. UserAdminSchool
((invitesResult, invitesWgt), invitesEncoding) <- runFormPost . renderWForm FormStandard $ do
school <- wreq (schoolFieldFor $ map E.unValue userSchools) (fslI MsgLecturerInviteSchool) Nothing
users <- wreq (multiUserField False Nothing) (fslI MsgLecturerInviteField & setTooltip MsgMultiEmailFieldTip) Nothing
return $ (,) <$> school <*> users
formResultModal invitesResult UsersR $ \(schoolId, users) -> do
let (emails, uids) = partitionEithers $ Set.toList users
lift . runDBJobs $ do
forM_ uids $ \lecId ->
void . insertUnique $ UserLecturer lecId schoolId
sinkInvitationsF lecturerInvitationConfig [ (mail, schoolId, (InvDBDataUserLecturer, InvTokenDataUserLecturer $ unSchoolKey schoolId)) | mail <- emails ]
unless (null emails) $
tell . pure <=< messageI Success . MsgLecturersInvited $ length emails
unless (null uids) $
tell . pure <=< messageI Success . MsgLecturersAdded $ length uids
siteLayoutMsg MsgLecturerInviteHeading $ do
setTitleI MsgLecturerInviteHeading
wrapForm invitesWgt def
{ formEncoding = invitesEncoding
, formAction = Just $ SomeRoute AdminNewLecturerInviteR
}
getAdminLecturerInviteR, postAdminLecturerInviteR :: Handler Html
getAdminLecturerInviteR = postAdminLecturerInviteR
postAdminLecturerInviteR = invitationR lecturerInvitationConfig

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

@ -855,16 +855,34 @@ boolField = Field
funcForm :: forall k v m.
( Finite k, Ord k
, MonadHandler m
, HandlerSite m ~ UniWorX
)
=> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
sectionedFuncForm :: forall k v m sec.
( Finite k, Ord k
, MonadHandler m
, HandlerSite m ~ UniWorX
, RenderMessage UniWorX sec
, Ord sec
)
=> (k -> Maybe sec) -> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
where
funcForm' :: AForm m (k -> v)
funcForm' = fmap (!) . sequenceA . Map.fromSet mkForm $ Set.fromList universeF
funcForm' = Set.fromList universeF
& foldr (\v -> Map.unionWith Set.union $ Map.singleton (mkSection v) (Set.singleton v)) Map.empty
& fmap (Map.fromSet mkForm)
& fmap sequenceA
& Map.foldrWithKey accSections (pure Map.empty)
& fmap (!)
accSections mSection optsForm acc = wFormToAForm $ do
(res, fs) <- wFormFields $ aFormToWForm optsForm
if
| not $ null fs
, Just section <- mSection
-> wformSection section
| otherwise
-> return ()
lift $ tell fs
aFormToWForm $ Map.union <$> wFormToAForm (pure res) <*> acc
funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX])
funcFieldView (res, fvInput) = do
mr <- getMessageRender
@ -879,6 +897,15 @@ funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAF
-- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
funcForm :: forall k v m.
( Finite k, Ord k
, MonadHandler m
, HandlerSite m ~ UniWorX
)
=> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
funcForm = sectionedFuncForm $ const (Nothing :: Maybe Text)
fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
@ -1000,3 +1027,51 @@ multiUserField onlySuggested suggestions = Field{..}
[] -> return $ Left email
[E.Value uid] -> return $ Right uid
_other -> fail "Ambiguous e-mail addr"
examResultField :: forall m res.
( MonadHandler m
, HandlerSite m ~ UniWorX
, PathPiece res
)
=> Field m res -> Field m (ExamResult' res)
examResultField innerField = Field
{ fieldEnctype = UrlEncoded <> fieldEnctype innerField
, fieldParse = \ts fs -> if
| [t] <- ts
, Just res <- fromPathPiece t
, is _ExamNoShow res || is _ExamVoided res
-> return . Right $ Just res
| otherwise
-> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (not . (`elem` ["attended", "no-show", "voided"])) ts) fs
, fieldView = \theId name attrs val isReq -> do
innerId <- newIdent
let
val' :: ExamResult' (Either Text res)
val' = either (ExamAttended . Left) (fmap Right) val
innerVal :: Either Text res
innerVal = val >>= maybe (Left "") return . preview _ExamAttended
[whamlet|
$newline never
<div>
<select id=#{theId} name=#{name} *{attrs} :isReq:required style="display: inline-block">
<option value="attended" :is _ExamAttended val':selected>_{MsgExamResultAttended}
<option value="no-show" :is _ExamNoShow val':selected>_{MsgExamResultNoShow}
<option value="voided" :is _ExamVoided val':selected>_{MsgExamResultVoided}
<fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{theId} data-conditional-value="attended" style="display: inline-block">
^{fieldView innerField innerId name attrs innerVal False}
|]
}
examGradeField :: forall m.
( MonadHandler m
, HandlerSite m ~ UniWorX
)
=> Field m ExamGrade
examGradeField = hoistField liftHandlerT $ selectField optionsFinite
examPassedField :: forall m.
( MonadHandler m
, HandlerSite m ~ UniWorX
)
=> Field m ExamPassed
examPassedField = hoistField liftHandlerT $ selectField optionsFinite

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

@ -115,10 +115,10 @@ invRef = toJSON . InvRef @junction
data InvitationConfig junction = forall formCtx. InvitationConfig
{ invitationRoute :: Entity (InvitationFor junction) -> InvitationData junction -> DB (Route UniWorX)
-- ^ Which route calls `invitationR` for this kind of invitation?
, invitationResolveFor :: DB (Key (InvitationFor junction))
, invitationResolveFor :: InvitationTokenData junction -> DB (Key (InvitationFor junction))
-- ^ Monadically resolve `InvitationFor` during `inviteR`
--
-- Usually from `requireBearerToken` or `getCurrentRoute`
-- Usually from `getCurrentRoute`
, invitationSubject :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX)
-- ^ Subject of the e-mail which sends the token to the user
, invitationHeading :: Entity (InvitationFor junction) -> InvitationData junction -> DB (SomeMessage UniWorX)
@ -282,12 +282,12 @@ invitationR' :: forall junction m.
-> m Html
-- | Generic handler for incoming invitations
invitationR' InvitationConfig{..} = liftHandlerT $ do
InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return currentTokenRestrictions :: Handler (InvitationTokenRestriction junction)
InvitationTokenRestriction{..} <- maybeM (invalidArgsI [MsgInvitationMissingRestrictions]) return requireCurrentTokenRestrictions :: Handler (InvitationTokenRestriction junction)
invitee <- requireAuthId
Just cRoute <- getCurrentRoute
(tRoute, (dataWidget, dataEnctype), heading, explanation) <- runDB $ do
fEnt@(Entity fid _) <- invitationResolveFor >>= (\k -> Entity k <$> get404 k)
fEnt@(Entity fid _) <- invitationResolveFor itData >>= (\k -> Entity k <$> get404 k)
dbData <- case ephemeralInvitation @junction of
Nothing -> do
Invitation{..} <- entityVal <$> getBy404 (UniqueInvitation itEmail $ invRef @junction fid)

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

@ -934,8 +934,8 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
= handle $ throwM . (DBCsvException (toNamedRecord inpCsv) :: Text -> DBCsvException k') <=< dbtCsvRenderException
| otherwise
= id
in yieldM . doHandle . runConduit $ dbtCsvComputeActions x .| C.fold accActionMap Map.empty
innerAct .| C.foldMap id
in C.sourceList <=< lift . doHandle . runConduit $ dbtCsvComputeActions x .| C.foldMap pure
innerAct .| C.fold accActionMap Map.empty
actionMap <- flip evalStateT Map.empty . runConduit $ sourceDiff .| transPipe lift dbtCsvComputeActions'
when (Map.null actionMap) $ do

19
src/Handler/Utils/Tokens.hs
View File

@ -1,6 +1,6 @@
module Handler.Utils.Tokens
( maybeBearerToken, requireBearerToken
, currentTokenRestrictions
, maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions
) where
import Import
@ -27,8 +27,19 @@ requireBearerToken = liftHandlerT $ do
guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
return token
currentTokenRestrictions :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m, MonadLogger m, FromJSON a, ToJSON a) => m (Maybe a)
currentTokenRestrictions = runMaybeT $ do
maybeCurrentTokenRestrictions, requireCurrentTokenRestrictions :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadCatch m
, MonadLogger m
, FromJSON a
, ToJSON a
)
=> m (Maybe a)
requireCurrentTokenRestrictions = runMaybeT $ do
token <- requireBearerToken
route <- MaybeT getCurrentRoute
hoistMaybe $ preview (_tokenRestrictionIx route) token
hoistMaybe $ token ^? _tokenRestrictionIx route
maybeCurrentTokenRestrictions = runMaybeT $ do
token <- MaybeT maybeBearerToken
route <- MaybeT getCurrentRoute
hoistMaybe $ token ^? _tokenRestrictionIx route

17
src/Handler/Utils/Users.hs Normal file
View File

@ -0,0 +1,17 @@
module Handler.Utils.Users
( computeUserAuthenticationDigest
, Digest, SHA3_256
, constEq
) where
import Import
import Crypto.Hash (Digest, SHA3_256, hashlazy)
import Data.ByteArray (constEq)
import qualified Data.Aeson as JSON
computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
computeUserAuthenticationDigest = hashlazy . JSON.encode

1
src/Jobs.hs
View File

@ -66,6 +66,7 @@ import Jobs.Handler.SetLogSettings
import Jobs.Handler.DistributeCorrections
import Jobs.Handler.SendCourseCommunication
import Jobs.Handler.Invitation
import Jobs.Handler.SendPasswordReset
import Jobs.HealthReport

6
src/Jobs/Handler/QueueNotification.hs
View File

@ -61,13 +61,15 @@ determineNotificationCandidates NotificationUserRightsUpdate{..}
affectedUser <- selectList [UserId ==. nUser] []
-- send to same-school admins only if there was an update
currentAdminSchools <- fmap (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. nUser] []
let oldAdminSchools = [ SchoolKey ssh | (ssh, True, _) <- originalRights ]
let oldAdminSchools = [ SchoolKey ssh | (ssh, True, _) <- nOriginalRights ]
newAdminSchools = currentAdminSchools \\ oldAdminSchools
affectedAdmins <- E.select . E.from $ \(user `E.InnerJoin` admin) -> do
E.on $ admin E.^. UserAdminUser E.==. user E.^. UserId
E.where_ $ admin E.^. UserAdminSchool `E.in_` E.valList newAdminSchools
return user
return $ nub $ affectedUser <> affectedAdmins
determineNotificationCandidates NotificationUserAuthModeUpdate{..}
= selectList [UserId ==. nUser] []
classifyNotification :: Notification -> DB NotificationTrigger
@ -82,5 +84,5 @@ classifyNotification NotificationSheetInactive{} = return NTSheetInactive
classifyNotification NotificationCorrectionsAssigned{} = return NTCorrectionsAssigned
classifyNotification NotificationCorrectionsNotDistributed{} = return NTCorrectionsNotDistributed
classifyNotification NotificationUserRightsUpdate{} = return NTUserRightsUpdate
classifyNotification NotificationUserAuthModeUpdate{} = return NTUserAuthModeUpdate

1
src/Jobs/Handler/SendNotification.hs
View File

@ -13,6 +13,7 @@ import Jobs.Handler.SendNotification.SheetInactive
import Jobs.Handler.SendNotification.CorrectionsAssigned
import Jobs.Handler.SendNotification.CorrectionsNotDistributed
import Jobs.Handler.SendNotification.UserRightsUpdate
import Jobs.Handler.SendNotification.UserAuthModeUpdate
dispatchJobSendNotification :: UserId -> Notification -> Handler ()

26
src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs Normal file
View File

@ -0,0 +1,26 @@
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- ihamletFile discards do results
module Jobs.Handler.SendNotification.UserAuthModeUpdate
( dispatchNotificationUserAuthModeUpdate
) where
import Import
import Utils.Lens
import Handler.Utils.Mail
import Jobs.Handler.SendNotification.Utils
import Text.Hamlet
-- import qualified Data.CaseInsensitive as CI
dispatchNotificationUserAuthModeUpdate :: UserId -> AuthenticationMode -> UserId -> Handler ()
dispatchNotificationUserAuthModeUpdate nUser _nOriginalAuthMode jRecipient = userMailT jRecipient $ do
User{..} <- liftHandlerT . runDB $ getJust nUser
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI MsgMailSubjectUserAuthModeUpdate
editNotifications <- mkEditNotifications jRecipient
addAlternatives $
providePreferredAlternative ($(ihamletFile "templates/mail/userAuthModeUpdate.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

41
src/Jobs/Handler/SendPasswordReset.hs Normal file
View File

@ -0,0 +1,41 @@
module Jobs.Handler.SendPasswordReset
( dispatchJobSendPasswordReset
) where
import Import
import Utils.Lens
import Handler.Utils
import Handler.Utils.Users
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteArray as BA
import qualified Data.HashSet as HashSet
import Text.Hamlet
dispatchJobSendPasswordReset :: UserId
-> Handler ()
dispatchJobSendPasswordReset jRecipient = userMailT jRecipient $ do
cID <- encrypt jRecipient
User{..} <- liftHandlerT . runDB $ getJust jRecipient
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI MsgMailSubjectPasswordReset
now <- liftIO getCurrentTime
let
localNow = utcToLocalTime now
tomorrowEndOfDay = case localTimeToUTC (LocalTime (addDays 2 $ localDay localNow) midnight) of
LTUUnique utc' _ -> utc'
_other -> UTCTime (addDays 2 $ utctDay now) 0
resetToken' <- bearerToken jRecipient (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
let resetToken = resetToken'
& tokenRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
encodedToken <- encodeToken resetToken
resetUrl <- toTextUrl (UserPasswordR cID, [(toPathPiece GetBearer, toPathPiece encodedToken)])
addAlternatives $
providePreferredAlternative ($(ihamletFile "templates/mail/passwordReset.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

5
src/Jobs/Types.hs
View File

@ -46,6 +46,8 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica
, jInvitationSubject :: Text
, jInvitationExplanation :: Html
}
| JobSendPasswordReset { jRecipient :: UserId
}
deriving (Eq, Ord, Show, Read, Generic, Typeable)
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
| NotificationSheetActive { nSheet :: SheetId }
@ -53,7 +55,8 @@ data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
| NotificationSheetInactive { nSheet :: SheetId }
| NotificationCorrectionsAssigned { nUser :: UserId, nSheet :: SheetId }
| NotificationCorrectionsNotDistributed { nSheet :: SheetId }
| NotificationUserRightsUpdate { nUser :: UserId, originalRights :: [(SchoolShorthand,Bool,Bool)] } -- User rights (admin, lecturer,...) were changed somehow
| NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: [(SchoolShorthand,Bool,Bool)] } -- User rights (admin, lecturer,...) were changed somehow
| NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
instance Hashable Job

35
src/Ldap/Client/Pool.hs
View File

@ -10,6 +10,8 @@ module Ldap.Client.Pool
import ClassyPrelude
import Control.Lens
import Ldap.Client (Ldap, LdapError)
import qualified Ldap.Client as Ldap
@ -22,11 +24,17 @@ import Data.Dynamic
import System.Timeout.Lifted
import Control.Concurrent.Async.Lifted.Safe
import Control.Concurrent.Async.Lifted.Safe.Utils
import Control.Monad.Trans.Resource (MonadResource)
import qualified Control.Monad.Trans.Resource as Resource
type LdapPool = Pool LdapExecutor
data LdapExecutor = LdapExecutor
{ ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapPoolError a)
, ldapDestroy :: TMVar ()
, ldapAsync :: Async ()
}
instance Exception LdapError
@ -41,7 +49,7 @@ withLdap :: (MonadBaseControl IO m, MonadIO m, Typeable a) => LdapPool -> (Ldap
withLdap pool act = withResource pool $ \LdapExecutor{..} -> liftIO $ ldapExec act
createLdapPool :: ( MonadLoggerIO m, MonadIO m )
createLdapPool :: ( MonadLoggerIO m, MonadResource m )
=> Ldap.Host
-> Ldap.PortNumber
-> Int -- ^ Stripes
@ -53,15 +61,15 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim
logFunc <- askLoggerIO
let
mkExecutor :: IO LdapExecutor
mkExecutor = do
ldapDestroy <- newEmptyTMVarIO
ldapAct <- newEmptyTMVarIO
mkExecutor :: Resource.InternalState -> IO LdapExecutor
mkExecutor rSt = Resource.runInternalState ?? rSt $ do
ldapDestroy <- liftIO newEmptyTMVarIO
ldapAct <- liftIO newEmptyTMVarIO
let
ldapExec :: forall a. Typeable a => (Ldap -> IO a) -> IO (Either LdapPoolError a)
ldapExec act = do
ldapAnswer <- newEmptyTMVarIO :: IO (TMVar (Either SomeException Dynamic))
ldapAnswer <- liftIO newEmptyTMVarIO :: IO (TMVar (Either SomeException Dynamic))
atomically $ putTMVar ldapAct (fmap toDyn . act, ldapAnswer)
either throwIO (return . Right . flip fromDyn (error "Could not cast dynamic")) =<< atomically (takeTMVar ldapAnswer)
`catches`
@ -91,10 +99,10 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim
]
go Nothing ldap
withTimeout $ do
setup <- newEmptyTMVarIO
ldapAsync <- withTimeout $ do
setup <- liftIO newEmptyTMVarIO
void . fork . flip runLoggingT logFunc $ do
ldapAsync <- allocateAsync . flip runLoggingT logFunc $ do
$logInfoS "LdapExecutor" "Starting"
res <- liftIO . Ldap.with host port $ flip runLoggingT logFunc . go (Just setup)
case res of
@ -105,11 +113,16 @@ createLdapPool host port stripes timeoutConn (round . (* 1e6) -> timeoutAct) lim
maybe (return ()) throwM =<< atomically (takeTMVar setup)
return ldapAsync
return LdapExecutor{..}
delExecutor :: LdapExecutor -> IO ()
delExecutor LdapExecutor{..} = atomically . void $ tryPutTMVar ldapDestroy ()
liftIO $ createPool mkExecutor delExecutor stripes timeoutConn limit
delExecutor LdapExecutor{..} = do
atomically . void $ tryPutTMVar ldapDestroy ()
wait ldapAsync
rSt <- view _2 <$> Resource.allocate Resource.createInternalState Resource.closeInternalState
liftIO $ createPool (mkExecutor rSt) delExecutor stripes timeoutConn limit
where
withTimeout :: forall m a. (MonadBaseControl IO m, MonadThrow m) => m a -> m a
withTimeout = maybe (throwM LdapPoolTimeout) return <=< timeout timeoutAct

33
src/Model/Migration.hs
View File

@ -16,6 +16,10 @@ import qualified Data.Map as Map
import Data.Set ()
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Conduit.List as C
import Database.Persist.Sql
import Database.Persist.Postgresql
@ -61,7 +65,7 @@ share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
migrateAll :: ( MonadLogger m
, MonadBaseControl IO m
, MonadIO m
, MonadResource m
)
=> ReaderT SqlBackend m ()
migrateAll = do
@ -86,7 +90,7 @@ migrateAll = do
requiresMigration :: forall m.
( MonadLogger m
, MonadBaseControl IO m
, MonadIO m
, MonadResource m
)
=> ReaderT SqlBackend m Bool
requiresMigration = mapReaderT (exceptT return return) $ do
@ -117,7 +121,7 @@ getMissingMigrations :: forall m m'.
( MonadLogger m
, MonadBaseControl IO m
, MonadIO m
, MonadIO m'
, MonadResource m'
)
=> ReaderT SqlBackend m (Map (Key AppliedMigration) (ReaderT SqlBackend m' ()))
getMissingMigrations = do
@ -134,8 +138,9 @@ getMissingMigrations = do
-}
customMigrations :: ( MonadIO m
) => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
customMigrations :: forall m.
MonadResource m
=> Map (Key AppliedMigration) (ReaderT SqlBackend m ())
customMigrations = Map.fromListWith (>>)
[ ( AppliedMigrationKey [migrationVersion|initial|] [version|0.0.0|]
, whenM (columnExists "user" "theme") $ do -- New theme format
@ -318,6 +323,24 @@ customMigrations = Map.fromListWith (>>)
ALTER TABLE "exam_occurrence" ALTER COLUMN "name" SET NOT NULL;
|]
)
, ( AppliedMigrationKey [migrationVersion|14.0.0|] [version|15.0.0|]
, whenM (tableExists "user") $ do
[executeQQ|
ALTER TABLE "user" ADD COLUMN "first_name" text NOT NULL DEFAULT '';
ALTER TABLE "user" ADD COLUMN "title" text DEFAULT null;
|]
let getUsers = rawQuery [st|SELECT "id", "display_name", "surname" FROM "user"|] []
updateUser (uid, firstName) = [executeQQ|UPDATE "user" SET "first_name" = #{firstName} WHERE "id" = #{uid}|]
splitFirstName :: [PersistValue] -> Maybe (UserId, Text)
splitFirstName [fromPersistValue -> Right uid, fromPersistValue -> Right displayName, fromPersistValue -> Right surname] = Just . (uid, ) $ if
| Just givenName <- Text.stripSuffix surname displayName
<|> Text.stripPrefix surname displayName
-> Text.strip givenName
| otherwise
-> Text.replace surname "…" displayName
splitFirstName _ = Nothing
runConduit $ getUsers .| C.mapMaybe splitFirstName .| C.mapM_ updateUser
)
]

101
src/Model/Types/Exam.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-|
Module: Model.Types.Exam
@ -11,12 +12,18 @@ module Model.Types.Exam
import Import.NoModel
import Model.Types.Common
import Control.Lens
import qualified Data.Text as Text
import Control.Lens hiding (universe)
import Utils.Lens.TH
import qualified Data.Csv as Csv
data ExamResult' res = ExamAttended { examResult :: res }
| ExamNoShow
| ExamVoided
deriving (Show, Read, Eq, Ord, Generic, Typeable)
deriving (Show, Read, Eq, Ord, Functor, Generic, Typeable)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = camelToPathPiece' 1
@ -25,6 +32,61 @@ deriveJSON defaultOptions
} ''ExamResult'
derivePersistFieldJSON ''ExamResult'
makeLenses_ ''ExamResult'
makePrisms ''ExamResult'
instance PathPiece res => PathPiece (ExamResult' res) where
toPathPiece ExamAttended{..} = toPathPiece examResult
toPathPiece ExamNoShow = "no-show"
toPathPiece ExamVoided = "voided"
fromPathPiece t
| t == "no-show" = Just ExamNoShow
| t == "voided" = Just ExamVoided
| Just examResult <- fromPathPiece t
= Just ExamAttended{..}
| otherwise = Nothing
instance Applicative ExamResult' where
pure = ExamAttended
ExamAttended f <*> ExamAttended x = ExamAttended $ f x
ExamAttended _ <*> ExamNoShow = ExamNoShow
ExamAttended _ <*> ExamVoided = ExamVoided
ExamNoShow <*> _ = ExamNoShow
ExamVoided <*> _ = ExamVoided
instance Semigroup res => Semigroup (ExamResult' res) where
ExamAttended r <> ExamAttended r' = ExamAttended $ r <> r'
ExamVoided <> _ = ExamVoided
_ <> ExamVoided = ExamVoided
_ <> _ = ExamNoShow
instance Monoid res => Monoid (ExamResult' res) where
mempty = ExamAttended mempty
ExamAttended r `mappend` ExamAttended r' = ExamAttended $ r `mappend` r'
ExamVoided `mappend` _ = ExamVoided
_ `mappend` ExamVoided = ExamVoided
_ `mappend` _ = ExamNoShow
instance Csv.ToField res => Csv.ToField (ExamResult' res) where
toField ExamVoided = "voided"
toField ExamNoShow = "no-show"
toField ExamAttended{..} = Csv.toField examResult
instance Csv.FromField res => Csv.FromField (ExamResult' res) where
parseField "voided" = pure ExamVoided
parseField "no-show" = pure ExamNoShow
parseField x = ExamAttended <$> Csv.parseField x
instance Universe res => Universe (ExamResult' res) where
universe = concat
[ pure ExamVoided
, pure ExamNoShow
, ExamAttended <$> universe
]
instance Finite res => Finite (ExamResult' res)
data ExamBonusRule = ExamNoBonus
| ExamBonusPoints
{ bonusMaxPoints :: Points
@ -102,8 +164,11 @@ instance PathPiece ExamGrade where
pathPieceJSON ''ExamGrade
pathPieceJSONKey ''ExamGrade
passingGrade :: ExamGrade -> Bool
passingGrade = (>= Grade40)
instance Csv.ToField ExamGrade where
toField = Csv.toField . toPathPiece
instance Csv.FromField ExamGrade where
parseField x = (parse =<< Csv.parseField x) <|> (parse . Text.replace "," "." =<< Csv.parseField x) -- Ugh.
where parse = maybe (fail "Could not decode PathPiece") return . fromPathPiece
data ExamGradingRule
= ExamGradingManual
@ -118,5 +183,29 @@ deriveJSON defaultOptions
} ''ExamGradingRule
derivePersistFieldJSON ''ExamGradingRule
type ExamResultPoints = ExamResult' (Maybe Points)
type ExamResultGrade = ExamResult' ExamGrade
newtype ExamPassed = ExamPassed { examPassed :: Bool }
deriving (Read, Show, Generic, Typeable)
deriving newtype (Eq, Ord, Enum, Bounded)
deriveFinite ''ExamPassed
finitePathPiece ''ExamPassed ["failed", "passed"]
makeWrapped ''ExamPassed
pathPieceCsv ''ExamPassed
pathPieceJSON ''ExamPassed
pathPieceJSONKey ''ExamPassed
passingGrade :: Iso' ExamGrade ExamPassed
-- ^ Improper isomorphism; maps @ExamPassed True@ to `Grade10`
passingGrade = iso (ExamPassed . (>= Grade40)) (bool Grade50 Grade10 . examPassed)
type ExamResultPoints = ExamResult' Points
type ExamResultGrade = ExamResult' ExamGrade
type ExamResultPassed = ExamResult' ExamPassed
instance Csv.ToField (Either ExamResultPassed ExamResultGrade) where
toField = either Csv.toField Csv.toField
instance Csv.FromField (Either ExamResultPassed ExamResultGrade) where
parseField x = (Left <$> Csv.parseField x) <|> (Right <$> Csv.parseField x) -- encodings are disjoint

4
src/Model/Types/Mail.hs
View File

@ -29,6 +29,7 @@ data NotificationTrigger
| NTCorrectionsAssigned
| NTCorrectionsNotDistributed
| NTUserRightsUpdate
| NTUserAuthModeUpdate
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe NotificationTrigger
@ -54,13 +55,14 @@ newtype NotificationSettings = NotificationSettings { notificationAllowed :: Not
instance Default NotificationSettings where
def = NotificationSettings $ \case
NTSubmissionRatedGraded -> True
NTSubmissionRated -> False
NTSubmissionRated -> True
NTSheetActive -> True
NTSheetSoonInactive -> False
NTSheetInactive -> True
NTCorrectionsAssigned -> True
NTCorrectionsNotDistributed -> True
NTUserRightsUpdate -> True
NTUserAuthModeUpdate -> True
instance ToJSON NotificationSettings where
toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF

4
src/Model/Types/Security.hs
View File

@ -26,6 +26,8 @@ data AuthenticationMode = AuthLDAP
| AuthPWHash { authPWHash :: Text }
deriving (Eq, Ord, Read, Show, Generic)
instance Hashable AuthenticationMode
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
@ -54,6 +56,8 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthRegisterGroup
| AuthEmpty
| AuthSelf
| AuthIsLDAP
| AuthIsPWHash
| AuthAuthentication
| AuthNoEscalation
| AuthRead

1
src/Utils.hs
View File

@ -27,6 +27,7 @@ import Utils.Icon as Utils
import Utils.Message as Utils
import Utils.Lang as Utils
import Utils.Parameters as Utils
import Utils.Csv as Utils
import Control.Concurrent.Async.Lifted.Safe.Utils as Utils
import Text.Blaze (Markup, ToMarkup)

19
src/Utils/Csv.hs Normal file
View File

@ -0,0 +1,19 @@
module Utils.Csv
( pathPieceCsv
) where
import ClassyPrelude
import Data.Csv hiding (Name)
import Language.Haskell.TH (Name)
import Language.Haskell.TH.Lib
pathPieceCsv :: Name -> DecsQ
pathPieceCsv (conT -> t) =
[d|
instance ToField $(t) where
toField = toField . toPathPiece
instance FromField $(t) where
parseField = maybe (fail "Could not unmarshal from PathPiece") return . fromPathPiece <=< parseField
|]

11
src/Utils/Form.hs
View File

@ -25,7 +25,7 @@ import qualified Data.Set as Set
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Writer.Class (MonadWriter(..), censor)
import Control.Monad.State.Class (MonadState(..))
import Control.Monad.Trans.RWS (RWST, execRWST, mapRWST)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
@ -210,6 +210,7 @@ data FormIdentifier
| FIDUserDelete
| FIDCommunication
| FIDAssignSubmissions
| FIDUserAuthMode
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where
@ -616,6 +617,10 @@ fileFieldMultiple = Field
, fieldEnctype = Multipart
}
checkMap :: (Monad m, RenderMessage (HandlerSite m) msg) => (a -> Either msg b) -> (b -> a) -> Field m a -> Field m b
checkMap f = checkMMap (return . f)
-----------
-- Forms --
-----------
@ -915,6 +920,10 @@ infixl 4 `fmapAForm`
fmapAForm :: Functor m => (FormResult a -> FormResult b) -> (AForm m a -> AForm m b)
fmapAForm f (AForm act) = AForm $ \app env ints -> over _1 f <$> act app env ints
wFormFields :: Monad m => WForm m a -> WForm m (a, [FieldView (HandlerSite m)])
-- ^ Suppress side effect of appending `FieldView`s and instead add them to the result
wFormFields = mapRWST (fmap (\((a, s, w'), w) -> ((a, w), s, w')) . censor (const mempty) . listen)
---------------------------------------------
-- Special variants of @mopt@, @mreq@, ... --
---------------------------------------------

3
src/Utils/Lens.hs
View File

@ -140,11 +140,14 @@ makeLenses_ ''PredDNF
makeLenses_ ''ExamBonusRule
makeLenses_ ''ExamGradingRule
makeLenses_ ''ExamResult
makeLenses_ ''UTCTime
makeLenses_ ''ExamOccurrence
makePrisms ''AuthenticationMode
-- makeClassy_ ''Load

2
stack.nix
View File

@ -8,7 +8,7 @@ in pkgs.haskell.lib.buildStackProject {
inherit (haskellPackages) stack;
name = "stackenv";
buildInputs = (with pkgs;
[ postgresql zlib libsodium
[ postgresql zlib libsodium gmp
]) ++ (with haskellPackages;
[ yesod-bin
]);

21
templates/adminUser.hamlet
View File

@ -1,11 +1,18 @@
<section>
^{mailtoHtml userEmail}
^{form}
<section>
^{userDataWidget}
<section>
<h3>
_{MsgAdminUserRightsHeading}
^{rightsForm}
<section>
<h3>
_{MsgAdminUserAuthHeading}
^{authForm}
<section>
<p>
Achtung, dieser Link löscht momentan noch den kompletten Benutzer
unwiderruflich aus der Live-Datenbank mit
<code>DELETE CASCADE uid
\ Klausurdaten müssen jedoch langfristig gespeichert werden!
<p>
^{modal "Benutzer löschen" (Right deleteWidget)}
Achtung, dieser Link löscht momentan noch den kompletten Benutzer
unwiderruflich aus der Live-Datenbank mit
<code>DELETE CASCADE uid
\ Klausurdaten müssen jedoch langfristig gespeichert werden!

6
templates/exam-show.hamlet
View File

@ -12,7 +12,7 @@ $maybe Entity _ ExamResult{examResultResult} <- result
$if examShowGrades
_{grade}
$else
$if passingGrade grade
$if view (passingGrade . _Wrapped) grade
_{MsgExamPassed}
$else
_{MsgExamNotPassed}
@ -148,10 +148,8 @@ $if gradingShown && not (null parts)
<td .table__td>
$case fmap (examPartResultResult . entityVal) (results !? partId)
$of Nothing
$of Just (ExamAttended (Just ps))
$of Just (ExamAttended ps)
#{showFixed True ps}
$of Just (ExamAttended Nothing)
#{iconOK}
$of Just ExamNoShow
_{MsgExamNoShow}
$of Just ExamVoided

15
templates/mail/passwordReset.hamlet Normal file
View File

@ -0,0 +1,15 @@
$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>
<a href=#{resetUrl}>
_{MsgResetPassword}

25
templates/mail/userAuthModeUpdate.hamlet Normal file
View File

@ -0,0 +1,25 @@
$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>
$case userAuthentication
$of AuthLDAP
_{MsgUserAuthModePWHashChangedToLDAP}
$of AuthPWHash _
_{MsgUserAuthModeLDAPChangedToPWHash}
$if is _AuthPWHash userAuthentication
<p>
_{MsgAuthPWHashTip}
<p>
_{MsgPasswordResetEmailIncoming}
^{editNotifications}

4
templates/messages/courseInvitationAlreadyRegistered.hamlet
View File

@ -1,5 +1,5 @@
<h2>
_{MsgCourseParticipantsAlreadyRegistered (length alreadyRegistered)}
_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}
<ul>
$forall email <- alreadyRegistered
$forall email <- aurAlreadyRegistered
<li style="font-family: monospace">#{email}

4
templates/messages/courseInvitationRegisteredWithoutField.hamlet
View File

@ -1,5 +1,5 @@
<h2>
_{MsgCourseParticipantsRegisteredWithoutField (length registeredNoField)}
_{MsgCourseParticipantsRegisteredWithoutField (length aurNoUniquePrimaryField)}
<ul>
$forall email <- registeredNoField
$forall email <- aurNoUniquePrimaryField
<li style="font-family: monospace">#{email}

2
templates/widgets/aform/aform.hamlet
View File

@ -3,7 +3,7 @@ $newline never
$case formLayout
$of FormDBTablePagesize
$forall view <- fieldViews
<div>
<div style="display: inline-block">
<label .form-group-label.label-pagesize for=#{fvId view}>#{fvLabel view}
^{fvInput view}
$of _

2
templates/widgets/data-delete/data-delete.hamlet
View File

@ -24,4 +24,4 @@
(Verbuchte Noten sollten dadurch nicht betroffen sein, aber in einem etwaigen
Streitfall konnen die per Uni2work verwalteten Hausaufgaben dann
auch nicht mehr rekonstruiert/berücksichtigt werden.)
^{btnForm}
^{deleteForm}

12
test/Database.hs
View File

@ -95,6 +95,8 @@ fillDb = do
, userEmail = "G.Kleen@campus.lmu.de"
, userDisplayName = "Gregor Kleen"
, userSurname = "Kleen"
, userFirstName = "Gregor Julius Arthur"
, userTitle = Nothing
, userMaxFavourites = 6
, userTheme = ThemeDefault
, userDateTimeFormat = userDefaultDateTimeFormat
@ -113,6 +115,8 @@ fillDb = do
, userEmail = "felix.hamann@campus.lmu.de"
, userDisplayName = "Felix Hamann"
, userSurname = "Hamann"
, userFirstName = "Felix"
, userTitle = Nothing
, userMaxFavourites = userDefaultMaxFavourites
, userTheme = ThemeDefault
, userDateTimeFormat = userDefaultDateTimeFormat
@ -131,6 +135,8 @@ fillDb = do
, userEmail = "jost@tcs.ifi.lmu.de"
, userDisplayName = "Steffen Jost"
, userSurname = "Jost"
, userFirstName = "Steffen"
, userTitle = Just "Dr."
, userMaxFavourites = 14
, userTheme = ThemeMossGreen
, userDateTimeFormat = userDefaultDateTimeFormat
@ -149,6 +155,8 @@ fillDb = do
, userEmail = "max@campus.lmu.de"
, userDisplayName = "Max Musterstudent"
, userSurname = "Musterstudent"
, userFirstName = "Max"
, userTitle = Nothing
, userMaxFavourites = 7
, userTheme = ThemeAberdeenReds
, userDateTimeFormat = userDefaultDateTimeFormat
@ -167,6 +175,8 @@ fillDb = do
, userEmail = "tester@campus.lmu.de"
, userDisplayName = "Tina Tester"
, userSurname = "von Terror"
, userFirstName = "Sabrina"
, userTitle = Just "Magister"
, userMaxFavourites = 5
, userTheme = ThemeAberdeenReds
, userDateTimeFormat = userDefaultDateTimeFormat
@ -185,6 +195,8 @@ fillDb = do
, userEmail = "vaupel.sarah@campus.lmu.de"
, userDisplayName = "Sarah Vaupel"
, userSurname = "Vaupel"
, userFirstName = "Sarah"
, userTitle = Nothing
, userMaxFavourites = 14
, userTheme = ThemeMossGreen
, userDateTimeFormat = userDefaultDateTimeFormat

2
test/ModelSpec.hs
View File

@ -84,6 +84,8 @@ instance Arbitrary User where
names <- listOf1 $ pack . getPrintableString <$> arbitrary
userDisplayName <- unwords <$> sublistOf names
userSurname <- unwords <$> sublistOf names
userFirstName <- unwords <$> sublistOf names
userTitle <- fmap (pack . getPrintableString) <$> arbitrary
userMaxFavourites <- getNonNegative <$> arbitrary
userTheme <- arbitrary

2
test/TestImport.hs
View File

@ -116,6 +116,8 @@ createUser adjUser = do
userEmail = "dummy@example.invalid"
userDisplayName = "Dummy Example"
userSurname = "Example"
userFirstName = "Dummy"
userTitle = Nothing
userTheme = userDefaultTheme
userMaxFavourites = userDefaultMaxFavourites
userDateTimeFormat = userDefaultDateTimeFormat