diff --git a/ChangeLog.md b/ChangeLog.md index f35e0e155..1e78cad00 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,9 @@ + * Version 20.04.2019 + + Versand von Benachrichtigungen an Kursteilnehmer + + Eintragen von Korrektoren und Kursverwaltern auch ohne bestehenden Account + * Version 27.03.2019 Kurse Veranstalter können nun mehrere Dozenten und Assistenten selbst eintragen diff --git a/config/settings.yml b/config/settings.yml index 3211d42db..287baf0b3 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -27,6 +27,8 @@ notification-rate-limit: 3600 notification-collate-delay: 300 notification-expiration: 259201 session-timeout: 7200 +jwt-expiration: 604800 +jwt-encoding: HS256 maximum-content-length: 52428800 log-settings: diff --git a/haddock.sh b/haddock.sh index aaceeb329..7414e60e8 100755 --- a/haddock.sh +++ b/haddock.sh @@ -1,3 +1,14 @@ #!/usr/bin/env bash -exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal +move-back() { + mv -v .stack-work .stack-work-doc + [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work +} + +if [[ -d .stack-work-doc ]]; then + [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build + mv -v .stack-work-doc .stack-work + trap move-back EXIT +fi + +stack build --fast --flag uniworx:library-only --flag uniworx:dev --haddock --haddock-hyperlink-source --haddock-deps --haddock-internal diff --git a/hlint.sh b/hlint.sh index 0dbb0fa1b..74a2a9fb7 100755 --- a/hlint.sh +++ b/hlint.sh @@ -1,3 +1,3 @@ #!/usr/bin/env bash -exec -- ./test.sh uniworx:test:hlint +exec -- stack build --test --fast --flag uniworx:dev --flag uniworx:library-only uniworx:test:hlint diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index bd11b5726..7a8c55085 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -10,6 +10,11 @@ BtnSave: Speichern BtnCandidatesInfer: Studienfachzuordnung automatisch lernen BtnCandidatesDeleteConflicts: Konflikte löschen BtnCandidatesDeleteAll: Alle Beobachtungen löschen +BtnResetTokens: Authorisierungs-Tokens invalidieren +BtnLecInvAccept: Annehmen +BtnLecInvDecline: Ablehnen +BtnCorrInvAccept: Annehmen +BtnCorrInvDecline: Ablehnen Aborted: Abgebrochen Remarks: Hinweise @@ -114,6 +119,7 @@ CourseUserNoteSaved: Notizänderungen gespeichert CourseUserNoteDeleted: Teilnehmernotiz gelöscht CourseUserDeregister: Abmelden CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet +CourseUserSendMail: Mitteilung verschicken CourseLecturers: Kursverwalter CourseLecturer: Dozent @@ -206,6 +212,13 @@ CorrectorAssignTitle: Korrektor zuweisen Unauthorized: Sie haben hierfür keine explizite Berechtigung. UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) UnauthorizedOr l@Text r@Text: (#{l} ODER #{r}) +UnauthorizedNoToken: Ihrer Anfrage war kein Authorisierungs-Token beigefügt. +UnauthorizedTokenExpired: Ihr Authorisierungs-Token ist abgelaufen. +UnauthorizedTokenNotStarted: Ihr Authorisierungs-Token ist noch nicht gültig. +UnauthorizedTokenInvalid: Ihr Authorisierungs-Token konnte nicht verarbeitet werden. +UnauthorizedTokenInvalidRoute: Ihr Authorisierungs-Token ist auf dieser Unterseite nicht gültig. +UnauthorizedTokenInvalidAuthority: Ihr Authorisierungs-Token basiert auf den Rechten eines Nutzers, der nicht mehr existiert. +UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden. UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen. UnauthorizedAdminEscalation: Sie sind nicht Administrator für alle Institute, für die dieser Nutzer Administrator oder Veranstalter ist. @@ -234,6 +247,7 @@ UnsupportedAuthPredicate authTagT@Text shownRoute@String: "#{authTagT}" wurde au UnauthorizedDisabledTag authTag@AuthTag: Authorisierungsprädikat "#{toPathPiece authTag}" ist für Ihre Sitzung nicht aktiv UnknownAuthPredicate tag@String: Authorisierungsprädikat "#{tag}" ist dem System nicht bekannt UnauthorizedRedirect: Die angeforderte Seite existiert nicht oder Sie haben keine Berechtigung, die angeforderte Seite zu sehen. +UnauthorizedSelf: Aktueller Nutzer ist nicht angegebener Benutzer. EMail: E-Mail EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer. @@ -241,7 +255,7 @@ NotAParticipant email@UserEmail tid@TermId csh@CourseShorthand: #{email} ist nic TooManyParticipants: Es wurden zu viele Mitabgebende angegeben AddCorrector: Zusätzlicher Korrektor -CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen +CorrectorExists: Nutzer ist bereits als Korrektor eingetragen SheetCorrectorsTitle tid@TermId ssh@SchoolId csh@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{csh} #{sheetName} CountTutProp: Tutorien zählen gegen Proportion AutoAssignCorrs: Korrekturen nach Ablauf des Abgabezeitraums automatisch zuteilen @@ -275,6 +289,9 @@ ImpressumHeading: Impressum DataProtHeading: Datenschutzerklärung SystemMessageHeading: Uni2work Statusmeldung SystemMessageListHeading: Uni2work Statusmeldungen +NotificationSettingsHeading displayName@Text: Benachrichtigungs-Einstellungen für #{displayName} +TokensLastReset: Tokens zuletzt invalidiert +TokensResetSuccess: Authorisierungs-Tokens invalidiert HomeOpenCourses: Kurse mit offener Registrierung HomeUpcomingSheets: Anstehende Übungsblätter @@ -291,7 +308,8 @@ Plugin: Plugin Ident: Identifikation LastLogin: Letzter Login Settings: Individuelle Benutzereinstellungen -SettingsUpdate: Einstellungen wurden gespeichert. +SettingsUpdate: Einstellungen erfolgreich gespeichert +NotificationSettingsUpdate: Benachrichtigungs-Einstellungen erfolgreich gespeichert Never: Nie PreviouslyUploadedInfo: Bereits hochgeladene Dateien: @@ -438,9 +456,10 @@ UploadModeNone: Kein Upload UploadModeUnpack: Upload, einzelne Datei UploadModeNoUnpack: Upload, ZIP-Archive entpacken -SheetNoSubmissions: Keine Abgabe -SheetCorrectorSubmissions: Abgabe extern mit Pseudonym -SheetUserSubmissions: Direkte Abgabe +NoSubmissions: Keine Abgabe +CorrectorSubmissions: Abgabe extern mit Pseudonym +UserSubmissions: Direkte Abgabe +BothSubmissions: Abgabe direkt & extern mit Pseudonym SheetCorrectorSubmissionsTip: Abgabe erfolgt über ein Uni2work-externes Verfahren (zumeist in Papierform durch Einwurf) unter Angabe eines persönlichen Pseudonyms. Korrektorn können mithilfe des Pseudonyms später Korrekturergebnisse in Uni2work eintragen, damit Sie sie einsehen können. @@ -515,6 +534,12 @@ MailEditNotifications: Benachrichtigungen ein-/ausschalten MailSubjectSupport: Supportanfrage MailSubjectSupportCustom customSubject@Text: [Support] #{customSubject} +CommCourseSubject: Kursmitteilung +MailSubjectLecturerInvitation tid@TermId ssh@SchoolId csh@CourseShorthand: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Kursverwalter +InvitationAcceptDecline: Einladung annehmen/ablehnen + +MailSubjectCorrectorInvitation tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: [#{display tid}-#{display ssh}-#{csh}] Einladung zum Korrektor für #{shn} + SheetGrading: Bewertung SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten @@ -669,9 +694,11 @@ MenuLogin: Login MenuLogout: Logout MenuCourseList: Kurse MenuCourseMembers: Kursteilnehmer +MenuCourseCommunication: Kursmitteilung MenuTermShow: Semester MenuSubmissionDelete: Abgabe löschen MenuUsers: Benutzer +MenuUserNotifications: Benachrichtigungs-Einstellungen MenuAdminTest: Admin-Demo MenuMessageList: Systemnachrichten MenuAdminErrMsg: Fehlermeldung entschlüsseln @@ -706,6 +733,7 @@ AuthPredsActive: Aktive Authorisierungsprädikate AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert AuthTagFree: Seite ist universell zugänglich AuthTagAdmin: Nutzer ist Administrator +AuthTagToken: Nutzer präsentiert Authorisierungs-Token AuthTagNoEscalation: Nutzer-Rechte werden nicht auf fremde Institute ausgeweitet AuthTagDeprecated: Seite ist nicht überholt AuthTagDevelopment: Seite ist nicht in Entwicklung @@ -721,6 +749,7 @@ AuthTagOwner: Nutzer ist Besitzer AuthTagRated: Korrektur ist bewertet AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren +AuthTagSelf: Nutzer greift nur auf eigene Daten zu AuthTagAuthentication: Nutzer ist angemeldet, falls erforderlich AuthTagRead: Zugriff ist nur lesend AuthTagWrite: Zugriff ist i.A. schreibend @@ -729,9 +758,38 @@ DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n " DeleteConfirmation: Bestätigung DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen. -DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde +DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeilen sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde MassInputAddDimension: Hinzufügen MassInputDeleteCell: Entfernen NavigationFavourites: Favoriten + +CommSubject: Betreff +CommBody: Nachricht +CommRecipients: Empfänger +CommRecipientsTip: Sie selbst erhalten immer eine Kopie der Nachricht +CommDuplicateRecipients n@Int: #{tshow n} #{pluralDE n "doppelter" "doppelte"} Empfänger ignoriert +CommSuccess n@Int: Nachricht wurde an #{tshow n} Empfänger versandt + +CommCourseHeading: Kursmitteilung + +RecipientCustom: Weitere Empfänger + +RGCourseParticipants: Kursteilnehmer +RGCourseLecturers: Kursverwalter +RGCourseCorrectors: Korrektoren + +MultiSelectFieldTip: Mehrfach-Auswahl ist möglich (Umschalt bzw. Strg) +MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Addressen möglich +EmailInvitationWarning: Dem System ist kein Nutzer mit dieser Addresse bekannt. Es wird eine Einladung per E-Mail versandt. + +LecturerInvitationAccepted lType@Text csh@CourseShorthand: Sie wurden als #{lType} für #{csh} eingetragen +LecturerInvitationDeclined csh@CourseShorthand: Sie haben die Einladung, Kursverwalter für #{csh} zu werden, abgelehnt +CourseLecInviteHeading courseName@Text: Einladung zum Kursverwalter für #{courseName} +CourseLecInviteExplanation: Sie wurden eingeladen, Verwalter für einen Kurs zu sein. + +CorrectorInvitationAccepted shn@SheetName: Sie wurden als Korrektor für #{shn} eingetragen +CorrectorInvitationDeclined shn@SheetName: Sie haben die Einladung, Korrektor für #{shn} zu werden, abgelehnt +SheetCorrInviteHeading shn@SheetName: Einladung zum Korrektor für #{shn} +SheetCorrInviteExplanation: Sie wurden eingeladen, Korrektor für ein Übungsblatt zu sein. \ No newline at end of file diff --git a/models/courses b/models/courses index 4fcf67d65..45166d7d5 100644 --- a/models/courses +++ b/models/courses @@ -35,6 +35,12 @@ Lecturer -- course ownership course CourseId type LecturerType default='"lecturer"' UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table +LecturerInvitation json -- preliminary course ownership for when a token to become `Lecturer` is sent to an email + email (CI Text) + course CourseId + type LecturerType Maybe + UniqueLecturerInvitation email course + deriving Eq Ord Read Show Generic Typeable CourseParticipant -- course enrolement course CourseId user UserId diff --git a/models/sheets b/models/sheets index e13fc2d47..293d75b2f 100644 --- a/models/sheets +++ b/models/sheets @@ -10,8 +10,7 @@ Sheet -- exercise sheet for a given course activeTo UTCTime -- Submission is only permitted before hintFrom UTCTime Maybe -- Additional files are made available solutionFrom UTCTime Maybe -- Solution is made available - uploadMode UploadMode -- Take apart Zip-Archives or not? - submissionMode SheetSubmissionMode default='UserSubmissions' -- Submission upload by students or through tutors only? + submissionMode SubmissionMode -- Submission upload by students and/or through tutors? autoDistribute Bool default=false -- Should correctors be assigned submissions automagically? CourseSheet course name deriving Generic @@ -36,6 +35,13 @@ SheetCorrector -- grant corrector role to user for a sheet state CorrectorState default='CorrectorNormal' -- whether a corrector is assigned his load this time (e.g. in case of sickness) UniqueSheetCorrector user sheet deriving Show Eq Ord +SheetCorrectorInvitation json + email UserEmail + sheet SheetId + load Load + state CorrectorState + UniqueSheetCorrectorInvitation email sheet + deriving Show Read Eq Ord Generic Typeable SheetFile -- a file that is part of an exercise sheet sheet SheetId file FileId diff --git a/models/users b/models/users index 80e5ff43c..cd08164d1 100644 --- a/models/users +++ b/models/users @@ -11,6 +11,7 @@ User json -- Each Uni2work user has a corresponding row in this table; create ident (CI Text) -- Case-insensitive user-identifier authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash) lastAuthentication UTCTime Maybe -- last login date + tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null) matrikelnummer Text Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...) email (CI Text) -- Case-insensitive eMail address displayName Text -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained) diff --git a/package.yaml b/package.yaml index c2a1ebf61..47917503c 100644 --- a/package.yaml +++ b/package.yaml @@ -85,6 +85,7 @@ dependencies: - scientific - tz - system-locale + - th-lift - th-lift-instances - gitrev - Glob @@ -117,6 +118,9 @@ dependencies: - lattices - hsass - semigroupoids + - jose-jwt + - mono-traversable + - lens-aeson other-extensions: - GeneralizedNewtypeDeriving diff --git a/routes b/routes index d558de967..0e801e22b 100644 --- a/routes +++ b/routes @@ -16,6 +16,7 @@ -- !registered -- participant for this course (no effect outside of courses) -- !participant -- connected with a given course (not necessarily registered), i.e. has a submission, is a corrector, etc. (no effect outside of courses) -- !owner -- part of the group of owners of this submission +-- !self -- route refers to the currently logged in user themselves -- !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 -- @@ -39,6 +40,7 @@ /users/#CryptoUUIDUser AdminUserR GET POST /users/#CryptoUUIDUser/delete AdminUserDeleteR POST /users/#CryptoUUIDUser/hijack AdminHijackUserR POST !adminANDno-escalation +/users/#CryptoUUIDUser/notifications UserNotificationR GET POST !self /admin AdminR GET /admin/features AdminFeaturesR GET POST /admin/test AdminTestR GET POST @@ -74,10 +76,12 @@ / CShowR GET !free /register CRegisterR POST !timeANDcapacity /edit CEditR GET POST + /lecturer-invite/#UserEmail CLecInviteR GET POST /delete CDeleteR GET POST !lecturerANDempty /users CUsersR GET POST /users/#CryptoUUIDUser CUserR GET POST !lecturerANDparticipant /correctors CHiWisR GET + /communication CCommR GET POST /notes CNotesR GET POST !corrector /subs CCorrectionsR GET POST /ex SheetListR GET !registered !materials !corrector @@ -100,6 +104,7 @@ !/#SubmissionFileType/*FilePath SubDownloadR GET !owner !corrector /correctors SCorrR GET POST /pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions + /corrector-invite/#UserEmail SCorrInviteR GET POST !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector diff --git a/src/Application.hs b/src/Application.hs index 20824d216..5b130dd50 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -101,7 +101,7 @@ mkYesodDispatch "UniWorX" resourcesUniWorX -- the place to put your migrate statements to have automatic database -- migrations handled by Yesod. makeFoundation :: (MonadResource m, MonadBaseControl IO m) => AppSettings -> m UniWorX -makeFoundation appSettings@AppSettings{..} = do +makeFoundation appSettings'@AppSettings{..} = do -- Some basic initializations: HTTP connection manager, logger, and static -- subsite. appHttpManager <- newManager @@ -141,7 +141,7 @@ makeFoundation appSettings@AppSettings{..} = do -- logging function. To get out of this loop, we initially create a -- temporary foundation without a real connection pool, get a log function -- from there, and then create the real foundation. - let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached = UniWorX {..} + let mkFoundation appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet = UniWorX {..} -- The UniWorX {..} syntax is an example of record wild cards. For more -- information, see: -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html @@ -153,13 +153,14 @@ makeFoundation appSettings@AppSettings{..} = do (error "sessionKey forced in tempFoundation") (error "secretBoxKey forced in tempFoundation") (error "widgetMemcached forced in tempFoundation") + (error "JSONWebKeySet forced in tempFoundation") logFunc loc src lvl str = do f <- messageLoggerSource tempFoundation <$> readTVarIO (snd appLogger) f loc src lvl str flip runLoggingT logFunc $ do $logDebugS "InstanceID" $ UUID.toText appInstanceID - -- logDebugS "Configuration" $ tshow appSettings + -- logDebugS "Configuration" $ tshow appSettings' smtpPool <- traverse createSmtpPool appSmtpConf @@ -177,8 +178,9 @@ makeFoundation appSettings@AppSettings{..} = do appCryptoIDKey <- clusterSetting (Proxy :: Proxy 'ClusterCryptoIDKey) `runSqlPool` sqlPool appSessionKey <- clusterSetting (Proxy :: Proxy 'ClusterClientSessionKey) `runSqlPool` sqlPool appSecretBoxKey <- clusterSetting (Proxy :: Proxy 'ClusterSecretBoxKey) `runSqlPool` sqlPool + appJSONWebKeySet <- clusterSetting (Proxy :: Proxy 'ClusterJSONWebKeySet) `runSqlPool` sqlPool - let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached + let foundation = mkFoundation sqlPool smtpPool ldapPool appCryptoIDKey appSessionKey appSecretBoxKey appWidgetMemcached appJSONWebKeySet handleJobs foundation @@ -265,7 +267,7 @@ makeLogWare app = do logger <- readTVarIO . snd $ appLogger app logWare <- mkRequestLogger def { outputFormat = bool - (Apache . bool FromSocket FromHeader . appIpFromHeader $ appSettings app) + (Apache . bool FromSocket FromHeader $ app ^. _appIpFromHeader) (Detailed True) logDetailed , destination = Logger $ loggerSet logger @@ -287,8 +289,8 @@ makeLogWare app = do -- | Warp settings for the given foundation value. warpSettings :: UniWorX -> Settings warpSettings foundation = defaultSettings - & setPort (appPort $ appSettings foundation) - & setHost (appHost $ appSettings foundation) + & setPort (foundation ^. _appPort) + & setHost (foundation ^. _appHost) & setOnException (\_req e -> when (defaultShouldDisplayException e) $ do logger <- readTVarIO . snd $ appLogger foundation @@ -384,6 +386,6 @@ addPWEntry :: User -> Text {-^ Password -} -> IO () addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db $ do - PWHashConf{..} <- getsYesod $ appAuthPWHash . appSettings + PWHashConf{..} <- getsYesod $ view _appAuthPWHash (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength void $ insert User{..} diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 2131bf527..e4c5aee74 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -159,7 +159,7 @@ campusUser conf@LdapConf{..} pool Creds{..} = liftIO . (`catches` errHandlers) $ ] -- ldapConfig :: UniWorX -> LDAPConfig --- ldapConfig _app@(appSettings -> settings) = LDAPConfig +-- ldapConfig _app@(appSettings' -> settings) = LDAPConfig -- { usernameFilter = \u -> principalName <> "=" <> u -- , identifierModifier -- , ldapUri = appLDAPURI settings diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 899047c3b..4914bac78 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -29,6 +29,11 @@ import Data.Aeson (ToJSON(..), ToJSONKey(..), ToJSONKeyFunction(..), FromJSON(.. import Data.Aeson.Encoding (text) +instance {-# OVERLAPPING #-} MonadThrow m => MonadCrypto (ReaderT CryptoIDKey m) where + type MonadCryptoKey (ReaderT CryptoIDKey m) = CryptoIDKey + cryptoIDKey f = ask >>= f + + -- Generates CryptoUUID... and CryptoFileName... Datatypes decCryptoIDs [ ''SubmissionId , ''FileId @@ -53,21 +58,3 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission parseJSON = withText "CryptoFileNameSubmission" $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => FromJSONKey (E.CryptoID namespace (CI FilePath)) where fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not parse CryptoFileNameSubmission") return . fromPathPiece - - -newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission) - deriving (Show, Read, Eq) - -pattern NewSubmission :: SubmissionMode -pattern NewSubmission = SubmissionMode Nothing -pattern ExistingSubmission :: CryptoFileNameSubmission -> SubmissionMode -pattern ExistingSubmission cID = SubmissionMode (Just cID) - -instance PathPiece SubmissionMode where - fromPathPiece "new" = Just $ SubmissionMode Nothing - fromPathPiece s = SubmissionMode . Just <$> fromPathPiece s - - toPathPiece (SubmissionMode Nothing) = "new" - toPathPiece (SubmissionMode (Just x)) = toPathPiece x - - diff --git a/src/Data/Aeson/Types/Instances.hs b/src/Data/Aeson/Types/Instances.hs new file mode 100644 index 000000000..66ff1df61 --- /dev/null +++ b/src/Data/Aeson/Types/Instances.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Aeson.Types.Instances + ( + ) where + +import ClassyPrelude + +import Data.Aeson.Types (Parser, Value) +import Control.Monad.Catch + +import Data.Binary (Binary) + +import Data.HashMap.Strict.Instances () +import Data.Vector.Instances () + + +instance MonadThrow Parser where + throwM = fail . show + + +instance Binary Value diff --git a/src/Data/HashMap/Strict/Instances.hs b/src/Data/HashMap/Strict/Instances.hs new file mode 100644 index 000000000..7d56f03a8 --- /dev/null +++ b/src/Data/HashMap/Strict/Instances.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.HashMap.Strict.Instances + ( + ) where + +import ClassyPrelude + +import Data.Binary (Binary(..)) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap + + +instance (Binary k, Binary v, Hashable k, Eq k) => Binary (HashMap k v) where + put = put . HashMap.toList + get = HashMap.fromList <$> get diff --git a/src/Data/HashSet/Instances.hs b/src/Data/HashSet/Instances.hs new file mode 100644 index 000000000..3fc16cd43 --- /dev/null +++ b/src/Data/HashSet/Instances.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.HashSet.Instances + ( + ) where + +import ClassyPrelude + +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet + +import Data.Binary (Binary(..)) + + +instance (Binary a, Hashable a, Eq a) => Binary (HashSet a) where + get = HashSet.fromList <$> get + put = put . HashSet.toList diff --git a/src/Data/NonNull/Instances.hs b/src/Data/NonNull/Instances.hs new file mode 100644 index 000000000..55981d6ff --- /dev/null +++ b/src/Data/NonNull/Instances.hs @@ -0,0 +1,28 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.NonNull.Instances + ( + ) where + +import ClassyPrelude + +import Data.Aeson + +import Data.Binary (Binary) +import qualified Data.Binary as Binary + + +instance ToJSON a => ToJSON (NonNull a) where + toJSON = toJSON . toNullable + +instance (FromJSON a, MonoFoldable a) => FromJSON (NonNull a) where + parseJSON = parseJSON >=> maybe (fail "Expected non-empty structure") return . fromNullable + + +instance Hashable a => Hashable (NonNull a) where + hashWithSalt s = hashWithSalt s . toNullable + + +instance (Binary a, MonoFoldable a) => Binary (NonNull a) where + get = Binary.get >>= maybe (fail "Expected non-empty structure") return . fromNullable + put = Binary.put . toNullable diff --git a/src/Data/Set/Instances.hs b/src/Data/Set/Instances.hs new file mode 100644 index 000000000..9dc1c48cd --- /dev/null +++ b/src/Data/Set/Instances.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Set.Instances + ( + ) where + +import ClassyPrelude + +import Data.Set (Set) +import qualified Data.Set as Set + + +instance (Ord a, Hashable a) => Hashable (Set a) where + hashWithSalt s xs = hashWithSalt s $ Set.toAscList xs diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs new file mode 100644 index 000000000..1783ac465 --- /dev/null +++ b/src/Data/Time/Clock/Instances.hs @@ -0,0 +1,26 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Time.Clock.Instances + ( + ) where + +import ClassyPrelude + +import Data.Time.Clock + +import Data.Binary (Binary) +import qualified Data.Binary as Binary + + +deriving instance Generic UTCTime + + +instance Binary Day where + get = ModifiedJulianDay <$> Binary.get + put = Binary.put . toModifiedJulianDay + +instance Binary DiffTime where + get = fromRational <$> Binary.get + put = Binary.put . toRational + +instance Binary UTCTime diff --git a/src/Data/Universe/TH.hs b/src/Data/Universe/TH.hs new file mode 100644 index 000000000..1dd097e9f --- /dev/null +++ b/src/Data/Universe/TH.hs @@ -0,0 +1,69 @@ +module Data.Universe.TH + ( finiteEnum + , deriveUniverse + , deriveFinite + ) where + +import Prelude + +import Language.Haskell.TH +import Language.Haskell.TH.Datatype + +import Data.Universe +import Data.Universe.Helpers (interleave) + +import Control.Monad (unless) + +import Data.List (elemIndex) + + +finiteEnum :: Name -> DecsQ +-- ^ Declare generic `Enum`- and `Bounded`-Instances given `Finite`- and `Eq`-Instances +finiteEnum tName = do + DatatypeInfo{..} <- reifyDatatype tName + + let datatype = foldl appT (conT datatypeName) $ map pure datatypeVars + tUniverse = [e|universeF :: [$(datatype)]|] + + [d| + instance Bounded $(datatype) where + minBound = head $(tUniverse) + maxBound = last $(tUniverse) + + instance Enum $(datatype) where + toEnum n + | n >= 0 + , n < length $(tUniverse) + = $(tUniverse) !! n + | otherwise = error $ "toEnum " ++ $(stringE $ nameBase tName) ++ ": out of bounds" + fromEnum = fromMaybe (error $ "fromEnum " ++ $(stringE $ nameBase tName) ++ ": invalid `universeF`") . flip elemIndex $(tUniverse) + + enumFrom x = map toEnum [fromEnum x .. fromEnum (maxBound :: $(datatype))] + enumFromThen x y = map toEnum [fromEnum x, fromEnum y .. fromEnum (maxBound :: $(datatype))] + |] + +deriveUniverse, deriveFinite :: Name -> DecsQ +deriveUniverse = deriveUniverse' [e|interleave|] [e|universe|] +deriveFinite tName = fmap concat . sequence $ + [ deriveUniverse' [e|concat|] [e|universeF|] tName + , do + DatatypeInfo{..} <- reifyDatatype tName + [d|instance Finite $(foldl appT (conT datatypeName) $ map pure datatypeVars)|] + ] + +deriveUniverse' :: ExpQ -> ExpQ -> Name -> DecsQ +deriveUniverse' interleaveExp universeExp tName = do + DatatypeInfo{..} <- reifyDatatype tName + + let datatype = foldl appT (conT datatypeName) $ map pure datatypeVars + consUniverse ConstructorInfo{..} = do + unless (null constructorVars) $ + fail "Constructors with variables no supported" + + foldl (\f t -> [e|ap|] `appE` f `appE` sigE universeExp (listT `appT` t)) [e|pure $(conE constructorName)|] $ map pure constructorFields + + pure <$> instanceD (cxt []) [t|Universe $(datatype)|] + [ funD 'universe + [ clause [] (normalB . appE interleaveExp . listE $ map consUniverse datatypeCons) [] + ] + ] diff --git a/src/Data/Vector/Instances.hs b/src/Data/Vector/Instances.hs new file mode 100644 index 000000000..953130328 --- /dev/null +++ b/src/Data/Vector/Instances.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Vector.Instances + ( + ) where + +import ClassyPrelude + +import Data.Vector (Vector) +import qualified Data.Vector as Vector + +import Data.Binary (Binary) +import qualified Data.Binary as Binary + + +instance Binary a => Binary (Vector a) where + get = Vector.fromList <$> Binary.get + put = Binary.put . Vector.toList diff --git a/src/Database/Persist/TH/Directory.hs b/src/Database/Persist/TH/Directory.hs index 770b71d71..66966913c 100644 --- a/src/Database/Persist/TH/Directory.hs +++ b/src/Database/Persist/TH/Directory.hs @@ -2,26 +2,35 @@ module Database.Persist.TH.Directory ( persistDirectoryWith ) where -import ClassyPrelude hiding (mapM_, toList) +import ClassyPrelude import Database.Persist.TH (parseReferences) import Database.Persist.Quasi (PersistSettings) -import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Syntax hiding (lift) import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified System.IO as SIO +import System.FilePath import qualified System.Directory.Tree as DirTree -import Data.Foldable (Foldable(..), mapM_) +import Control.Monad.Trans.Maybe (MaybeT(MaybeT), runMaybeT) + +import Control.Lens + persistDirectoryWith :: PersistSettings -> FilePath -> Q Exp persistDirectoryWith settings dir = do - files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> do - h <- SIO.openFile fp SIO.ReadMode - SIO.hSetEncoding h SIO.utf8_bom - Text.hGetContents h - mapM_ (qAddDependentFile . fst) $ DirTree.zipPaths files + files <- runIO . flip DirTree.readDirectoryWith dir $ \fp -> runMaybeT $ do + fn <- MaybeT . return . fromNullable $ takeFileName fp + guard . not $ head fn == '.' + guard . not $ head fn == '#' && last fn == '#' + + lift $ do + h <- SIO.openFile fp SIO.ReadMode + SIO.hSetEncoding h SIO.utf8_bom + Text.hGetContents h + mapM_ qAddDependentFile . toListOf (traverse . filtered (has $ _2 . _Just) . _1) $ DirTree.zipPaths files - parseReferences settings . Text.intercalate "\n" . toList $ DirTree.dirTree files + parseReferences settings . Text.intercalate "\n" . toListOf (traverse . _Just) $ DirTree.dirTree files diff --git a/src/Database/Persist/Types/Instances.hs b/src/Database/Persist/Types/Instances.hs new file mode 100644 index 000000000..db5957d54 --- /dev/null +++ b/src/Database/Persist/Types/Instances.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database.Persist.Types.Instances + ( + ) where + +import ClassyPrelude +import Database.Persist.Types + +instance (Hashable record, Hashable (Key record)) => Hashable (Entity record) where + s `hashWithSalt` Entity{..} = s `hashWithSalt` entityKey `hashWithSalt` entityVal diff --git a/src/Foundation.hs b/src/Foundation.hs index f85e69e54..46e176a19 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -43,6 +43,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Map (Map, (!?)) import qualified Data.Map as Map +import qualified Data.HashSet as HashSet import Data.List (nubBy) @@ -55,12 +56,12 @@ import Data.Conduit.List (sourceList) import qualified Database.Esqueleto as E -import Control.Monad.Except (MonadError(..), runExceptT) +import Control.Monad.Except (MonadError(..), ExceptT, runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Reader (runReader, mapReaderT) import Control.Monad.Trans.Writer (WriterT(..), runWriterT) import Control.Monad.Writer.Class (MonadWriter(..)) -import Control.Monad.Memo (MemoT, startEvalMemoT, MonadMemo(..)) +import Control.Monad.Memo.Class (MonadMemo(..), for4) import qualified Control.Monad.Catch as C import Handler.Utils.StudyFeatures @@ -77,6 +78,7 @@ import qualified Yesod.Auth.Message as Auth import qualified Data.Conduit.List as C import qualified Crypto.Saltine.Core.SecretBox as SecretBox +import qualified Jose.Jwk as Jose import qualified Database.Memcached.Binary.IO as Memcached import Data.Bits (Bits(zeroBits)) @@ -96,6 +98,8 @@ instance DisplayAble TermId where instance DisplayAble SchoolId where display = CI.original . unSchoolKey +type SMTPPool = Pool SMTPConnection + -- infixl 9 :$: -- pattern a :$: b = a b @@ -104,7 +108,7 @@ instance DisplayAble SchoolId where -- starts running, such as database connections. Every handler will have -- access to the data present here. data UniWorX = UniWorX - { appSettings :: AppSettings + { appSettings' :: AppSettings , appStatic :: EmbeddedStatic -- ^ Settings for static file serving. , appConnPool :: ConnectionPool -- ^ Database connection pool. , appSmtpPool :: Maybe SMTPPool @@ -119,9 +123,16 @@ data UniWorX = UniWorX , appCronThread :: TMVar (ReleaseKey, ThreadId) , appSessionKey :: ClientSession.Key , appSecretBoxKey :: SecretBox.Key + , appJSONWebKeySet :: Jose.JwkSet } -type SMTPPool = Pool SMTPConnection +makeLenses_ ''UniWorX +instance HasInstanceID UniWorX InstanceId where + instanceID = _appInstanceID +instance HasJSONWebKeySet UniWorX Jose.JwkSet where + jsonWebKeySet = _appJSONWebKeySet +instance HasAppSettings UniWorX where + appSettings = _appSettings' -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: @@ -137,8 +148,10 @@ type SMTPPool = Pool SMTPConnection -- type Widget = WidgetT UniWorX IO () mkYesodData "UniWorX" $(parseRoutesFile "routes") +deriving instance Generic (Route UniWorX) + -- | Convenient Type Synonyms: -type DB a = YesodDB UniWorX a +type DB = YesodDB UniWorX type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) type MsgRenderer = MsgRendererS UniWorX -- see Utils type MailM a = MailT (HandlerT UniWorX IO) a @@ -173,8 +186,9 @@ noneOneMoreDE num noneText singularForm pluralForm | num == 1 = singularForm | otherwise = pluralForm --- Convenience Type for Messages -type IntMaybe = Maybe Int -- Yesod messages cannot deal with compound type identifiers +-- Convenience Type for Messages, since Yesod messages cannot deal with compound type identifiers +type IntMaybe = Maybe Int +type TextList = [Text] -- | Convenience function for i18n messages definitions maybeDisplay :: DisplayAble m => Text -> Maybe m -> Text -> Text @@ -239,9 +253,13 @@ embedRenderMessage ''UniWorX ''RatingException id embedRenderMessage ''UniWorX ''SubmissionSinkException ("SubmissionSinkException" <>) embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>) embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel -embedRenderMessage ''UniWorX ''SheetSubmissionMode ("Sheet" <>) embedRenderMessage ''UniWorX ''EncodedSecretBoxException id embedRenderMessage ''UniWorX ''LecturerType id +embedRenderMessage ''UniWorX ''SubmissionModeDescr + $ let verbMap [_, _, "None"] = "NoSubmissions" + verbMap [_, _, v] = v <> "Submissions" + verbMap _ = error "Invalid number of verbs" + in verbMap . splitCamel newtype SheetTypeHeader = SheetTypeHeader SheetType embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>) @@ -385,25 +403,30 @@ appLanguagesOpts = do -- Access Control +newtype InvalidAuthTag = InvalidAuthTag Text + deriving (Eq, Ord, Show, Read, Generic, Typeable) +instance Exception InvalidAuthTag + + data AccessPredicate - = APPure (Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) - | APHandler (Route UniWorX -> Bool -> Handler AuthResult) - | APDB (Route UniWorX -> Bool -> DB AuthResult) + = APPure (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Reader MsgRenderer AuthResult) + | APHandler (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> Handler AuthResult) + | APDB (Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> DB AuthResult) class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where - evalAccessPred :: AccessPredicate -> Route UniWorX -> Bool -> m AuthResult + evalAccessPred :: AccessPredicate -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult instance {-# INCOHERENT #-} (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where - evalAccessPred aPred r w = liftHandlerT $ case aPred of - (APPure p) -> runReader (p r w) <$> getMsgRenderer - (APHandler p) -> p r w - (APDB p) -> runDB $ p r w + evalAccessPred aPred aid r w = liftHandlerT $ case aPred of + (APPure p) -> runReader (p aid r w) <$> getMsgRenderer + (APHandler p) -> p aid r w + (APDB p) -> runDB $ p aid r w instance (MonadHandler m, HandlerSite m ~ UniWorX, backend ~ YesodPersistBackend UniWorX) => MonadAP (ReaderT backend m) where - evalAccessPred aPred r w = mapReaderT liftHandlerT $ case aPred of - (APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer - (APHandler p) -> lift $ p r w - (APDB p) -> p r w + evalAccessPred aPred aid r w = mapReaderT liftHandlerT $ case aPred of + (APPure p) -> lift $ runReader (p aid r w) <$> getMsgRenderer + (APHandler p) -> lift $ p aid r w + (APDB p) -> p aid r w orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult @@ -424,16 +447,57 @@ trueAR = const Authorized falseAR = Unauthorized . ($ MsgUnauthorized) . render trueAP, falseAP :: AccessPredicate -trueAP = APPure . const . const $ trueAR <$> ask -falseAP = APPure . const . const $ falseAR <$> ask -- included for completeness +trueAP = APPure . const . const . const $ trueAR <$> ask +falseAP = APPure . const . const . const $ falseAR <$> ask -- included for completeness + + +askTokenUnsafe :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadLogger m + , MonadCatch m + ) + => ExceptT AuthResult m (BearerToken (UniWorX)) +-- | This performs /no/ meaningful validation of the `BearerToken` +-- +-- Use `Handler.Utils.Tokens.requireBearerToken` or `Handler.Utils.Tokens.maybeBearerToken` instead +askTokenUnsafe = $cachedHere $ do + jwt <- maybeMExceptT (unauthorizedI MsgUnauthorizedNoToken) askJwt + catch (decodeToken jwt) $ \case + BearerTokenExpired -> throwError =<< unauthorizedI MsgUnauthorizedTokenExpired + BearerTokenNotStarted -> throwError =<< unauthorizedI MsgUnauthorizedTokenNotStarted + other -> do + $logWarnS "AuthToken" $ tshow other + throwError =<< unauthorizedI MsgUnauthorizedTokenInvalid + +validateToken :: Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> BearerToken UniWorX -> DB AuthResult +validateToken mAuthId' route' isWrite' token' = runCachedMemoT $ for4 memo validateToken' mAuthId' route' isWrite' token' + where + validateToken' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult DB AuthResult + validateToken' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do + guardMExceptT (maybe True (HashSet.member route) tokenRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute) + + User{userTokensIssuedAfter} <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthority) $ get tokenAuthority + guardMExceptT (Just tokenIssuedAt >= userTokensIssuedAfter) (unauthorizedI MsgUnauthorizedTokenExpired) + + authorityVal <- do + dnf <- either throwM return $ routeAuthTags route + fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) dnf (Just tokenAuthority) route isWrite + guardExceptT (is _Authorized authorityVal) authorityVal + + whenIsJust tokenAddAuth $ \addDNF -> do + additionalVal <- fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ (/=) AuthToken) addDNF mAuthId route isWrite + guardExceptT (is _Authorized additionalVal) additionalVal + + return Authorized tagAccessPredicate :: AuthTag -> AccessPredicate tagAccessPredicate AuthFree = trueAP -tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of +tagAccessPredicate AuthAdmin = APDB $ \mAuthId route _ -> case route of -- Courses: access only to school admins CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId @@ -445,13 +509,15 @@ tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of return Authorized -- other routes: access to any admin is granted here _other -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId adrights <- lift $ selectFirst [UserAdminUser ==. authId] [] guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin) return Authorized -tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of +tagAccessPredicate AuthToken = APDB $ \mAuthId route isWrite -> exceptT return return $ + lift . validateToken mAuthId route isWrite =<< askTokenUnsafe +tagAccessPredicate AuthNoEscalation = APDB $ \mAuthId route _ -> case route of AdminHijackUserR cID -> exceptT return return $ do - myUid <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + myUid <- maybeExceptT AuthenticationRequired $ return mAuthId uid <- decrypt cID otherSchoolsAdmin <- lift $ Set.fromList . map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. uid] [] otherSchoolsLecturer <- lift $ Set.fromList . map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. uid] [] @@ -459,21 +525,21 @@ tagAccessPredicate AuthNoEscalation = APDB $ \route _ -> case route of guardMExceptT ((otherSchoolsAdmin `Set.union` otherSchoolsLecturer) `Set.isSubsetOf` mySchools) (unauthorizedI MsgUnauthorizedAdminEscalation) return Authorized r -> $unsupportedAuthPredicate AuthNoEscalation r -tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do +tagAccessPredicate AuthDeprecated = APHandler $ \_ r _ -> do $logWarnS "AccessControl" ("deprecated route: " <> tshow r) addMessageI Error MsgDeprecatedRoute - allow <- appAllowDeprecated . appSettings <$> getYesod + allow <- view _appAllowDeprecated return $ bool (Unauthorized "Deprecated Route") Authorized allow -tagAccessPredicate AuthDevelopment = APHandler $ \r _ -> do +tagAccessPredicate AuthDevelopment = APHandler $ \_ r _ -> do $logWarnS "AccessControl" ("route in development: " <> tshow r) #ifdef DEVELOPMENT return Authorized #else return $ Unauthorized "Route under development" #endif -tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of +tagAccessPredicate AuthLecturer = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId @@ -485,11 +551,11 @@ tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of return Authorized -- lecturer for any school will do _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] [] return Authorized -tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId +tagAccessPredicate AuthCorrector = APDB $ \mAuthId route _ -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ return mAuthId resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId @@ -516,7 +582,7 @@ tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do _ -> do guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) return Authorized -tagAccessPredicate AuthTime = APDB $ \route _ -> case route of +tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn @@ -542,8 +608,7 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of CourseR tid ssh csh CRegisterR -> do now <- liftIO getCurrentTime mbc <- getBy $ TermSchoolCourseShort tid ssh csh - mAid <- lift maybeAuthId - registered <- case (mbc,mAid) of + registered <- case (mbc,mAuthId) of (Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid) _ -> return False case mbc of @@ -565,9 +630,9 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of return Authorized r -> $unsupportedAuthPredicate AuthTime r -tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of +tagAccessPredicate AuthRegistered = APDB $ \mAuthId route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId @@ -578,7 +643,7 @@ tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedRegistered) return Authorized r -> $unsupportedAuthPredicate AuthRegistered r -tagAccessPredicate AuthParticipant = APDB $ \route _ -> case route of +tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do let authorizedIfExists f = do [E.Value ok] <- lift . E.select . return . E.exists $ E.from f @@ -640,14 +705,14 @@ tagAccessPredicate AuthParticipant = APDB $ \route _ -> case route of E.&&. course E.^. CourseShorthand E.==. E.val csh unauthorizedI MsgUnauthorizedParticipant r -> $unsupportedAuthPredicate AuthParticipant r -tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of +tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ NTop courseCapacity > NTop (Just registered) return Authorized r -> $unsupportedAuthPredicate AuthCapacity r -tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of +tagAccessPredicate AuthEmpty = APDB $ \_ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh @@ -658,73 +723,81 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of return E.countRows return Authorized r -> $unsupportedAuthPredicate AuthEmpty r -tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of +tagAccessPredicate AuthMaterials = APDB $ \_ route _ -> case route of CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh guard courseMaterialFree return Authorized r -> $unsupportedAuthPredicate AuthMaterials r -tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of +tagAccessPredicate AuthOwner = APDB $ \mAuthId route _ -> case route of CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID - authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + authId <- maybeExceptT AuthenticationRequired $ return mAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid return Authorized r -> $unsupportedAuthPredicate AuthOwner r -tagAccessPredicate AuthRated = APDB $ \route _ -> case route of +tagAccessPredicate AuthRated = APDB $ \_ route _ -> case route of CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sub <- MaybeT $ get sid guard $ submissionRatingDone sub return Authorized r -> $unsupportedAuthPredicate AuthRated r -tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of +tagAccessPredicate AuthUserSubmissions = APDB $ \_ route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn - guard $ sheetSubmissionMode == UserSubmissions + Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn + guard $ is _Just submissionModeUser return Authorized r -> $unsupportedAuthPredicate AuthUserSubmissions r -tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of +tagAccessPredicate AuthCorrectorSubmissions = APDB $ \_ route _ -> case route of CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh - Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn - guard $ sheetSubmissionMode == CorrectorSubmissions + Entity _ Sheet{ sheetSubmissionMode = SubmissionMode{..} } <- MaybeT . getBy $ CourseSheet cid shn + guard submissionModeCorrector return Authorized r -> $unsupportedAuthPredicate AuthCorrectorSubmissions r -tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of +tagAccessPredicate AuthSelf = APHandler $ \mAuthId 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 + CourseR _ _ _ (CUserR cID) -> return cID + _other -> throwError =<< $unsupportedAuthPredicate AuthSelf route + referencedUser' <- decrypt referencedUser + case mAuthId of + Just uid + | uid == referencedUser' -> return Authorized + Nothing -> return AuthenticationRequired + _other -> unauthorizedI MsgUnauthorizedSelf +tagAccessPredicate AuthAuthentication = APDB $ \mAuthId route _ -> case route of MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do smId <- decrypt cID SystemMessage{..} <- MaybeT $ get smId - isAuthenticated <- isJust <$> liftHandlerT maybeAuthId + let isAuthenticated = isJust mAuthId guard $ not systemMessageAuthenticatedOnly || isAuthenticated return Authorized r -> $unsupportedAuthPredicate AuthAuthentication r -tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite) -tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized) +tagAccessPredicate AuthRead = APHandler . const . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite) +tagAccessPredicate AuthWrite = APHandler . const . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized) -newtype InvalidAuthTag = InvalidAuthTag Text - deriving (Eq, Ord, Show, Read, Generic, Typeable) -instance Exception InvalidAuthTag +defaultAuthDNF :: AuthDNF +defaultAuthDNF = PredDNF $ Set.fromList + [ impureNonNull . Set.singleton $ PLVariable AuthAdmin + , impureNonNull . Set.singleton $ PLVariable AuthToken + ] -type DNF a = Set (NonNull (Set a)) - -data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags - deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) -instance Universe SessionAuthTags -instance Finite SessionAuthTags -nullaryPathPiece ''SessionAuthTags (camelToPathPiece' 1) - -routeAuthTags :: Route UniWorX -> Either InvalidAuthTag (NonNull (DNF AuthTag)) +routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF -- ^ DNF up to entailment: -- -- > (A_1 && A_2 && ...) OR' B OR' ... -- -- > A OR' B := ((A |- B) ==> A) && (A || B) -routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.singleton $ Set.singleton AuthAdmin) . routeAttrs +routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs where - partition' :: Set (Set AuthTag) -> Text -> Either InvalidAuthTag (Set (Set AuthTag)) + partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral)) partition' prev t | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t) = if @@ -735,42 +808,63 @@ routeAuthTags = fmap (impureNonNull . Set.mapMonotonic impureNonNull) . ofoldM p | otherwise = Left $ InvalidAuthTag t -evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult +evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> AuthDNF -> Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult -- ^ `tell`s disabled predicates, identified as pivots -evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) route isWrite - = startEvalMemoT $ do - mr <- lift getMsgRenderer +evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . dnfTerms -> authDNF) mAuthId route isWrite + = do + mr <- getMsgRenderer let authTagIsInactive = not . authTagIsActive - evalAuthTag :: AuthTag -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult - evalAuthTag = memo $ \authTag -> lift . lift $ evalAccessPred (tagAccessPredicate authTag) route isWrite + evalAuthTag :: AuthTag -> WriterT (Set AuthTag) m AuthResult + evalAuthTag authTag = lift . (runCachedMemoT :: CachedMemoT (AuthTag, Maybe UserId, Route UniWorX, Bool) AuthResult m _ -> m _) $ for4 memo evalAccessPred' authTag mAuthId route isWrite + where + evalAccessPred' authTag' mAuthId' route' isWrite' = CachedMemoT $ do + $logDebugS "evalAccessPred" $ tshow (authTag', mAuthId', route', isWrite') + evalAccessPred (tagAccessPredicate authTag') mAuthId' route' isWrite' + + evalAuthLiteral :: AuthLiteral -> WriterT (Set AuthTag) m AuthResult + evalAuthLiteral PLVariable{..} = evalAuthTag plVar + evalAuthLiteral PLNegated{..} = evalAuthTag plVar >>= \case + Unauthorized _ -> return Authorized + AuthenticationRequired -> return AuthenticationRequired + Authorized -> unauthorizedI plVar orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult orAR' = shortCircuitM (is _Authorized) (orAR mr) andAR' = shortCircuitM (is _Unauthorized) (andAR mr) - evalDNF :: [[AuthTag]] -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult - evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr) + evalDNF :: [[AuthLiteral]] -> WriterT (Set AuthTag) m AuthResult + evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthLiteral aTag) (return $ trueAR mr) ats) (return $ falseAR mr) - lift . $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF + $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive . plVar) authDNF - result <- evalDNF $ filter (all authTagIsActive) authDNF + result <- evalDNF $ filter (all $ authTagIsActive . plVar) authDNF - unless (is _Authorized result) . forM_ (filter (any authTagIsInactive) authDNF) $ \conj -> - whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do - let pivots = filter authTagIsInactive conj - whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do - lift $ $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|] - lift . tell $ Set.fromList pivots + unless (is _Authorized result) . forM_ (filter (any $ authTagIsInactive . plVar) authDNF) $ \conj -> + whenM (allM conj (\aTag -> (return . not . authTagIsActive $ plVar aTag) `or2M` (not . is _Unauthorized <$> evalAuthLiteral aTag))) $ do + let pivots = filter (authTagIsInactive . plVar) conj + whenM (allM pivots $ fmap (is _Authorized) . evalAuthLiteral) $ do + let pivots' = plVar <$> pivots + $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots'}|] + tell $ Set.fromList pivots' return result +evalAccessFor :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> m AuthResult +evalAccessFor mAuthId route isWrite = do + dnf <- either throwM return $ routeAuthTags route + fmap fst . runWriterT $ evalAuthTags (AuthTagActive $ const True) dnf mAuthId route isWrite + +evalAccessForDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (AuthId UniWorX) -> Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult +evalAccessForDB = evalAccessFor + evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult evalAccess route isWrite = do + mAuthId <- liftHandlerT maybeAuthId tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags dnf <- either throwM return $ routeAuthTags route - (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf route isWrite + (result, deactivated) <- runWriterT $ evalAuthTags tagActive dnf mAuthId route isWrite result <$ tellSessionJson SessionInactiveAuthTags deactivated evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult @@ -796,17 +890,17 @@ instance Yesod UniWorX where -- Controls the base of generated URLs. For more information on modifying, -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot approot = ApprootRequest $ \app req -> - case appRoot $ appSettings app of + case app ^. _appRoot of Nothing -> getApprootText guessApproot app req Just root -> root -- Store session data on the client in encrypted cookies, -- default session idle timeout is 120 minutes - makeSessionBackend UniWorX{appSessionKey,appSettings=AppSettings{appSessionTimeout}} = do - (getCachedDate, _) <- clientSessionDateCacher appSessionTimeout - return . Just $ clientSessionBackend appSessionKey getCachedDate + makeSessionBackend app = do + (getCachedDate, _) <- clientSessionDateCacher (app ^. _appSessionTimeout) + return . Just $ clientSessionBackend (app ^. _appSessionKey) getCachedDate - maximumContentLength UniWorX{appSettings=AppSettings{appMaximumContentLength}} _ = appMaximumContentLength + maximumContentLength app _ = app ^. _appMaximumContentLength -- Yesod Middleware allows you to run code before and after each handler function. -- The defaultYesodMiddleware adds the response header "Vary: Accept, Accept-Language" and performs authorization checks. @@ -865,7 +959,7 @@ instance Yesod UniWorX where encrypted :: ToJSON a => a -> Widget -> Widget encrypted plaintextJson plaintext = do canDecrypt <- (== Authorized) <$> evalAccess AdminErrMsgR True - shouldEncrypt <- getsYesod $ appEncryptErrors . appSettings + shouldEncrypt <- view _appEncryptErrors if | shouldEncrypt , not canDecrypt -> do @@ -906,8 +1000,8 @@ instance Yesod UniWorX where isAuthorized = evalAccess addStaticContent ext _mime content = do - UniWorX{appWidgetMemcached, appSettings} <- getYesod - for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings) $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do + UniWorX{appWidgetMemcached, appSettings'} <- getYesod + for ((,) <$> appWidgetMemcached <*> appWidgetMemcachedConf appSettings') $ \(mConn, WidgetMemcachedConf{ widgetMemcachedConnectInfo = _, .. }) -> do let expiry = (maybe 0 ceiling widgetMemcachedExpiry) touch = liftIO $ Memcached.touch expiry (encodeUtf8 $ pack fileName) mConn add = liftIO $ Memcached.add zeroBits expiry (encodeUtf8 $ pack fileName) content mConn @@ -958,8 +1052,7 @@ siteLayout = siteLayout' . Just siteLayout' :: Maybe Widget -- ^ Optionally override `pageHeading` -> Widget -> Handler Html siteLayout' headingOverride widget = do - master <- getYesod - let AppSettings { appUserDefaults = UserDefaultConf{..}, .. } = appSettings master + AppSettings { appUserDefaults = UserDefaultConf{..}, .. } <- view appSettings isModal <- hasCustomHeader HeaderIsModal @@ -1171,6 +1264,7 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR) breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR) + breadcrumb (CourseR tid ssh csh CCommR ) = return ("Kursmitteilung", Just $ CourseR tid ssh csh CShowR) breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit", Just $ CSheetR tid ssh csh shn SShowR) @@ -1414,6 +1508,16 @@ pageActions (AdminR) = , menuItemAccessCallback' = return True } ] +pageActions (AdminUserR cID) = [ + MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuUserNotifications + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ UserNotificationR cID + , menuItemModal = True + , menuItemAccessCallback' = return True + } + ] pageActions (InfoR) = [ MenuItem { menuItemType = PageActionPrime @@ -1538,6 +1642,14 @@ pageActions (CourseR tid ssh csh CShowR) = , menuItemModal = False , menuItemAccessCallback' = return True } + , MenuItem + { menuItemType = PageActionSecondary + , menuItemLabel = MsgMenuCourseCommunication + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute $ CourseR tid ssh csh CCommR + , menuItemModal = False + , menuItemAccessCallback' = return True + } , MenuItem { menuItemType = PageActionSecondary , menuItemLabel = MsgMenuCourseEdit @@ -1783,7 +1895,7 @@ pageActions (CorrectionsR) = , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId - [E.Value sheetCount] <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ @@ -1792,10 +1904,9 @@ pageActions (CorrectionsR) = isLecturer = E.exists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions - E.&&. ( isCorrector' E.||. isLecturer ) - return E.countRows - return $ (sheetCount :: Int) /= 0 + E.where_ $ isCorrector' E.||. isLecturer + return $ sheet E.^. SheetSubmissionMode + return $ orOf (traverse . _Value . _submissionModeCorrector) sheets } , MenuItem { menuItemType = PageActionPrime @@ -1823,7 +1934,7 @@ pageActions (CorrectionsGradeR) = , menuItemModal = False , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId - [E.Value sheetCount] <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + sheets <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let isCorrector' = E.exists . E.from $ \sheetCorrector -> E.where_ @@ -1832,10 +1943,9 @@ pageActions (CorrectionsGradeR) = isLecturer = E.exists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions - E.&&. ( isCorrector' E.||. isLecturer ) - return E.countRows - return $ (sheetCount :: Int) /= 0 + E.where_ $ isCorrector' E.||. isLecturer + return $ sheet E.^. SheetSubmissionMode + return $ orOf (traverse . _Value . _submissionModeCorrector) sheets } ] pageActions _ = [] @@ -2074,7 +2184,7 @@ instance YesodAuth UniWorX where _other -> return res $logDebugS "auth" $ tshow Creds{..} - UniWorX{ appSettings = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod + UniWorX{ appSettings' = AppSettings{ appUserDefaults = UserDefaultConf{..}, ..}, .. } <- getYesod flip catches excHandlers $ case (,) <$> appLdapConf <*> appLdapPool of Just (ldapConf, ldapPool) -> fmap (either id id) . runExceptT $ do @@ -2129,6 +2239,7 @@ instance YesodAuth UniWorX where , userDownloadFiles = userDefaultDownloadFiles , userNotificationSettings = def , userMailLanguages = def + , userTokensIssuedAfter = Nothing , .. } userUpdate = [ UserMatrikelnummer =. userMatrikelnummer @@ -2193,7 +2304,7 @@ instance YesodAuth UniWorX where where insertMaybe key val = get key >>= maybe (insert_ val) (\_ -> return ()) - authPlugins (UniWorX{ appSettings = AppSettings{..}, appLdapPool }) = catMaybes + authPlugins (UniWorX{ appSettings' = AppSettings{..}, appLdapPool }) = catMaybes [ campusLogin <$> appLdapConf <*> appLdapPool , Just . hashLogin $ pwHashAlgorithm appAuthPWHash , dummyLogin <$ guard appAuthDummyLogin @@ -2218,19 +2329,23 @@ unsafeHandler f h = do instance YesodMail UniWorX where - defaultFromAddress = getsYesod $ appMailFrom . appSettings - mailObjectIdDomain = getsYesod $ appMailObjectDomain . appSettings - mailVerp = getsYesod $ appMailVerp . appSettings + defaultFromAddress = getsYesod $ view _appMailFrom + mailObjectIdDomain = getsYesod $ view _appMailObjectDomain + mailVerp = getsYesod $ view _appMailVerp mailDateTZ = return appTZ mailSmtp act = do pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool withResource pool act mailT ctx mail = defMailT ctx $ do - void setMailObjectId + void setMailObjectIdRandom setDateCurrent - replaceMailHeader "Sender" . Just . addressEmail =<< getsYesod (appMailFrom . appSettings) + replaceMailHeader "Sender" . Just =<< getsYesod (view $ _appMailFrom . _addressEmail) - mail <* setMailSmtpData + (mRes, smtpData) <- listen mail + unless (view _MailSmtpDataSet smtpData) + setMailSmtpData + + return mRes instance (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => MonadCrypto m where diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 4e4b07eee..aba016f41 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -205,7 +205,7 @@ postAdminTestR = do -- The actual call to @massInput@ is comparatively simple: - ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd buttonAction) "" True Nothing + ((miResult, fvInput -> miForm), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd (\_ _ _ -> Set.empty) buttonAction defaultMiLayout) "" True Nothing let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|] @@ -286,9 +286,6 @@ instance Button UniWorX ButtonAdminStudyTerms where btnClasses BtnCandidatesDeleteAll = [BCIsButton, BCDanger] -- END Button needed only here -sessionKeyNewStudyTerms :: Text -sessionKeyNewStudyTerms = "key-new-study-terms" - getAdminFeaturesR, postAdminFeaturesR :: Handler Html getAdminFeaturesR = postAdminFeaturesR postAdminFeaturesR = do @@ -304,7 +301,7 @@ postAdminFeaturesR = do unless (null infAmbiguous) . addMessageI Info . MsgAmbiguousCandidatesRemoved $ length infAmbiguous unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant let newKeys = map (StudyTermsKey' . fst) infAccepted - setSessionJson sessionKeyNewStudyTerms newKeys + setSessionJson SessionNewStudyTerms newKeys if | null infAccepted -> addMessageI Info MsgNoCandidatesInferred | otherwise @@ -322,7 +319,7 @@ postAdminFeaturesR = do Candidates.conflicts _other -> runDB Candidates.conflicts - newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms + newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson SessionNewStudyTerms ( (degreeResult,degreeTable) , (studyTermsResult,studytermsTable) , ((), candidateTable)) <- runDB $ (,,) diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 2a3a2b89a..7de5e6b0d 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -80,9 +80,6 @@ courseIs cid (( course `E.InnerJoin` _sheet `E.InnerJoin` _submission) `E.LeftO sheetIs :: Key Sheet -> CorrectionTableWhere sheetIs shid ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetId E.==. E.val shid -submissionModeIs :: SheetSubmissionMode -> CorrectionTableWhere -submissionModeIs sMode ((_course `E.InnerJoin` sheet `E.InnerJoin` _submission) `E.LeftOuterJoin` _corrector) = sheet E.^. SheetSubmissionMode E.==. E.val sMode - -- Columns colTerm :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) @@ -350,7 +347,7 @@ correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormSubmit , dbParamsFormAdditional = \frag -> do - (actionRes, action) <- multiAction actions Nothing + (actionRes, action) <- multiActionM actions "" Nothing mempty return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action) , dbParamsFormEvaluate = liftHandlerT . runFormPost , dbParamsFormResult = _1 @@ -702,7 +699,7 @@ getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html getCorrectionsUploadR = postCorrectionsUploadR postCorrectionsUploadR = do ((uploadRes, upload), uploadEncoding) <- runFormPost . identifyForm FIDcorrectionsUpload . renderAForm FormStandard $ - areq (zipFileField True) (fslI MsgCorrUploadField) Nothing + areq (zipFileField True) (fslI MsgCorrUploadField & addAttr "uw-file-input" "") Nothing case uploadRes of FormMissing -> return () @@ -733,7 +730,7 @@ getCorrectionsCreateR, postCorrectionsCreateR :: Handler Html getCorrectionsCreateR = postCorrectionsCreateR postCorrectionsCreateR = do uid <- requireAuthId - let sheetOptions = mkOptList <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do + let sheetOptions = mkOptList . toListOf (traverse . filtered (view $ _1 . _Value . _submissionModeCorrector) . _2) <=< runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse let isCorrector = E.exists . E.from $ \sheetCorrector -> E.where_ @@ -742,10 +739,9 @@ postCorrectionsCreateR = do isLecturer = E.exists . E.from $ \lecturer -> E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid E.&&. lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.where_ $ sheet E.^. SheetSubmissionMode E.==. E.val CorrectorSubmissions - E.&&. ( isCorrector E.||. isLecturer ) + E.where_ $ isCorrector E.||. isLecturer E.orderBy [E.desc $ course E.^. CourseTerm, E.asc $ course E.^. CourseShorthand, E.desc $ sheet E.^. SheetActiveFrom] - return (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName) + return (sheet E.^. SheetSubmissionMode, (sheet E.^. SheetId, course E.^. CourseTerm, course E.^. CourseShorthand, sheet E.^. SheetName)) mkOptList :: [(E.Value SheetId, E.Value TermId, E.Value CourseShorthand, E.Value SheetName)] -> Handler (OptionList SheetId) mkOptList opts = do opts' <- mapM (\v@(E.Value sid, _, _, _) -> (, v) <$> encrypt sid) opts diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 98016ca8e..5697b7bd4 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -9,6 +9,7 @@ import Utils.Form -- import Utils.DB import Handler.Utils import Handler.Utils.Course +import Handler.Utils.Communication import Handler.Utils.Form.MassInput import Handler.Utils.Delete import Handler.Utils.Database @@ -27,12 +28,15 @@ import Data.Monoid (Last(..)) 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 Text.Blaze.Html.Renderer.Text (renderHtml) +import Jobs.Queue + -- NOTE: Outdated way to use dbTable; see ProfileDataR Handler for a more recent method. type CourseTableData = DBRow (Entity Course, Int, Bool, Entity School) @@ -416,7 +420,7 @@ getCourseNewR = do return course template <- case listToMaybe oldCourses of (Just oldTemplate) -> - let newTemplate = courseToForm oldTemplate [] in + 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 @@ -445,13 +449,14 @@ postCEditR = pgCEditR pgCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html pgCEditR tid ssh csh = do - courseLecs <- runDB $ do - mbCourse <- getBy (TermSchoolCourseShort tid ssh csh) - mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType] - return $ (,) <$> mbCourse <*> mbLecs + courseData <- runDB $ do + mbCourse <- getBy (TermSchoolCourseShort tid ssh csh) + mbLecs <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerCourse ==. entityKey course] [Asc LecturerType] + mbLecInvites <- for mbCourse $ \course -> map entityVal <$> selectList [LecturerInvitationCourse ==. entityKey course] [Asc LecturerInvitationType] + 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) $ uncurry courseToForm <$> courseLecs + courseEditHandler (\p -> Just . SomeRoute $ CourseR tid ssh csh CEditR :#: p) $ $(uncurryN 3) courseToForm <$> courseData getCDeleteR, postCDeleteR :: TermId -> SchoolId -> CourseShorthand -> Handler Html @@ -479,7 +484,7 @@ courseEditHandler miButtonAction mbCourseForm = do , cfTerm = tid } -> do -- create new course now <- liftIO getCurrentTime - insertOkay <- runDB $ do + insertOkay <- runDBJobs $ do insertOkay <- insertUnique Course { courseName = cfName res , courseDescription = cfDesc res @@ -495,7 +500,11 @@ courseEditHandler miButtonAction mbCourseForm = do , courseDeregisterUntil = cfDeRegUntil res } whenIsJust insertOkay $ \cid -> do - forM_ (cfLecturers res) (\(lid,lty) -> insert_ $ Lecturer lid cid lty) + forM_ (cfLecturers res) $ \case + Right (lid, lty) -> insert_ $ Lecturer lid cid lty + Left (lEmail, mLTy) -> do + insert_ $ LecturerInvitation lEmail cid mLTy + queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy insert_ $ CourseEdit aid now cid return insertOkay case insertOkay of @@ -513,7 +522,7 @@ courseEditHandler miButtonAction mbCourseForm = do } -> do -- edit existing course now <- liftIO getCurrentTime -- addMessage "debug" [shamlet| #{show res}|] - success <- runDB $ do + success <- runDBJobs $ do old <- get cid case old of Nothing -> addMessageI Error MsgInvalidInput $> False @@ -536,7 +545,16 @@ courseEditHandler miButtonAction mbCourseForm = do (Just _) -> addMessageI Warning (MsgCourseEditDupShort tid ssh csh) $> False Nothing -> do deleteWhere [LecturerCourse ==. cid] - forM_ (cfLecturers res) (\(lid,lty) -> insert_ $ Lecturer lid cid lty) + deleteWhere [LecturerInvitationCourse ==. cid, LecturerInvitationEmail /<-. toListOf (folded . _Left . _1) (cfLecturers res)] + forM_ (cfLecturers res) $ \case + Right (lid, lty) -> insert_ $ Lecturer lid cid lty + Left (lEmail, mLTy) -> do + insertRes <- insertUnique (LecturerInvitation lEmail cid mLTy) + case insertRes of + Just _ -> + queueDBJob . JobLecturerInvitation aid $ LecturerInvitation lEmail cid mLTy + Nothing -> + updateBy (UniqueLecturerInvitation lEmail cid) [ LecturerInvitationType =. mLTy ] insert_ $ CourseEdit aid now cid addMessageI Success $ MsgCourseEditOk tid ssh csh return True @@ -564,11 +582,11 @@ data CourseForm = CourseForm , cfRegFrom :: Maybe UTCTime , cfRegTo :: Maybe UTCTime , cfDeRegUntil :: Maybe UTCTime - , cfLecturers :: [(UserId, LecturerType)] + , cfLecturers :: [Either (UserEmail, Maybe LecturerType) (UserId, LecturerType)] } -courseToForm :: Entity Course -> [Lecturer] -> CourseForm -courseToForm (Entity cid Course{..}) lecs = CourseForm +courseToForm :: Entity Course -> [Lecturer] -> [LecturerInvitation] -> CourseForm +courseToForm (Entity cid Course{..}) lecs lecInvites = CourseForm { cfCourseId = Just cid , cfName = courseName , cfDesc = courseDescription @@ -582,7 +600,8 @@ courseToForm (Entity cid Course{..}) lecs = CourseForm , cfRegFrom = courseRegisterFrom , cfRegTo = courseRegisterTo , cfDeRegUntil = courseDeregisterUntil - , cfLecturers = [(lecturerUser, lecturerType) | Lecturer{..} <- lecs] + , cfLecturers = [Right (lecturerUser, lecturerType) | Lecturer{..} <- lecs] + ++ [Left (lecturerInvitationEmail, lecturerInvitationType) | LecturerInvitation{..} <- lecInvites ] } makeCourseForm :: (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)) -> Maybe CourseForm -> Form CourseForm @@ -609,29 +628,30 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do | otherwise -> termsSetField [cfTerm cform] _allOtherCases -> return termsAllowedField - let miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition UserId -> FormResult (Map ListPosition UserId))) + 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 (email, Nothing) -> FormFailure [ mr . MsgEMailUnknown $ CI.mk email ] - FormSuccess (email, Just lid) -> FormSuccess $ \prev -> if - | lid `elem` Map.elems prev -> FormFailure [ mr . MsgCourseLecturerAlreadyAdded $ CI.mk email ] - | otherwise -> FormSuccess $ Map.singleton (maybe 0 succ . fmap fst $ Map.lookupMax prev) lid + 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' = toWidget csrf >> fvInput addView >> fvInput btn + addView' = $(widgetFile "course/lecturerMassInput/add") return (addRes'', addView') - miCell :: ListPosition -> UserId -> Maybe LecturerType -> (Text -> Text) -> Form LecturerType - miCell _ lid defType nudge = \csrf -> do - (lrwRes,lrwView) <- mreq (selectField optionsFinite) ("" & addName (nudge "lecturer-type")) defType + 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' = [whamlet|$newline never - #{csrf} - ^{nameEmailWidget userEmail userDisplayName userSurname} # - ^{fvInput lrwView} - |] + 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 :: ListLength -- ^ Current shape @@ -642,14 +662,34 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse $ \html -> do miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool miAllowAdd _ _ _ = True + miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition + miAddEmpty _ _ _ = Set.empty - lecturerForm :: AForm Handler [(UserId,LecturerType)] - lecturerForm = formToAForm . over (mapped._2) pure . over (mapped._1.mapped) Map.elems $ massInput + 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") + + + 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 MsgCourseLecturerRightsIdentical) True - (Just . Map.fromList . zip [0..] $ maybe [(uid, CourseLecturer)] cfLecturers template) + (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) @@ -717,7 +757,7 @@ validateCourse CourseForm{..} = do ( NTop cfRegFrom <= NTop cfDeRegUntil , MsgCourseDeregistrationEndMustBeAfterStart ) - , ( maybe (any ((== uid) . fst) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin + , ( maybe (anyOf (traverse . _Right . _1) (== uid) cfLecturers) (\(Entity _ UserAdmin{}) -> True) userAdmin , MsgCourseUserMustBeLecturer ) ] ] @@ -821,7 +861,7 @@ colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDeg foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just) -data CourseUserAction = CourseUserDeregister +data CourseUserAction = CourseUserSendMail | CourseUserDeregister deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe CourseUserAction @@ -928,6 +968,9 @@ postCUsersR tid ssh csh = do table <- makeCourseUserTable cid 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 @@ -1039,3 +1082,103 @@ getCNotesR, postCNotesR :: TermId -> SchoolId -> CourseShorthand -> Handler Html -- If they are shared, adjust MsgCourseUserNoteTooltip getCNotesR = error "CNotesR: Not implemented" postCNotesR = error "CNotesR: Not implemented" + + +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 + return user + ) + ] + , crRecipientAuth = Just $ \uid -> do + cID <- encrypt uid + evalAccessDB (CourseR tid ssh csh $ CUserR cID) False + } + + +data ButtonLecInvite = BtnLecInvAccept | BtnLecInvDecline + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe ButtonLecInvite +instance Finite ButtonLecInvite + +nullaryPathPiece ''ButtonLecInvite $ camelToPathPiece' 3 +embedRenderMessage ''UniWorX ''ButtonLecInvite id + +instance Button UniWorX ButtonLecInvite where + btnClasses BtnLecInvAccept = [BCIsButton, BCPrimary] + btnClasses BtnLecInvDecline = [BCIsButton, BCDanger] + +getCLecInviteR, postCLecInviteR :: TermId -> SchoolId -> CourseShorthand -> UserEmail -> Handler Html +getCLecInviteR = postCLecInviteR +postCLecInviteR tid ssh csh email = do + uid <- requireAuthId + (Entity cid Course{..}, Entity liId LecturerInvitation{..}) <- runDB $ do + cRes@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh + iRes <- getBy404 $ UniqueLecturerInvitation email cid + return (cRes, iRes) + + ((btnResult, btnInnerWidget), btnEncoding) <- runFormPost . formEmbedJwtPost $ \csrf -> do + (ltRes, ltView) <- case lecturerInvitationType of + Nothing -> mreq (selectField optionsFinite) "" Nothing + Just lType -> mforced (selectField optionsFinite) "" lType + (btnRes, btnWdgt) <- buttonForm mempty + return ((,) <$> ltRes <*> btnRes, toWidget csrf <> fvInput ltView <> btnWdgt) + + let btnWidget = wrapForm btnInnerWidget def + { formEncoding = btnEncoding + , formAction = Just . SomeRoute . CourseR tid ssh csh $ CLecInviteR email + , formSubmit = FormNoSubmit + } + + formResult btnResult $ \case + (lType, BtnLecInvAccept) -> do + runDB $ do + delete liId + insert_ $ Lecturer uid cid lType + MsgRenderer mr <- getMsgRenderer + addMessageI Success $ MsgLecturerInvitationAccepted (mr lType) csh + redirect $ CourseR tid ssh csh CShowR + (_, BtnLecInvDecline) -> do + runDB $ + delete liId + addMessageI Info $ MsgLecturerInvitationDeclined csh + redirect HomeR + + siteLayoutMsg (MsgCourseLecInviteHeading $ CI.original courseName) $ do + setTitleI . MsgCourseLecInviteHeading $ CI.original courseName + $(widgetFile "courseLecInvite") diff --git a/src/Handler/Help.hs b/src/Handler/Help.hs index d29b7f214..bf33da8d5 100644 --- a/src/Handler/Help.hs +++ b/src/Handler/Help.hs @@ -25,7 +25,7 @@ data HelpForm = HelpForm helpForm :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm helpForm mr mReferer mUid = HelpForm <$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer) - <*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid) + <*> multiActionA identActions (fslI MsgHelpAnswer) (HIUser <$ mUid) <*> aopt textField (fslpI MsgHelpSubject $ mr MsgHelpSubject) Nothing <*> (unTextarea <$> areq textareaField (fslpI MsgHelpRequest $ mr MsgHelpRequest) Nothing) where @@ -47,14 +47,14 @@ postHelpR = do isModal <- hasCustomHeader HeaderIsModal MsgRenderer mr <- getMsgRenderer - ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mr mReferer mUid + ((res,formWidget'),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mr mReferer mUid formResultModal res HelpR $ \HelpForm{..} -> do now <- liftIO getCurrentTime hfReferer' <- traverse toTextUrl hfReferer queueJob' JobHelpRequest - { jSender = hfUserId - , jHelpSubject = hfSubject + { jHelpSender = hfUserId + , jSubject = hfSubject , jHelpRequest = hfRequest , jRequestTime = now , jReferer = hfReferer' @@ -63,8 +63,9 @@ postHelpR = do defaultLayout $ do setTitleI MsgHelpTitle - wrapForm $(widgetFile "help") def - { formAction = Just $ SomeRoute HelpR - , formEncoding = formEnctype - , formAttrs = [ ("data-ajax-submit", "") | isModal ] - } + let formWidget = wrapForm formWidget' def + { formAction = Just $ SomeRoute HelpR + , formEncoding = formEnctype + , formAttrs = [ ("data-ajax-submit", "") | isModal ] + } + $(widgetFile "help") diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 00ac76742..38f47c3e1 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -42,11 +42,10 @@ makeSettingForm template = identifyForm FIDsettings $ \html -> do & setTooltip MsgDownloadFilesTip ) (stgDownloadFiles <$> template) <* aformSection MsgFormNotifications - <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True) + <*> notificationForm (stgNotificationSettings <$> template) return (result, widget) -- no validation required here where themeList = [Option (display t) t (toPathPiece t) | t <- universeF] - nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template) -- -- Version with proper grouping: -- @@ -76,6 +75,31 @@ makeSettingForm template = identifyForm FIDsettings $ \html -> do -- <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True) -- 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) + + +data ButtonResetTokens = BtnResetTokens + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonResetTokens +instance Finite ButtonResetTokens + +nullaryPathPiece ''ButtonResetTokens $ camelToPathPiece' 1 + +embedRenderMessage ''UniWorX ''ButtonResetTokens id +instance Button UniWorX ButtonResetTokens where + btnClasses BtnResetTokens = [BCIsButton, BCDanger] + +data ProfileAnchor = ProfileSettings | ProfileResetTokens + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) +instance Universe ProfileAnchor +instance Finite ProfileAnchor + +nullaryPathPiece ''ProfileAnchor $ camelToPathPiece' 1 + + getProfileR, postProfileR :: Handler Html getProfileR = postProfileR postProfileR = do @@ -89,38 +113,60 @@ postProfileR = do , stgDownloadFiles = userDownloadFiles , stgNotificationSettings = userNotificationSettings } - ((res,formWidget), formEnctype) <- runFormPost $ makeSettingForm settingsTemplate - case res of - (FormSuccess SettingsForm{..}) -> do - runDB $ do - update uid [ UserMaxFavourites =. stgMaxFavourties - , UserTheme =. stgTheme - , UserDateTimeFormat =. stgDateTime - , UserDateFormat =. stgDate - , UserTimeFormat =. stgTime - , UserDownloadFiles =. stgDownloadFiles - , UserNotificationSettings =. stgNotificationSettings - ] - when (stgMaxFavourties < userMaxFavourites) $ do - -- prune Favourites to user-defined size - oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid] - [ Desc CourseFavouriteTime - , OffsetBy stgMaxFavourties - ] - mapM_ delete oldFavs - addMessageI Info MsgSettingsUpdate - redirect ProfileR -- TODO: them change does not happen without redirect + ((res,formWidget), formEnctype) <- runFormPost . identifyForm ProfileSettings $ makeSettingForm settingsTemplate - (FormFailure msgs) -> forM_ msgs $ addMessage Warning . toHtml - _ -> return () + formResult res $ \SettingsForm{..} -> do + runDB $ do + update uid [ UserMaxFavourites =. stgMaxFavourties + , UserTheme =. stgTheme + , UserDateTimeFormat =. stgDateTime + , UserDateFormat =. stgDate + , UserTimeFormat =. stgTime + , UserDownloadFiles =. stgDownloadFiles + , UserNotificationSettings =. stgNotificationSettings + ] + when (stgMaxFavourties < userMaxFavourites) $ do + -- prune Favourites to user-defined size + oldFavs <- selectKeysList [ CourseFavouriteUser ==. uid] + [ Desc CourseFavouriteTime + , OffsetBy stgMaxFavourties + ] + mapM_ delete oldFavs + addMessageI Info MsgSettingsUpdate + redirect $ ProfileR :#: ProfileSettings + + ((tokenRes, tokenFormWidget), tokenEnctype) <- runFormPost . identifyForm ProfileResetTokens $ buttonForm + + formResult tokenRes $ \BtnResetTokens -> do + now <- liftIO getCurrentTime + runDB $ update uid [ UserTokensIssuedAfter =. Just now ] + addMessageI Info MsgTokensResetSuccess + redirect $ ProfileR :#: ProfileResetTokens + + tResetTime <- traverse (formatTime SelFormatDateTime) userTokensIssuedAfter siteLayout [whamlet|_{MsgProfileFor} ^{nameWidget userDisplayName userSurname}|] $ do setTitle . toHtml $ "Profil " <> userIdent - let settingsForm = wrapForm formWidget def - { formAction = Just $ SomeRoute ProfileR - , formEncoding = formEnctype - } - $(widgetFile "profile") + let settingsForm = + wrapForm formWidget FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ ProfileR :#: ProfileSettings + , formEncoding = formEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Just ProfileSettings + } + tokenForm = + wrapForm tokenFormWidget FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ ProfileR :#: ProfileResetTokens + , formEncoding = tokenEnctype + , formAttrs = [] + , formSubmit = FormNoSubmit + , formAnchor = Just ProfileResetTokens + } + tokenExplanation = $(i18nWidgetFile "profile/tokenExplanation") + $(widgetFile "profile/profile") getProfileDataR :: Handler Html @@ -469,9 +515,9 @@ mkCorrectionsTable = , sortable (toNothing "cload") (i18nCell MsgCorProportion) $ correctorLoadCell <$> view (_dbrOutput . _3 . _entityVal) , sortable (toNothing "assigned") (i18nCell MsgCorProportion) $ - int64Cell <$> view (_dbrOutput . _4 . _1 . _unValue) + int64Cell <$> view (_dbrOutput . _4 . _1 . _Value) , sortable (toNothing "corrected") (i18nCell MsgCorProportion) $ - int64Cell <$> view (_dbrOutput . _4 . _2 . _unValue) + int64Cell <$> view (_dbrOutput . _4 . _2 . _Value) ] validator = def & defaultSorting [SortDescBy "term", SortAscBy "school", SortAscBy "course", SortAscBy "sheet"] @@ -533,3 +579,27 @@ postAuthPredsR = do siteLayoutMsg MsgAuthPredsActive $ do setTitleI MsgAuthPredsActive $(widgetFile "authpreds") + + +getUserNotificationR, postUserNotificationR :: CryptoUUIDUser -> Handler Html +getUserNotificationR = postUserNotificationR +postUserNotificationR cID = do + uid <- decrypt cID + User{userNotificationSettings, userDisplayName} <- runDB $ get404 uid + + ((nsRes, nsInnerWdgt), nsEnc) <- runFormPost . formEmbedJwtPost . renderAForm FormStandard . notificationForm $ Just userNotificationSettings + mJwt <- askJwt + isModal <- hasCustomHeader HeaderIsModal + let formWidget = wrapForm nsInnerWdgt def + { formAction = Just . SomeRoute $ UserNotificationR cID + , formEncoding = nsEnc + , formAttrs = [ ("data-ajax-submit", "") | isModal ] + } + + formResultModal nsRes (UserNotificationR cID, [ (toPathPiece GetBearer, toPathPiece jwt) | Just jwt <- pure mJwt ]) $ \ns -> do + lift . runDB $ update uid [ UserNotificationSettings =. ns ] + tell . pure =<< messageI Success MsgNotificationSettingsUpdate + + siteLayoutMsg (MsgNotificationSettingsHeading userDisplayName) $ do + setTitleI $ MsgNotificationSettingsHeading userDisplayName + formWidget diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 39b2effd9..5016f8662 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -1,6 +1,9 @@ module Handler.Sheet where import Import + +import Jobs.Queue + import System.FilePath (takeFileName) import Utils.Sheet @@ -9,20 +12,19 @@ import Handler.Utils import Handler.Utils.Table.Cells import Handler.Utils.SheetType import Handler.Utils.Delete +import Handler.Utils.Form.MassInput -- import Data.Time -- import qualified Data.Text as T -- import Data.Function ((&)) -- -- import Colonnade hiding (fromMaybe, singleton, bool) -import qualified Yesod.Colonnade as Yesod -import Text.Blaze (text) -- -- import qualified Data.UUID.Cryptographic as UUID import qualified Data.Conduit.List as C -- import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI +-- import qualified Data.CaseInsensitive as CI import qualified Database.Esqueleto as E -- import qualified Database.Esqueleto.Internal.Sql as E @@ -42,7 +44,7 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map -import Data.Map (Map, (!?)) +import Data.Map (Map, (!)) import Data.Monoid (Any(..)) @@ -69,8 +71,7 @@ data SheetForm = SheetForm , sfVisibleFrom :: Maybe UTCTime , sfActiveFrom :: UTCTime , sfActiveTo :: UTCTime - , sfSubmissionMode :: SheetSubmissionMode - , sfUploadMode :: UploadMode + , sfSubmissionMode :: SubmissionMode , sfSheetF :: Maybe (Source Handler (Either FileId File)) , sfHintFrom :: Maybe UTCTime , sfHintF :: Maybe (Source Handler (Either FileId File)) @@ -110,8 +111,7 @@ makeSheetForm msId template = identifyForm FIDsheet $ \html -> do & setTooltip MsgSheetActiveFromTip) (sfActiveFrom <$> template) <*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template) - <*> areq submissionModeField (fslI MsgSheetSubmissionMode) ((sfSubmissionMode <$> template) <|> pure UserSubmissions) - <*> areq uploadModeField (fslI MsgSheetUploadMode) ((sfUploadMode <$> template) <|> pure (Upload True)) + <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ Upload True)) <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template) <*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren" & setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template) @@ -462,7 +462,6 @@ getSheetNewR tid ssh csh = do , sfActiveFrom = addTime sheetActiveFrom , sfActiveTo = addTime sheetActiveTo , sfSubmissionMode = sheetSubmissionMode - , sfUploadMode = sheetUploadMode , sfSheetF = Nothing , sfHintFrom = addTime <$> sheetHintFrom , sfHintF = Nothing @@ -495,7 +494,6 @@ getSEditR tid ssh csh shn = do , sfActiveFrom = sheetActiveFrom , sfActiveTo = sheetActiveTo , sfSubmissionMode = sheetSubmissionMode - , sfUploadMode = sheetUploadMode , sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise , sfHintFrom = sheetHintFrom , sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint @@ -537,7 +535,6 @@ handleSheetEdit tid ssh csh msId template dbAction = do , sheetActiveTo = sfActiveTo , sheetHintFrom = sfHintFrom , sheetSolutionFrom = sfSolutionFrom - , sheetUploadMode = sfUploadMode , sheetSubmissionMode = sfSubmissionMode , sheetAutoDistribute = fromMaybe False oldAutoDistribute } @@ -614,7 +611,7 @@ data CorrectorForm = CorrectorForm , cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX } -type Loads = Map UserId (CorrectorState, Load) +type Loads = Map (Either UserEmail UserId) (CorrectorState, Load) defaultLoads :: SheetId -> DB Loads -- ^ Generate `Loads` in such a way that minimal editing is required @@ -637,164 +634,152 @@ defaultLoads shid = do return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState) where toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads - toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load) + toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load) -correctorForm :: SheetId -> MForm Handler (FormResult (Bool, Set SheetCorrector), [FieldView UniWorX]) -correctorForm shid = do - cListIdent <- newFormIdent - let - guardNonDeleted :: UserId -> Handler (Maybe UserId) - guardNonDeleted uid = do - CryptoID{ciphertext} <- encrypt uid :: Handler CryptoUUIDUser - deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del" - return $ bool Just (const Nothing) (isJust deleted) uid - formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser]) +correctorForm :: SheetId -> AForm Handler (Set (Either SheetCorrectorInvitation SheetCorrector)) +correctorForm shid = wFormToAForm $ do + Just currentRoute <- liftHandlerT getCurrentRoute + userId <- liftHandlerT requireAuthId + MsgRenderer mr <- getMsgRenderer + let currentLoads :: DB Loads - currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] [] - (autoDistribute, defaultLoads', currentLoads') <- lift . runDB $ (,,) <$> (sheetAutoDistribute <$> getJust shid) <*> defaultLoads shid <*> currentLoads - loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if - | Map.null currentLoads' - , null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted) - | otherwise -> return $ Map.fromList (map (, (CorrectorNormal, mempty)) formCIDs) `Map.union` currentLoads' + currentLoads = Map.union + <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] []) + <*> fmap (foldMap $ \(Entity _ SheetCorrectorInvitation{..}) -> Map.singleton (Left sheetCorrectorInvitationEmail) (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) (selectList [ SheetCorrectorInvitationSheet ==. shid ] []) + (defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads - deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads') - - let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions) - didDelete = any (flip Set.member deletions) formCIDs - - (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads' - (autoDistributeRes, autoDistributeView) <- mreq checkBoxField (fsm MsgAutoAssignCorrs) (Just autoDistribute) - let - tutorField :: Field Handler [UserEmail] - tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField - { fieldView = \theId name attrs _val isReq -> asWidgetT $ do - listIdent <- newIdent - userId <- handlerToWidget requireAuthId - previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do - E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet - E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId - E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId - return $ user E.^. UserEmail - [whamlet| - $newline never - - - $forall E.Value prev <- previousCorrectors -