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

Merge branch 'master' into 'live'

Browse Source 
Master

See merge request !94
This commit is contained in:
Gregor Kleen 2018-11-14 16:18:29 +01:00
commit 4bf70fbea4
26 changed files with 730 additions and 399 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
.vscode/tasks.json vendored
View File

@ -28,7 +28,8 @@
"focus": false, "focus": false,
"panel": "dedicated", "panel": "dedicated",
"showReuseMessage": false "showReuseMessage": false
} },
"problemMatcher": []
}, },
{ {
"label": "test", "label": "test",

122
README.md
View File

@ -3,79 +3,125 @@
The following Description applies to Ubuntu or similar. The following Description applies to Ubuntu or similar.
## Clone repository ## Clone repository
Clone this repository `git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git` and navigate into the new directory `cd UniWorX`. Clone this repository and navigate into
```sh
$ git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git && cd UniWorX
```
## LDAP ## LDAP
install: install:
`sudo apt-get install slapd ldap-utils` ```sh
$ sudo apt-get install slapd ldap-utils
```
## PostgreSQL ## PostgreSQL
install: install:
`sudo apt-get install postgresql` ```sh
$ sudo apt-get install postgresql
```
switch to user *postgres* (got created during installation): switch to user *postgres* (got created during installation):
`sudo -i -u postgres` ```sh
$ sudo -i -u postgres
```
add db user *uniworx*: add db user *uniworx*:
`createuser --interactive` ```sh
$ createuser --interactive
```
you'll get a prompt: you'll get a prompt:
``` ```sh
Enter name of role to add:` - [enter 'uniworx'] Enter name of role to add:` - uniworx
Shall the new role be a superuser? (y/n)` - [not exactly sure. Guess not?] Shall the new role be a superuser? (y/n)` - [not exactly sure. Guess not?]
Password: uniworx
...
``` ```
create database *uniworx*: create database *uniworx*:
`createdb uniworx` ```sh
$ createdb uniworx
```
to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*: after you added the database switch back to your own user with `Ctrl + D`.
`sudo adduser uniworx`
log-in as new user *uniworx*: to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*. when you get asked for a password enter *uniworx*.
`sudo -i -u uniworx` ```sh
$ sudo adduser uniworx
```
you can now use `psql uniworx` to execute SQL-commands and such. log-in as new user *uniworx*:
```sh
$ sudo -i -u uniworx
```
you can now use
```sh
$ psql uniworx
```
to execute SQL-commands and such.
## stack ## stack
Install with: Install with:
`curl -sSL https://get.haskellstack.org/ | sh` ```sh
$ curl -sSL https://get.haskellstack.org/ | sh
```
setup stack and install dependencies: setup stack and install dependencies:
`stack setup` ```sh
$ stack setup
```
During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using
`sudo apt-get install libsasl2-dev libldap2-dev` ```sh
$ sudo apt-get install libsasl2-dev libldap2-dev
```
If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.* If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.*
Go ahead an install `libpq-dev` with Go ahead an install `libpq-dev` with
`sudo apt-get install libpq-dev` ```sh
$ sudo apt-get install libpq-dev
```
Build the app: Other packages you might need to install during this process:
`stack build` ```sh
$ sudo apt-get install pkg-config
sudo apt-get install libsodium-dev
```
Build the app:
```sh
$ stack build
```
This might take a few minutes if not hours... be prepared. This might take a few minutes if not hours... be prepared.
install yesod: install yesod:
`stack install yesod-bin --install-ghc` ```sh
$ stack install yesod-bin --install-ghc
```
## Add Dumy-Data and run the app ## Add Dumy-Data and run the app
After building the app you can prepare the database and add some dummy data: After building the app you can prepare the database and add some dummy data:
`./fill-db.hs` ```sh
$ ./db.sh -f
```
Run the app: Run the app:
`./start.sh` ```sh
$ ./start.sh
`Devel application launched: http://localhost:3000` ...
means you are good to go. Devel application launched: http://localhost:3000
```
If you followed the steps above you should now be able to login as user Gregor Kleen using `LDAP:g.kleen@ifi.lmu.de` as dummy login. If you followed the steps above you should now be able to login as user Gregor Kleen using `LDAP:g.kleen@ifi.lmu.de` as dummy login.
*** ***
# Sources and more infos # Sources and more infos
PostgreSQl: PostgreSQl:
https://www.digitalocean.com/community/tutorials/how-to-install-and-use-postgresql-on-ubuntu-16-04 https://www.digitalocean.com/community/tutorials/how-to-install-and-use-postgresql-on-ubuntu-16-04
stack: https://docs.haskellstack.org/en/stable/README/#how-to-install stack: https://docs.haskellstack.org/en/stable/README/#how-to-install

4
ghci.sh
View File

@ -7,11 +7,11 @@ export DUMMY_LOGIN=true
move-back() { move-back() {
mv -v .stack-work .stack-work-ghci mv -v .stack-work .stack-work-ghci
[[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
} }
if [[ -d .stack-work-ghci ]]; then if [[ -d .stack-work-ghci ]]; then
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-run [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
mv -v .stack-work-ghci .stack-work mv -v .stack-work-ghci .stack-work
trap move-back EXIT trap move-back EXIT
fi fi

38
messages/uniworx/de.msg
View File

@ -142,10 +142,13 @@ SubmissionGroupName: Gruppenname
CorrectionsTitle: Zugewiesene Korrekturen CorrectionsTitle: Zugewiesene Korrekturen
CourseCorrectionsTitle: Korrekturen für diesen Kurs CourseCorrectionsTitle: Korrekturen für diesen Kurs
CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName} CorrectorsHead sheetName@SheetName: Korrektoren für #{sheetName}
CorrectorAssignTitle: Korrektor zuweisen
Unauthorized: Sie haben hierfür keine explizite Berechtigung. Unauthorized: Sie haben hierfür keine explizite Berechtigung.
UnauthorizedAnd l@Text r@Text: (#{l} UND #{r}) UnauthorizedAnd l@Text r@Text: (#{l} UND #{r})
UnauthorizedOr l@Text r@Text: (#{l} ODER #{r}) UnauthorizedOr l@Text r@Text: (#{l} ODER #{r})
UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen. UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen.
UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen. UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen.
@ -167,7 +170,9 @@ MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar. UnauthorizedSystemMessageTime: Diese Systemnachricht ist noch nicht oder nicht mehr einsehbar.
UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar. UnauthorizedSystemMessageAuth: Diese Systemnachricht ist nur für angemeldete Benutzer einsehbar.
UnsupportedAuthPredicate tag@String shownRoute@String: "!#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute} UnsupportedAuthPredicate tag@String shownRoute@String: "#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
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
EMail: E-Mail EMail: E-Mail
EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer. EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
@ -189,6 +194,7 @@ CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Ante
DeleteRow: Zeile entfernen DeleteRow: Zeile entfernen
ProportionNegative: Anteile dürfen nicht negativ sein ProportionNegative: Anteile dürfen nicht negativ sein
CorrectorUpdated: Korrektor erfolgreich aktualisiert
CorrectorsUpdated: Korrektoren erfolgreich aktualisiert CorrectorsUpdated: Korrektoren erfolgreich aktualisiert
CorrectorsPlaceholder: Korrektoren... CorrectorsPlaceholder: Korrektoren...
CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert. CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert.
@ -228,6 +234,7 @@ CorrAutoSetCorrector: Korrekturen verteilen
NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein! NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!
SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert: SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
SubmissionsAssignUnauthorized num@Int64: #{display num} Abgaben können momentan nicht einem Korrektor zugeteilt werden (z.B. weil die Abgabe noch offen ist):
UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neuen Korrektor zugeteilt. UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neuen Korrektor zugeteilt.
NoCorrector: Kein Korrektor NoCorrector: Kein Korrektor
RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt. RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt.
@ -258,7 +265,7 @@ RatingDone: Bewertung fertiggestellt
RatingPercent: Erreicht RatingPercent: Erreicht
RatingFiles: Korrigierte Dateien RatingFiles: Korrigierte Dateien
PointsNotPositive: Punktzahl darf nicht negativ sein PointsNotPositive: Punktzahl darf nicht negativ sein
PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{tshow maxPoints} sein PointsTooHigh maxPoints@Points: Punktzahl darf nicht höher als #{tshow maxPoints} sein
RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
ColumnRatingPointsDone: Punktzahl/Abgeschlossen ColumnRatingPointsDone: Punktzahl/Abgeschlossen
Pseudonyms: Pseudonyme Pseudonyms: Pseudonyme
@ -299,6 +306,8 @@ DownloadFiles: Dateien automatisch herunterladen
DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden). DownloadFilesTip: Wenn gesetzt werden Dateien von Abgaben und Übungsblättern automatisch als Download behandelt, ansonsten ist das Verhalten browserabhängig (es können z.B. PDFs im Browser geöffnet werden).
NotificationSettings: Erwünschte Benachrichtigungen NotificationSettings: Erwünschte Benachrichtigungen
ActiveAuthTags: Aktivierte Authorisierungsprädikate
InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet InvalidDateTimeFormat: Ungültiges Datums- und Zeitformat, JJJJ-MM-TTTHH:MM[:SS] Format erwartet
AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren AmbiguousUTCTime: Der angegebene Zeitpunkt lässt sich nicht eindeutig zu UTC konvertieren
IllDefinedUTCTime: Der angegebene Zeitpunkt lässt sich nicht zu UTC konvertieren IllDefinedUTCTime: Der angegebene Zeitpunkt lässt sich nicht zu UTC konvertieren
@ -366,7 +375,7 @@ SheetGrading: Bewertung
SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte SheetGradingPoints maxPoints@Points: #{tshow maxPoints} Punkte
SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten SheetGradingPassPoints maxPoints@Points passingPoints@Points: Bestanden ab #{tshow passingPoints} von #{tshow maxPoints} Punkten
SheetGradingPassBinary: Bestanden/Nicht Bestanden SheetGradingPassBinary: Bestanden/Nicht Bestanden
SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter. SheetGradingInfo: "Bestanden nach Punkten" zählt sowohl zur maximal erreichbaren Gesamtpunktzahl also auch zur Anzahl der zu bestehenden Blätter.
SheetGradingPoints': Punkte SheetGradingPoints': Punkte
SheetGradingPassPoints': Bestehen nach Punkten SheetGradingPassPoints': Bestehen nach Punkten
@ -424,7 +433,7 @@ HelpUser: Meinen Benutzeraccount
HelpAnonymous: Keine Antwort (Anonym) HelpAnonymous: Keine Antwort (Anonym)
HelpEMail: E-Mail HelpEMail: E-Mail
HelpRequest: Supportanfrage / Verbesserungsvorschlag HelpRequest: Supportanfrage / Verbesserungsvorschlag
HelpProblemPage: Problematische Seite HelpProblemPage: Problematische Seite
HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten. HelpIntroduction: Wenn Ihnen die Benutzung dieser Webseite Schwierigkeiten bereitet oder Sie einen verbesserbaren Umstand entdecken bitten wir Sie uns das zu melden, auch wenn Sie Ihr Problem bereits selbst lösen konnten. Wir passen die Seite ständig an und versuchen sie auch für zukünftige Benutzer so einsichtig wie möglich zu halten.
HelpSent: Ihre Supportanfrage wurde weitergeleitet. HelpSent: Ihre Supportanfrage wurde weitergeleitet.
@ -484,6 +493,7 @@ ErrMsgCouldNotDecodeNonce: Konnte secretbox-nonce nicht dekodieren
ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch) ErrMsgCouldNotOpenSecretbox: Konnte libsodium-secretbox nicht öffnen (Verschlüsselte Daten sind nicht authentisch)
ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err} ErrMsgCouldNotDecodePlaintext utf8Err@Text: Konnte Klartext nicht UTF8-dekodieren: #{utf8Err}
ErrMsgHeading: Fehlermeldung entschlüsseln ErrMsgHeading: Fehlermeldung entschlüsseln
ErrorCryptoIdMismatch: Verschlüsselte Id der Abgabe passte nicht zu anderen Daten
InvalidRoute: Konnte URL nicht interpretieren InvalidRoute: Konnte URL nicht interpretieren
@ -516,3 +526,23 @@ MenuSheetEdit: Übungsblatt editieren
MenuCorrectionsUpload: Korrekturen hochladen MenuCorrectionsUpload: Korrekturen hochladen
MenuCorrectionsCreate: Abgaben registrieren MenuCorrectionsCreate: Abgaben registrieren
MenuCorrectionsGrade: Abgaben bewerten MenuCorrectionsGrade: Abgaben bewerten
AuthPredsActive: Aktive Authorisierungsprädikate
AuthPredsActiveChanged: Authorisierungseinstellungen für aktuelle Sitzung gespeichert
AuthTagFree: Seite ist generell zugänglich
AuthTagAdmin: Nutzer ist Administrator
AuthTagDeprecated: Seite ist nicht überholt
AuthTagDevelopment: Seite ist nicht in Entwicklung
AuthTagLecturer: Nutzer ist Dozent
AuthTagCorrector: Nutzer ist Korrektor
AuthTagTime: Zeitliche Einschränkungen sind erfüllt
AuthTagRegistered: Nutzer ist Kursteilnehmer
AuthTagCapacity: Kapazität ist ausreichend
AuthTagMaterials: Kursmaterialien sind freigegeben
AuthTagOwner: Nutzer ist Besitzer
AuthTagRated: Korrektur ist bewertet
AuthTagUserSubmissions: Abgaben erfolgen durch Kursteilnehmer
AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektoren
AuthTagAuthentication: Authentifizierung erfüllt Anforderungen
AuthTagIsRead: Zugriff ist nur lesend
AuthTagIsWrite: Zugriff ist i.A. schreibend

14
models
View File

@ -15,7 +15,7 @@ User json
notificationSettings NotificationSettings notificationSettings NotificationSettings
UniqueAuthentication ident UniqueAuthentication ident
UniqueEmail email UniqueEmail email
deriving Show deriving Show Eq
UserAdmin UserAdmin
user UserId user UserId
school SchoolId school SchoolId
@ -46,9 +46,9 @@ Term json
start Day -- TermKey :: TermIdentifier -> TermId start Day -- TermKey :: TermIdentifier -> TermId
end Day end Day
holidays [Day] holidays [Day]
lectureStart Day lectureStart Day
lectureEnd Day lectureEnd Day
active Bool active Bool
Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier } Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
deriving Show -- type TermId = Key Term deriving Show -- type TermId = Key Term
School json School json
@ -57,7 +57,7 @@ School json
UniqueSchool name UniqueSchool name
UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand } Primary shorthand -- newtype Key School = SchoolKey { unSchoolKey :: SchoolShorthand }
deriving Eq deriving Eq
DegreeCourse json DegreeCourse json
course CourseId course CourseId
degree StudyDegreeId degree StudyDegreeId
@ -89,7 +89,7 @@ CourseFavourite
course CourseId course CourseId
UniqueCourseFavourite user course UniqueCourseFavourite user course
deriving Show deriving Show
Lecturer Lecturer
user UserId user UserId
course CourseId course CourseId
UniqueLecturer user course UniqueLecturer user course
@ -135,7 +135,7 @@ SheetFile
file FileId file FileId
type SheetFileType type SheetFileType
UniqueSheetFile file sheet type UniqueSheetFile file sheet type
File File
title FilePath title FilePath
content ByteString Maybe -- Nothing iff this is a directory content ByteString Maybe -- Nothing iff this is a directory
modified UTCTime modified UTCTime

1
package.yaml
View File

@ -107,6 +107,7 @@ dependencies:
- word24 - word24
- mmorph - mmorph
- clientsession - clientsession
- monad-memo
other-extensions: other-extensions:
- GeneralizedNewtypeDeriving - GeneralizedNewtypeDeriving

13
routes
View File

@ -23,7 +23,7 @@
-- !isWrite -- only if it is write access (i.e. POST only) why needed??? -- !isWrite -- only if it is write access (i.e. POST only) why needed???
-- --
-- !deprecated -- like free, but logs and gives a warning; entirely disabled in production -- !deprecated -- like free, but logs and gives a warning; entirely disabled in production
-- !development -- like free, but only for development builds -- !development -- like free, but only for development builds
/static StaticR Static appStatic !free /static StaticR Static appStatic !free
/auth AuthR Auth getAuth !free /auth AuthR Auth getAuth !free
@ -40,8 +40,10 @@
/info VersionR GET !free /info VersionR GET !free
/help HelpR GET POST !free /help HelpR GET POST !free
/profile ProfileR GET POST !free !free /profile ProfileR GET POST !free
/profile/data ProfileDataR GET POST !free !free /profile/data ProfileDataR GET POST !free
/authpreds AuthPredsR GET POST !free
/term TermShowR GET !free /term TermShowR GET !free
/term/current TermCurrentR GET !free /term/current TermCurrentR GET !free
@ -77,9 +79,10 @@
/subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions /subs/new SubmissionNewR GET POST !timeANDregisteredANDuser-submissions
/subs/own SubmissionOwnR GET !free -- just redirect /subs/own SubmissionOwnR GET !free -- just redirect
/sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead: /sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead:
/ SubShowR GET POST !ownerANDtime !ownerANDisRead / SubShowR GET POST !ownerANDtime !ownerANDisRead
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner /archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner
/correction CorrectionR GET POST !corrector !ownerANDisReadANDrated /assign SAssignR GET POST !lecturerANDtime
/correction CorrectionR GET POST !corrector !ownerANDisReadANDrated
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !/#SubmissionFileType/*FilePath SubDownloadR GET !owner
/correctors SCorrR GET POST /correctors SCorrR GET POST
/pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions /pseudonym SPseudonymR GET POST !registeredANDcorrector-submissions

564
src/Foundation.hs
View File

@ -40,7 +40,6 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
import Data.List (foldr1)
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Map (Map, (!?)) import Data.Map (Map, (!?))
@ -58,12 +57,14 @@ import qualified Database.Esqueleto as E
import Control.Monad.Except (MonadError(..), runExceptT) import Control.Monad.Except (MonadError(..), runExceptT)
import Control.Monad.Trans.Maybe (MaybeT(..)) import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Trans.Reader (runReader, mapReaderT) import Control.Monad.Trans.Reader (runReader, mapReaderT)
import Control.Monad.Trans.Writer (WriterT(..)) import Control.Monad.Trans.Writer (WriterT(..), runWriterT)
import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Memo (MemoT, startEvalMemoT, MonadMemo(..))
import qualified Control.Monad.Catch as C import qualified Control.Monad.Catch as C
import Handler.Utils.StudyFeatures import Handler.Utils.StudyFeatures
import Control.Lens import Handler.Utils.Templates
import Utils.Lens
import Utils.Form import Utils.Form
import Utils.SystemMessage import Utils.SystemMessage
@ -200,6 +201,7 @@ embedRenderMessage ''UniWorX ''SheetFileType id
embedRenderMessage ''UniWorX ''CorrectorState id embedRenderMessage ''UniWorX ''CorrectorState id
embedRenderMessage ''UniWorX ''RatingException id embedRenderMessage ''UniWorX ''RatingException id
embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>) embedRenderMessage ''UniWorX ''SheetGrading ("SheetGrading" <>)
embedRenderMessage ''UniWorX ''AuthTag $ ("AuthTag" <>) . concat . drop 1 . splitCamel
newtype SheetTypeHeader = SheetTypeHeader SheetType newtype SheetTypeHeader = SheetTypeHeader SheetType
embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>) embedRenderMessageVariant ''UniWorX ''SheetTypeHeader ("SheetType" <>)
@ -208,7 +210,7 @@ instance RenderMessage UniWorX (SheetType) where
renderMessage foundation ls sheetType = case sheetType of renderMessage foundation ls sheetType = case sheetType of
NotGraded -> mr $ SheetTypeHeader NotGraded NotGraded -> mr $ SheetTypeHeader NotGraded
other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other) other -> mr (grading other) <> ", " <> mr (SheetTypeHeader other)
where where
mr :: RenderMessage UniWorX msg => msg -> Text mr :: RenderMessage UniWorX msg => msg -> Text
mr = renderMessage foundation ls mr = renderMessage foundation ls
@ -300,264 +302,300 @@ data AccessPredicate
| APHandler (Route UniWorX -> Bool -> Handler AuthResult) | APHandler (Route UniWorX -> Bool -> Handler AuthResult)
| APDB (Route UniWorX -> Bool -> DB AuthResult) | APDB (Route UniWorX -> Bool -> DB AuthResult)
orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult class (MonadHandler m, HandlerSite m ~ UniWorX) => MonadAP m where
evalAccessPred :: AccessPredicate -> 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
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
orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
orAR _ Authorized _ = Authorized orAR _ Authorized _ = Authorized
orAR _ _ Authorized = Authorized orAR _ _ Authorized = Authorized
orAR _ AuthenticationRequired _ = AuthenticationRequired orAR _ AuthenticationRequired _ = AuthenticationRequired
orAR _ _ AuthenticationRequired = AuthenticationRequired orAR _ _ AuthenticationRequired = AuthenticationRequired
orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y
-- and -- and
andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y
andAR _ reason@(Unauthorized _) _ = reason andAR _ reason@(Unauthorized _) _ = reason
andAR _ _ reason@(Unauthorized _) = reason andAR _ _ reason@(Unauthorized _) = reason
andAR _ Authorized other = other andAR _ Authorized other = other
andAR _ AuthenticationRequired _ = AuthenticationRequired andAR _ AuthenticationRequired _ = AuthenticationRequired
orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate trueAR, falseAR :: MsgRendererS UniWorX -> AuthResult
orAP = liftAR orAR (== Authorized) trueAR = const Authorized
andAP = liftAR andAR (const False) falseAR = Unauthorized . ($ MsgUnauthorized) . render
liftAR :: (MsgRenderer -> AuthResult -> AuthResult -> AuthResult) trueAP, falseAP :: AccessPredicate
-> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument trueAP = APPure . const . const $ trueAR <$> ask
-> AccessPredicate -> AccessPredicate -> AccessPredicate falseAP = APPure . const . const $ falseAR <$> ask -- included for completeness
-- Ensure to first evaluate Pure conditions, then Handler before DB
liftAR ops sc (APPure f) (APPure g) = APPure $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< ask
liftAR ops sc (APHandler f) (APHandler g) = APHandler $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< getMsgRenderer
liftAR ops sc (APDB f) (APDB g) = APDB $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< getMsgRenderer
liftAR ops sc (APPure f) apg = liftAR ops sc (APHandler $ \r w -> runReader (f r w) <$> getMsgRenderer) apg
liftAR ops sc apf apg@(APPure _) = liftAR ops sc apg apf
liftAR ops sc (APHandler f) apdb = liftAR ops sc (APDB $ \r w -> lift $ f r w) apdb
liftAR ops sc apdb apg@(APHandler _) = liftAR ops sc apg apdb
trueAP,falseAP :: AccessPredicate tagAccessPredicate :: AuthTag -> AccessPredicate
trueAP = APPure . const . const $ return Authorized tagAccessPredicate AuthFree = trueAP
falseAP = APPure . const . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask -- always use adminAP instead tagAccessPredicate AuthAdmin = APDB $ \route _ -> case route of
-- Courses: access only to school admins
CourseR tid ssh csh _ -> exceptT return return $ do
adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes) authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
adminAP = APDB $ \route _ -> case route of [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
-- Courses: access only to school admins E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
CourseR tid ssh csh _ -> exceptT return return $ do E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId E.&&. course E.^. CourseTerm E.==. E.val tid
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do E.&&. course E.^. CourseSchool E.==. E.val ssh
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool E.&&. course E.^. CourseShorthand E.==. E.val csh
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId return (E.countRows :: E.SqlExpr (E.Value Int64))
E.&&. course E.^. CourseTerm E.==. E.val tid guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
E.&&. course E.^. CourseSchool E.==. E.val ssh return Authorized
E.&&. course E.^. CourseShorthand E.==. E.val csh -- other routes: access to any admin is granted here
return (E.countRows :: E.SqlExpr (E.Value Int64)) _other -> exceptT return return $ do
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin) authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
return Authorized adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
-- other routes: access to any admin is granted here guardMExceptT (isJust adrights) (unauthorizedI MsgUnauthorizedSiteAdmin)
_other -> exceptT return return $ do return Authorized
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId tagAccessPredicate AuthDeprecated = APHandler $ \r _ -> do
adrights <- lift $ selectFirst [UserAdminUser ==. authId] [] $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
guardMExceptT (isJust adrights) (unauthorizedI $ MsgUnauthorized) addMessageI Error MsgDeprecatedRoute
return Authorized allow <- appAllowDeprecated . appSettings <$> getYesod
return $ bool (Unauthorized "Deprecated Route") Authorized allow
tagAccessPredicate AuthDevelopment = APHandler $ \r _ -> do
knownTags :: Map (CI Text) AccessPredicate $logWarnS "AccessControl" ("route in development: " <> tshow r)
knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or requireAuthId
[("free", trueAP)
,("deprecated", APHandler $ \r _ -> do
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
addMessageI Error MsgDeprecatedRoute
allow <- appAllowDeprecated . appSettings <$> getYesod
return $ bool (Unauthorized "Deprecated Route") Authorized allow
)
,("development", APHandler $ \r _ -> do
$logWarnS "AccessControl" ("route in development: " <> tshow r)
#ifdef DEVELOPMENT #ifdef DEVELOPMENT
return Authorized return Authorized
#else #else
return $ Unauthorized "Route under development" return $ Unauthorized "Route under development"
#endif #endif
) tagAccessPredicate AuthLecturer = APDB $ \route _ -> case route of
,("lecturer", APDB $ \route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do
CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. course E.^. CourseShorthand E.==. E.val csh return (E.countRows :: E.SqlExpr (E.Value Int64))
return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer) return Authorized
return Authorized _ -> exceptT return return $ do
_ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] [] return Authorized
return Authorized tagAccessPredicate AuthCorrector = APDB $ \route _ -> exceptT return return $ do
) authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
,("corrector", APDB $ \route _ -> exceptT return return $ do resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId return (course E.^. CourseId, sheet E.^. SheetId)
E.where_ $ sheetCorrector E.^. SheetCorrectorUser E.==. E.val authId let
return (course E.^. CourseId, sheet E.^. SheetId) resMap :: Map CourseId (Set SheetId)
let resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
resMap :: Map CourseId (Set SheetId) case route of
resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
case route of sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do Submission{..} <- MaybeT . lift $ get sid
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID guard $ maybe False (== authId) submissionRatingBy
Submission{..} <- MaybeT . lift $ get sid return Authorized
guard $ maybe False (== authId) submissionRatingBy CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
return Authorized Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn return Authorized
guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
return Authorized Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do guard $ cid `Set.member` Map.keysSet resMap
Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh return Authorized
guard $ cid `Set.member` Map.keysSet resMap _ -> do
return Authorized guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
_ -> do return Authorized
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny) tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
return Authorized CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
) Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
,("time", APDB $ \route _ -> case route of Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do cTime <- liftIO getCurrentTime
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh let
Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn visible = NTop sheetVisibleFrom <= NTop (Just cTime)
cTime <- liftIO getCurrentTime active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
let marking = cTime > sheetActiveTo
visible = NTop sheetVisibleFrom <= NTop (Just cTime)
active = sheetActiveFrom <= cTime && cTime <= sheetActiveTo
guard visible guard visible
case subRoute of case subRoute of
SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime
SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
SubmissionNewR -> guard active SubmissionNewR -> guard active
SubmissionR _ _ -> guard active SubmissionR _ SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
_ -> return () SubmissionR _ _ -> guard active
_ -> return ()
return Authorized return Authorized
CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
cTime <- (NTop . Just) <$> liftIO getCurrentTime cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop courseRegisterFrom <= cTime guard $ NTop courseRegisterFrom <= cTime
&& NTop courseRegisterTo >= cTime && NTop courseRegisterTo >= cTime
return Authorized return Authorized
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
smId <- decrypt cID smId <- decrypt cID
SystemMessage{systemMessageFrom, systemMessageTo} <- MaybeT $ get smId SystemMessage{systemMessageFrom, systemMessageTo} <- MaybeT $ get smId
cTime <- (NTop . Just) <$> liftIO getCurrentTime cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop systemMessageFrom <= cTime guard $ NTop systemMessageFrom <= cTime
&& NTop systemMessageTo >= cTime && NTop systemMessageTo >= cTime
return Authorized return Authorized
r -> $unsupportedAuthPredicate "time" r r -> $unsupportedAuthPredicate "time" r
) tagAccessPredicate AuthRegistered = APDB $ \route _ -> case route of
,("registered", APDB $ \route _ -> case route of CourseR tid ssh csh _ -> exceptT return return $ do
CourseR tid ssh csh _ -> exceptT return return $ do authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. course E.^. CourseShorthand E.==. E.val csh return (E.countRows :: E.SqlExpr (E.Value Int64))
return (E.countRows :: E.SqlExpr (E.Value Int64)) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant) return Authorized
return Authorized r -> $unsupportedAuthPredicate "registered" r
r -> $unsupportedAuthPredicate "registered" r tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of
) CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
,("capacity", APDB $ \route _ -> case route of Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh guard $ NTop courseCapacity > NTop (Just registered)
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] return Authorized
guard $ NTop courseCapacity > NTop (Just registered) r -> $unsupportedAuthPredicate "capacity" r
return Authorized tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of
r -> $unsupportedAuthPredicate "capacity" r CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
) Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
,("materials", APDB $ \route _ -> case route of guard courseMaterialFree
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do return Authorized
Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh r -> $unsupportedAuthPredicate "materials" r
guard courseMaterialFree tagAccessPredicate AuthOwner = APDB $ \route _ -> case route of
return Authorized CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
r -> $unsupportedAuthPredicate "materials" r sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
) authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
,("owner", APDB $ \route _ -> case route of void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do return Authorized
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID r -> $unsupportedAuthPredicate "owner" r
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId tagAccessPredicate AuthRated = APDB $ \route _ -> case route of
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
return Authorized sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
r -> $unsupportedAuthPredicate "owner" r sub <- MaybeT $ get sid
) guard $ submissionRatingDone sub
,("rated", APDB $ \route _ -> case route of return Authorized
CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do r -> $unsupportedAuthPredicate "rated" r
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID tagAccessPredicate AuthUserSubmissions = APDB $ \route _ -> case route of
sub <- MaybeT $ get sid CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do
guard $ submissionRatingDone sub Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
return Authorized Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
r -> $unsupportedAuthPredicate "rated" r guard $ sheetSubmissionMode == UserSubmissions
) return Authorized
,("user-submissions", APDB $ \route _ -> case route of r -> $unsupportedAuthPredicate "user-submissions" r
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedUserSubmission) $ do tagAccessPredicate AuthCorrectorSubmissions = APDB $ \route _ -> case route of
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
guard $ sheetSubmissionMode == UserSubmissions Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn
return Authorized guard $ sheetSubmissionMode == CorrectorSubmissions
r -> $unsupportedAuthPredicate "user-submissions" r return Authorized
) r -> $unsupportedAuthPredicate "corrector-submissions" r
,("corrector-submissions", APDB $ \route _ -> case route of tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedCorrectorSubmission) $ do MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do
Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh smId <- decrypt cID
Entity _ Sheet{sheetSubmissionMode} <- MaybeT . getBy $ CourseSheet cid shn SystemMessage{..} <- MaybeT $ get smId
guard $ sheetSubmissionMode == CorrectorSubmissions isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
return Authorized guard $ not systemMessageAuthenticatedOnly || isAuthenticated
r -> $unsupportedAuthPredicate "corrector-submissions" r return Authorized
) r -> $unsupportedAuthPredicate "authentication" r
,("authentication", APDB $ \route _ -> case route of tagAccessPredicate AuthIsRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do tagAccessPredicate AuthIsWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
smId <- decrypt cID
SystemMessage{..} <- MaybeT $ get smId
isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
guard $ not systemMessageAuthenticatedOnly || isAuthenticated
return Authorized
r -> $unsupportedAuthPredicate "authentication" r
)
,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite))
,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized))
]
tag2ap :: Text -> AccessPredicate newtype InvalidAuthTag = InvalidAuthTag Text
tag2ap t = case Map.lookup (CI.mk t) knownTags of deriving (Eq, Ord, Show, Read, Generic, Typeable)
(Just acp) -> acp instance Exception InvalidAuthTag
Nothing -> APHandler $ \_route _isWrite -> do -- Can this be pure like falseAP? GK: not if we want to log a message (which we definitely should)
$logWarnS "AccessControl" $ "'" <> t <> "' not known to access control"
unauthorizedI MsgUnauthorized
route2ap :: Route UniWorX -> AccessPredicate type DNF a = Set (NonNull (Set a))
route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK: Due to shortCircuitM this (while still true) is no longer costly (we do a `runDB` but then only actually send off queries, if needed)
data SessionAuthTags = SessionActiveAuthTags | SessionInactiveAuthTags
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
instance Universe SessionAuthTags
instance Finite SessionAuthTags
$(return [])
instance PathPiece SessionAuthTags where
toPathPiece = $(nullaryToPathPiece ''SessionAuthTags [intercalate "-" . map toLower . splitCamel])
fromPathPiece = finiteFromPathPiece
routeAuthTags :: Route UniWorX -> Either InvalidAuthTag (NonNull (DNF AuthTag))
-- ^ 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
where where
attrsAND = map splitAND $ Set.toList $ routeAttrs r partition' :: Set (Set AuthTag) -> Text -> Either InvalidAuthTag (Set (Set AuthTag))
splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND" partition' prev t
| Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t)
= if
| oany (authTags `Set.isSubsetOf`) prev
-> Right prev
| otherwise
-> Right $ Set.insert authTags prev
| otherwise
= Left $ InvalidAuthTag t
evalAccessDB :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise evalAuthTags :: forall m. (MonadAP m, MonadLogger m) => AuthTagActive -> NonNull (DNF AuthTag) -> Route UniWorX -> Bool -> WriterT (Set AuthTag) m AuthResult
evalAccessDB r w = mapReaderT liftHandlerT $ case route2ap r of -- ^ `tell`s disabled predicates, identified as pivots
(APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toNullable -> authDNF) route isWrite
(APHandler p) -> lift $ p r w = startEvalMemoT $ do
(APDB p) -> p r w mr <- lift 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
evalAccess :: (MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult orAR', andAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
evalAccess r w = liftHandlerT $ case route2ap r of orAR' = shortCircuitM (is _Authorized) (orAR mr)
(APPure p) -> runReader (p r w) <$> getMsgRenderer andAR' = shortCircuitM (is _Unauthorized) (andAR mr)
(APHandler p) -> p r w
(APDB p) -> runDB $ p r w
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)
lift . $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF
result <- evalDNF $ filter (all authTagIsActive) 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
return result
evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult
evalAccess route isWrite = do
tagActive <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
dnf <- either throwM return $ routeAuthTags route
(result, (Set.toList -> deactivated)) <- runWriterT $ evalAuthTags tagActive dnf route isWrite
result <$ tellSessionJson SessionInactiveAuthTags deactivated
evalAccessDB :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> ReaderT (YesodPersistBackend UniWorX) m AuthResult
evalAccessDB = evalAccess
-- Please see the documentation for the Yesod typeclass. There are a number -- Please see the documentation for the Yesod typeclass. There are a number
@ -601,7 +639,7 @@ instance Yesod UniWorX where
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
user <- MaybeT $ get uid user <- MaybeT $ get uid
let courseFavourite = CourseFavourite uid now cid let courseFavourite = CourseFavourite uid now cid
$logDebugS "updateFavourites" [st|Updating/Inserting: #{tshow courseFavourite}|] $logDebugS "updateFavourites" [st|Updating/Inserting: #{tshow courseFavourite}|]
-- update Favourites -- update Favourites
void . lift $ upsertBy void . lift $ upsertBy
@ -650,7 +688,7 @@ instance Yesod UniWorX where
#{formatted} #{formatted}
|] |]
| otherwise -> plaintext | otherwise -> plaintext
errPage = case err of errPage = case err of
NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|] NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
InternalError err' -> encrypted err' [whamlet|<p .errMsg>#{err'}|] InternalError err' -> encrypted err' [whamlet|<p .errMsg>#{err'}|]
@ -726,12 +764,6 @@ siteLayout headingOverride widget = do
isModal <- isJust <$> siteModalId isModal <- isJust <$> siteModalId
mmsgs <- if
| isModal -> return []
| otherwise -> do
applySystemMessages
getMessages
mcurrentRoute <- getCurrentRoute mcurrentRoute <- getCurrentRoute
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance. -- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
@ -767,6 +799,14 @@ siteLayout headingOverride widget = do
items' <- forM items $ \i -> (i, ) <$> toTextUrl i items' <- forM items $ \i -> (i, ) <$> toTextUrl i
return (c, courseRoute, items') return (c, courseRoute, items')
mmsgs <- if
| isModal -> return []
| otherwise -> do
applySystemMessages
authTagPivots <- fromMaybe Set.empty <$> getSessionJson SessionInactiveAuthTags
forM_ authTagPivots $ \authTag -> addMessageWidget Info $ modal [whamlet|_{MsgUnauthorizedDisabledTag authTag}|] (Left AuthPredsR)
getMessages
let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents highlight = let crumbs = mcons mcurrentRoute $ fst <$> reverse parents
navItems = map snd3 favourites ++ map (urlRoute . menuItemRoute . view _1) menuTypes navItems = map snd3 favourites ++ map (urlRoute . menuItemRoute . view _1) menuTypes
@ -777,14 +817,12 @@ siteLayout headingOverride widget = do
favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [(MenuItem, Text)])] favouriteTerm :: TermIdentifier -> [(Course, Route UniWorX, [(MenuItem, Text)])]
favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites favouriteTerm tid = filter (\(Course{..}, _, _) -> unTermKey courseTerm == tid) favourites
-- We break up the default layout into two components: -- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and -- default-layout is the contents of the body tag, and
-- default-layout-wrapper is the entire page. Since the final -- default-layout-wrapper is the entire page. Since the final
-- value passed to hamletToRepHtml cannot be a widget, this allows -- value passed to hamletToRepHtml cannot be a widget, this allows
-- you to use normal widget features in default-layout. -- you to use normal widget features in default-layout.
let
navbar :: Widget navbar :: Widget
navbar = $(widgetFile "widgets/navbar") navbar = $(widgetFile "widgets/navbar")
asidenav :: Widget asidenav :: Widget
@ -938,7 +976,7 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
} }
, do , do
mCurrentRoute <- getCurrentRoute mCurrentRoute <- getCurrentRoute
return MenuItem return MenuItem
{ menuItemType = NavbarRight { menuItemType = NavbarRight
, menuItemLabel = MsgMenuHelp , menuItemLabel = MsgMenuHelp
@ -1226,6 +1264,14 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
, menuItemModal = False , menuItemModal = False
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgCorrectorAssignTitle
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SAssignR
, menuItemModal = True
, menuItemAccessCallback' = return True
}
] ]
pageActions (CSheetR tid ssh csh shn SCorrR) = pageActions (CSheetR tid ssh csh shn SCorrR) =
[ MenuItem [ MenuItem
@ -1417,6 +1463,7 @@ routeNormalizers =
, ncSchool , ncSchool
, ncCourse , ncCourse
, ncSheet , ncSheet
, verifySubmission
] ]
where where
normalizeRender route = route <$ do normalizeRender route = route <$ do
@ -1454,8 +1501,17 @@ routeNormalizers =
Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
hasChanged shn sheetName hasChanged shn sheetName
return $ CSheetR tid ssh csh sheetName subRoute return $ CSheetR tid ssh csh sheetName subRoute
verifySubmission = maybeOrig $ \route -> do
CSubmissionR _tid _ssh _csh _shn cID sr <- return route
sId <- decrypt cID
Submission{submissionSheet} <- lift . lift $ get404 sId
Sheet{sheetCourse, sheetName} <- lift . lift $ get404 submissionSheet
Course{courseTerm, courseSchool, courseShorthand} <- lift . lift $ get404 sheetCourse
let newRoute = CSubmissionR courseTerm courseSchool courseShorthand sheetName cID sr
tell . Any $ route /= newRoute
return newRoute
-- How to run database actions. -- How to run database actions.
instance YesodPersist UniWorX where instance YesodPersist UniWorX where
type YesodPersistBackend UniWorX = SqlBackend type YesodPersistBackend UniWorX = SqlBackend
@ -1525,7 +1581,7 @@ instance YesodAuth UniWorX where
userEmail' = lookup (Attr "mail") ldapData userEmail' = lookup (Attr "mail") ldapData
userDisplayName' = lookup (Attr "displayName") ldapData userDisplayName' = lookup (Attr "displayName") ldapData
userSurname' = lookup (Attr "sn") ldapData userSurname' = lookup (Attr "sn") ldapData
userAuthentication userAuthentication
| isPWHash = error "PWHash should only work for users that are already known" | isPWHash = error "PWHash should only work for users that are already known"
| otherwise = AuthLDAP | otherwise = AuthLDAP
@ -1631,13 +1687,13 @@ instance YesodMail UniWorX where
mailSmtp act = do mailSmtp act = do
pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool pool <- maybe (throwM MailNotAvailable) return =<< getsYesod appSmtpPool
withResource pool act withResource pool act
mailT ctx mail = defMailT ctx $ do mailT ctx mail = defMailT ctx $ do
void setMailObjectId void setMailObjectId
setDateCurrent setDateCurrent
replaceMailHeader "Auto-Submitted" $ Just "auto-generated" replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
ret <- mail ret <- mail
setMailSmtpData setMailSmtpData
return ret return ret

124
src/Handler/Corrections.hs
View File

@ -83,11 +83,7 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse) colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(_, _, course, _, _) } -> $ \DBRow{ dbrOutput=(_, _, (_,csh,tid,sid), _, _) } -> courseCellCL (tid,sid,csh)
let tid = course ^. _3
ssh = course ^. _4
csh = course ^. _2
in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|]
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSheet = sortable (Just "sheet") (i18nCell MsgSheet) colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
@ -135,7 +131,7 @@ colSMatrikel :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let colSMatrikel = sortable Nothing (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer) protoCell = listCell (Map.toList users) $ \(userId, (User{..}, _)) -> anchorCellM (AdminUserR <$> encrypt userId) (maybe mempty toWidget userMatrikelnummer)
in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")] in protoCell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } -> colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } ->
let csh = course ^. _2 let csh = course ^. _2
@ -181,7 +177,7 @@ colCommentField = sortable Nothing (i18nCell MsgRatingComment) $ formCell
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
=> _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x) => _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> _ -> Handler (DBResult m x)
makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do makeCorrectionsTable whereClause dbtColonnade psValidator dbtProj' = do
@ -303,11 +299,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
unless (null alreadyAssigned) $ do unless (null alreadyAssigned) $ do
mr <- (toHtml . ) <$> getMessageRender mr <- (toHtml . ) <$> getMessageRender
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
unless (null unassigned) $ do (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] unless (null unassignedUnauth) $ do
let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission
unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth
$(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet")
unless (null unassignedAuth) $ do
num <- updateWhereCount [SubmissionId <-. Set.toList unassignedAuth]
[ SubmissionRatingBy =. Just uid [ SubmissionRatingBy =. Just uid
, SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned , SubmissionRatingAssigned =. Just now -- save, since only applies to unassigned
] ]
@ -319,15 +320,15 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
return (E.countRows :: E.SqlExpr (E.Value Int64)) return (E.countRows :: E.SqlExpr (E.Value Int64))
when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors when (selfCorrectors > 0) $ addMessageI Warning $ MsgSelfCorrectors selfCorrectors
redirect currentRoute redirect currentRoute
FormSuccess (CorrSetCorrectorData Nothing, subs') -> do FormSuccess (CorrSetCorrectorData Nothing, subs') -> do -- delete corrections
subs <- mapM decrypt $ Set.toList subs' subs <- mapM decrypt $ Set.toList subs'
runDB $ do runDB $ do
num <- updateWhereCount [SubmissionId <-. subs] num <- updateWhereCount [SubmissionId <-. subs]
[ SubmissionRatingPoints =. Nothing [ SubmissionRatingBy =. Nothing
, SubmissionRatingComment =. Nothing
, SubmissionRatingBy =. Nothing
, SubmissionRatingAssigned =. Nothing , SubmissionRatingAssigned =. Nothing
, SubmissionRatingTime =. Nothing , SubmissionRatingTime =. Nothing
-- , SubmissionRatingPoints =. Nothing -- Kept for easy reassignment by 2nd corrector
-- , SubmissionRatingComment =. Nothing -- Kept for easy reassignment by 2nd corrector
] ]
addMessageI Success $ MsgRemovedCorrections num addMessageI Success $ MsgRemovedCorrections num
redirect currentRoute redirect currentRoute
@ -337,11 +338,16 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] [] alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
unless (null alreadyAssigned) $ do unless (null alreadyAssigned) $ do
mr <- (toHtml . ) <$> getMessageRender mr <- (toHtml . ) <$> getMessageRender
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission) alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr) addMessage Warning =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned) let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
unless (null unassigned) $ do (unassignedAuth, unassignedUnauth) <- partitionM authorizedToAssign unassigned
(assigned, stillUnassigned) <- assignSubmissions shid (Just unassigned) unless (null unassignedUnauth) $ do
let submissionEncrypt = encrypt :: SubmissionId -> DB CryptoFileNameSubmission
unassignedUnauth' <- mapM submissionEncrypt $ Set.toList unassignedUnauth
$(addMessageFile Warning "templates/messages/submissionsAssignUnauthorized.hamlet")
unless (null unassignedAuth) $ do
(assigned, stillUnassigned) <- assignSubmissions shid (Just unassignedAuth)
unless (null assigned) $ unless (null assigned) $
addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned) addMessageI Success $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
unless (null stillUnassigned) $ do unless (null stillUnassigned) $ do
@ -353,10 +359,21 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
fmap toTypedContent . defaultLayout $ do fmap toTypedContent . defaultLayout $ do
setTitleI MsgCourseCorrectionsTitle setTitleI MsgCourseCorrectionsTitle
$(widgetFile "corrections") $(widgetFile "corrections")
where
authorizedToAssign :: SubmissionId -> DB Bool
authorizedToAssign sId = do
[(E.Value tid, E.Value ssh, E.Value csh, E.Value shn)] <-
E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission ) -> do
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ submission E.^. SubmissionId E.==. E.val sId
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, sheet E.^. SheetName)
cID <- encrypt sId
let route = CSubmissionR tid ssh csh shn cID SAssignR
(== Authorized) <$> evalAccessDB route True
type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData) type ActionCorrections' = (ActionCorrections, AForm (HandlerT UniWorX IO) ActionCorrectionsData)
downloadAction :: ActionCorrections' downloadAction :: ActionCorrections'
downloadAction = ( CorrDownload downloadAction = ( CorrDownload
, pure CorrDownloadData , pure CorrDownloadData
@ -366,13 +383,13 @@ assignAction :: Either CourseId SheetId -> ActionCorrections'
assignAction selId = ( CorrSetCorrector assignAction selId = ( CorrSetCorrector
, wFormToAForm $ do , wFormToAForm $ do
correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId
return user E.distinct $ return user
mr <- getMessageRender mr <- getMessageRender
@ -483,8 +500,8 @@ postCorrectionR tid ssh csh shn cid = do
let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) let ratingComment = fmap Text.strip submissionRatingComment >>= (\c -> c <$ guard (not $ null c))
pointsForm = case sheetType of pointsForm = case sheetType of
NotGraded -> pure Nothing NotGraded -> pure Nothing
_otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType) _otherwise -> aopt (pointsFieldMax $ preview (_grading . _maxPoints) sheetType)
(fslpI MsgRatingPoints "Punktezahl") (fslpI MsgRatingPoints "Punktezahl")
(Just submissionRatingPoints) (Just submissionRatingPoints)
((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,) ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,,)
@ -500,7 +517,7 @@ postCorrectionR tid ssh csh shn cid = do
case corrResult of case corrResult of
FormMissing -> return () FormMissing -> return ()
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess (rated, ratingPoints', ratingComment') FormSuccess (rated, ratingPoints', ratingComment')
| errs <- validateRating sheetType Rating' | errs <- validateRating sheetType Rating'
{ ratingPoints=ratingPoints' { ratingPoints=ratingPoints'
, ratingComment=ratingComment' , ratingComment=ratingComment'
@ -511,7 +528,7 @@ postCorrectionR tid ssh csh shn cid = do
runDBJobs $ do runDBJobs $ do
uid <- liftHandlerT requireAuthId uid <- liftHandlerT requireAuthId
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
update sub [ SubmissionRatingBy =. Just uid update sub [ SubmissionRatingBy =. Just uid
, SubmissionRatingTime =. (now <$ guard rated) , SubmissionRatingTime =. (now <$ guard rated)
, SubmissionRatingPoints =. ratingPoints' , SubmissionRatingPoints =. ratingPoints'
@ -522,7 +539,7 @@ postCorrectionR tid ssh csh shn cid = do
when (rated && isNothing submissionRatingTime) $ do when (rated && isNothing submissionRatingTime) $ do
$logDebugS "CorrectionR" [st|Rated #{tshow sub}|] $logDebugS "CorrectionR" [st|Rated #{tshow sub}|]
queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub queueDBJob . JobQueueNotification $ NotificationSubmissionRated sub
redirect $ CSubmissionR tid ssh csh shn cid CorrectionR redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
@ -531,7 +548,7 @@ postCorrectionR tid ssh csh shn cid = do
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess fileUploads -> do FormSuccess fileUploads -> do
uid <- requireAuthId uid <- requireAuthId
void . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True void . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
addMessageI Success MsgRatingFilesUpdated addMessageI Success MsgRatingFilesUpdated
@ -545,7 +562,7 @@ postCorrectionR tid ssh csh shn cid = do
_ -> notFound _ -> notFound
getCorrectionUserR tid ssh csh shn cid = do getCorrectionUserR tid ssh csh shn cid = do
sub <- decrypt cid sub <- decrypt cid
results <- runDB $ correctionData tid ssh csh shn sub results <- runDB $ correctionData tid ssh csh shn sub
case results of case results of
@ -557,7 +574,7 @@ getCorrectionUserR tid ssh csh shn cid = do
$(widgetFile "correction-user") $(widgetFile "correction-user")
_ -> notFound _ -> notFound
getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
getCorrectionsUploadR = postCorrectionsUploadR getCorrectionsUploadR = postCorrectionsUploadR
postCorrectionsUploadR = do postCorrectionsUploadR = do
@ -577,7 +594,7 @@ postCorrectionsUploadR = do
subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission] subs' <- traverse encrypt $ Set.toList subs :: Handler [CryptoFileNameSubmission]
mr <- (toHtml .) <$> getMessageRender mr <- (toHtml .) <$> getMessageRender
addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr) addMessage Success =<< withUrlRenderer ($(ihamletFile "templates/messages/correctionsUploaded.hamlet") mr)
defaultLayout $ defaultLayout $
$(widgetFile "corrections-upload") $(widgetFile "corrections-upload")
@ -692,17 +709,17 @@ postCorrectionsCreateR = do
insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser insertMany_ . flip map spGroup $ \SheetPseudonym{sheetPseudonymUser} -> SubmissionUser
{ submissionUserUser = sheetPseudonymUser { submissionUserUser = sheetPseudonymUser
, submissionUserSubmission = subId , submissionUserSubmission = subId
} }
addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc addMessageI Warning $ MsgSheetNoGroupSubmission sheetGroupDesc
redirect CorrectionsGradeR redirect CorrectionsGradeR
defaultLayout $ defaultLayout $
$(widgetFile "corrections-create") $(widgetFile "corrections-create")
where where
partitionEithers' :: [[Either a b]] -> ([[b]], [a]) partitionEithers' :: [[Either a b]] -> ([[b]], [a])
partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers) partitionEithers' = runWriter . mapM (WriterT . Identity . swap . partitionEithers)
textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]]) textToList :: Textarea -> Handler (Either UniWorXMessage [[Pseudonym]])
textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . Text.lines . unTextarea -> ws) textToList (map (map Text.strip . Text.splitOn ",") . filter (not . Text.null) . Text.lines . unTextarea -> ws)
= let = let
@ -735,7 +752,7 @@ postCorrectionsGradeR = do
psValidator = def psValidator = def
& defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text))) & defaultSorting [("ratingtime", SortDesc)] :: PSValidator (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult (DBFormResult CorrectionTableData SubmissionId (Bool, Maybe Points, Maybe Text)))
unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) unFormResult = getDBFormResult $ \DBRow{ dbrOutput = (Entity _ sub@Submission{..}, _, _, _, _) } -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment)
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do tableForm <- makeCorrectionsTable whereClause displayColumns psValidator $ \i@(Entity subId _, Entity _ Sheet{ sheetName = shn }, (_, csh, tid, ssh), _, _) -> do
cID <- encrypt subId cID <- encrypt subId
void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True void . assertM (== Authorized) . lift $ evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) True
@ -762,3 +779,36 @@ postCorrectionsGradeR = do
defaultLayout $ defaultLayout $
$(widgetFile "corrections-grade") $(widgetFile "corrections-grade")
getSAssignR, postSAssignR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getSAssignR = postSAssignR
postSAssignR tid ssh csh shn cID = do
let actionUrl = CSubmissionR tid ssh csh shn cID SAssignR
sId <- decrypt cID
(currentCorrector, sheetCorrectors) <- runDB $ do
Submission{submissionRatingBy, submissionSheet} <- get404 sId
sheetCorrectors <- map (sheetCorrectorUser . entityVal) <$> selectList [SheetCorrectorSheet ==. submissionSheet] []
userCorrector <- traverse getJustEntity submissionRatingBy
return (userCorrector, maybe id (:) submissionRatingBy sheetCorrectors)
$logDebugS "SAssignR" $ tshow currentCorrector
let correctorField = selectField $ optionsPersistCryptoId [UserId <-. sheetCorrectors] [Asc UserSurname, Asc UserDisplayName] userDisplayName
((corrResult, corrForm), corrEncoding) <- runFormPost . renderAForm FormStandard $
aopt correctorField (fslI MsgCorrector) (Just currentCorrector)
<* submitButton
formResult corrResult $ \(fmap entityKey -> mbUserId) -> do
when (mbUserId /= fmap entityKey currentCorrector) . runDB $ do
now <- liftIO getCurrentTime
update sId [ SubmissionRatingBy =. mbUserId
, SubmissionRatingAssigned =. (now <$ mbUserId)
]
addMessageI Success MsgCorrectorUpdated
redirect actionUrl
defaultLayout $ do
setTitleI MsgCorrectorAssignTitle
$(widgetFile "submission-assign")

20
src/Handler/Home.hs
View File

@ -295,3 +295,23 @@ postHelpR = do
$(widgetFile "help") $(widgetFile "help")
getAuthPredsR, postAuthPredsR :: Handler Html
getAuthPredsR = postAuthPredsR
postAuthPredsR = do
AuthTagActive{..} <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
let taForm authTag = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagIsActive authTag)
((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
$ AuthTagActive
<$> funcForm taForm (fslI MsgActiveAuthTags) True
<* submitButton
formResult authActiveRes $ \authTagActive -> do
setSessionJson SessionActiveAuthTags authTagActive
addMessageI Success MsgAuthPredsActiveChanged
redirect AuthPredsR
defaultLayout $ do
setTitleI MsgAuthPredsActive
$(widgetFile "authpreds")

20
src/Handler/Profile.hs
View File

@ -10,8 +10,6 @@ import Utils.Lens
-- import Yesod.Colonnade -- import Yesod.Colonnade
import Data.Monoid (Any(..)) import Data.Monoid (Any(..))
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Map ((!))
import qualified Data.Set as Set
-- import qualified Data.Set as Set -- import qualified Data.Set as Set
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
-- import Database.Esqueleto ((^.)) -- import Database.Esqueleto ((^.))
@ -42,25 +40,11 @@ makeSettingForm template = identForm FIDsettings $ \html -> do
<*> areq checkBoxField (fslI MsgDownloadFiles <*> areq checkBoxField (fslI MsgDownloadFiles
& setTooltip MsgDownloadFilesTip & setTooltip MsgDownloadFilesTip
) (stgDownloadFiles <$> template) ) (stgDownloadFiles <$> template)
<*> formToAForm (nsFieldView =<< renderAForm FormStandard nsForm mempty) <*> (NotificationSettings <$> funcForm nsForm (fslI MsgNotificationSettings) True)
<* submitButton <* submitButton
return (result, widget) -- no validation required here return (result, widget) -- no validation required here
where where
nsForm = fmap (\m -> NotificationSettings $ \nt -> m ! nt) . sequenceA . flip Map.fromSet (Set.fromList universeF) $ \nt -> nsForm nt = fromMaybe False <$> aopt checkBoxField (fslI nt) (Just $ flip notificationAllowed nt . stgNotificationSettings <$> template)
areq checkBoxField (fslI nt) (flip notificationAllowed nt . stgNotificationSettings <$> template)
nsFieldView :: (FormResult NotificationSettings, Widget) -> MForm Handler (FormResult NotificationSettings, [FieldView UniWorX])
nsFieldView (res, fvInput) = do
mr <- getMessageRender
let fvLabel = toHtml $ mr MsgNotificationSettings
fvTooltip = mempty
fvRequired = True
fvErrors
| FormFailure (err:_) <- res = Just $ toHtml err
| otherwise = Nothing
fvId <- newIdent
return (res, pure FieldView{..})
-- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
getProfileR, postProfileR :: Handler Html getProfileR, postProfileR :: Handler Html

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

@ -30,8 +30,9 @@ import qualified Data.Conduit.List as C
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map) import Data.Map (Map, (!))
import qualified Data.Map as Map import qualified Data.Map as Map
import Control.Monad.Writer.Class import Control.Monad.Writer.Class
@ -488,6 +489,32 @@ langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) .
langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages
funcForm :: forall k v m.
( Finite k, Ord k
, MonadHandler m
, HandlerSite m ~ UniWorX
)
=> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
where
funcForm' :: AForm m (k -> v)
funcForm' = fmap (!) . sequenceA . Map.fromSet mkForm $ Set.fromList universeF
funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX])
funcFieldView (res, fvInput) = do
mr <- getMessageRender
let fvLabel = toHtml $ mr fsLabel
fvTooltip = fmap (toHtml . mr) fsTooltip
fvRequired = isRequired
fvErrors
| FormFailure (err:_) <- res = Just $ toHtml err
| otherwise = Nothing
fvId <- maybe newIdent return fsId
return (res, pure FieldView{..})
-- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)
fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
fsm = bfs -- TODO: get rid of Bootstrap fsm = bfs -- TODO: get rid of Bootstrap

2
src/Import/NoFoundation.hs
View File

@ -3,7 +3,7 @@ module Import.NoFoundation
, MForm , MForm
) where ) where
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy) import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM)
import Model as Import import Model as Import
import Model.Types.JSON as Import import Model.Types.JSON as Import
import Model.Migration as Import import Model.Migration as Import

65
src/Model/Types.hs
View File

@ -564,6 +564,8 @@ instance ToBackendKey SqlBackend record => Hashable (Key record) where
derivePersistFieldJSON ''MailLanguages derivePersistFieldJSON ''MailLanguages
type PseudonymWord = CI Text
newtype Pseudonym = Pseudonym Word24 newtype Pseudonym = Pseudonym Word24
deriving (Eq, Ord, Read, Show, Generic, Data) deriving (Eq, Ord, Read, Show, Generic, Data)
deriving newtype (Bounded, Enum, Integral, Num, Real, Bits, FiniteBits, Ix) deriving newtype (Bounded, Enum, Integral, Num, Real, Bits, FiniteBits, Ix)
@ -642,9 +644,68 @@ pseudonymText = iso tFromWords tToWords . pseudonymWords
tToWords = Text.unwords . map CI.original tToWords = Text.unwords . map CI.original
-- Type synonyms data AuthTag
= AuthFree
| AuthAdmin
| AuthDeprecated
| AuthDevelopment
| AuthLecturer
| AuthCorrector
| AuthTime
| AuthRegistered
| AuthCapacity
| AuthMaterials
| AuthOwner
| AuthRated
| AuthUserSubmissions
| AuthCorrectorSubmissions
| AuthAuthentication
| AuthIsRead
| AuthIsWrite
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
type PseudonymWord = CI Text instance Universe AuthTag
instance Finite AuthTag
instance Hashable AuthTag
deriveJSON defaultOptions
{ constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel
} ''AuthTag
instance PathPiece AuthTag where
toPathPiece = $(nullaryToPathPiece ''AuthTag [Text.intercalate "-" . map toLower . drop 1 . splitCamel])
fromPathPiece = finiteFromPathPiece
instance ToJSONKey AuthTag where
toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t
instance FromJSONKey AuthTag where
fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String
newtype AuthTagActive = AuthTagActive { authTagIsActive :: AuthTag -> Bool }
deriving (Read, Show, Generic)
deriving newtype (Eq, Ord)
instance Default AuthTagActive where
def = AuthTagActive $ \case
AuthAdmin -> False
_ -> True
instance ToJSON AuthTagActive where
toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF
instance FromJSON AuthTagActive where
parseJSON = withObject "AuthTagActive" $ \o -> do
o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool)
return . AuthTagActive $ \n -> case HashMap.lookup n o' of
Nothing -> authTagIsActive def n
Just b -> b
derivePersistFieldJSON ''AuthTagActive
-- Type synonyms
type Email = Text type Email = Text

66
src/Utils.hs
View File

@ -4,10 +4,11 @@ module Utils
( module Utils ( module Utils
) where ) where
import ClassyPrelude.Yesod import ClassyPrelude.Yesod hiding (foldlM)
-- import Data.Double.Conversion.Text -- faster implementation for textPercent? -- import Data.Double.Conversion.Text -- faster implementation for textPercent?
import Data.Foldable as Fold hiding (length) import qualified Data.Foldable as Fold
import Data.Foldable as Utils (foldlM, foldrM)
import Data.Monoid (Sum(..)) import Data.Monoid (Sum(..))
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
@ -200,7 +201,6 @@ stepTextCounter text
-- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo Ue3bung00322 34 (H)" -- Data.Text.groupBy ((==) `on` isDigit) $ Data.Text.pack "12.ProMo Ue3bung00322 34 (H)"
-- ["12",".ProMo Ue","3","bung","00322"," ","34"," (H)"] -- ["12",".ProMo Ue","3","bung","00322"," ","34"," (H)"]
------------ ------------
-- Tuples -- -- Tuples --
------------ ------------
@ -306,9 +306,9 @@ ifMaybeM (Just x) _ act = act x
maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespear: one $maybe instead of $with & $if maybePositive :: (Num a, Ord a) => a -> Maybe a -- convenient for Shakespear: one $maybe instead of $with & $if
maybePositive a | a > 0 = Just a maybePositive a | a > 0 = Just a
| otherwise = Nothing | otherwise = Nothing
positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive positiveSum :: (Num a, Ord a) => Sum a -> Maybe a -- like maybePositive
positiveSum (Sum x) = maybePositive x positiveSum (Sum x) = maybePositive x
maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b maybeM :: Monad m => m b -> (a -> m b) -> m (Maybe a) -> m b
@ -395,12 +395,12 @@ catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
-- Monads -- -- Monads --
------------ ------------
shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a shortCircuitM :: Monad m => (a -> Bool) -> (a -> a -> a) -> m a -> m a -> m a
shortCircuitM sc mx my bop = do shortCircuitM sc binOp mx my = do
x <- mx x <- mx
if if
| sc x -> return x | sc x -> return x
| otherwise -> bop <$> pure x <*> my | otherwise -> binOp <$> pure x <*> my
guardM :: MonadPlus m => m Bool -> m () guardM :: MonadPlus m => m Bool -> m ()
@ -423,26 +423,40 @@ ifM c m m' =
ifNotM :: Monad m => m Bool -> m a -> m a -> m a ifNotM :: Monad m => m Bool -> m a -> m a -> m a
ifNotM c = flip $ ifM c ifNotM c = flip $ ifM c
-- | Lazy monadic conjunction. and2M, or2M :: Monad m => m Bool -> m Bool -> m Bool
and2M :: Monad m => m Bool -> m Bool -> m Bool
and2M ma mb = ifM ma mb (return False) and2M ma mb = ifM ma mb (return False)
andM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
andM = Fold.foldr and2M (return True)
allM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
allM xs f = andM $ fmap f xs
-- | Lazy monadic disjunction.
or2M :: Monad m => m Bool -> m Bool -> m Bool
or2M ma = ifM ma (return True) or2M ma = ifM ma (return True)
orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool andM, orM :: (Foldable f, Monad m) => f (m Bool) -> m Bool
andM = Fold.foldr and2M (return True)
orM = Fold.foldr or2M (return False) orM = Fold.foldr or2M (return False)
anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool allM, anyM :: (Functor f, Foldable f, Monad m) => f a -> (a -> m Bool) -> m Bool
allM xs f = andM $ fmap f xs
anyM xs f = orM $ fmap f xs anyM xs f = orM $ fmap f xs
ofoldr1M, ofoldl1M :: (MonoFoldable mono, Monad m) => (Element mono -> Element mono -> m (Element mono)) -> NonNull mono -> m (Element mono)
ofoldr1M f (otoList -> x:xs) = foldrM f x xs
ofoldr1M _ _ = error "otoList of NonNull is empty"
ofoldl1M f (otoList -> x:xs) = foldlM f x xs
ofoldl1M _ _ = error "otoList of NonNull is empty"
partitionM :: forall mono m .
( MonoFoldable mono
, Monoid mono
, MonoPointed mono
, Monad m)
=> (Element mono -> m Bool) -> mono -> m (mono, mono)
partitionM crit = ofoldlM dist mempty
where
dist :: (mono,mono) -> Element mono -> m (mono,mono)
dist acc x = do
okay <- crit x
return $ if
| okay -> acc `mappend` (opoint x, mempty)
| otherwise -> acc `mappend` (mempty, opoint x)
-------------- --------------
-- Sessions -- -- Sessions --
-------------- --------------
@ -452,3 +466,13 @@ setSessionJson (toPathPiece -> key) (LBS.toStrict . Aeson.encode -> val) = setSe
lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v) lookupSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key lookupSessionJson (toPathPiece -> key) = (Aeson.decode' . LBS.fromStrict =<<) <$> lookupSessionBS key
modifySessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m) => k -> (Maybe v -> Maybe v) -> m ()
modifySessionJson (toPathPiece -> key) f = lookupSessionJson key >>= maybe (deleteSession key) (setSessionJson key) . f
tellSessionJson :: (PathPiece k, FromJSON v, ToJSON v, MonadHandler m, Monoid v) => k -> v -> m ()
tellSessionJson key val = modifySessionJson key $ Just . (`mappend` val) . fromMaybe mempty
getSessionJson :: (PathPiece k, FromJSON v, MonadHandler m) => k -> m (Maybe v)
-- ^ `lookupSessionJson` followed by `deleteSession`
getSessionJson key = lookupSessionJson key <* deleteSession (toPathPiece key)

3
src/Utils/Lens.hs
View File

@ -2,6 +2,7 @@ module Utils.Lens ( module Utils.Lens ) where
import Import.NoFoundation import Import.NoFoundation
import Control.Lens as Utils.Lens import Control.Lens as Utils.Lens
import Control.Lens.Extras as Utils.Lens (is)
import Utils.Lens.TH as Utils.Lens (makeLenses_) import Utils.Lens.TH as Utils.Lens (makeLenses_)
import qualified Database.Esqueleto as E (Value(..),InnerJoin(..)) import qualified Database.Esqueleto as E (Value(..),InnerJoin(..))
@ -28,6 +29,8 @@ makeLenses_ ''SheetGrading
makeLenses_ ''SheetType makeLenses_ ''SheetType
makePrisms ''AuthResult
-- makeClassy_ ''Load -- makeClassy_ ''Load

12
src/Utils/Message.hs
View File

@ -1,6 +1,6 @@
module Utils.Message module Utils.Message
( MessageClass(..) ( MessageClass(..)
, addMessage, addMessageI, addMessageIHamlet, addMessageFile , addMessage, addMessageI, addMessageIHamlet, addMessageFile, addMessageWidget
) where ) where
@ -53,3 +53,13 @@ addMessageIHamlet mc iHamlet = do
addMessageFile :: MessageClass -> FilePath -> ExpQ addMessageFile :: MessageClass -> FilePath -> ExpQ
addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|] addMessageFile mc tPath = [e|addMessageIHamlet mc $(ihamletFile tPath)|]
addMessageWidget :: forall m site.
( MonadHandler m
, HandlerSite m ~ site
, Yesod site
) => MessageClass -> WidgetT site IO () -> m ()
-- ^ _Note_: `addMessageWidget` ignores `pageTitle` and `pageHead`
addMessageWidget mc wgt = do
PageContent{pageBody} <- liftHandlerT $ widgetToPageContent wgt
addMessageIHamlet mc (const pageBody :: HtmlUrlI18n (SomeMessage site) (Route site))

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

@ -12,6 +12,8 @@ import Control.Lens
import Data.ByteString.Builder (toLazyByteString) import Data.ByteString.Builder (toLazyByteString)
import System.FilePath ((</>)) import System.FilePath ((</>))
import Data.Aeson
instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
@ -32,3 +34,8 @@ instance (RenderRoute site, ParseRoute site) => PathPiece (Route site) where
. over (_2.traverse._2) (assertM' $ not . null) . over (_2.traverse._2) (assertM' $ not . null)
. renderRoute . renderRoute
instance (RenderRoute site, ParseRoute site) => FromJSON (Route site) where
parseJSON = withText "Route" $ maybe (fail "Could not parse route") return . fromPathPiece
instance (RenderRoute site, ParseRoute site) => ToJSON (Route site) where
toJSON = String . toPathPiece

4
start.sh
View File

@ -10,11 +10,11 @@ export PWFILE=users.yml
move-back() { move-back() {
mv -v .stack-work .stack-work-run mv -v .stack-work .stack-work-run
[[ -d .stack-work-ghci ]] && mv -v .stack-work-ghci .stack-work [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
} }
if [[ -d .stack-work-run ]]; then if [[ -d .stack-work-run ]]; then
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-ghci [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
mv -v .stack-work-run .stack-work mv -v .stack-work-run .stack-work
trap move-back EXIT trap move-back EXIT
fi fi

2
templates/authpreds.hamlet Normal file
View File

@ -0,0 +1,2 @@
<form method=post action=@{AuthPredsR} enctype=#{authActiveEnctype}>
^{authActiveWidget}

2
templates/formPage.hamlet
View File

@ -1,2 +1,2 @@
<form .form-horizontal method=post action=@{actionUrl}#forms enctype=#{formEnctype}> <form method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
^{formWidget} ^{formWidget}

2
templates/formPageI18n.hamlet
View File

@ -1,5 +1,5 @@
$maybe text <- formText $maybe text <- formText
<h3> <h3>
_{text} _{text}
<form .form-horizontal method=post action=@{actionUrl}#forms enctype=#{formEnctype}> <form method=post action=@{actionUrl}#forms enctype=#{formEnctype}>
^{formWidget} ^{formWidget}

5
templates/messages/submissionsAssignUnauthorized.hamlet Normal file
View File

@ -0,0 +1,5 @@
_{MsgSubmissionsAssignUnauthorized (fromIntegral (length unassignedUnauth'))}
<ul>
$forall cID <- unassignedUnauth'
<li><pre>#{toPathPiece cID}

1
templates/standalone/inputs.lucius
View File

@ -91,7 +91,6 @@ input[type*="time"] {
input[type="number"] { input[type="number"] {
width: 100px; width: 100px;
text-align: right;
} }
input[type*="date"], input[type*="date"],

2
templates/submission-assign.hamlet Normal file
View File

@ -0,0 +1,2 @@
<form method=post action=@{actionUrl} enctype=#{corrEncoding}>
^{corrForm}

4
test.sh
View File

@ -2,11 +2,11 @@
move-back() { move-back() {
mv -v .stack-work .stack-work-test mv -v .stack-work .stack-work-test
[[ -d .stack-work-run ]] && mv -v .stack-work-run .stack-work [[ -d .stack-work-build ]] && mv -v .stack-work-build .stack-work
} }
if [[ -d .stack-work-test ]]; then if [[ -d .stack-work-test ]]; then
[[ -d .stack-work ]] && mv -v .stack-work .stack-work-run [[ -d .stack-work ]] && mv -v .stack-work .stack-work-build
mv -v .stack-work-test .stack-work mv -v .stack-work-test .stack-work
trap move-back EXIT trap move-back EXIT
fi fi