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

Upload instructions

Browse Source
This commit is contained in:
Steffen Jost 2019-04-25 10:40:40 +02:00
commit 54f6cf1679
125 changed files with 3242 additions and 779 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
ChangeLog.md
View File

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

2
config/settings.yml
View File

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

13
haddock.sh
View File

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

2
hlint.sh
View File

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

70
messages/uniworx/de.msg
View File

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

6
models/courses
View File

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

10
models/sheets
View File

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

1
models/users
View File

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

4
package.yaml
View File

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

5
routes
View File

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

18
src/Application.hs
View File

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

2
src/Auth/LDAP.hs
View File

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

23
src/CryptoID.hs
View File

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

22
src/Data/Aeson/Types/Instances.hs Normal file
View File

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

16
src/Data/HashMap/Strict/Instances.hs Normal file
View File

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

17
src/Data/HashSet/Instances.hs Normal file
View File

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

28
src/Data/NonNull/Instances.hs Normal file
View File

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

14
src/Data/Set/Instances.hs Normal file
View File

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

26
src/Data/Time/Clock/Instances.hs Normal file
View File

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

69
src/Data/Universe/TH.hs Normal file
View File

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

18
src/Data/Vector/Instances.hs Normal file
View File

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

27
src/Database/Persist/TH/Directory.hs
View File

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

12
src/Database/Persist/Types/Instances.hs Normal file
View File

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

347
src/Foundation.hs
View File

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

9
src/Handler/Admin.hs
View File

@ -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 $ (,,)

14
src/Handler/Corrections.hs
View File

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

209
src/Handler/Course.hs
View File

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

19
src/Handler/Help.hs
View File

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

134
src/Handler/Profile.hs
View File

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

313
src/Handler/Sheet.hs
View File

@ -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
<input id=#{theId} name=#{name} list=#{listIdent} *{attrs} type=email multiple :isReq:required value="" placeholder=_{MsgCorrectorsPlaceholder}>
<datalist id=#{listIdent}>
$forall E.Value prev <- previousCorrectors
<option value=#{prev}>
|]
}
(addTutRes, addTutView) <- mopt tutorField (fsm MsgAddCorrector) (Just Nothing)
loads <- case addTutRes of
FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
case mUid of
Nothing -> loads'' <$ addMessageI Error (MsgEMailUnknown email)
Just uid
| not (Map.member uid loads') -> return $ Map.insert uid (CorrectorNormal, mempty) loads''
| otherwise -> loads'' <$ addMessageI Warning (MsgCorrectorExists email)
FormFailure errs -> loads'' <$ mapM_ (addMessage Error . toHtml) errs
_ -> return loads''
let deletions' = deletions `Set.difference` Map.keysSet loads
names <- fmap (Map.fromList . map (\(E.Value a, E.Value b) -> (a, b))) . lift . runDB . E.select . E.from $ \user -> do
E.where_ $ user E.^. UserId `E.in_` E.valList (Map.keys loads)
return $ (user E.^. UserId, user E.^. UserDisplayName)
isWrite <- liftHandlerT $ isWriteRequest currentRoute
let
constructFields :: (UserId, Text, (CorrectorState, Load)) -> MForm Handler CorrectorForm
constructFields (uid, uname, (state, Load{..})) = do
CryptoID{ciphertext} <- encrypt uid :: MForm Handler CryptoUUIDUser
let
fs name = ""
{ fsName = Just $ tshow ciphertext <> "-" <> name
}
rationalField = convertField toRational fromRational doubleField
applyDefaultLoads = Map.null currentLoads' && not isWrite
loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
loads
| applyDefaultLoads = defaultLoads'
| otherwise = currentLoads'
(stateRes, cfViewState) <- mreq (selectField optionsFinite) (fs "state") (Just state)
(byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
(propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
(_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
when (not (Map.null loads) && applyDefaultLoads) $
addMessageI Warning MsgCorrectorsDefaulted
countTutRes <- wreq checkBoxField (fsm MsgCountTutProp) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
let
previousCorrectors :: E.SqlQuery (E.SqlExpr (Entity User))
previousCorrectors = E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> 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
miAdd :: ListPosition
-> Natural
-> (Text -> Text)
-> FieldView UniWorX
-> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
miAdd _ _ nudge submitView = Just $ \csrf -> do
(addRes, addView) <- mpreq (multiUserField False $ Just previousCorrectors) (fslpI MsgCorrector (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing
let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
| existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData
, not $ null existing
-> FormFailure [mr MsgCorrectorExists]
| otherwise
-> FormSuccess . Map.fromList . zip [kStart..] $ Set.toList nCorrs
return (addRes', $(widgetFile "sheetCorrectors/add"))
miCell :: ListPosition
-> Either UserEmail UserId
-> Maybe (CorrectorState, Load)
-> (Text -> Text)
-> Form (CorrectorState, Load)
miCell _ userIdent initRes nudge csrf = do
(stateRes, stateView) <- mreq (selectField optionsFinite) ("" & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
(byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
(propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) ("" & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
let
cfResult :: FormResult (CorrectorState, Load)
cfResult = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
res :: FormResult (CorrectorState, Load)
res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
tutRes'
| FormSuccess True <- byTutRes = Just <$> countTutRes
| otherwise = Nothing <$ byTutRes
cfUserId = uid
cfUserName = uname
return CorrectorForm{..}
identWidget <- case userIdent of
Left email -> return . toWidget $ mailtoHtml email
Right uid -> do
User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ getJust uid
return $ nameEmailWidget userEmail userDisplayName userSurname
return (res, $(widgetFile "sheetCorrectors/cell"))
corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid
mr <- getMessageRender
miDelete :: ListLength
-> ListPosition
-> MaybeT (MForm Handler) (Map ListPosition ListPosition)
miDelete = miDeleteList
$logDebugS "SCorrR" $ tshow (didDelete, addTutRes)
miAllowAdd :: ListPosition
-> Natural
-> ListLength
-> Bool
miAllowAdd _ _ _ = True
let
corrColonnade = mconcat
[ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName
, headed (Yesod.textCell $ mr MsgCorState) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewState
, headed (Yesod.textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut
, headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp
, headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel
]
corrResults
| FormSuccess (Just es) <- addTutRes
, not $ null es = FormMissing
| didDelete = FormMissing
| otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> (snd <$> cfResult) <*> (fst <$> cfResult)
| CorrectorForm{..} <- corrData
]
idField CorrectorForm{..} = do
cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
miAddEmpty :: ListPosition
-> Natural
-> ListLength
-> Set ListPosition
miAddEmpty _ _ _ = Set.empty
delField uid = do
cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
miButtonAction :: forall p.
PathPiece p
=> p
-> Maybe (SomeRoute UniWorX)
miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
return ( (,) <$> autoDistributeRes <*> corrResults
, [ autoDistributeView
, countTutView
, FieldView
{ fvLabel = text $ mr MsgCorrectors
, fvTooltip = Just $ toHtml $ mr MsgCorrectorStateTip
, fvId = ""
, fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions'
, fvErrors = Nothing
, fvRequired = True
}
, addTutView
{ fvInput = [whamlet|
<div>
^{fvInput addTutView}
<button type=submit formnovalidate data-formnorequired>Hinzufügen
|]
}
])
miLayout :: ListLength
-> Map ListPosition (Either UserEmail UserId, FormResult (CorrectorState, Load))
-> Map ListPosition Widget
-> Map ListPosition (FieldView UniWorX)
-> Map (Natural, ListPosition) Widget
-> Widget
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout")
-- Eingabebox für Korrektor hinzufügen
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either SheetCorrectorInvitation SheetCorrector)
postProcess = Set.fromList . map postProcess' . Map.elems
where
sheetCorrectorSheet = shid
sheetCorrectorInvitationSheet = shid
postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either SheetCorrectorInvitation SheetCorrector
postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..}
postProcess' (Left sheetCorrectorInvitationEmail, (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) = Left SheetCorrectorInvitation{..}
fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors) True (Just . Map.fromList . zip [0..] $ Map.toList loads)
getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSCorrR = getSCorrR
getSCorrR tid ssh csh shn = do
uid <- requireAuthId
Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid)
((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $
(,) <$> areq checkBoxField (fslI MsgAutoAssignCorrs) (Just sheetAutoDistribute)
<*> correctorForm shid
case res of
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess (autoDistribute, res') -> runDB $ do
FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do
update shid [ SheetAutoDistribute =. autoDistribute ]
deleteWhere [SheetCorrectorSheet ==. shid]
insertMany_ $ Set.toList res'
deleteWhere [ SheetCorrectorSheet ==. shid ]
deleteWhere [ SheetCorrectorInvitationSheet ==. shid, SheetCorrectorInvitationEmail /<-. toListOf (folded . _Left . _sheetCorrectorInvitationEmail) sheetCorrectors ]
forM_ sheetCorrectors $ \case
Right shCor -> insert_ shCor
Left shCorInv -> do
insertRes <- insertBy shCorInv
case insertRes of
Right _ ->
void . queueDBJob $ JobCorrectorInvitation uid shCorInv
Left (Entity old _) ->
replace old shCorInv
addMessageI Success MsgCorrectorsUpdated
FormMissing -> return ()
@ -805,3 +790,49 @@ getSCorrR tid ssh csh shn = do
, formEncoding = formEnctype
}
data ButtonCorrInvite = BtnCorrInvAccept | BtnCorrInvDecline
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe ButtonCorrInvite
instance Finite ButtonCorrInvite
nullaryPathPiece ''ButtonCorrInvite $ camelToPathPiece' 3
embedRenderMessage ''UniWorX ''ButtonCorrInvite id
instance Button UniWorX ButtonCorrInvite where
btnClasses BtnCorrInvAccept = [BCIsButton, BCPrimary]
btnClasses BtnCorrInvDecline = [BCIsButton, BCDanger]
getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> UserEmail -> Handler Html
getSCorrInviteR = postSCorrInviteR
postSCorrInviteR tid ssh csh shn email = do
uid <- requireAuthId
(Entity _ Course{..}, Entity shid Sheet{..}, Entity ciId SheetCorrectorInvitation{..}) <- runDB $ do
(sRes@(Entity shid _), cRes) <- fetchSheetCourse tid ssh csh shn
iRes <- getBy404 $ UniqueSheetCorrectorInvitation email shid
return (cRes, sRes, iRes)
((btnResult, btnInnerWidget), btnEncoding) <- runFormPost $ formEmbedJwtPost buttonForm
let btnWidget = wrapForm btnInnerWidget def
{ formEncoding = btnEncoding
, formAction = Just . SomeRoute . CSheetR tid ssh csh shn $ SCorrInviteR email
, formSubmit = FormNoSubmit
}
formResult btnResult $ \case
BtnCorrInvAccept -> do
runDB $ do
delete ciId
insert_ $ SheetCorrector uid shid sheetCorrectorInvitationLoad sheetCorrectorInvitationState
addMessageI Success $ MsgCorrectorInvitationAccepted shn
redirect $ CSheetR tid ssh csh shn SShowR
BtnCorrInvDecline -> do
runDB $
delete ciId
addMessageI Info $ MsgCorrectorInvitationDeclined shn
redirect HomeR
siteLayoutMsg (MsgSheetCorrInviteHeading shn) $ do
setTitleI $ MsgSheetCorrInviteHeading shn
$(widgetFile "sheetCorrInvite")

10
src/Handler/Submission.hs
View File

@ -75,12 +75,12 @@ makeSubmissionForm msmid uploadMode grouping (self :| buddies) = identifyForm FI
getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSubmissionNewR = postSubmissionNewR
postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn NewSubmission
postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn Nothing
getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getSubShowR = postSubShowR
postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ ExistingSubmission cid
postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ Just cid
getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSubmissionOwnR tid ssh csh shn = do
@ -98,8 +98,8 @@ getSubmissionOwnR tid ssh csh shn = do
cID <- encrypt sid
redirect $ CSubmissionR tid ssh csh shn cID SubShowR
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Maybe CryptoFileNameSubmission -> Handler Html
submissionHelper tid ssh csh shn mcid = do
(Entity uid userData) <- requireAuth
msmid <- traverse decrypt mcid
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
@ -168,7 +168,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
return (userName, submissionEdit E.^. SubmissionEditTime)
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
return (csheet,buddies,lastEdits)
((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid sheetUploadMode sheetGrouping (userEmail userData :| buddies)
((res,formWidget'), formEnctype) <- runFormPost $ makeSubmissionForm msmid (fromMaybe (Upload True) . submissionModeUser $ sheetSubmissionMode) sheetGrouping (userEmail userData :| buddies)
let formWidget = wrapForm formWidget' def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = formEnctype

2
src/Handler/SystemMessage.hs
View File

@ -217,7 +217,7 @@ postMessageListR = do
, (SMActivate, SMDActivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just $ Just now))
, (SMDeactivate, SMDDeactivate <$> aopt utcTimeField (fslI MsgSystemMessageTimestamp) (Just Nothing))
]
(actionRes, action) <- multiAction actions (Just SMActivate)
(actionRes, action) <- multiActionM actions "" (Just SMActivate) mempty
return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
, dbParamsFormEvaluate = liftHandlerT . runFormPost
, dbParamsFormResult = id

6
src/Handler/Utils.hs
View File

@ -4,6 +4,8 @@ module Handler.Utils
import Import
import Utils.Lens
import qualified Data.Text as T
-- import qualified Data.Set (Set)
import qualified Data.Set as Set
@ -40,7 +42,7 @@ downloadFiles = do
case mauth of
Just (Entity _ User{..}) -> return userDownloadFiles
Nothing -> do
AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
return userDefaultDownloadFiles
tidFromText :: Text -> Maybe TermId
@ -99,7 +101,7 @@ wrapMailto (original -> email) linkText
-- | Just show an email address in a standard way, for convenience inside hamlet files.
mailtoHtml :: UserEmail -> Html
mailtoHtml email = wrapMailto email $ toHtml email
mailtoHtml email = wrapMailto email $(shamletFile "templates/widgets/email.hamlet")
-- | Generic i18n text for "edited at sometime by someone"
editedByW :: SelDateTimeFormat -> UTCTime -> Text -> Widget

187
src/Handler/Utils/Communication.hs Normal file
View File

@ -0,0 +1,187 @@
module Handler.Utils.Communication
( RecipientGroup(..)
, CommunicationRoute(..)
, Communication(..)
, commR
-- * Re-Exports
, Job(..)
) where
import Import
import Handler.Utils
import Handler.Utils.Form.MassInput
import Utils.Lens
import Jobs.Queue
import Control.Monad.Trans.Reader (mapReaderT)
import qualified Database.Esqueleto as E
import qualified Data.CaseInsensitive as CI
import Data.Map ((!), (!?))
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Aeson.TH
import Data.Aeson.Types (ToJSONKey(..), FromJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..))
data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe RecipientGroup
instance Finite RecipientGroup
nullaryPathPiece ''RecipientGroup $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''RecipientGroup id
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
} ''RecipientGroup
data RecipientCategory
= RecipientGroup RecipientGroup
| RecipientCustom
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriveFinite ''RecipientCategory
finiteEnum ''RecipientCategory
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
, unwrapUnaryRecords = True
, sumEncoding = UntaggedValue
} ''RecipientCategory
instance ToJSONKey RecipientCategory where
toJSONKey = toJSONKeyText toPathPiece
instance FromJSONKey RecipientCategory where
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Could not pars RecipientCategory") return . fromPathPiece
instance PathPiece RecipientCategory where
toPathPiece RecipientCustom = "custom"
toPathPiece (RecipientGroup g) = toPathPiece g
fromPathPiece = finiteFromPathPiece
instance RenderMessage UniWorX RecipientCategory where
renderMessage foundation ls = \case
RecipientCustom -> renderMessage' MsgRecipientCustom
RecipientGroup g -> renderMessage' g
where
renderMessage' :: forall msg. RenderMessage UniWorX msg => msg -> Text
renderMessage' = renderMessage foundation ls
data CommunicationRoute = CommunicationRoute
{ crRecipients :: Map RecipientGroup (E.SqlQuery (E.SqlExpr (Entity User)))
, crRecipientAuth :: Maybe (UserId -> DB AuthResult)
, crJobs :: Communication -> Source (YesodDB UniWorX) Job
, crHeading :: SomeMessage UniWorX
, crUltDest :: SomeRoute UniWorX
}
data Communication = Communication
{ cRecipients :: Set (Either UserEmail UserId)
, cSubject :: Maybe Text
, cBody :: Html
}
commR :: CommunicationRoute -> Handler Html
commR CommunicationRoute{..} = do
cUser <- maybeAuth
MsgRenderer mr <- getMsgRenderer
mbCurrentRoute <- getCurrentRoute
(suggestedRecipients, chosenRecipients) <- runDB $ do
suggested <- for crRecipients $ \user -> E.select user
let
decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User))
decrypt' cID = do
uid <- decrypt cID
whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid)
getEntity uid
chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient
return (suggested, chosen')
let
lookupUser :: UserId -> User
lookupUser lId
= entityVal . unsafeHead . filter ((== lId) . entityKey) $ concat (Map.elems suggestedRecipients) ++ chosenRecipients
let chosenRecipients' = Map.fromList $
[ ( (EnumPosition $ RecipientGroup g, pos)
, (Right recp, recp `elem` map entityKey chosenRecipients)
)
| (g, recps) <- Map.toList suggestedRecipients
, (pos, recp) <- zip [0..] $ map entityKey recps
] ++
[ ( (EnumPosition RecipientCustom, pos)
, (Right recp, True)
)
| (pos, recp) <- zip [0..] . Set.toList $ Set.fromList (map entityKey chosenRecipients) \\ Set.fromList (concatMap (map entityKey) $ Map.elems suggestedRecipients)
]
activeCategories = map RecipientGroup (Map.keys suggestedRecipients) `snoc` RecipientCustom
let recipientAForm :: AForm Handler (Set (Either UserEmail UserId))
recipientAForm = postProcess <$> massInputA MassInput{..} (fslI MsgCommRecipients & setTooltip MsgCommRecipientsTip) True (Just chosenRecipients')
where
miAdd (EnumPosition RecipientCustom, 0) 1 nudge submitView = Just $ \csrf -> do
(addRes, addView) <- mpreq (multiUserField True Nothing) (fslpI MsgEMail (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "email")) Nothing
let
addRes' = addRes <&> \(Set.toList -> nEmails) (maybe 0 (succ . snd . fst) . Map.lookupMax . Map.filterWithKey (\(EnumPosition c, _) _ -> c == RecipientCustom) -> kStart) -> FormSuccess . Map.fromList $ zip (map (EnumPosition RecipientCustom, ) [kStart..]) nEmails
return (addRes', $(widgetFile "widgets/communication/recipientAdd"))
miAdd _ _ _ _ = Nothing
miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
(tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
return (tickRes, $(widgetFile "widgets/communication/recipientEmail"))
miCell _ (Right (lookupUser -> User{..})) initRes nudge csrf = do
(tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
return (tickRes, $(widgetFile "widgets/communication/recipientName"))
miAllowAdd (EnumPosition RecipientCustom, 0) 1 _ = True
miAllowAdd _ _ _ = False
miAddEmpty _ 0 _ = Set.singleton (EnumPosition RecipientCustom, 0)
miAddEmpty _ _ _ = Set.empty
miButtonAction :: forall p . PathPiece p => p -> Maybe (SomeRoute UniWorX)
miButtonAction anchor = SomeRoute . (:#: anchor) <$> mbCurrentRoute
miLayout :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength
-> Map (EnumPosition RecipientCategory, ListPosition) (_, FormResult Bool)
-> Map (EnumPosition RecipientCategory, ListPosition) Widget
-> Map (EnumPosition RecipientCategory, ListPosition) (FieldView UniWorX)
-> Map (Natural, (EnumPosition RecipientCategory, ListPosition)) Widget
-> Widget
miLayout liveliness state cellWdgts _delButtons addWdgts = do
checkedIdentBase <- newIdent
let checkedCategories = Set.mapMonotonic (unEnumPosition . fst) . Set.filter (\k' -> Map.foldrWithKey (\k (_, checkState) -> (||) $ k == k' && checkState /= FormSuccess False && (checkState /= FormMissing || maybe True snd (chosenRecipients' !? k))) False state) $ Map.keysSet state
checkedIdent c = checkedIdentBase <> "-" <> toPathPiece c
hasContent c = not (null $ categoryIndices c) || Map.member (1, (EnumPosition c, 0)) addWdgts
categoryIndices c = Set.filter ((== c) . unEnumPosition . fst) $ review liveCoords liveliness
$(widgetFile "widgets/communication/recipientLayout")
miDelete :: MapLiveliness (EnumLiveliness RecipientCategory) ListLength -> (EnumPosition RecipientCategory, ListPosition) -> MaybeT (MForm Handler) (Map (EnumPosition RecipientCategory, ListPosition) (EnumPosition RecipientCategory, ListPosition))
-- miDelete liveliness@(MapLiveliness lMap) (EnumPosition RecipientCustom, delPos) = mappend (Map.fromSet id . Set.filter (\(EnumPosition c, _) -> c /= RecipientCustom) $ review liveCoords liveliness) . fmap (EnumPosition RecipientCustom, ) . Map.mapKeysMonotonic (EnumPosition RecipientCustom, ) <$> miDeleteList (lMap ! EnumPosition RecipientCustom) delPos
miDelete _ _ = mzero
postProcess :: Map (EnumPosition RecipientCategory, ListPosition) (Either UserEmail UserId, Bool) -> Set (Either UserEmail UserId)
postProcess = Set.fromList . map fst . filter snd . Map.elems
((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . renderAForm FormStandard $ Communication
<$> recipientAForm
<*> aopt textField (fslI MsgCommSubject) Nothing
<*> areq htmlField (fslI MsgCommBody) Nothing
formResult commRes $ \comm -> do
runDBJobs . runConduit $ hoist (mapReaderT lift) (crJobs comm) .| sinkDBJobs
addMessageI Success . MsgCommSuccess . Set.size $ cRecipients comm
redirect crUltDest
let formWdgt = wrapForm commWdgt def
{ formMethod = POST
, formAction = SomeRoute <$> mbCurrentRoute
, formEncoding = commEncoding
}
siteLayoutMsg crHeading $ do
setTitleI crHeading
formWdgt

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

@ -13,6 +13,8 @@ module Handler.Utils.DateTime
import Import
import Utils.Lens
import Data.Time.Zones
import qualified Data.Time.Zones as TZ
@ -83,7 +85,7 @@ getTimeLocale = getTimeLocale' <$> languages
getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
getDateTimeFormat sel = do
mauth <- liftHandlerT maybeAuth
AppSettings{ appUserDefaults = UserDefaultConf{..} } <- getsYesod appSettings
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
let
fmt
| Just (Entity _ User{..}) <- mauth
@ -182,4 +184,4 @@ weeksToAdd old new = loop 0 old
where
loop n t
| t > new = n
| otherwise = loop (succ n) (addOneWeek t)
| otherwise = loop (succ n) (addOneWeek t)

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

@ -10,7 +10,7 @@ import Handler.Utils.Form.Types
import Handler.Utils.DateTime
import Import hiding (cons)
import Import
import qualified Data.Char as Char
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
@ -33,12 +33,13 @@ import Data.Map (Map, (!))
import qualified Data.Map as Map
import Control.Monad.Trans.Writer (execWriterT, WriterT)
import Control.Monad.Except (runExceptT)
import Control.Monad.Trans.Except (throwE, runExceptT)
import Control.Monad.Writer.Class
import Data.Scientific (Scientific)
import Data.Ratio
import Text.Read (readMaybe)
import Data.Either (partitionEithers)
import Utils.Lens
@ -47,6 +48,8 @@ import Data.Aeson.Text (encodeToLazyText)
import Data.Proxy
import qualified Text.Email.Validate as Email
----------------------------
-- Buttons (new version ) --
----------------------------
@ -137,7 +140,47 @@ linkButton lbl cls url = do
^{lbl}
|]
--------------------------
-- Interactive fieldset --
--------------------------
multiAction :: forall action a.
( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
multiAction acts fs@FieldSettings{..} defAction csrf = do
mr <- getMessageRender
let
options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
(actionRes, actionView) <- mreq (selectField $ return options) fs defAction
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
let actionResults = view _1 <$> results
actionViews = Map.foldrWithKey accViews [] results
accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> AForm Handler a
multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
-> FieldSettings UniWorX
-> Maybe action
-> (Html -> MForm Handler (FormResult a, Widget))
multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction
------------
-- Fields --
------------
@ -274,8 +317,26 @@ studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
uploadModeField :: Field Handler UploadMode
uploadModeField = selectField optionsFinite
submissionModeField :: Field Handler SheetSubmissionMode
submissionModeField = selectField optionsFinite
submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev
where
uploadModeForm = apreq uploadModeField (fslI MsgSheetUploadMode) (preview (_Just . _submissionModeUser . _Just) $ prev)
actions :: Map SubmissionModeDescr (AForm Handler SubmissionMode)
actions = Map.fromList
[ ( SubmissionModeNone
, pure $ SubmissionMode False Nothing
)
, ( SubmissionModeCorrector
, pure $ SubmissionMode True Nothing
)
, ( SubmissionModeUser
, SubmissionMode False . Just <$> uploadModeForm
)
, ( SubmissionModeBoth
, SubmissionMode True . Just <$> uploadModeForm
)
]
pseudonymWordField :: Field Handler PseudonymWord
pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist)
@ -377,7 +438,7 @@ nullaryPathPiece ''SheetGroup' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'")
sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
where
selOptions = Map.fromList
[ ( Points', Points <$> maxPointsReq )
@ -395,7 +456,7 @@ sheetGradingAFormReq fs template = multiActionA fs selOptions (classify' <$> tem
sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> template)
sheetTypeAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
where
selOptions = Map.fromList
[ ( Normal', Normal <$> gradingReq )
@ -414,8 +475,8 @@ sheetTypeAFormReq fs template = multiActionA fs selOptions (classify' <$> templa
NotGraded -> NotGraded'
sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
let
sheetGroupAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
where
selOptions = Map.fromList
[ ( Arbitrary', Arbitrary
<$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
@ -423,25 +484,6 @@ sheetGroupAFormReq FieldSettings{..} template = formToAForm $ do
, ( RegisteredGroups', pure RegisteredGroups )
, ( NoGroups', pure NoGroups )
]
(res, selView) <- multiAction selOptions (classify' <$> template)
fvId <- maybe newIdent return fsId
MsgRenderer mr <- getMsgRenderer
return (res,
[ FieldView
{ fvLabel = toHtml $ mr fsLabel
, fvTooltip = toHtml . mr <$> fsTooltip
, fvId
, fvInput = selView
, fvErrors = case res of
FormFailure [e] -> Just $ toHtml e
_ -> Nothing
, fvRequired = True
}
])
where
classify' :: SheetGroup -> SheetGroup'
classify' = \case
Arbitrary _ -> Arbitrary'
@ -621,49 +663,6 @@ optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
, optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
}) cPairs
multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> Map action (AForm (HandlerT UniWorX IO) a)
-> Maybe action
-> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
multiAction acts defAction = do
mr <- getMessageRender
let
options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
(actionRes, actionView) <- mreq (selectField $ return options) "" defAction
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
let mToWidget (_, []) = return Nothing
mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty
widgets <- mapM mToWidget results
let actionWidgets = Map.foldrWithKey accWidget [] widgets
accWidget _act Nothing = id
accWidget act (Just w) = cons $(widgetFile "widgets/multi-action/multi-action")
actionResults = Map.map fst results
return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multi-action/multi-action-collect"))
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
=> FieldSettings UniWorX
-> Map action (AForm (HandlerT UniWorX IO) a)
-> Maybe action
-> AForm (HandlerT UniWorX IO) a
multiActionA FieldSettings{..} acts defAction = formToAForm $ do
(res, selView) <- multiAction acts defAction
fvId <- maybe newIdent return fsId
MsgRenderer mr <- getMsgRenderer
return (res,
[ FieldView
{ fvLabel = toHtml $ mr fsLabel
, fvTooltip = toHtml . mr <$> fsTooltip
, fvId
, fvInput = selView
, fvErrors = case res of
FormFailure [e] -> Just $ toHtml e
_ -> Nothing
, fvRequired = True
}
])
formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m ()
formResultModal res finalDest handler = maybeT_ $ do
messages <- case res of
@ -677,3 +676,67 @@ formResultModal res finalDest handler = maybeT_ $ do
| otherwise -> do
forM_ messages $ \Message{..} -> addMessage messageStatus messageContent
redirect finalDest
multiUserField :: forall m.
( MonadHandler m
, HandlerSite m ~ UniWorX
)
=> Bool -- ^ Only resolve suggested users?
-> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
-> Field m (Set (Either UserEmail UserId))
multiUserField onlySuggested suggestions = Field{..}
where
lookupExpr
| onlySuggested = suggestions
| otherwise = Just $ E.from return
fieldEnctype = UrlEncoded
fieldView theId name attrs val isReq = do
val' <- case val of
Left t -> return t
Right vs -> Text.intercalate ", " . map CI.original <$> do
let (emails, uids) = partitionEithers $ Set.toList vs
rEmails <- case lookupExpr of
Nothing -> return []
Just lookupExpr' -> fmap concat . forM uids $ \uid -> do
dbRes <- liftHandlerT . runDB . E.select $ do
user <- lookupExpr'
E.where_ $ user E.^. UserId E.==. E.val uid
return $ user E.^. UserEmail
case dbRes of
[E.Value email] -> return [email]
_other -> return []
return $ emails ++ rEmails
datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
[whamlet|
$newline never
<input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
|]
whenIsJust suggestions $ \suggestions' -> do
suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select $ do
user <- suggestions'
return $ user E.^. UserEmail
[whamlet|
$newline never
<datalist id=#{datalistId}>
$forall email <- suggestedEmails
<option value=#{email}>
|]
fieldParse (all Text.null -> True) _ = return $ Right Nothing
fieldParse ts _ = runExceptT . fmap Just $ do
let ts' = concatMap (Text.splitOn ",") ts
emails <- forM ts' $ \t -> either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
fmap Set.fromList . forM emails $ \(CI.mk -> email) -> case lookupExpr of
Nothing -> return $ Left email
Just lookupExpr' -> do
dbRes <- liftHandlerT . runDB . E.select $ do
user <- lookupExpr'
E.where_ $ user E.^. UserEmail E.==. E.val email
return $ user E.^. UserId
case dbRes of
[] -> return $ Left email
[E.Value uid] -> return $ Right uid
_other -> fail "Ambiguous e-mail addr"

217
src/Handler/Utils/Form/MassInput.hs
View File

@ -1,19 +1,24 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Handler.Utils.Form.MassInput
( MassInput(..)
, defaultMiLayout
, massInput
, module Handler.Utils.Form.MassInput.Liveliness
, massInputA, massInputW
, massInputList
, BoxDimension(..)
, IsBoxCoord(..), boxDimension
, Liveliness(..)
, ListLength(..), ListPosition(..), miDeleteList
, EnumLiveliness(..), EnumPosition(..)
, MapLiveliness(..)
) where
import Import
import Utils.Form
import Utils.Lens
import Handler.Utils.Form (secretJsonField)
import Handler.Utils.Form.MassInput.Liveliness
import Handler.Utils.Form.MassInput.TH
import Data.Aeson
@ -24,35 +29,15 @@ import Text.Blaze (Markup)
import qualified Data.Text as Text
import qualified Data.Set as Set
import qualified Data.IntSet as IntSet
import Data.Map ((!))
import qualified Data.Map as Map
import qualified Data.Foldable as Fold
import Data.List (genericLength, genericIndex, iterate)
import Control.Monad.Trans.Maybe
import Control.Monad.Reader.Class (MonadReader(local))
data BoxDimension x = forall n. (Enum n, Num n) => BoxDimension (Lens' x n)
class (PathPiece x, ToJSONKey x, FromJSONKey x, Eq x, Ord x) => IsBoxCoord x where
boxDimensions :: [BoxDimension x]
boxOrigin :: x
boxDimension :: IsBoxCoord x => Natural -> BoxDimension x
boxDimension n
| n < genericLength dims = genericIndex dims n
| otherwise = error "boxDimension: insufficient dimensions"
where
dims = boxDimensions
-- zeroDimension :: IsBoxCoord x => Natural -> x -> x
-- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
type BoxCoord a :: *
liveCoords :: Prism' (Set (BoxCoord a)) a
liveCoord :: BoxCoord a -> Prism' Bool a
liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))
$(mapM tupleBoxCoord [2..4])
newtype ListLength = ListLength { unListLength :: Natural }
@ -70,13 +55,13 @@ instance BoundedJoinSemiLattice ListLength where
bottom = 0
newtype ListPosition = ListPosition { unListPosition :: Natural }
deriving newtype (Num, Integral, Real, Enum, PathPiece, ToJSONKey, FromJSONKey)
deriving newtype (Num, Integral, Real, Enum, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
deriving (Eq, Ord, Generic, Typeable, Read, Show)
makeWrapped ''ListPosition
instance IsBoxCoord ListPosition where
boxDimensions = [BoxDimension id]
boxDimensions = [BoxDimension _Wrapped]
boxOrigin = 0
instance Liveliness ListLength where
@ -94,7 +79,66 @@ instance Liveliness ListLength where
= Nothing
where
max' = Set.lookupMax ns
liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just 0) (1 <$ guard (n == 0)))
liveCoord (ListPosition n) = prism' (\(ListLength l) -> n < l) (bool (Just bottom) (1 <$ guard (n == 0)))
newtype EnumLiveliness enum = EnumLiveliness { unEnumLiveliness :: IntSet }
deriving (Eq, Ord, Generic, Typeable, Read, Show)
makeWrapped ''EnumLiveliness
instance JoinSemiLattice (EnumLiveliness enum) where
(EnumLiveliness a) \/ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.union` b
instance MeetSemiLattice (EnumLiveliness enum) where
(EnumLiveliness a) /\ (EnumLiveliness b) = EnumLiveliness $ a `IntSet.intersection` b
instance Lattice (EnumLiveliness enum)
instance BoundedJoinSemiLattice (EnumLiveliness enum) where
bottom = EnumLiveliness IntSet.empty
instance (Enum enum, Bounded enum) => BoundedMeetSemiLattice (EnumLiveliness enum) where
top = EnumLiveliness . IntSet.fromList $ map (fromEnum :: enum -> Int) [minBound..maxBound]
instance (Enum enum, Bounded enum) => BoundedLattice (EnumLiveliness enum)
newtype EnumPosition enum = EnumPosition { unEnumPosition :: enum }
deriving newtype (Enum, Bounded, PathPiece, ToJSON, FromJSON, ToJSONKey, FromJSONKey)
deriving (Eq, Ord, Generic, Typeable, Read, Show)
makeWrapped ''EnumPosition
instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => IsBoxCoord (EnumPosition enum) where
boxDimensions = [BoxDimension _Wrapped]
boxOrigin = minBound
instance (Enum enum, Bounded enum, PathPiece enum, ToJSON enum, FromJSON enum, ToJSONKey enum, FromJSONKey enum, Eq enum, Ord enum) => Liveliness (EnumLiveliness enum) where
type BoxCoord (EnumLiveliness enum) = EnumPosition enum
liveCoords = iso fromSet toSet
where
toSet = Set.fromList . map toEnum . IntSet.toList . unEnumLiveliness
fromSet = EnumLiveliness . IntSet.fromList . map fromEnum . Set.toList
newtype MapLiveliness l1 l2 = MapLiveliness { unMapLiveliness :: Map (BoxCoord l1) l2 }
deriving (Generic, Typeable)
makeWrapped ''MapLiveliness
deriving instance (Ord (BoxCoord l1), JoinSemiLattice l2) => JoinSemiLattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), MeetSemiLattice l2) => MeetSemiLattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Lattice l2) => Lattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), BoundedJoinSemiLattice l2) => BoundedJoinSemiLattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedMeetSemiLattice l2) => BoundedMeetSemiLattice (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Finite (BoxCoord l1), BoundedLattice l2) => BoundedLattice (MapLiveliness l1 l2)
deriving instance (Eq (BoxCoord l1), Eq l2) => Eq (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Ord l2) => Ord (MapLiveliness l1 l2)
deriving instance (Ord (BoxCoord l1), Read (BoxCoord l1), Read l2) => Read (MapLiveliness l1 l2)
deriving instance (Show (BoxCoord l1), Show l2) => Show (MapLiveliness l1 l2)
instance (Liveliness l1, Liveliness l2) => Liveliness (MapLiveliness l1 l2) where
type BoxCoord (MapLiveliness l1 l2) = (BoxCoord l1, BoxCoord l2)
liveCoords = prism'
(Set.fromList . concatMap (\(k, v) -> (k, ) <$> Set.toAscList (review liveCoords v)) . Map.toAscList . unMapLiveliness)
(\ts -> let ks = Set.mapMonotonic fst ts in fmap MapLiveliness . sequence $ Map.fromSet (\k -> preview liveCoords . Set.mapMonotonic snd $ Set.filter ((== k) . fst) ts) ks)
miDeleteList :: Applicative m => ListLength -> ListPosition -> m (Map ListPosition ListPosition)
@ -205,7 +249,17 @@ data MassInput handler liveliness cellData cellResult = MassInput
-> Natural
-> liveliness
-> Bool -- ^ Decide whether an addition-operation should be permitted
, miAddEmpty :: BoxCoord liveliness
-> Natural
-> liveliness
-> Set (BoxCoord liveliness) -- ^ Usually addition widgets are only provided for dimension 0 and all _lines_ that have at least one live coordinate. `miAddEmpty` allows specifying when to provide additional widgets
, miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) -- ^ Override form-tag route for `massInput`-Buttons to keep the user closer to the Widget, the `PathPiece` Argument is to be used for constructiong a `Fragment`
, miLayout :: liveliness
-> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
-> Map (BoxCoord liveliness) Widget -- Cell Widgets
-> Map (BoxCoord liveliness) (FieldView UniWorX) -- Delete buttons
-> Map (Natural, BoxCoord liveliness) Widget -- Addition forms
-> Widget
}
massInput :: forall handler cellData cellResult liveliness.
@ -221,12 +275,12 @@ massInput :: forall handler cellData cellResult liveliness.
-> (Markup -> MForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)), FieldView UniWorX))
massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
let initialShape = fmap fst <$> initialResult
miName <- maybe newFormIdent return fsName
fvId <- maybe newIdent return fsId
miAction <- traverse toTextUrl $ miButtonAction fvId
let addFormAction = maybe id (addAttr "formaction") miAction
let
shapeName :: MassInputFieldName (BoxCoord liveliness)
shapeName = MassInputShape{..}
@ -243,10 +297,10 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
sentLiveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet sentShape' ^? liveCoords :: MForm handler liveliness
let addForm :: [BoxDimension (BoxCoord liveliness)] -> MForm handler (Map (Natural, BoxCoord liveliness) (FormResult (Maybe (Map (BoxCoord liveliness) cellData -> FormResult (Map (BoxCoord liveliness) cellData))), Maybe Widget))
addForm = addForm' boxOrigin . zip [0..]
addForm = addForm' boxOrigin [] . zip [0..]
where
addForm' _ [] = return Map.empty
addForm' miCoord ((dimIx, _) : remDims) = do
addForm' _ _ [] = return Map.empty
addForm' miCoord pDims (dim''@(dimIx, _) : remDims) = do
let nudgeAddWidgetName :: Text -> Text
nudgeAddWidgetName miAddWidgetField = toPathPiece MassInputAddWidget{..}
(btnRes', btnView) <- mopt (buttonField $ MassInputAddDimension dimIx miCoord) ("" & addName MassInputAddButton{..} & addFormAction) Nothing
@ -262,9 +316,12 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
case remDims of
[] -> return dimRes'
((_, BoxDimension dim) : _) -> do
let
miCoords = Set.fromList . takeWhile (\c -> review (liveCoord c) sentLiveliness) $ iterate (over dim succ) miCoord
dimRess <- sequence $ Map.fromSet (\c -> addForm' c remDims) miCoords
let miCoords
= Set.union (miAddEmpty miCoord dimIx sentLiveliness)
. Set.map (\c -> miCoord & dim .~ (c ^. dim))
. Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims `snoc` dim'' ])
$ review liveCoords sentLiveliness
dimRess <- sequence $ Map.fromSet (\c -> addForm' c (pDims `snoc` dim'') remDims) miCoords
return $ dimRes' `Map.union` fold dimRess
addResults <- addForm boxDimensions
@ -303,8 +360,8 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
let shapeChanged = Fold.any (isn't _FormMissing . view _1) addResults || Fold.any (is _FormSuccess . view _1) delResults
shape <- if
| Just s <- addShape -> return s
| Just s <- delShape -> return s
| Just s <- addShape -> return s
| Just s <- delShape -> return s
| otherwise -> return sentShape'
liveliness <- maybe (throwM MassInputInvalidShape) return $ Map.keysSet shape ^? liveCoords :: MForm handler liveliness
@ -342,25 +399,16 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
guard $ not shapeChanged
for cellResults $ \(cData, (cResult, _)) -> (cData, ) <$> cResult
let miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
miWidget' _ [] = mempty
miWidget' miCoord ((dimIx, BoxDimension dim) : remDims) =
let coords = takeWhile (\c -> review (liveCoord c) liveliness) $ iterate (over dim succ) miCoord
cells
| [] <- remDims = do
coord <- coords
Just (_data, (_cellRes, cellWdgt)) <- return $ Map.lookup coord cellResults
let deleteButton = snd <$> Map.lookup coord delResults
return (coord, $(widgetFile "widgets/massinput/cell"))
| otherwise =
[ (coord, miWidget' coord remDims) | coord <- coords ]
addWidget = (\(_, mWgt) -> mWgt <* guard (miAllowAdd miCoord dimIx liveliness)) =<< Map.lookup (dimIx, miCoord) addResults
in $(widgetFile "widgets/massinput/row")
miWidget = miWidget' boxOrigin $ zip [0..] boxDimensions
let miWidget
= miLayout
liveliness
(fmap (view _1 &&& view (_2 . _1)) cellResults)
(fmap (view $ _2 . _2) cellResults)
(fmap (view _2) delResults)
(Map.mapMaybeWithKey (\(dimIx, miCoord) (_, wdgt) -> wdgt <* guard (miAllowAdd miCoord dimIx liveliness)) addResults)
MsgRenderer mr <- getMsgRenderer
let
fvLabel = toHtml $ mr fsLabel
fvTooltip = toHtml . mr <$> fsTooltip
@ -368,6 +416,32 @@ massInput MassInput{..} FieldSettings{..} fvRequired initialResult csrf = do
fvErrors = Nothing
in return (result, FieldView{..})
defaultMiLayout :: forall liveliness cellData cellResult.
Liveliness liveliness
=> liveliness
-> Map (BoxCoord liveliness) (cellData, FormResult cellResult)
-> Map (BoxCoord liveliness) Widget
-> Map (BoxCoord liveliness) (FieldView UniWorX)
-> Map (Natural, BoxCoord liveliness) Widget
-> Widget
-- | Generic `miLayout` using recursively nested lists
defaultMiLayout liveliness _ cellResults delResults addResults = miWidget' boxOrigin [] $ zip [0..] boxDimensions
where
miWidget' :: BoxCoord liveliness -> [(Natural, BoxDimension (BoxCoord liveliness))] -> [(Natural, BoxDimension (BoxCoord liveliness))] -> Widget
miWidget' _ _ [] = mempty
miWidget' miCoord pDims (dim'@(dimIx, BoxDimension dim) : remDims) =
let coords = Set.toList . Set.map (\c -> miCoord & dim .~ (c ^. dim)) . Set.filter (\c -> and [ ((==) `on` view pDim) miCoord c | (_, BoxDimension pDim) <- pDims ]) $ review liveCoords liveliness
cells
| [] <- remDims = do
coord <- coords
Just cellWdgt <- return $ Map.lookup coord cellResults
let deleteButton = Map.lookup coord delResults
return (coord, $(widgetFile "widgets/massinput/cell"))
| otherwise =
[ (coord, miWidget' coord (pDims `snoc` dim') remDims) | coord <- coords ]
addWidget = Map.lookup (dimIx, miCoord) addResults
in $(widgetFile "widgets/massinput/row")
-- | Wrapper around `massInput` for the common case, that we just want an arbitrary list of single fields without any constraints
massInputList :: forall handler cellResult.
@ -388,8 +462,39 @@ massInputList field fieldSettings miButtonAction miSettings miRequired miPrevRes
over _2 (\FieldView{..} -> $(widgetFile "widgets/massinput/list/cell")) <$> mreq field (fieldSettings pos & addName (nudge "field")) iRes
, miDelete = miDeleteList
, miAllowAdd = \_ _ _ -> True
, miAddEmpty = \_ _ _ -> Set.empty
, miButtonAction
, miLayout = \lLength _ cellWdgts delButtons addWdgts
-> $(widgetFile "widgets/massinput/list/layout")
}
miSettings
miRequired
(Map.fromList . zip [0..] . map ((), ) <$> miPrevResult)
massInputA :: forall handler cellData cellResult liveliness.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, ToJSON cellData, FromJSON cellData
, Liveliness liveliness
, MonadLogger handler
)
=> MassInput handler liveliness cellData cellResult
-> FieldSettings UniWorX
-> Bool -- ^ Required?
-> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
-> AForm handler (Map (BoxCoord liveliness) (cellData, cellResult))
massInputA mi fs fvRequired initialResult = formToAForm $
over _2 pure <$> massInput mi fs fvRequired initialResult mempty
massInputW :: forall handler cellData cellResult liveliness.
( MonadHandler handler, HandlerSite handler ~ UniWorX
, ToJSON cellData, FromJSON cellData
, Liveliness liveliness
, MonadLogger handler
)
=> MassInput handler liveliness cellData cellResult
-> FieldSettings UniWorX
-> Bool -- ^ Required?
-> Maybe (Map (BoxCoord liveliness) (cellData, cellResult))
-> WForm handler (FormResult (Map (BoxCoord liveliness) (cellData, cellResult)))
massInputW mi fs fvRequired initialResult = mFormToWForm $
massInput mi fs fvRequired initialResult mempty

45
src/Handler/Utils/Form/MassInput/Liveliness.hs Normal file
View File

@ -0,0 +1,45 @@
module Handler.Utils.Form.MassInput.Liveliness
( BoxDimension(..)
, IsBoxCoord(..)
, boxDimension
, Liveliness(..)
) where
import ClassyPrelude
import Web.PathPieces (PathPiece)
import Data.Aeson (ToJSON, FromJSON, ToJSONKey, FromJSONKey)
import Numeric.Natural
import Utils.Lens
import Algebra.Lattice
import qualified Data.Set as Set
import Data.List (genericLength, genericIndex)
data BoxDimension x = forall n. (Enum n, Eq n) => BoxDimension (Lens' x n)
class (ToJSON x, FromJSON x, ToJSONKey x, FromJSONKey x, PathPiece x, Eq x, Ord x) => IsBoxCoord x where
boxDimensions :: [BoxDimension x]
boxOrigin :: x
boxDimension :: IsBoxCoord x => Natural -> BoxDimension x
boxDimension n
| n < genericLength dims = genericIndex dims n
| otherwise = error "boxDimension: insufficient dimensions"
where
dims = boxDimensions
-- zeroDimension :: IsBoxCoord x => Natural -> x -> x
-- zeroDimension (boxDimension -> BoxDimension dim) = set dim $ boxOrigin ^. dim
class (IsBoxCoord (BoxCoord a), Lattice a, BoundedJoinSemiLattice a) => Liveliness a where
type BoxCoord a :: *
liveCoords :: Prism' (Set (BoxCoord a)) a
liveCoord :: BoxCoord a -> Prism' Bool a
liveCoord bC = prism' (\l -> bC `Set.member` review liveCoords l) (bool (Just bottom) (preview liveCoords $ Set.singleton bC))

40
src/Handler/Utils/Form/MassInput/TH.hs Normal file
View File

@ -0,0 +1,40 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Handler.Utils.Form.MassInput.TH
( tupleBoxCoord
) where
import Prelude
import Handler.Utils.Form.MassInput.Liveliness
import Language.Haskell.TH
import Control.Lens
import Data.List ((!!))
import Control.Monad (replicateM)
tupleBoxCoord :: Int -> DecQ
tupleBoxCoord tupleDim = do
cs <- replicateM tupleDim $ newName "c"
let tupleType = foldl appT (tupleT tupleDim) $ map varT cs
tCxt = cxt
[ [t|IsBoxCoord $(varT c)|] | c <- cs ]
fieldLenses =
[ [e|_1|]
, [e|_2|]
, [e|_3|]
, [e|_4|]
]
instanceD tCxt ([t|IsBoxCoord|] `appT` tupleType)
[ funD 'boxDimensions
[ clause [] (normalB . foldr1 (\ds1 ds2 -> [e|(++)|] `appE` ds1 `appE` ds2) . map (\field -> [e|map (\(BoxDimension dim) -> BoxDimension $ $(field) . dim) boxDimensions|]) $ map (fieldLenses !!) [0..pred tupleDim]) []
]
, funD 'boxOrigin
[ clause [] (normalB . tupE $ replicate tupleDim [e|boxOrigin|]) []
]
]

17
src/Handler/Utils/Mail.hs
View File

@ -1,12 +1,13 @@
module Handler.Utils.Mail
( addRecipientsDB
, userAddress
, userMailT
, addFileDB
) where
import Import
import Utils.Lens hiding (snoc)
import Utils.Lens
import qualified Data.CaseInsensitive as CI
@ -31,22 +32,22 @@ addRecipientsDB uFilter = runConduit $ transPipe (liftHandlerT . runDB) (selectS
let addr = Address (Just userDisplayName) $ CI.original userEmail
_mailTo %= flip snoc addr
userAddress :: User -> Address
userAddress User{userEmail, userDisplayName} = Address (Just userDisplayName) $ CI.original userEmail
userMailT :: ( MonadHandler m
, HandlerSite m ~ UniWorX
, MonadBaseControl IO m
, MonadLogger m
) => UserId -> MailT m a -> m a
userMailT uid mAct = do
User
{ userEmail
, userDisplayName
, userMailLanguages
user@User
{ userMailLanguages
, userDateTimeFormat
, userDateFormat
, userTimeFormat
} <- liftHandlerT . runDB $ getJust uid
let
addr = Address (Just userDisplayName) $ CI.original userEmail
ctx = MailContext
{ mcLanguages = userMailLanguages
, mcDateTimeFormat = \case
@ -55,7 +56,7 @@ userMailT uid mAct = do
SelFormatTime -> userTimeFormat
}
mailT ctx $ do
_mailTo .= pure addr
_mailTo .= pure (userAddress user)
mAct
addFileDB :: ( MonadMail m
@ -69,4 +70,4 @@ addFileDB fId = do
_partEncoding .= Base64
_partFilename .= Just fileName
_partContent .= LBS.fromStrict fileContent
setMailObjectId' fId :: StateT Part (HandlerT UniWorX IO) MailObjectId
setMailObjectIdCrypto fId :: StateT Part (HandlerT UniWorX IO) MailObjectId

2
src/Handler/Utils/Rating.hs
View File

@ -18,8 +18,6 @@ import Import
import Text.PrettyPrint.Leijen.Text hiding ((<$>))
import Control.Monad.Trans.Maybe
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Text.Encoding.Error (UnicodeException(..))

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

@ -12,7 +12,7 @@ fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
, Typeable a, MonadHandler m, IsPersistBackend backend
, PersistQueryRead backend, PersistUniqueRead backend
)
=> (E.SqlExpr (Entity Sheet) -> b)
=> (E.SqlExpr (Entity Sheet) -> E.SqlExpr (Entity Course) -> b)
-> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a
fetchSheetAux prj tid ssh csh shn =
let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn)
@ -27,19 +27,22 @@ fetchSheetAux prj tid ssh csh shn =
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. sheet E.^. SheetName E.==. E.val shn
return $ prj sheet
return $ prj sheet course
case sheetList of
[sheet] -> return sheet
_other -> notFound
fetchSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet)
fetchSheet = fetchSheetAux id
fetchSheet = fetchSheetAux const
fetchSheetCourse :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet, Entity Course)
fetchSheetCourse = fetchSheetAux (,)
fetchSheetId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet)
fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid ssh cid shn
fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (\sheet _ -> sheet E.^. SheetId) tid ssh cid shn
fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid ssh cid shn
fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux (\sheet course -> (sheet E.^. SheetId, course E.^. CourseId)) tid ssh cid shn
sheetDeleteRoute :: Set SheetId -> DeleteRoute Sheet

27
src/Handler/Utils/Tokens.hs Normal file
View File

@ -0,0 +1,27 @@
module Handler.Utils.Tokens
( maybeBearerToken, requireBearerToken
) where
import Import
import Utils.Lens
import Control.Monad.Trans.Maybe (runMaybeT)
maybeBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m) => m (Maybe (BearerToken UniWorX))
maybeBearerToken = runMaybeT $ catchIfMaybeT cPred requireBearerToken
where
cPred err = any ($ err)
[ is $ _HCError . _PermissionDenied
, is $ _HCError . _NotAuthenticated
]
requireBearerToken :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (BearerToken UniWorX)
requireBearerToken = liftHandlerT $ do
token <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askTokenUnsafe
mAuthId <- maybeAuthId
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
isWrite <- isWriteRequest currentRoute
guardAuthResult <=< runDB $ validateToken mAuthId currentRoute isWrite token
return token

22
src/Import/NoFoundation.hs
View File

@ -3,12 +3,13 @@ module Import.NoFoundation
, MForm
) where
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm)
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons)
import Model as Import
import Model.Types.JSON as Import
import Model.Migration as Import
import Model.Rating as Import
import Model.Submission as Import
import Model.Tokens as Import
import Settings as Import
import Settings.StaticFiles as Import
import Yesod.Auth as Import
@ -18,7 +19,11 @@ import Utils as Import
import Utils.Frontend.Modal as Import
import Utils.Frontend.I18n as Import
import Yesod.Core.Json as Import (provideJson)
import Yesod.Core.Types.Instances as Import ()
import Yesod.Core.Types.Instances as Import (CachedMemoT(..))
import Language.Haskell.TH.Instances as Import ()
import Utils.Tokens as Import
import Data.Fixed as Import
@ -31,6 +36,7 @@ import Text.Lucius as Import
import Text.Shakespeare.Text as Import hiding (text, stext)
import Data.Universe as Import
import Data.Universe.TH as Import
import Data.Pool as Import (Pool)
import Network.HaskellNet.SMTP as Import (SMTPConnection)
@ -44,10 +50,16 @@ import GHC.Exts as Import (IsList)
import Data.Hashable as Import
import Data.List.NonEmpty as Import (NonEmpty(..))
import Data.List.NonEmpty.Instances as Import ()
import Data.NonNull.Instances as Import ()
import Data.Text.Encoding.Error as Import(UnicodeException(..))
import Data.Semigroup as Import (Semigroup)
import Data.Monoid as Import (Last(..), First(..))
import Data.Monoid.Instances as Import ()
import Data.Set.Instances as Import ()
import Data.HashMap.Strict.Instances as Import ()
import Data.HashSet.Instances as Import ()
import Data.Vector.Instances as Import ()
import Data.Time.Clock.Instances as Import ()
import Data.Binary as Import (Binary)
@ -57,17 +69,23 @@ import Control.Monad.Trans.Resource as Import (ReleaseKey)
import Network.Mail.Mime.Instances as Import ()
import Yesod.Core.Instances as Import ()
import Data.Aeson.Types.Instances as Import ()
import Ldap.Client.Pool as Import
import Database.Esqueleto.Instances as Import ()
import Database.Persist.Sql.Instances as Import ()
import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
import Database.Persist.Types.Instances as Import ()
import Numeric.Natural.Instances as Import ()
import System.Random as Import (Random)
import Control.Monad.Random.Class as Import (MonadRandom(..))
import Text.Blaze.Instances as Import ()
import Jose.Jwt.Instances as Import ()
import Web.PathPieces.Instances as Import ()
import Control.Monad.Trans.RWS (RWST)

20
src/Jobs.hs
View File

@ -6,6 +6,7 @@ module Jobs
) where
import Import
import Utils.Lens
import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
import Jobs.Types (JobCtl(JobCtlQueue))
@ -58,6 +59,9 @@ import Jobs.Handler.QueueNotification
import Jobs.Handler.HelpRequest
import Jobs.Handler.SetLogSettings
import Jobs.Handler.DistributeCorrections
import Jobs.Handler.SendCourseCommunication
import Jobs.Handler.LecturerInvitation
import Jobs.Handler.CorrectorInvitation
data JobQueueException = JInvalid QueuedJobId QueuedJob
@ -77,7 +81,7 @@ handleJobs :: ( MonadResource m
-- Uses `unsafeHandler`, as per documentation all HTTP-related fields of state/environment are meaningless placeholders.
-- Handling commands in `HandlerT` provides us with the facilities to render urls, unifies logging, provides a value of the foundation type, ...
handleJobs foundation@UniWorX{..} = do
let num = appJobWorkers appSettings
let num = foundation ^. _appJobWorkers
jobCrontab <- liftIO $ newTMVarIO HashMap.empty
jobConfirm <- liftIO $ newTVarIO HashMap.empty
@ -135,7 +139,7 @@ execCrontab = evalStateT go HashMap.empty
runConduit $ transPipe lift (selectSource [] []) .| C.mapM_ merge
refT <- liftIO getCurrentTime
settings <- getsYesod appSettings
settings <- getsYesod appSettings'
currentState <- mapStateT (mapReaderT $ liftIO . atomically) $ do
crontab' <- liftBase . tryReadTMVar =<< asks jobCrontab
case crontab' of
@ -157,7 +161,7 @@ execCrontab = evalStateT go HashMap.empty
| ((==) `on` HashMap.lookup jobCtl) newCrontab currentCrontab
-> do
now <- liftIO $ getCurrentTime
instanceID <- getsYesod appInstanceID
instanceID' <- getsYesod appInstanceID
State.modify $ HashMap.alter (Just . ($ Max now) . maybe id (<>)) jobCtl
case jobCtl of
JobCtlQueue job -> do
@ -166,7 +170,7 @@ execCrontab = evalStateT go HashMap.empty
CronLastExec
{ cronLastExecJob = toJSON job
, cronLastExecTime = now
, cronLastExecInstance = instanceID
, cronLastExecInstance = instanceID'
}
[ CronLastExecTime =. now ]
lift . lift $ queueDBJob job
@ -285,21 +289,21 @@ jLocked jId act = do
let
lock = runDB . setSerializable $ do
qj@QueuedJob{..} <- maybe (throwM $ JNonexistant jId) return =<< get jId
instanceID <- getsYesod appInstanceID
threshold <- getsYesod $ appJobStaleThreshold . appSettings
instanceID' <- getsYesod $ view instanceID
threshold <- getsYesod $ view _appJobStaleThreshold
now <- liftIO getCurrentTime
hadStale <- maybeT (return False) $ do
lockTime <- MaybeT $ return queuedJobLockTime
lockInstance <- MaybeT $ return queuedJobLockInstance
if
| lockInstance == instanceID
| lockInstance == instanceID'
, diffUTCTime now lockTime >= threshold
-> return True
| otherwise
-> throwM $ JLocked jId lockInstance lockTime
when hadStale .
$logWarnS "Jobs" $ "Ignored stale lock: " <> tshow qj
val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID
val <- updateGet jId [ QueuedJobLockInstance =. Just instanceID'
, QueuedJobLockTime =. Just now
]
liftIO . atomically $ writeTVar hasLock True

2
src/Jobs/Crontab.hs
View File

@ -23,7 +23,7 @@ import qualified Data.Conduit.List as C
determineCrontab :: DB (Crontab JobCtl)
-- ^ Extract all future jobs from the database (sheet deadlines, ...)
determineCrontab = execWriterT $ do
AppSettings{..} <- getsYesod appSettings
AppSettings{..} <- getsYesod appSettings'
case appJobFlushInterval of
Just interval -> tell $ HashMap.singleton

42
src/Jobs/Handler/CorrectorInvitation.hs Normal file
View File

@ -0,0 +1,42 @@
module Jobs.Handler.CorrectorInvitation
( dispatchJobCorrectorInvitation
) where
import Import
import Text.Hamlet
import qualified Data.HashSet as HashSet
import qualified Data.CaseInsensitive as CI
import Utils.Lens
dispatchJobCorrectorInvitation :: UserId -> SheetCorrectorInvitation -> Handler ()
dispatchJobCorrectorInvitation jInviter jCorrectorInvitation@SheetCorrectorInvitation{..} = do
ctx <- runDB . runMaybeT $ do
sheet <- MaybeT $ get sheetCorrectorInvitationSheet
course <- MaybeT . get $ sheetCourse sheet
void . MaybeT $ getByValue jCorrectorInvitation
user <- MaybeT $ get jInviter
return (sheet, course, user)
case ctx of
Just (Sheet{..}, Course{..}, User{..}) -> do
let baseRoute = CSheetR courseTerm courseSchool courseShorthand sheetName $ SCorrInviteR sheetCorrectorInvitationEmail
jwt <- encodeToken =<< bearerToken jInviter (Just $ HashSet.singleton baseRoute) Nothing Nothing Nothing
let
invitationUrl :: SomeRoute UniWorX
invitationUrl = SomeRoute (baseRoute, [(toPathPiece GetBearer, toPathPiece jwt)])
invitationUrl' <- toTextUrl invitationUrl
mailT def $ do
_mailTo .= [Address Nothing $ CI.original sheetCorrectorInvitationEmail]
replaceMailHeader "Reply-To" . Just . renderAddress $ Address (Just userDisplayName) (CI.original userEmail)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
addPart ($(ihamletFile "templates/mail/correctorInvitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
Nothing -> runDB .
deleteBy $ UniqueSheetCorrectorInvitation sheetCorrectorInvitationEmail sheetCorrectorInvitationSheet

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

@ -21,15 +21,15 @@ dispatchJobHelpRequest :: Either (Maybe Address) UserId
-> Maybe Text -- ^ Referer
-> Handler ()
dispatchJobHelpRequest jSender jRequestTime jHelpSubject jHelpRequest jReferer = do
supportAddress <- getsYesod $ appMailSupport . appSettings
supportAddress <- view _appMailSupport
userInfo <- bitraverse return (runDB . getEntity) jSender
let userAddress = either
let senderAddress = either
id
(fmap $ \(Entity _ User{..}) -> Address (Just userDisplayName) (CI.original userEmail))
userInfo
mailT def $ do
_mailTo .= [supportAddress]
whenIsJust userAddress (_mailFrom .=)
whenIsJust senderAddress (_mailFrom .=)
replaceMailHeader "Auto-Submitted" $ Just "no"
setSubjectI $ maybe MsgMailSubjectSupport MsgMailSubjectSupportCustom jHelpSubject
setDate jRequestTime

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

@ -0,0 +1,41 @@
module Jobs.Handler.LecturerInvitation
( dispatchJobLecturerInvitation
) where
import Import
import Text.Hamlet
import qualified Data.HashSet as HashSet
import qualified Data.CaseInsensitive as CI
import Utils.Lens
dispatchJobLecturerInvitation :: UserId -> LecturerInvitation -> Handler ()
dispatchJobLecturerInvitation jInviter jLecturerInvitation@LecturerInvitation{..} = do
ctx <- runDB . runMaybeT $ do
course <- MaybeT $ get lecturerInvitationCourse
void . MaybeT $ getByValue jLecturerInvitation
user <- MaybeT $ get jInviter
return (course, user)
case ctx of
Just (Course{..}, User{..}) -> do
let baseRoute = CourseR courseTerm courseSchool courseShorthand $ CLecInviteR lecturerInvitationEmail
jwt <- encodeToken =<< bearerToken jInviter (Just $ HashSet.singleton baseRoute) Nothing Nothing Nothing
let
invitationUrl :: SomeRoute UniWorX
invitationUrl = SomeRoute (baseRoute, [(toPathPiece GetBearer, toPathPiece jwt)])
invitationUrl' <- toTextUrl invitationUrl
mailT def $ do
_mailTo .= [Address Nothing $ CI.original lecturerInvitationEmail]
replaceMailHeader "Reply-To" . Just . renderAddress $ Address (Just userDisplayName) (CI.original userEmail)
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectLecturerInvitation courseTerm courseSchool courseShorthand
addPart ($(ihamletFile "templates/mail/lecturerInvitation.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
Nothing -> runDB .
deleteBy $ UniqueLecturerInvitation lecturerInvitationEmail lecturerInvitationCourse

37
src/Jobs/Handler/SendCourseCommunication.hs Normal file
View File

@ -0,0 +1,37 @@
module Jobs.Handler.SendCourseCommunication
( dispatchJobSendCourseCommunication
) where
import Import
import Utils.Lens
import Handler.Utils
import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI
dispatchJobSendCourseCommunication :: Either UserEmail UserId
-> Set Address
-> CourseId
-> UserId
-> UUID
-> Maybe Text
-> Html
-> Handler ()
dispatchJobSendCourseCommunication jRecipientEmail jAllRecipientAddresses jCourse jSender jMailObjectUUID jSubject jMailContent = do
(sender, Course{..}) <- runDB $ (,)
<$> getJust jSender
<*> getJust jCourse
either (\email -> mailT def . (assign _mailTo (pure . Address Nothing $ CI.original email) *>)) userMailT jRecipientEmail $ do
void $ setMailObjectUUID jMailObjectUUID
_mailFrom .= userAddress sender
if -- Use `addMailHeader` instead of `_mailCc` to make `mailT` ignore the additional recipients
| jRecipientEmail == Right jSender
-> addMailHeader "Cc" . intercalate ", " . map renderAddress $ Set.toAscList (Set.delete (userAddress sender) jAllRecipientAddresses)
| otherwise
-> addMailHeader "Cc" "Undisclosed Recipients:;"
addMailHeader "Auto-Submitted" "no"
setSubjectI . prependCourseTitle courseTerm courseSchool courseShorthand $ maybe (SomeMessage MsgCommCourseSubject) SomeMessage jSubject
void $ addPart jMailContent

6
src/Jobs/Handler/SendNotification/CorrectionsAssigned.hs
View File

@ -6,6 +6,7 @@ module Jobs.Handler.SendNotification.CorrectionsAssigned
import Import
import Jobs.Handler.SendNotification.Utils
import Handler.Utils.Mail
import Text.Hamlet
@ -28,6 +29,7 @@ dispatchNotificationCorrectionsAssigned nUser nSheet jRecipient = do
MsgRenderer mr <- getMailMsgRenderer
let termDesc = mr . ShortTermIdentifier $ unTermKey courseTerm
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
editNotifications <- mkEditNotifications jRecipient
addAlternatives $
providePreferredAlternative ($(ihamletFile "templates/mail/correctionsAssigned.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

6
src/Jobs/Handler/SendNotification/SheetActive.hs
View File

@ -7,6 +7,7 @@ module Jobs.Handler.SendNotification.SheetActive
import Import
import Handler.Utils.Mail
import Jobs.Handler.SendNotification.Utils
import Text.Hamlet
import qualified Data.CaseInsensitive as CI
@ -27,6 +28,7 @@ dispatchNotificationSheetActive nSheet jRecipient = userMailT jRecipient $ do
csh = courseShorthand
shn = sheetName
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
editNotifications <- mkEditNotifications jRecipient
addAlternatives $
providePreferredAlternative ($(ihamletFile "templates/mail/sheetActive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

11
src/Jobs/Handler/SendNotification/SheetInactive.hs
View File

@ -8,6 +8,7 @@ module Jobs.Handler.SendNotification.SheetInactive
import Import
import Handler.Utils.Mail
import Jobs.Handler.SendNotification.Utils
import Text.Hamlet
import qualified Data.CaseInsensitive as CI
@ -30,8 +31,9 @@ dispatchNotificationSheetSoonInactive nSheet jRecipient = userMailT jRecipient $
csh = courseShorthand
shn = sheetName
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
editNotifications <- mkEditNotifications jRecipient
addAlternatives $
providePreferredAlternative ($(ihamletFile "templates/mail/sheetSoonInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))
dispatchNotificationSheetInactive :: SheetId -> UserId -> Handler ()
@ -56,7 +58,8 @@ dispatchNotificationSheetInactive nSheet jRecipient = userMailT jRecipient $ do
csh = courseShorthand
shn = sheetName
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
editNotifications <- mkEditNotifications jRecipient
addAlternatives $
providePreferredAlternative ($(ihamletFile "templates/mail/sheetInactive.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

4
src/Jobs/Handler/SendNotification/SubmissionRated.hs
View File

@ -9,6 +9,7 @@ import Import
import Utils.Lens
import Handler.Utils.DateTime
import Handler.Utils.Mail
import Jobs.Handler.SendNotification.Utils
import Text.Hamlet
import qualified Data.Aeson as Aeson
@ -35,6 +36,8 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
csh = courseShorthand
shn = sheetName
editNotifications <- mkEditNotifications jRecipient
-- TODO: provide convienience template-haskell for `addAlternatives`
addAlternatives $ do
provideAlternative $ Aeson.object
@ -52,5 +55,4 @@ dispatchNotificationSubmissionRated nSubmission jRecipient = userMailT jRecipien
, "course-school" Aeson..= courseSchool
]
-- provideAlternative $ \(MsgRenderer mr) -> ($(textFile "templates/mail/submissionRated.txt") :: TextUrl (Route UniWorX)) -- textFile does not support control statements
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
providePreferredAlternative ($(ihamletFile "templates/mail/submissionRated.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

5
src/Jobs/Handler/SendNotification/UserRightsUpdate.hs
View File

@ -8,6 +8,7 @@ import Import
import Handler.Utils.Database
import Handler.Utils.Mail
import Jobs.Handler.SendNotification.Utils
import Text.Hamlet
-- import qualified Data.CaseInsensitive as CI
@ -22,7 +23,7 @@ dispatchNotificationUserRightsUpdate nUser _originalRights jRecipient = userMai
replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI $ MsgMailSubjectUserRightsUpdate userDisplayName
-- MsgRenderer mr <- getMailMsgRenderer
addAlternatives $ do
let editNotifications = $(ihamletFile "templates/mail/editNotifications.hamlet")
editNotifications <- mkEditNotifications jRecipient
addAlternatives $
providePreferredAlternative ($(ihamletFile "templates/mail/userRightsUpdate.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

20
src/Jobs/Handler/SendNotification/Utils.hs Normal file
View File

@ -0,0 +1,20 @@
module Jobs.Handler.SendNotification.Utils
( mkEditNotifications
) where
import Import
import Text.Hamlet
import qualified Data.HashSet as HashSet
mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
mkEditNotifications uid = liftHandlerT $ do
cID <- encrypt uid
jwt <- encodeToken =<< bearerToken uid (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
let
editNotificationsUrl :: SomeRoute UniWorX
editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])
editNotificationsUrl' <- toTextUrl editNotificationsUrl
return ($(ihamletFile "templates/mail/editNotifications.hamlet") :: HtmlUrlI18n UniWorXMessage (Route UniWorX))

28
src/Jobs/Queue.hs
View File

@ -2,7 +2,7 @@ module Jobs.Queue
( writeJobCtl, writeJobCtlBlock
, queueJob, queueJob'
, YesodJobDB
, runDBJobs, queueDBJob
, runDBJobs, queueDBJob, sinkDBJobs
, module Jobs.Types
) where
@ -21,6 +21,8 @@ import qualified Data.HashMap.Strict as HashMap
import Control.Monad.Random (evalRand, mkStdGen, uniform)
import qualified Data.Conduit.List as C
data JobQueueException = JobQueuePoolEmpty
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
@ -29,6 +31,10 @@ instance Exception JobQueueException
writeJobCtl :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> m ()
-- | Pass an instruction to the `Job`-Workers
--
-- Instructions are assigned deterministically and pseudo-randomly to one specific worker.
-- While this means that they might be executed later than desireable, rouge threads that queue the same instruction many times do not deny service to others
writeJobCtl cmd = do
tid <- liftIO myThreadId
wMap <- getsYesod appJobCtl >>= liftIO . readTVarIO
@ -39,6 +45,7 @@ writeJobCtl cmd = do
liftIO . atomically $ writeTMChan chan cmd
writeJobCtlBlock :: (MonadHandler m, HandlerSite m ~ UniWorX) => JobCtl -> ReaderT JobContext m ()
-- | Pass an instruction to the `Job`-Workers and block until it was acted upon
writeJobCtlBlock cmd = do
getResVar <- asks jobConfirm
resVar <- liftIO . atomically $ do
@ -67,19 +74,30 @@ queueJobUnsafe job = do
-- return jId
queueJob :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m QueuedJobId
-- ^ Queue a job for later execution
--
-- Makes no guarantees as to when it will be executed (`queueJob'`) and does not interact with any running database transactions (`runDBJobs`)
queueJob = liftHandlerT . runDB . setSerializable . queueJobUnsafe
queueJob' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Job -> m ()
-- ^ `queueJob` followed by `JobCtlPerform`
-- ^ `queueJob` followed by `writeJobCtl` `JobCtlPerform` to ensure, that it is executed asap
queueJob' job = queueJob job >>= writeJobCtl . JobCtlPerform
-- | Slightly modified Version of `YesodDB` for `runDBJobs`
type YesodJobDB site = ReaderT (YesodPersistBackend site) (WriterT (Set QueuedJobId) (HandlerT site IO))
queueDBJob :: Job -> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) ()
queueDBJob :: Job -> YesodJobDB UniWorX ()
-- | Queue a job as part of a database transaction and execute it after the transaction succeeds
queueDBJob job = mapReaderT lift (queueJobUnsafe job) >>= tell . Set.singleton
runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX)
=> ReaderT (YesodPersistBackend UniWorX) (WriterT (Set QueuedJobId) (HandlerT UniWorX IO)) a -> m a
sinkDBJobs :: Sink Job (YesodJobDB UniWorX) ()
-- | Queue many jobs as part of a database transaction and execute them after the transaction passes
sinkDBJobs = C.mapM_ queueDBJob
runDBJobs :: (MonadHandler m, HandlerSite m ~ UniWorX) => YesodJobDB UniWorX a -> m a
-- | Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction
--
-- Jobs get immediately executed if the transaction succeeds
runDBJobs act = do
(ret, jIds) <- liftHandlerT . runDB $ mapReaderT runWriterT act
forM_ jIds $ writeJobCtl . JobCtlPerform

26
src/Jobs/Types.hs
View File

@ -15,14 +15,28 @@ import Data.List.NonEmpty (NonEmpty)
data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notification }
| JobSendTestEmail { jEmail :: Email, jMailContext :: MailContext }
| JobQueueNotification { jNotification :: Notification }
| JobHelpRequest { jSender :: Either (Maybe Address) UserId
| JobHelpRequest { jHelpSender :: Either (Maybe Address) UserId
, jRequestTime :: UTCTime
, jHelpSubject :: Maybe Text
, jSubject :: Maybe Text
, jHelpRequest :: Text
, jReferer :: Maybe Text
}
| JobSetLogSettings { jInstance :: InstanceId, jLogSettings :: LogSettings }
| JobDistributeCorrections { jSheet :: SheetId }
| JobSendCourseCommunication { jRecipientEmail :: Either UserEmail UserId
, jAllRecipientAddresses :: Set Address
, jCourse :: CourseId
, jSender :: UserId
, jMailObjectUUID :: UUID
, jSubject :: Maybe Text
, jMailContent :: Html
}
| JobLecturerInvitation { jInviter :: UserId
, jLecturerInvitation :: LecturerInvitation
}
| JobCorrectorInvitation { jInviter :: UserId
, jCorrectorInvitation :: SheetCorrectorInvitation
}
deriving (Eq, Ord, Show, Read, Generic, Typeable)
data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId }
| NotificationSheetActive { nSheet :: SheetId }
@ -37,15 +51,15 @@ instance Hashable Job
instance Hashable Notification
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
{ constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = camelToPathPiece' 1
, tagSingleConstructors = True
, sumEncoding = TaggedObject "job" "data"
} ''Job
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
, fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
{ constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = camelToPathPiece' 1
, tagSingleConstructors = True
, sumEncoding = TaggedObject "notification" "data"
} ''Notification

19
src/Jose/Jwt/Instances.hs Normal file
View File

@ -0,0 +1,19 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Jose.Jwt.Instances
(
) where
import ClassyPrelude.Yesod
import Jose.Jwt
instance PathPiece Jwt where
toPathPiece (Jwt bytes) = decodeUtf8 bytes
fromPathPiece = Just . Jwt . encodeUtf8
deriving instance Generic JwtError
deriving instance Typeable JwtError
instance Exception JwtError

14
src/Language/Haskell/TH/Instances.hs Normal file
View File

@ -0,0 +1,14 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.TH.Instances
(
) where
import Language.Haskell.TH
import Language.Haskell.TH.Lift (deriveLift)
import Data.Binary (Binary)
instance Binary Loc
deriveLift ''Loc

66
src/Mail.hs
View File

@ -7,7 +7,9 @@ module Mail
module Network.Mail.Mime
-- * MailT
, MailT, defMailT
, MailSmtpData(..), MailContext(..), MailLanguages(..)
, MailSmtpData(..)
, _MailSmtpDataSet
, MailContext(..), MailLanguages(..)
, MonadMail(..)
, getMailMessageRender, getMailMsgRenderer
-- * YesodMail
@ -24,9 +26,11 @@ module Mail
, MailObjectId
, replaceMailHeader, addMailHeader, removeMailHeader
, replaceMailHeaderI, addMailHeaderI
, setSubjectI, setMailObjectId, setMailObjectId'
, setSubjectI
, setMailObjectUUID, setMailObjectIdRandom, setMailObjectIdCrypto, setMailObjectIdPseudorandom
, setDate, setDateCurrent
, setMailSmtpData
, _addressName, _addressEmail
, _mailFrom, _mailTo, _mailCc, _mailBcc, _mailHeaders, _mailHeader, _mailParts
, _partType, _partEncoding, _partFilename, _partHeaders, _partContent
) where
@ -60,18 +64,19 @@ import qualified Data.Text.Lazy as LT
import qualified Data.Text.Lazy.Builder as LTB
import qualified Data.ByteString.Lazy as LBS
import Utils (MsgRendererS(..))
import Utils (MsgRendererS(..), MonadSecretBox(..))
import Utils.Lens.TH
import Control.Lens hiding (from)
import Control.Lens.Extras (is)
import Text.Blaze.Renderer.Utf8
import Data.UUID (UUID)
import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Data.UUID.Cryptographic.ImplicitNamespace
import Data.Binary (Binary)
import qualified Data.Binary as Binary
import GHC.TypeLits (KnownSymbol)
@ -104,7 +109,14 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Control.Monad.Random (MonadRandom(..), evalRand, mkStdGen)
import qualified Crypto.Saltine.Class as Saltine (IsEncoding(..))
import qualified Data.ByteArray as ByteArray (convert)
import Crypto.MAC.HMAC (hmac, HMAC)
import Crypto.Hash.Algorithms (SHAKE128)
makeLenses_ ''Address
makeLenses_ ''Mail
makeLenses_ ''Part
@ -131,6 +143,13 @@ instance Monoid (MailSmtpData) where
mempty = memptydefault
mappend = mappenddefault
_MailSmtpDataSet :: Getter MailSmtpData Bool
_MailSmtpDataSet = to $ \MailSmtpData{..} -> none id
[ is (_Wrapped . _Nothing) smtpEnvelopeFrom
, Set.null smtpRecipients
]
newtype MailLanguages = MailLanguages { mailLanguages :: [Lang] }
deriving (Eq, Ord, Show, Read, Generic, Typeable)
deriving newtype (FromJSON, ToJSON, IsList)
@ -424,20 +443,33 @@ setMailObjectUUID uuid = do
replaceMailHeader oidHeader . Just $ "<" <> objectId <> ">"
return objectId
setMailObjectId :: ( MonadHeader m
, YesodMail (HandlerSite m)
) => m MailObjectId
setMailObjectId = setMailObjectUUID =<< liftIO UUID.nextRandom
setMailObjectIdRandom :: ( MonadHeader m
, YesodMail (HandlerSite m)
) => m MailObjectId
setMailObjectIdRandom = setMailObjectUUID =<< liftIO getRandom
setMailObjectId' :: ( MonadHeader m
, YesodMail (HandlerSite m)
, MonadCrypto m
, HasCryptoUUID plain m
, MonadCryptoKey m ~ CryptoIDKey
, KnownSymbol (CryptoIDNamespace UUID plain)
, Binary plain
) => plain -> m MailObjectId
setMailObjectId' oid = setMailObjectUUID . ciphertext =<< encrypt oid
setMailObjectIdCrypto :: ( MonadHeader m
, YesodMail (HandlerSite m)
, MonadCrypto m
, HasCryptoUUID plain m
, MonadCryptoKey m ~ CryptoIDKey
, KnownSymbol (CryptoIDNamespace UUID plain)
, Binary plain
) => plain -> m MailObjectId
setMailObjectIdCrypto oid = setMailObjectUUID . ciphertext =<< encrypt oid
setMailObjectIdPseudorandom :: ( MonadHeader m
, YesodMail (HandlerSite m)
, Binary obj
, MonadSecretBox m
) => obj -> m MailObjectId
-- | Designed to leak no information about the `secretBoxKey` or the given object
setMailObjectIdPseudorandom obj = do
sbKey <- secretBoxKey
let
seed :: HMAC (SHAKE128 64)
seed = hmac (Saltine.encode sbKey) . toStrict $ Binary.encode obj
setMailObjectUUID . evalRand getRandom . mkStdGen $ hash (ByteArray.convert seed :: ByteString)
setDateCurrent :: (MonadHandler m, YesodMail (HandlerSite m)) => MailT m ()

3
src/Model.hs
View File

@ -40,5 +40,8 @@ deriving instance Eq (Unique Sheet)
-- Automatically generated (i.e. numeric) ids are already taken care of
deriving instance Binary (Key Term)
instance Hashable LecturerInvitation
instance Hashable SheetCorrectorInvitation
submissionRatingDone :: Submission -> Bool
submissionRatingDone Submission{..} = isJust submissionRatingTime

17
src/Model/Migration.hs
View File

@ -223,6 +223,23 @@ customMigrations = Map.fromListWith (>>)
whenM (columnExists "study_terms" "shorthand") $ [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
whenM (columnExists "study_terms" "name") $ [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
)
, ( AppliedMigrationKey [migrationVersion|10.0.0|] [version|11.0.0|]
, whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do
sheetModes <- [sqlQQ| SELECT "id", "upload_mode", "submission_mode" FROM "sheet"; |]
[executeQQ|
ALTER TABLE "sheet" DROP COLUMN "upload_mode";
ALTER TABLE "sheet" ALTER COLUMN "submission_mode" DROP DEFAULT;
ALTER TABLE "sheet" ALTER COLUMN "submission_mode" TYPE jsonb USING 'null'::jsonb;
|]
forM_ sheetModes $ \(shid :: SheetId, unSingle -> uploadMode :: Legacy.UploadMode, unSingle -> submissionMode :: Legacy.SheetSubmissionMode ) -> do
let submissionMode' = case (submissionMode, uploadMode) of
( Legacy.NoSubmissions , _ ) -> SubmissionMode False Nothing
( Legacy.CorrectorSubmissions, _ ) -> SubmissionMode True Nothing
( Legacy.UserSubmissions , Legacy.NoUpload ) -> SubmissionMode False (Just NoUpload)
( Legacy.UserSubmissions , Legacy.Upload True ) -> SubmissionMode False (Just $ Upload True)
( Legacy.UserSubmissions , Legacy.Upload False ) -> SubmissionMode False (Just $ Upload False)
[executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
)
]

41
src/Model/Migration/Types.hs
View File

@ -1,12 +1,17 @@
module Model.Migration.Types where
import ClassyPrelude.Yesod
import Data.Aeson
import Data.Aeson.TH (deriveJSON, defaultOptions)
import Database.Persist.Sql
import Utils.PathPiece
import qualified Model as Current
import qualified Model.Types.JSON as Current
import Data.Universe
data SheetType
= Bonus { maxPoints :: Current.Points } -- Erhöht nicht das Maximum, wird gutgeschrieben
| Normal { maxPoints :: Current.Points } -- Erhöht das Maximum, wird gutgeschrieben
@ -20,6 +25,40 @@ sheetType Normal {..} = Current.Normal Current.Points {..}
sheetType Pass {..} = Current.Normal Current.PassPoints {..}
sheetType NotGraded = Current.NotGraded
data UploadMode = NoUpload | Upload { unpackZips :: Bool }
deriving (Show, Read, Eq, Ord, Generic)
deriveJSON defaultOptions ''UploadMode
Current.derivePersistFieldJSON ''UploadMode
instance Universe UploadMode where
universe = NoUpload : (Upload <$> universe)
instance Finite UploadMode
instance PathPiece UploadMode where
toPathPiece = \case
NoUpload -> "no-upload"
Upload True -> "unpack"
Upload False -> "no-unpack"
fromPathPiece = finiteFromPathPiece
data SheetSubmissionMode = NoSubmissions
| CorrectorSubmissions
| UserSubmissions
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece
} ''SheetSubmissionMode
derivePersistField "SheetSubmissionMode"
instance Universe SheetSubmissionMode
instance Finite SheetSubmissionMode
nullaryPathPiece ''SheetSubmissionMode camelToPathPiece
{- TODO:
* RenderMessage instance for newtype(SheetType) if needed
-}

149
src/Model/Tokens.hs Normal file
View File

@ -0,0 +1,149 @@
{-# LANGUAGE UndecidableInstances #-}
module Model.Tokens
( BearerToken(..)
, _tokenIdentifier, _tokenAuthority, _tokenRoutes, _tokenAddAuth, _tokenRestrictions, _tokenRestrictionIx, _tokenRestrictionAt, _tokenIssuedAt, _tokenIssuedBy, _tokenExpiresAt, _tokenStartsAt
, tokenRestrict
, tokenToJSON, tokenParseJSON
) where
import ClassyPrelude.Yesod
import Yesod.Core.Instances ()
import Model
import Utils (assertM')
import Utils.Lens hiding ((.=))
import Data.Aeson.Lens (AsJSON(..))
import Yesod.Auth (AuthId)
import Jose.Jwt (IntDate(..))
import qualified Jose.Jwt as Jose
import Jose.Jwt.Instances ()
import Data.Aeson.Types.Instances ()
import Data.HashSet (HashSet)
import qualified Data.HashMap.Strict as HashMap
import Data.HashMap.Strict.Instances ()
import Data.HashSet.Instances ()
import Data.Time.Clock.Instances ()
import Data.Aeson.Types (Parser, (.:?), (.:), (.!=), (.=))
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import CryptoID
import Data.Time.Clock.POSIX
import Data.Binary (Binary)
-- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
data BearerToken site = BearerToken
{ tokenIdentifier :: TokenId
-- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
, tokenAuthority :: AuthId site
-- ^ Tokens only grant rights the `tokenAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `tokenAuthority`)
, tokenRoutes :: Maybe (HashSet (Route site))
-- ^ Tokens can optionally be restricted to only be usable on a subset of routes
, tokenAddAuth :: Maybe AuthDNF
-- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
, tokenRestrictions :: HashMap (Route site) Value
-- ^ Tokens can be restricted to certain actions within the context of a route (i.e. creating an user only with a certain username, resetting a password only if the old matches a hash, ...)
--
-- In general this is not encrypted; some care is required to not expose sensitive information to the bearer of the token
, tokenIssuedAt :: UTCTime
, tokenIssuedBy :: InstanceId
, tokenExpiresAt
, tokenStartsAt :: Maybe UTCTime
} deriving (Generic, Typeable)
deriving instance (Eq (AuthId site), Eq (Route site)) => Eq (BearerToken site)
deriving instance (Read (AuthId site), Eq (Route site), Hashable (Route site), Read (Route site)) => Read (BearerToken site)
deriving instance (Show (AuthId site), Show (Route site)) => Show (BearerToken site)
instance (Binary (AuthId site), Binary (Route site), Hashable (Route site), Eq (Route site)) => Binary (BearerToken site)
makeLenses_ ''BearerToken
_tokenRestrictionIx :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) a
-- ^ Focus a singular restriction (by route) if it exists
--
-- This /cannot/ be used to add restrictions, use `_tokenRestrictionAt` or `tokenRestrict` instead
_tokenRestrictionIx route = _tokenRestrictions . ix route . _JSON
_tokenRestrictionAt :: (FromJSON a, ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> Traversal' (BearerToken site) (Maybe a)
-- ^ Focus a singular restriction (by route) whether it exists, or not
_tokenRestrictionAt route = _tokenRestrictions . at route . maybePrism _JSON
tokenRestrict :: (ToJSON a, Hashable (Route site), Eq (Route site)) => Route site -> a -> BearerToken site -> BearerToken site
-- ^ Add a restriction to a `BearerToken`
--
-- If a restriction already exists for the targeted route, it's silently overwritten
tokenRestrict route (toJSON -> resVal) = over _tokenRestrictions $ HashMap.insert route resVal
tokenToJSON :: forall m.
( MonadHandler m
, HasCryptoUUID (AuthId (HandlerSite m)) m
, RenderRoute (HandlerSite m)
) => BearerToken (HandlerSite m) -> m Value
-- ^ Encode a `BearerToken` analogously to `toJSON`
--
-- Monadic context is needed because `AuthId`s are encrypted during encoding
tokenToJSON BearerToken{..} = do
cID <- encrypt tokenAuthority :: m (CryptoUUID (AuthId (HandlerSite m)))
let stdPayload = Jose.JwtClaims
{ jwtIss = Just $ toPathPiece tokenIssuedBy
, jwtSub = Nothing
, jwtAud = Nothing
, jwtExp = IntDate . utcTimeToPOSIXSeconds <$> tokenExpiresAt
, jwtNbf = IntDate . utcTimeToPOSIXSeconds <$> tokenStartsAt
, jwtIat = Just . IntDate $ utcTimeToPOSIXSeconds tokenIssuedAt
, jwtJti = Just $ toPathPiece tokenIdentifier
}
return . JSON.object $
catMaybes [ Just $ "authority" .= cID
, ("routes" .=) <$> tokenRoutes
, ("add-auth" .=) <$> tokenAddAuth
, ("restrictions" .=) <$> assertM' (not . HashMap.null) tokenRestrictions
]
++ let JSON.Object hm = toJSON stdPayload in HashMap.toList hm
tokenParseJSON :: forall site.
( HasCryptoUUID (AuthId site) (ReaderT CryptoIDKey Parser)
, ParseRoute site
, Hashable (Route site)
)
=> Value
-> ReaderT CryptoIDKey Parser (BearerToken site)
-- ^ Decode a `Value` to a `BearerToken` analogously to `parseJSON`
--
-- Monadic context is needed because `AuthId`s are encrypted during encoding
--
-- It's usually easier to use `Utils.Tokens.tokenParseJSON'`
tokenParseJSON v@(Object o) = do
tokenAuthority' <- lift (o .: "authority") :: ReaderT CryptoIDKey Parser (CryptoUUID (AuthId site))
tokenAuthority <- decrypt tokenAuthority'
tokenRoutes <- lift $ o .:? "routes"
tokenAddAuth <- lift $ o .:? "add-auth"
tokenRestrictions <- lift $ o .:? "restrictions" .!= HashMap.empty
Jose.JwtClaims{..} <- lift $ parseJSON v
let unIntDate (IntDate posix) = posixSecondsToUTCTime posix
Just tokenIssuedBy <- return $ jwtIss >>= fromPathPiece
Just tokenIdentifier <- return $ jwtJti >>= fromPathPiece
Just tokenIssuedAt <- return $ unIntDate <$> jwtIat
let tokenExpiresAt = unIntDate <$> jwtExp
tokenStartsAt = unIntDate <$> jwtNbf
return BearerToken{..}
tokenParseJSON v = lift $ JSON.typeMismatch "BearerToken" v

124
src/Model/Types.hs
View File

@ -24,9 +24,12 @@ import Data.Monoid (Sum(..))
import Data.Maybe (fromJust)
import Data.Universe
import Data.Universe.Helpers
import Data.Universe.TH
import Data.UUID.Types (UUID)
import qualified Data.UUID.Types as UUID
import Data.NonNull.Instances ()
import Data.Default
import Text.Read (readMaybe)
@ -54,7 +57,7 @@ import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withText, withObject, Value())
import Data.Aeson.Types (toJSONKeyText)
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..))
import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON)
import GHC.Generics (Generic)
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
@ -79,7 +82,8 @@ import Model.Types.Wordlist
import Data.Text.Metrics (damerauLevenshtein)
import Data.Binary (Binary)
import qualified Data.Binary as Binary
instance PathPiece UUID where
fromPathPiece = UUID.fromString . unpack
@ -286,12 +290,14 @@ instance DisplayAble DA where
data UploadMode = NoUpload | Upload { unpackZips :: Bool }
deriving (Show, Read, Eq, Ord, Generic)
deriveJSON defaultOptions ''UploadMode
derivePersistFieldJSON ''UploadMode
deriveFinite ''UploadMode
instance Universe UploadMode where
universe = NoUpload : (Upload <$> universe)
instance Finite UploadMode
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece
, fieldLabelModifier = camelToPathPiece
, sumEncoding = TaggedObject "mode" "settings"
}''UploadMode
derivePersistFieldJSON ''UploadMode
instance PathPiece UploadMode where
toPathPiece = \case
@ -300,20 +306,51 @@ instance PathPiece UploadMode where
Upload False -> "no-unpack"
fromPathPiece = finiteFromPathPiece
data SheetSubmissionMode = NoSubmissions
| CorrectorSubmissions
| UserSubmissions
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
data SubmissionMode = SubmissionMode
{ submissionModeCorrector :: Bool
, submissionModeUser :: Maybe UploadMode
}
deriving (Show, Read, Eq, Ord, Generic)
deriveFinite ''SubmissionMode
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece
} ''SheetSubmissionMode
derivePersistField "SheetSubmissionMode"
{ fieldLabelModifier = camelToPathPiece' 2
} ''SubmissionMode
derivePersistFieldJSON ''SubmissionMode
instance Universe SheetSubmissionMode
instance Finite SheetSubmissionMode
finitePathPiece ''SubmissionMode
[ "no-submissions"
, "no-upload"
, "no-unpack"
, "unpack"
, "correctors"
, "correctors+no-upload"
, "correctors+no-unpack"
, "correctors+unpack"
]
nullaryPathPiece ''SheetSubmissionMode camelToPathPiece
data SubmissionModeDescr = SubmissionModeNone
| SubmissionModeCorrector
| SubmissionModeUser
| SubmissionModeBoth
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
instance Universe SubmissionModeDescr
instance Finite SubmissionModeDescr
finitePathPiece ''SubmissionModeDescr
[ "no-submissions"
, "correctors"
, "users"
, "correctors+users"
]
classifySubmissionMode :: SubmissionMode -> SubmissionModeDescr
classifySubmissionMode (SubmissionMode False Nothing ) = SubmissionModeNone
classifySubmissionMode (SubmissionMode True Nothing ) = SubmissionModeCorrector
classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser
classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth
data ExamStatus = Attended | NoShow | Voided
deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic)
@ -329,6 +366,7 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati
deriveJSON defaultOptions ''Load
derivePersistFieldJSON ''Load
instance Hashable Load
instance Semigroup Load where
(Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop')
@ -526,9 +564,11 @@ deriveJSON defaultOptions
{ constructorTagModifier = fromJust . stripPrefix "Corrector"
} ''CorrectorState
instance Universe CorrectorState where universe = universeDef
instance Universe CorrectorState
instance Finite CorrectorState
instance Hashable CorrectorState
nullaryPathPiece ''CorrectorState (camelToPathPiece' 1)
derivePersistField "CorrectorState"
@ -712,6 +752,7 @@ pseudonymFragments = folding
data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
= AuthAdmin
| AuthToken
| AuthLecturer
| AuthCorrector
| AuthRegistered
@ -724,6 +765,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthCorrectorSubmissions
| AuthCapacity
| AuthEmpty
| AuthSelf
| AuthAuthentication
| AuthNoEscalation
| AuthRead
@ -731,7 +773,7 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
| AuthDeprecated
| AuthDevelopment
| AuthFree
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe AuthTag
instance Finite AuthTag
@ -749,6 +791,8 @@ instance ToJSONKey AuthTag where
instance FromJSONKey AuthTag where
fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
instance Binary AuthTag
newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool }
deriving (Read, Show, Generic)
@ -772,6 +816,45 @@ instance FromJSON AuthTagActive where
derivePersistFieldJSON ''AuthTagActive
data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
instance Hashable a => Hashable (PredLiteral a)
deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
, sumEncoding = ObjectWithSingleField
, unwrapUnaryRecords = True
} ''PredLiteral
instance PathPiece a => PathPiece (PredLiteral a) where
toPathPiece PLVariable{..} = toPathPiece plVar
toPathPiece PLNegated{..} = "¬" <> toPathPiece plVar
fromPathPiece t = PLVariable <$> fromPathPiece t
<|> PLNegated <$> (Text.stripPrefix "¬" t >>= fromPathPiece)
instance Binary a => Binary (PredLiteral a)
newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
deriving (Eq, Ord, Read, Show, Generic, Typeable)
deriving newtype (Semigroup, Monoid)
$(return [])
instance ToJSON a => ToJSON (PredDNF a) where
toJSON = $(mkToJSON predNFAesonOptions ''PredDNF)
instance (Ord a, FromJSON a) => FromJSON (PredDNF a) where
parseJSON = $(mkParseJSON predNFAesonOptions ''PredDNF)
instance (Ord a, Binary a) => Binary (PredDNF a) where
get = PredDNF <$> Binary.get
put = Binary.put . dnfTerms
type AuthLiteral = PredLiteral AuthTag
type AuthDNF = PredDNF AuthTag
data LecturerType = CourseLecturer | CourseAssistant
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
@ -785,6 +868,8 @@ deriveJSON defaultOptions
} ''LecturerType
derivePersistFieldJSON ''LecturerType
instance Hashable LecturerType
-- Type synonyms
@ -799,4 +884,5 @@ type UserEmail = CI Email
type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString
type InstanceId = UUID
type TokenId = UUID
type TermCandidateIncidence = UUID

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

@ -1,5 +1,6 @@
module Model.Types.JSON
( derivePersistFieldJSON
, predNFAesonOptions
) where
import ClassyPrelude.Yesod hiding (derivePersistFieldJSON)
@ -9,11 +10,13 @@ import Database.Persist.Sql
import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text.Encoding as Text
import qualified Data.Aeson as JSON
import Data.Aeson as JSON
import Language.Haskell.TH
import Language.Haskell.TH.Datatype
import Utils.PathPiece
derivePersistFieldJSON :: Name -> DecsQ
derivePersistFieldJSON tName = do
@ -28,10 +31,10 @@ derivePersistFieldJSON tName = do
| otherwise = cxt [[t|PersistField|] `appT` t]
sequence
[ instanceD iCxt ([t|PersistField|] `appT` t)
[ funD (mkName "toPersistValue")
[ funD 'toPersistValue
[ clause [] (normalB [e|PersistDbSpecific . LBS.toStrict . JSON.encode|]) []
]
, funD (mkName "fromPersistValue")
, funD 'fromPersistValue
[ do
bs <- newName "bs"
clause [[p|PersistDbSpecific $(varP bs)|]] (normalB [e|first pack $ JSON.eitherDecodeStrict' $(varE bs)|]) []
@ -45,8 +48,20 @@ derivePersistFieldJSON tName = do
]
]
, instanceD sqlCxt ([t|PersistFieldSql|] `appT` t)
[ funD (mkName "sqlType")
[ funD 'sqlType
[ clause [wildP] (normalB [e|SqlOther "jsonb"|]) []
]
]
]
predNFAesonOptions :: Options
-- ^ Needed for JSON instances of `predCNF` and `predDNF`
--
-- Moved to this module due to stage restriction
predNFAesonOptions = defaultOptions
{ constructorTagModifier = camelToPathPiece' 1
, sumEncoding = ObjectWithSingleField
, tagSingleConstructors = True
}

78
src/Settings.hs
View File

@ -21,12 +21,18 @@ import Data.Aeson.TH
import Data.FileEmbed (embedFile)
import Data.Yaml (decodeEither')
import Database.Persist.Postgresql (PostgresConf)
import Language.Haskell.TH.Syntax (Exp, Name, Q)
import Network.Wai.Handler.Warp (HostPreference)
import Yesod.Default.Config2 (applyEnvValue, configSettingsYml)
import Yesod.Default.Util (WidgetFileSettings,
widgetFileNoReload,
widgetFileReload)
#ifdef DEVELOPMENT
import Yesod.Default.Util (WidgetFileSettings, widgetFileReload)
import Language.Haskell.TH.Syntax (Exp, Q, location, Loc(..))
import Text.Shakespeare.Text (st)
import Text.Blaze.Html (preEscapedToHtml)
#else
import Yesod.Default.Util (WidgetFileSettings, widgetFileNoReload, widgetFileReload)
import Language.Haskell.TH.Syntax (Exp, Q)
#endif
import qualified Yesod.Auth.Util.PasswordStore as PWStore
import Data.Time (NominalDiffTime, nominalDay)
@ -63,6 +69,9 @@ import Control.Monad.Trans.Maybe (MaybeT(..))
import qualified System.FilePath as FilePath
import Jose.Jwt (JwtEncoding(..))
-- | Runtime settings to configure this application. These settings can be
-- loaded from various sources: defaults, environment variables, config files,
-- theoretically even a database.
@ -100,6 +109,8 @@ data AppSettings = AppSettings
, appNotificationExpiration :: NominalDiffTime
, appSessionTimeout :: NominalDiffTime
, appMaximumContentLength :: Maybe Word64
, appJwtExpiration :: Maybe NominalDiffTime
, appJwtEncoding :: JwtEncoding
, appInitialLogSettings :: LogSettings
@ -310,6 +321,18 @@ deriveFromJSON
}
''SmtpAuthConf
instance FromJSON JwtEncoding where
parseJSON v@(String _) = JwsEncoding <$> parseJSON v
parseJSON v = flip (withObject "JwtEncoding") v $ \obj -> asum
[ do
alg <- obj .: "alg"
return $ JwsEncoding alg
, do
alg <- obj .: "alg"
enc <- obj .: "enc"
return $ JweEncoding alg enc
]
instance FromJSON AppSettings where
parseJSON = withObject "AppSettings" $ \o -> do
@ -352,6 +375,8 @@ instance FromJSON AppSettings where
appNotificationRateLimit <- o .: "notification-rate-limit"
appNotificationCollateDelay <- o .: "notification-collate-delay"
appNotificationExpiration <- o .: "notification-expiration"
appJwtExpiration <- o .:? "jwt-expiration"
appJwtEncoding <- o .: "jwt-encoding"
appSessionTimeout <- o .: "session-timeout"
@ -379,6 +404,8 @@ instance FromJSON AppSettings where
return AppSettings {..}
makeClassy_ ''AppSettings
-- | Settings for 'widgetFile', such as which template languages to support and
-- default Hamlet settings.
--
@ -388,18 +415,29 @@ instance FromJSON AppSettings where
widgetFileSettings :: WidgetFileSettings
widgetFileSettings = def
-- | How static files should be combined.
combineSettings :: CombineSettings
combineSettings = def
-- The rest of this file contains settings which rarely need changing by a
-- user.
widgetFile :: String -> Q Exp
widgetFile = (if appReloadTemplates compileTimeAppSettings
then widgetFileReload
else widgetFileNoReload)
widgetFileSettings
#ifdef DEVELOPMENT
widgetFile nameBase = do
Loc{..} <- location
let nameBase' = "templates" </> nameBase
before, after :: Text
before = [st|<!-- BEGIN ‘#{nameBase'}.*’ IN ‘#{loc_filename}’ #{tshow loc_start}–#{tshow loc_end} -->|]
after = [st|<!-- END ‘#{nameBase'}.*’ -->|]
[e| do
toWidget $ preEscapedToHtml before
$(widgetFileReload widgetFileSettings nameBase)
toWidget $ preEscapedToHtml after
|]
#else
widgetFile
| appReloadTemplates compileTimeAppSettings
= widgetFileReload widgetFileSettings
| otherwise
= widgetFileNoReload widgetFileSettings
#endif
-- | Raw bytes at compile time of @config/settings.yml@
configSettingsYmlBS :: ByteString
@ -416,19 +454,3 @@ compileTimeAppSettings =
case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
Error e -> error e
Success settings -> settings
-- The following two functions can be used to combine multiple CSS or JS files
-- at compile time to decrease the number of http requests.
-- Sample usage (inside a Widget):
--
-- > $(combineStylesheets 'StaticR [style1_css, style2_css])
combineStylesheets :: Name -> [Route Static] -> Q Exp
combineStylesheets = combineStylesheets'
(appSkipCombining compileTimeAppSettings)
combineSettings
combineScripts :: Name -> [Route Static] -> Q Exp
combineScripts = combineScripts'
(appSkipCombining compileTimeAppSettings)
combineSettings

14
src/Settings/Cluster.hs
View File

@ -32,11 +32,16 @@ import qualified Data.Binary as Binary
import qualified Data.Serialize as Serialize
import qualified Data.ByteString.Base64.URL as Base64
import qualified Jose.Jwa as Jose
import qualified Jose.Jwk as Jose
import qualified Jose.Jwt as Jose
data ClusterSettingsKey
= ClusterCryptoIDKey
| ClusterClientSessionKey
| ClusterSecretBoxKey
| ClusterJSONWebKeySet
deriving (Eq, Ord, Enum, Bounded, Show, Read)
instance Universe ClusterSettingsKey
@ -120,3 +125,12 @@ instance FromJSON SecretBox.Key where
parseJSON = Aeson.withText "Key" $ \t -> do
bytes <- either fail return . Base64.decode $ encodeUtf8 t
maybe (fail "Could not parse key") return $ Saltine.decode bytes
instance ClusterSetting 'ClusterJSONWebKeySet where
type ClusterSettingValue 'ClusterJSONWebKeySet = Jose.JwkSet
initClusterSetting _ = liftIO $ do
now <- getCurrentTime
jwkSig <- Jose.generateSymmetricKey 32 (Jose.UTCKeyId now) Jose.Sig (Just $ Jose.Signed Jose.HS256)
return $ Jose.JwkSet [jwkSig]
knownClusterSetting _ = ClusterJSONWebKeySet

37
src/Text/Blaze/Instances.hs Normal file
View File

@ -0,0 +1,37 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Text.Blaze.Instances
(
) where
import ClassyPrelude
import Text.Blaze
import qualified Text.Blaze.Renderer.Text as Text
import Text.Read (Read(..))
import Data.Hashable (Hashable(..))
import Data.Aeson (ToJSON(..), FromJSON(..))
import qualified Data.Aeson as Aeson
instance Eq Markup where
(==) = (==) `on` Text.renderMarkup
instance Ord Markup where
compare = comparing Text.renderMarkup
instance Read Markup where
readPrec = preEscapedLazyText <$> readPrec
instance Show Markup where
showsPrec prec = showsPrec prec . Text.renderMarkup
instance Hashable Markup where
hashWithSalt s = hashWithSalt s . Text.renderMarkup
instance ToJSON Markup where
toJSON = Aeson.String . toStrict . Text.renderMarkup
instance FromJSON Markup where
parseJSON = Aeson.withText "Html" $ return . preEscapedText

29
src/Utils.hs
View File

@ -45,13 +45,14 @@ import Control.Lens as Utils (none)
import Control.Arrow as Utils ((>>>))
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
import Control.Monad.Except (MonadError(..))
import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.Maybe as Utils (MaybeT(..))
import Control.Monad.Catch hiding (throwM)
import qualified Database.Esqueleto as E (Value, unValue)
import Language.Haskell.TH
import Language.Haskell.TH.Instances ()
import Instances.TH.Lift ()
import Text.Shakespeare.Text (st)
@ -69,6 +70,8 @@ import qualified Crypto.Data.PKCS7 as PKCS7
import Data.Fixed (Centi)
import Data.Ratio ((%))
import qualified Data.Binary as Binary
{-# ANN choice ("HLint: ignore Use asum" :: String) #-}
@ -490,6 +493,12 @@ maybeExceptT err act = lift act >>= maybe (throwE err) return
maybeMExceptT :: Monad m => m e -> m (Maybe b) -> ExceptT e m b
maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
maybeTExceptT :: Monad m => e -> MaybeT m b -> ExceptT e m b
maybeTExceptT err act = maybeExceptT err $ runMaybeT act
maybeTMExceptT :: Monad m => m e -> MaybeT m b -> ExceptT e m b
maybeTMExceptT err act = maybeMExceptT err $ runMaybeT act
whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
whenExceptT b err = when b $ throwE err
@ -601,6 +610,15 @@ choice = foldr (<|>) empty
-- Sessions --
--------------
data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
| SessionNewStudyTerms
| SessionBearer
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe SessionKey
instance Finite SessionKey
nullaryPathPiece ''SessionKey $ camelToPathPiece' 1
setSessionJson :: (PathPiece k, ToJSON v, MonadHandler m) => k -> v -> m ()
setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSessionBS key val
@ -725,3 +743,12 @@ encodedSecretBoxOpen :: ( FromJSON a, MonadError EncodedSecretBoxException m, Mo
encodedSecretBoxOpen ciphertext = do
sKey <- secretBoxKey
encodedSecretBoxOpen' sKey ciphertext
-------------
-- Caching --
-------------
cachedHere :: Q Exp
cachedHere = do
loc <- location
[e| cachedBy (toStrict $ Binary.encode loc) |]

6
src/Utils/DB.hs
View File

@ -35,6 +35,12 @@ existsKey :: (PersistEntityBackend record ~ BaseBackend backend, PersistEntity r
=> Key record -> ReaderT backend m Bool
existsKey = fmap isJust . get -- TODO optimize, so that DB does not deliver entire record
updateBy :: (PersistUniqueRead backend, PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend )
=> Unique record -> [Update record] -> ReaderT backend m ()
updateBy uniq updates = do
key <- getKeyBy uniq
for_ key $ flip update updates
myReplaceUnique -- Identical to Database.Persist.Class, except for the better type signature (original requires Eq record which is not needed anyway)
:: (MonadIO m
,Eq (Unique record)

4
src/Utils/Form.hs
View File

@ -189,6 +189,7 @@ data FormIdentifier
| FIDcUserNote
| FIDAdminDemo
| FIDUserDelete
| FIDCommunication
deriving (Eq, Ord, Read, Show)
instance PathPiece FormIdentifier where
@ -440,6 +441,9 @@ optionsFinite = do
}
return . mkOptionList $ mkOption <$> universeF
rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational
rationalField = convertField toRational fromRational doubleField
-----------
-- Forms --

29
src/Utils/Lens.hs
View File

@ -1,14 +1,15 @@
module Utils.Lens ( module Utils.Lens ) where
import Import.NoFoundation
import Control.Lens as Utils.Lens hiding ((<.>))
import ClassyPrelude.Yesod
import Model
import Control.Lens as Utils.Lens hiding ((<.>), universe, snoc)
import Control.Lens.Extras as Utils.Lens (is)
import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
_unValue :: Lens' (E.Value a) a
_unValue f (E.Value a) = E.Value <$> f a
_PathPiece :: PathPiece v => Prism' Text v
_PathPiece = prism' toPathPiece fromPathPiece
@ -90,7 +91,27 @@ makeLenses_ ''StudyTerms
makeLenses_ ''StudyTermCandidate
makeLenses_ ''FieldView
makePrisms ''HandlerContents
makePrisms ''ErrorResponse
makeLenses_ ''SheetCorrectorInvitation
makeLenses_ ''SubmissionMode
makePrisms ''E.Value
-- makeClassy_ ''Load
--------------------------
-- Fields for `UniWorX` --
--------------------------
class HasInstanceID s a | s -> a where
instanceID :: Lens' s a
class HasJSONWebKeySet s a | s -> a where
jsonWebKeySet :: Lens' s a

16
src/Utils/Parameters.hs
View File

@ -1,10 +1,10 @@
module Utils.Parameters
( GlobalGetParam(..)
, lookupGlobalGetParam, hasGlobalGetParam
, lookupGlobalGetParam, hasGlobalGetParam, lookupGlobalGetParams
, lookupGlobalGetParamForm, hasGlobalGetParamForm
, globalGetParamField
, GlobalPostParam(..)
, lookupGlobalPostParam, hasGlobalPostParam
, lookupGlobalPostParam, hasGlobalPostParam, lookupGlobalPostParams
, lookupGlobalPostParamForm, hasGlobalPostParamForm
, globalPostParamField
) where
@ -20,7 +20,7 @@ import Data.Universe
import Control.Monad.Trans.Maybe (MaybeT(..))
data GlobalGetParam = GetReferer
data GlobalGetParam = GetReferer | GetBearer | GetRecipient
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe GlobalGetParam
@ -33,6 +33,9 @@ lookupGlobalGetParam ident = (>>= fromPathPiece) <$> lookupGetParam (toPathPiece
hasGlobalGetParam :: MonadHandler m => GlobalGetParam -> m Bool
hasGlobalGetParam ident = isJust <$> lookupGetParam (toPathPiece ident)
lookupGlobalGetParams :: (MonadHandler m, PathPiece result) => GlobalGetParam -> m [result]
lookupGlobalGetParams ident = mapMaybe fromPathPiece <$> lookupGetParams (toPathPiece ident)
lookupGlobalGetParamForm :: (Monad m, PathPiece result) => GlobalGetParam -> MForm m (Maybe result)
lookupGlobalGetParamForm ident = runMaybeT $ do
@ -42,7 +45,7 @@ lookupGlobalGetParamForm ident = runMaybeT $ do
hasGlobalGetParamForm :: Monad m => GlobalGetParam -> MForm m Bool
hasGlobalGetParamForm ident = maybe False (Map.member $ toPathPiece ident) <$> askParams
globalGetParamField :: Monad m => GlobalPostParam -> Field m a -> MForm m (Maybe a)
globalGetParamField :: Monad m => GlobalGetParam -> Field m a -> MForm m (Maybe a)
globalGetParamField ident Field{fieldParse} = runMaybeT $ do
ts <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askParams
fs <- fromMaybe [] . Map.lookup (toPathPiece ident) <$> MaybeT askFiles
@ -51,6 +54,7 @@ globalGetParamField ident Field{fieldParse} = runMaybeT $ do
data GlobalPostParam = PostFormIdentifier
| PostDeleteTarget
| PostMassInputShape
| PostBearer
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe GlobalPostParam
@ -62,7 +66,11 @@ lookupGlobalPostParam ident = (>>= fromPathPiece) <$> lookupPostParam (toPathPie
hasGlobalPostParam :: MonadHandler m => GlobalPostParam -> m Bool
hasGlobalPostParam ident = isJust <$> lookupPostParam (toPathPiece ident)
lookupGlobalPostParams :: (MonadHandler m, PathPiece result) => GlobalPostParam -> m [result]
lookupGlobalPostParams ident = mapMaybe fromPathPiece <$> lookupPostParams (toPathPiece ident)
lookupGlobalPostParamForm :: (Monad m, PathPiece result) => GlobalPostParam -> MForm m (Maybe result)
lookupGlobalPostParamForm ident = runMaybeT $ do
ps <- MaybeT askParams

48
src/Utils/PathPiece.hs
View File

@ -1,9 +1,10 @@
module Utils.PathPiece
( finiteFromPathPiece
, nullaryToPathPiece
, nullaryPathPiece
, nullaryPathPiece, finitePathPiece
, splitCamel
, camelToPathPiece, camelToPathPiece'
, tuplePathPiece
) where
import ClassyPrelude.Yesod
@ -15,8 +16,14 @@ import Data.Universe
import qualified Data.Text as Text
import qualified Data.Char as Char
import Data.Map ((!), (!?))
import qualified Data.Map as Map
import Numeric.Natural
import Data.List (foldl)
finiteFromPathPiece :: (PathPiece a, Finite a) => Text -> Maybe a
finiteFromPathPiece text = case filter (\c -> toPathPiece c == text) universeF of
[x] -> Just x
@ -40,6 +47,16 @@ nullaryPathPiece nullaryType mangle =
, funD 'fromPathPiece
[ clause [] (normalB [e|finiteFromPathPiece|]) [] ]
]
finitePathPiece :: Name -> [Text] -> DecsQ
finitePathPiece finiteType verbs =
pure <$> instanceD (cxt []) [t|PathPiece $(conT finiteType)|]
[ funD 'toPathPiece
[ clause [] (normalB [|(Map.fromList (zip universeF verbs) !)|]) [] ]
, funD 'fromPathPiece
[ clause [] (normalB [e|(Map.fromList (zip verbs universeF) !?)|]) [] ]
]
splitCamel :: Textual t => t -> [t]
splitCamel = map fromList . reverse . helper (error "hasChange undefined at start of string") [] "" . otoList
@ -63,3 +80,32 @@ camelToPathPiece' dropN = intercalate "-" . map toLower . drop (fromIntegral dro
camelToPathPiece :: Textual t => t -> t
camelToPathPiece = camelToPathPiece' 0
tuplePathPiece :: Int -> DecQ
tuplePathPiece tupleDim = do
let
tupleSeparator :: Text
tupleSeparator = ","
xs <- replicateM tupleDim $ newName "x" :: Q [Name]
xs' <- replicateM tupleDim $ newName "x'" :: Q [Name]
let tupleType = foldl appT (tupleT tupleDim) $ map varT xs
tCxt = cxt
[ [t|PathPiece $(varT x)|] | x <- xs ]
t <- newName "t"
instanceD tCxt [t|PathPiece $(tupleType)|]
[ funD 'toPathPiece
[ clause [tupP $ map varP xs] (normalB [e|Text.intercalate tupleSeparator $(listE $ map (appE [e|toPathPiece|] . varE) xs)|]) []
]
, funD 'fromPathPiece
[ clause [varP t] (normalB . doE $ concat
[ pure $ bindS (listP $ map varP xs) [e|return $ Text.splitOn tupleSeparator $(varE t)|]
, [ bindS (varP x') [e|fromPathPiece $(varE x)|] | (x, x') <- zip xs xs' ]
, pure $ noBindS [e|return $(tupE $ map varE xs')|]
]) []
]
]

174
src/Utils/Tokens.hs Normal file
View File

@ -0,0 +1,174 @@
module Utils.Tokens
( bearerToken
, encodeToken, BearerTokenException(..), decodeToken
, tokenParseJSON'
, askJwt
, formEmbedJwtPost, formEmbedJwtGet
) where
import ClassyPrelude.Yesod
import Yesod.Auth (AuthId)
import Utils (NTop(..), hoistMaybe, SessionKey(..))
import Utils.Parameters
import Utils.Lens
import Model
import Model.Tokens
import Jose.Jwk (JwkSet(..))
import Jose.Jwt (Jwt(..))
import qualified Jose.Jwt as Jose
import Data.Aeson.Types (Parser)
import qualified Data.Aeson as JSON
import qualified Data.Aeson.Parser as JSON
import qualified Data.Aeson.Parser.Internal as JSON (jsonEOF')
import qualified Data.Aeson.Internal as JSON (iparse, formatError)
import qualified Data.HashMap.Strict as HashMap
import Data.Time.Clock
import Control.Monad.Random (MonadRandom(..))
import Control.Monad.Trans.Maybe (MaybeT(..))
import Settings
import CryptoID
import Text.Blaze (Markup)
tokenParseJSON' :: forall m.
( HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
, ParseRoute (HandlerSite m)
, Hashable (Route (HandlerSite m))
, MonadHandler m
, MonadCrypto m
, MonadCryptoKey m ~ CryptoIDKey
)
=> m (Value -> Parser (BearerToken (HandlerSite m)))
-- ^ Read `CryptoIDKey` from monadic context and construct a `Parser` for `BearerToken`s
tokenParseJSON' = do
cidKey <- cryptoIDKey return
return $ flip runReaderT cidKey . tokenParseJSON
bearerToken :: forall m.
( MonadHandler m
, HasInstanceID (HandlerSite m) InstanceId
, HasCryptoUUID (AuthId (HandlerSite m)) m
, HasAppSettings (HandlerSite m)
)
=> AuthId (HandlerSite m)
-> Maybe (HashSet (Route (HandlerSite m)))
-> Maybe AuthDNF
-> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
-> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
-> m (BearerToken (HandlerSite m))
-- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict`
bearerToken tokenAuthority tokenRoutes tokenAddAuth mTokenExpiresAt tokenStartsAt = do
tokenIdentifier <- liftIO getRandom
tokenIssuedAt <- liftIO getCurrentTime
tokenIssuedBy <- getsYesod $ view instanceID
defaultExpiration <- getsYesod $ view _appJwtExpiration
let tokenExpiresAt
| Just t <- mTokenExpiresAt
= t
| Just tDiff <- defaultExpiration
= Just $ tDiff `addUTCTime` fromMaybe tokenIssuedAt tokenStartsAt
| otherwise
= Nothing
tokenRestrictions = HashMap.empty
return BearerToken{..}
encodeToken :: forall m.
( MonadHandler m
, HasJSONWebKeySet (HandlerSite m) JwkSet
, HasInstanceID (HandlerSite m) InstanceId
, HasAppSettings (HandlerSite m)
, HasCryptoUUID (AuthId (HandlerSite m)) m
, RenderRoute (HandlerSite m)
)
=> BearerToken (HandlerSite m) -> m Jwt
-- ^ Call `tokenToJSON` and encode the result as a `Jwt` according to `appJwtEncoding`
encodeToken token = do
payload <- Jose.Claims . toStrict . JSON.encode <$> tokenToJSON token
JwkSet jwks <- getsYesod $ view jsonWebKeySet
jwtEncoding <- getsYesod $ view _appJwtEncoding
either throwM return =<< liftIO (Jose.encode jwks jwtEncoding payload)
data BearerTokenException
= BearerTokenJwtError Jose.JwtError -- ^ An Error occurred in the underlying `Jwt`-Implementation
| BearerTokenUnsecured -- ^ `Jwt` is insufficiently secured (unsigned and not encrypted)
| BearerTokenInvalidFormat String -- ^ Content of the `Jwt` could not be parsed as a `BearerToken`
| BearerTokenExpired | BearerTokenNotStarted
deriving (Eq, Show, Generic, Typeable)
instance Exception BearerTokenException
decodeToken :: forall m.
( MonadHandler m
, HasJSONWebKeySet (HandlerSite m) JwkSet
, HasCryptoUUID (AuthId (HandlerSite m)) (ReaderT CryptoIDKey Parser)
, MonadCryptoKey m ~ CryptoIDKey
, MonadCrypto m
, MonadThrow m
, ParseRoute (HandlerSite m)
, Hashable (Route (HandlerSite m))
)
=> Jwt -> m (BearerToken (HandlerSite m))
-- ^ Decode a `Jwt` and call `tokenParseJSON`
--
-- Throws `bearerTokenException`s
decodeToken (Jwt bs) = do
JwkSet jwks <- getsYesod $ view jsonWebKeySet
content <- either (throwM . BearerTokenJwtError) return =<< liftIO (Jose.decode jwks Nothing bs)
content' <- case content of
Jose.Unsecured _ -> throwM BearerTokenUnsecured
Jose.Jws (_header, payload) -> return payload
Jose.Jwe (_header, payload) -> return payload
parser <- tokenParseJSON'
token@BearerToken{..} <- either (throwM . BearerTokenInvalidFormat . uncurry JSON.formatError) return $ JSON.eitherDecodeStrictWith JSON.jsonEOF' (JSON.iparse parser) content'
now <- liftIO getCurrentTime
unless (NTop tokenExpiresAt > NTop (Just now)) $
throwM BearerTokenExpired
unless (tokenStartsAt <= Just now) $
throwM BearerTokenNotStarted
return token
askJwt :: forall m. ( MonadHandler m )
=> m (Maybe Jwt)
-- ^ Retrieve current `Jwt` from HTTP-Header, POST-Parameter, or GET-Parameter
askJwt = runMaybeT $ asum
[ MaybeT lookupBearerAuth >>= hoistMaybe . fromPathPiece
, MaybeT $ lookupGlobalPostParam PostBearer
, MaybeT $ lookupGlobalGetParam GetBearer
, fmap Jwt . MaybeT $ lookupSessionBS (toPathPiece SessionBearer)
]
formEmbedJwtPost, formEmbedJwtGet :: MonadHandler m => (Markup -> m a) -> (Markup -> m a)
formEmbedJwtPost f fragment = do
mJwt <- askJwt
f [shamlet|
$newline never
$maybe jwt <- mJwt
<input type=hidden name=#{toPathPiece PostBearer} value=#{toPathPiece jwt}>
#{fragment}
|]
formEmbedJwtGet f fragment = do
mJwt <- askJwt
f [shamlet|
$newline never
$maybe jwt <- mJwt
<input type=hidden name=#{toPathPiece GetBearer} value=#{toPathPiece jwt}>
#{fragment}
|]

12
src/Web/PathPieces/Instances.hs Normal file
View File

@ -0,0 +1,12 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Web.PathPieces.Instances
(
) where
import Prelude
import Utils.PathPiece
$(mapM tuplePathPiece [2..4])

68
src/Yesod/Core/Instances.hs
View File

@ -15,37 +15,61 @@ import Data.ByteString.Builder (toLazyByteString)
import System.FilePath ((</>))
import Data.Aeson
import Data.Aeson.Types
import Control.Monad.Fix
import Control.Monad.Fail (MonadFail)
import qualified Control.Monad.Fail as MonadFail
import Control.Monad.Except (MonadError(..))
import Data.Functor.Extend
import Data.Binary (Binary)
import qualified Data.Binary as Binary
routeFromPathPiece :: ParseRoute site => Text -> Maybe (Route site)
routeFromPathPiece
= parseRoute
. over (_2.traverse._2) (fromMaybe "")
. over _2 queryToQueryText
. decodePath
. encodeUtf8
routeToPathPiece :: RenderRoute site => Route site -> Text
routeToPathPiece
= pack
. ("/" </>)
. unpack
. decodeUtf8
. toLazyByteString
. uncurry encodePath
. over _2 queryTextToQuery
. over (_2.traverse._2) (assertM' $ not . null)
. renderRoute
instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
fromPathPiece
= parseRoute
. over (_2.traverse._2) (fromMaybe "")
. over _2 queryToQueryText
. decodePath
. encodeUtf8
toPathPiece
= pack
. ("/" </>)
. unpack
. decodeUtf8
. toLazyByteString
. uncurry encodePath
. over _2 queryTextToQuery
. over (_2.traverse._2) (assertM' $ not . null)
. renderRoute
fromPathPiece = routeFromPathPiece
toPathPiece = routeToPathPiece
instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where
parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . fromPathPiece
instance ParseRoute site => FromJSON (Route site) where
parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . routeFromPathPiece
instance (RenderRoute site, ParseRoute site) => ToJSON (Route site) where
toJSON = String . toPathPiece
instance RenderRoute site => ToJSON (Route site) where
toJSON = String . routeToPathPiece
instance ParseRoute site => FromJSONKey (Route site) where
fromJSONKey = FromJSONKeyTextParser $ maybe (fail "Coulde not parse route") return . routeFromPathPiece
instance RenderRoute site => ToJSONKey (Route site) where
toJSONKey = toJSONKeyText routeToPathPiece
instance (RenderRoute site, ParseRoute site) => Binary (Route site) where
put = Binary.put . toPathPiece
get = Binary.get >>= maybe (fail "Could not parse route") return . fromPathPiece
instance RenderRoute site => Hashable (Route site) where
hashWithSalt s = hashWithSalt s . routeToPathPiece
instance Monad FormResult where
@ -77,3 +101,5 @@ instance Extend FormResult where
duplicated (FormSuccess x) = FormSuccess $ FormSuccess x
duplicated FormMissing = FormMissing
duplicated (FormFailure errs) = FormFailure errs
deriving instance Eq a => Eq (FormResult a)

36
src/Yesod/Core/Types/Instances.hs
View File

@ -1,16 +1,48 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE GeneralizedNewtypeDeriving, UndecidableInstances #-}
module Yesod.Core.Types.Instances
(
( CachedMemoT(..)
) where
import ClassyPrelude
import ClassyPrelude.Yesod
import Yesod.Core.Types
import Control.Monad.Fix
import Control.Monad.Memo
import Data.Binary (Binary)
import qualified Data.Binary as Binary
import Control.Monad.Logger (MonadLoggerIO)
instance MonadFix m => MonadFix (HandlerT site m) where
mfix f = HandlerT $ \r -> mfix $ \a -> unHandlerT (f a) r
instance MonadFix m => MonadFix (WidgetT site m) where
mfix f = WidgetT $ \r -> mfix $ \ ~(a, _) -> unWidgetT (f a) r
-- | Type-level tags for compatability of Yesod `cached`-System with `MonadMemo`
newtype CachedMemoT k v m a = CachedMemoT { runCachedMemoT :: m a }
deriving newtype ( Functor, Applicative, Alternative, Monad, MonadPlus, MonadFix
, MonadIO
, MonadThrow, MonadCatch, MonadMask, MonadLogger, MonadLoggerIO
, MonadResource, MonadHandler, MonadWidget
, IsString, Semigroup, Monoid
)
deriving newtype instance MonadBase b m => MonadBase b (CachedMemoT k v m)
deriving newtype instance MonadBaseControl b m => MonadBaseControl b (CachedMemoT k v m)
deriving newtype instance MonadReader r m => MonadReader r (CachedMemoT k v m)
instance MonadTrans (CachedMemoT k v) where
lift = CachedMemoT
-- | Uses `cachedBy` with a `Binary`-encoded @k@
instance (Typeable v, Binary k, MonadHandler m) => MonadMemo k v (CachedMemoT k v m) where
memo act key = cachedBy (toStrict $ Binary.encode key) $ act key

11
start.sh
View File

@ -1,12 +1,11 @@
#!/usr/bin/env bash
unset HOST
export DETAILED_LOGGING=true
export LOG_ALL=false
export LOGLEVEL=info
export DUMMY_LOGIN=true
export ALLOW_DEPRECATED=true
export PWFILE=users.yml
export DETAILED_LOGGING=${DETAILED_LOGGIN:-true}
export LOG_ALL=${LOG_ALL:-false}
export LOGLEVEL=${LOGLEVEL:-info}
export DUMMY_LOGIN=${DUMMY_LOGIN:-true}
export ALLOW_DEPRECATED=${ALLOW_DEPRECATED:-true}
move-back() {
mv -v .stack-work .stack-work-run

7
static/css/utils/form.scss
View File

@ -1,16 +1,13 @@
fieldset {
border: 0;
margin: 20px 0 30px;
margin: 0;
padding: 0;
legend {
display: none;
}
}
.form-group__input > fieldset {
margin-bottom: 0;
}
@media (min-width: 769px) {
.form-group__input {
grid-column: 2;

28
static/css/utils/modal.scss
View File

@ -1,27 +1,43 @@
.modal {
.modals-wrapper {
position: fixed;
left: 50%;
top: 50%;
transform: translate(-50%, -50%) scale(0.8, 0.8);
left: 0;
top: 0;
width: 100%;
height: 100%;
z-index: -1;
display: flex;
align-items: center;
justify-content: center;
&.modals-wrapper--open {
z-index: 200;
width: 100%;
height: 100%;
}
}
.modal {
position: relative;
display: none;
background-color: rgba(255, 255, 255, 1);
min-width: 60vw;
max-width: 70vw;
min-height: 100px;
max-height: calc(100vh - 30px);
border-radius: 2px;
z-index: -1;
color: var(--color-font);
padding: 0 65px 0 20px;
padding: 0 40px;
overflow: auto;
overscroll-behavior: contain;
pointer-events: none;
opacity: 0;
&.modal--open {
display: flex;
opacity: 1;
pointer-events: auto;
z-index: 200;
transform: translate(-50%, -50%) scale(1, 1);
transition:
opacity .2s .1s ease-in-out,
transform .3s ease-in-out;

8
static/js/services/utilRegistry.js
View File

@ -144,12 +144,4 @@
window.UtilRegistry.setupAll();
});
// REMOVE ME. JUST HERE TO AVOID JS ERRORS
window.utils = {
setup: function(name) {
console.log('not really setting up', name);
},
};
})();

4
static/js/utils/checkAll.js
View File

@ -91,12 +91,10 @@
checkboxColumn = columns[checkboxColumnId];
var firstRow = element.querySelector('tr');
var th = Array.from(firstRow.querySelectorAll('th, td'))[checkboxColumnId];
th.innerHTML = 'test';
checkAllCheckbox = document.createElement('input');
checkAllCheckbox.setAttribute('type', 'checkbox');
checkAllCheckbox.setAttribute('id', getCheckboxId());
th.innerHTML = '';
th.insertBefore(checkAllCheckbox, null);
th.insertBefore(checkAllCheckbox, th.firstChild);
// manually set up newly created checkbox
if (UtilRegistry) {

45
static/js/utils/form.js
View File

@ -124,8 +124,10 @@
* Selector for the input that this fieldset watches for changes
* data-conditional-value: string
* The value the conditional input needs to be set to for this fieldset to be shown
* Can be omitted if conditionalInput is a checkbox
*
* Example usage:
* ## example with text input
* <input id="input-0" type="text">
* <fieldset uw-interactive-fieldset data-conditional-input="#input-0" data-conditional-value="yes">...</fieldset>
* <fieldset uw-interactive-fieldset data-conditional-input="#input-0" data-conditional-value="no">...</fieldset>
@ -135,16 +137,25 @@
* <option value="1">One
* <fieldset uw-interactive-fieldset data-conditional-input="#select-0" data-conditional-value="0">...</fieldset>
* <fieldset uw-interactive-fieldset data-conditional-input="#select-0" data-conditional-value="1">...</fieldset>
* ## example with checkbox
* <input id="checkbox-0" type="checkbox">
* <input id="checkbox-1" type="checkbox">
* <fieldset uw-interactive-fieldset data-conditional-input="#checkbox-0">...</fieldset>
* <fieldset uw-interactive-fieldset data-conditional-input="#checkbox-1">...</fieldset>
*/
var INTERACTIVE_FIELDSET_UTIL_NAME = 'interactiveFieldset';
var INTERACTIVE_FIELDSET_UTIL_SELECTOR = '[uw-interactive-fieldset]';
var INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR = '.interactive-fieldset__target';
var INTERACTIVE_FIELDSET_INITIALIZED_CLASS = 'interactive-fieldset--initialized';
var INTERACTIVE_FIELDSET_CHILD_SELECTOR = 'input:not([disabled]), select:not([disabled]), textarea:not([disabled]), button:not([disabled])';
var interactiveFieldsetUtil = function(element) {
var conditionalInput;
var conditionalValue;
var target;
var childInputs;
function init() {
if (!element) {
@ -166,12 +177,23 @@
}
// param conditionalValue
if (!element.dataset.conditionalValue) {
if (!element.dataset.conditionalValue && !isCheckbox()) {
throw new Error('Interactive Fieldset needs a conditional value!');
}
conditionalValue = element.dataset.conditionalValue;
target = element.closest(INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR);
if (!target || element.matches(INTERACTIVE_FIELDSET_UTIL_TARGET_SELECTOR)) {
target = element;
}
childInputs = Array.from(element.querySelectorAll(INTERACTIVE_FIELDSET_CHILD_SELECTOR));
// add event listener
var observer = new MutationObserver(function(mutationsList, observer) {
updateVisibility();
});
observer.observe(conditionalInput, { attributes: true, attributeFilter: ['disabled'] });
conditionalInput.addEventListener('input', updateVisibility);
// initial visibility update
@ -188,7 +210,25 @@
}
function updateVisibility() {
element.classList.toggle('hidden', conditionalInput.value !== conditionalValue);
var active = matchesConditionalValue() && !conditionalInput.disabled;
target.classList.toggle('hidden', !active);
childInputs.forEach(function(el) {
el.disabled = !active;
});
}
function matchesConditionalValue() {
if (isCheckbox()) {
return conditionalInput.checked === true;
}
return conditionalInput.value === conditionalValue;
}
function isCheckbox() {
return conditionalInput.getAttribute('type') === 'checkbox';
}
return init();
@ -260,6 +300,7 @@
var FORM_GROUP_SELECTOR = '.form-group';
var FORM_GROUP_WITH_ERRORS_CLASS = 'form-group--has-error';
var formErrorRemoverUtil = function(element) {
var formGroups;

2
static/js/utils/inputs.js
View File

@ -161,7 +161,7 @@
return false;
}
var siblingEl = element.nextElementSibling;
var siblingEl = element.nextSibling;
var parentEl = element.parentElement;
var wrapperEl = document.createElement('div');

44
static/js/utils/modal.js
View File

@ -37,9 +37,17 @@
var MAIN_CONTENT_CLASS = 'main__content-body'
// one singleton wrapper to keep all the modals to avoid CSS bug
// with blurry text due to `transform: translate(-50%, -50%)`
// will be created (and reused) for the first modal that gets initialized
var MODALS_WRAPPER_CLASS = 'modals-wrapper';
var MODALS_WRAPPER_SELECTOR = '.' + MODALS_WRAPPER_CLASS;
var MODALS_WRAPPER_OPEN_CLASS = 'modals-wrapper--open';
var modalUtil = function(element) {
var overlayElement = document.createElement('div');
var modalsWrapper;
var modalOverlay;
var modalUrl;
function _init() {
@ -51,6 +59,8 @@
return false;
}
ensureModalWrapper();
// param modalTrigger
if (!element.dataset.modalTrigger) {
throw new Error('Modal utility cannot be setup without a trigger element!');
@ -63,8 +73,6 @@
setupCloser();
}
// setupForm();
// mark as initialized and add modal class for styling
element.classList.add(MODAL_INITIALIZED_CLASS, MODAL_CLASS);
@ -75,6 +83,24 @@
};
}
function ensureModalWrapper() {
modalsWrapper = document.querySelector(MODALS_WRAPPER_SELECTOR);
if (!modalsWrapper) {
// create modal wrapper
modalsWrapper = document.createElement('div');
modalsWrapper.classList.add(MODALS_WRAPPER_CLASS);
document.body.appendChild(modalsWrapper);
}
modalOverlay = modalsWrapper.querySelector('.' + MODAL_OVERLAY_CLASS);
if (!modalOverlay) {
// create modal overlay
modalOverlay = document.createElement('div');
modalOverlay.classList.add(MODAL_OVERLAY_CLASS);
modalsWrapper.appendChild(modalOverlay);
}
}
function setupTrigger() {
var triggerSelector = element.dataset.modalTrigger;
if (!triggerSelector.startsWith('#')) {
@ -96,7 +122,7 @@
element.insertBefore(closerElement, null);
closerElement.classList.add(MODAL_CLOSER_CLASS);
closerElement.addEventListener('click', onCloseClicked, false);
overlayElement.addEventListener('click', onCloseClicked, false);
modalOverlay.addEventListener('click', onCloseClicked, false);
}
function onTriggerClicked(event) {
@ -116,11 +142,10 @@
}
function open() {
document.body.insertBefore(element, null);
element.classList.add(MODAL_OPEN_CLASS);
overlayElement.classList.add(MODAL_OVERLAY_CLASS);
document.body.insertBefore(overlayElement, element);
overlayElement.classList.add(MODAL_OVERLAY_OPEN_CLASS);
modalOverlay.classList.add(MODAL_OVERLAY_OPEN_CLASS);
modalsWrapper.classList.add(MODALS_WRAPPER_OPEN_CLASS);
modalsWrapper.appendChild(element);
if (modalUrl) {
fillModal(modalUrl);
@ -130,8 +155,9 @@
}
function close() {
overlayElement.classList.remove(MODAL_OVERLAY_OPEN_CLASS);
modalOverlay.classList.remove(MODAL_OVERLAY_OPEN_CLASS);
element.classList.remove(MODAL_OPEN_CLASS);
modalsWrapper.classList.remove(MODALS_WRAPPER_OPEN_CLASS);
document.removeEventListener('keyup', onKeyUp);
};

6
templates/course/lecturerMassInput/add.hamlet Normal file
View File

@ -0,0 +1,6 @@
$newline never
<td colspan=3>
#{csrf}
^{fvInput addView}
<td>
^{fvInput btn}

12
templates/course/lecturerMassInput/cellInvitation.hamlet Normal file
View File

@ -0,0 +1,12 @@
$newline never
<td>
#{csrf}
<span style="font-family: monospace">
#{lEmail}
<td>
<div .tooltip>
<div .tooltip__handle>
<div .tooltip__content>
_{MsgEmailInvitationWarning}
<td>
^{fvInput lrwView}

6
templates/course/lecturerMassInput/cellKnown.hamlet Normal file
View File

@ -0,0 +1,6 @@
$newline never
<td colspan=2>
#{csrf}
^{nameEmailWidget userEmail userDisplayName userSurname} #
<td>
^{fvInput lrwView}

11
templates/course/lecturerMassInput/layout.hamlet Normal file
View File

@ -0,0 +1,11 @@
$newline never
<table>
<tbody>
$forall coord <- review liveCoords lLength
<tr .massinput--cell>
^{cellWdgts ! coord}
<td>
^{fvInput (delButtons ! coord)}
<tfoot>
<tr .massinput--add>
^{addWdgts ! (0, 0)}

3
templates/courseLecInvite.hamlet Normal file
View File

@ -0,0 +1,3 @@
<p>
_{MsgCourseLecInviteExplanation}
^{btnWidget}

17
templates/default-layout.hamlet
View File

@ -15,16 +15,15 @@ $if not isModal
<div .main__content-body>
<section>
$maybe headline <- contentHeadline
<h1 .headline-one>
<!-- $maybe back <- lastMaybe parents
<a .breadcrumbs__link href="@{fst back}">#{snd back} -->
^{headline}
$maybe headline <- contentHeadline
<h1 .headline-one>
<!-- $maybe back <- lastMaybe parents
<a .breadcrumbs__link href="@{fst back}">#{snd back} -->
^{headline}
$if not isModal && hasPageActions
<!-- page actions -->
^{pageaction}
$if not isModal && hasPageActions
<!-- page actions -->
^{pageaction}
<!-- actual content -->
^{widget}

2
templates/default-layout.lucius
View File

@ -541,5 +541,5 @@ section {
}
.headline-one {
margin-bottom: 15px;
margin-bottom: 10px;
}

5
templates/help.hamlet
View File

@ -1,3 +1,4 @@
<p>
<section>
_{MsgHelpIntroduction}
^{formWidget}
<section>
^{formWidget}

11
templates/mail/correctorInvitation.hamlet Normal file
View File

@ -0,0 +1,11 @@
$newline never
\<!doctype html>
<html>
<head>
<meta charset="UTF-8">
<body>
<p>
_{MsgSheetCorrInviteExplanation}
<p>
<a href=#{invitationUrl'}>
_{MsgInvitationAcceptDecline}

5
templates/mail/editNotifications.hamlet
View File

@ -1,4 +1,3 @@
<p>
<a href=@{ProfileR}>
_{MsgProfileHeading}
\ _{MsgMailEditNotifications}
<a href=#{editNotificationsUrl'}>
_{MsgMailEditNotifications}

11
templates/mail/lecturerInvitation.hamlet Normal file
View File

@ -0,0 +1,11 @@
$newline never
\<!doctype html>
<html>
<head>
<meta charset="UTF-8">
<body>
<p>
_{MsgCourseLecInviteExplanation}
<p>
<a href=#{invitationUrl'}>
_{MsgInvitationAcceptDecline}

2
templates/profile.hamlet
View File

@ -1,2 +0,0 @@
<div .profile>
^{settingsForm}

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