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

Merge branch 'master' into 'live'

Browse Source 
Deploy master

Closes #96, #128, #129, and #130

See merge request !62
This commit is contained in:
Steffen Jost 2018-07-31 10:10:25 +02:00
commit a2df941fbc
28 changed files with 592 additions and 276 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
messages/de.msg
View File

@ -12,7 +12,7 @@ DeRegUntil: Abmeldungen bis
SummerTerm year@Integer: Sommersemester #{display year} SummerTerm year@Integer: Sommersemester #{display year}
WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year} WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ year}
SummerTermShort year@Integer: SoSe #{display year} SummerTermShort year@Integer: SoSe #{display year}
WinterTermShort year@Integer: WiSe #{display year}/#{display $ succ year} WinterTermShort year@Integer: WiSe #{display year}/#{display $ mod (succ year) 100}
PSLimitNonPositive: “pagesize” muss größer als null sein PSLimitNonPositive: “pagesize” muss größer als null sein
Page n@Int64: #{display n} Page n@Int64: #{display n}
@ -34,29 +34,29 @@ CourseRegisterOk: Sie wurden angemeldet
CourseDeregisterOk: Sie wurden abgemeldet CourseDeregisterOk: Sie wurden abgemeldet
CourseSecretWrong: Falsches Kennwort CourseSecretWrong: Falsches Kennwort
CourseSecret: Zugangspasswort CourseSecret: Zugangspasswort
CourseNewOk tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt. CourseNewOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt.
CourseEditOk tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich geändert. CourseEditOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich geändert.
CourseNewDupShort tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. CourseNewDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
CourseEditDupShort tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. CourseEditDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
FFSheetName: Name FFSheetName: Name
TermCourseListHeading tid@TermId: Kursübersicht #{display tid} TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
TermCourseListTitle tid@TermId: Kurse #{display tid} TermCourseListTitle tid@TermId: Kurse #{display tid}
CourseNewHeading: Neuen Kurs anlegen CourseNewHeading: Neuen Kurs anlegen
CourseEditHeading tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} editieren CourseEditHeading tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} editieren
CourseEditTitle: Kurs editieren/anlegen CourseEditTitle: Kurs editieren/anlegen
Sheet: Blatt Sheet: Blatt
SheetList tid@TermId courseShortHand@Text: #{display tid}-#{courseShortHand} Übersicht Übungsblätter SheetList tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Übersicht Übungsblätter
SheetNewHeading tid@TermId courseShortHand@Text: #{display tid}-#{courseShortHand} Neues Übungsblatt anlegen SheetNewHeading tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Neues Übungsblatt anlegen
SheetNewOk tid@TermId courseShortHand@Text sheetName@Text: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{courseShortHand} erfolgreich erstellt. SheetNewOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{courseShortHand} erfolgreich erstellt.
SheetTitle tid@TermId courseShortHand@Text sheetName@Text: #{display tid}-#{courseShortHand} #{sheetName} SheetTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName}
SheetTitleNew tid@TermId courseShortHand@Text : #{display tid}-#{courseShortHand}: Neues Übungsblatt SheetTitleNew tid@TermId courseShortHand@CourseShorthand : #{display tid}-#{courseShortHand}: Neues Übungsblatt
SheetEditHead tid@TermId courseShortHand@Text sheetName@Text: #{display tid}-#{courseShortHand} #{sheetName} editieren SheetEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName} editieren
SheetEditOk tid@TermId courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{courseShortHand} wurde gespeichert. SheetEditOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{courseShortHand} wurde gespeichert.
SheetNameDup tid@TermId courseShortHand@Text sheetName@Text: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{courseShortHand}. SheetNameDup tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{courseShortHand}.
SheetDelHead tid@TermId courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{courseShortHand} herauslöschen? SheetDelHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{courseShortHand} herauslöschen?
SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben. SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
SheetDelOk tid@TermId courseShortHand@Text sheetName@Text: #{display tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht. SheetDelOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht.
SheetExercise: Aufgabenstellung SheetExercise: Aufgabenstellung
SheetHint: Hinweis SheetHint: Hinweis
@ -80,21 +80,21 @@ Deadline: Abgabe
Done: Eingereicht Done: Eingereicht
Submission: Abgabenummer Submission: Abgabenummer
SubmissionsCourse tid@TermId courseShortHand@Text: Alle Abgaben Kurs #{display tid}-#{courseShortHand} SubmissionsCourse tid@TermId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{courseShortHand}
SubmissionsSheet sheetName@Text: Abgaben für Blatt #{sheetName} SubmissionsSheet sheetName@SheetName: Abgaben für Blatt #{sheetName}
SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt. SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
SubmissionEditHead tid@TermId courseShortHand@Text sheetName@Text: #{display tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen SubmissionEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
CorrectionHead tid@TermId courseShortHand@Text sheetName@Text cid@CryptoFileNameSubmission: #{display tid}-#{courseShortHand} #{sheetName}: Korrektur CorrectionHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{courseShortHand} #{sheetName}: Korrektur
SubmissionMember g@Int: Mitabgebende(r) ##{display g} SubmissionMember g@Int: Mitabgebende(r) ##{display g}
SubmissionArchive: Zip-Archiv der Abgabedatei(en) SubmissionArchive: Zip-Archiv der Abgabedatei(en)
SubmissionFile: Datei zur Abgabe SubmissionFile: Datei zur Abgabe
SubmissionFiles: Abgegebene Dateien SubmissionFiles: Abgegebene Dateien
SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem bÜbungsblatt. SubmissionAlreadyExistsFor email@UserEmail: #{email} hat bereits eine Abgabe zu diesem bÜbungsblatt.
CorrectionsTitle: Zugewiesene Korrekturen CorrectionsTitle: Zugewiesene Korrekturen
CourseCorrectionsTitle: Korrekturen für diesen Kurs CourseCorrectionsTitle: Korrekturen für diesen Kurs
CorrectorsHead sheetName@Text: Korrektoren für Blatt #{sheetName} CorrectorsHead sheetName@SheetName: Korrektoren für Blatt #{sheetName}
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})
@ -109,21 +109,23 @@ UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung
UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen. UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben. UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt. UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
UnauthorizedSubmissionRated: Diese Abgabe ist noch nicht korrigiert.
UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe. UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
OnlyUploadOneFile: Bitte nur eine Datei hochladen. OnlyUploadOneFile: Bitte nur eine Datei hochladen.
DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen. DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben. UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben.
MaterialFree: Kursmaterialien ohne Anmeldung zugänglich MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
UnsupportedAuthPredicate tag@String shownRoute@String: "!#{tag}" wurde auf eine Route angewandt, die dies nicht unterstützt: #{shownRoute}
EMail: E-Mail EMail: E-Mail
EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer. EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
NotAParticipant user@Text tid@TermId csh@Text: #{user} ist nicht im Kurs #{display tid}-#{csh} angemeldet. NotAParticipant email@UserEmail tid@TermId csh@CourseShorthand: #{email} ist nicht im Kurs #{display tid}-#{csh} angemeldet.
TooManyParticipants: Es wurden zu viele Mitabgebende angegeben TooManyParticipants: Es wurden zu viele Mitabgebende angegeben
AddCorrector: Zusätzlicher Korrektor AddCorrector: Zusätzlicher Korrektor
CorrectorExists user@Text: #{user} ist bereits als Korrektor eingetragen CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
SheetCorrectorsTitle tid@TermId courseShortHand@Text sheetName@Text: Korrektoren für #{display tid}-#{courseShortHand} #{sheetName} SheetCorrectorsTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{courseShortHand} #{sheetName}
CountTutProp: Tutorien zählen gegen Proportion CountTutProp: Tutorien zählen gegen Proportion
Corrector: Korrektor Corrector: Korrektor
Correctors: Korrektoren Correctors: Korrektoren
@ -187,6 +189,7 @@ Passed: Bestanden
NotPassed: Nicht bestanden NotPassed: Nicht bestanden
RatingTime: Korrigiert RatingTime: Korrigiert
RatingComment: Kommentar RatingComment: Kommentar
SubmissionUsers: Studenten
RatingPoints: Punkte RatingPoints: Punkte
RatingFiles: Korrigierte Dateien RatingFiles: Korrigierte Dateien

15
models
View File

@ -2,7 +2,7 @@ User json
plugin Text plugin Text
ident Text ident Text
matrikelnummer Text Maybe matrikelnummer Text Maybe
email Text email (CI Text)
displayName Text displayName Text
maxFavourites Int default=12 maxFavourites Int default=12
theme Theme default='Default' theme Theme default='Default'
@ -48,9 +48,10 @@ Term json
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
name Text name (CI Text)
shorthand Text shorthand (CI Text)
UniqueSchool name UniqueSchool name
UniqueSchoolShorthand shorthand
deriving Eq deriving Eq
DegreeCourse json DegreeCourse json
course CourseId course CourseId
@ -58,10 +59,10 @@ DegreeCourse json
terms StudyTermsId terms StudyTermsId
UniqueDegreeCourse course degree terms UniqueDegreeCourse course degree terms
Course Course
name Text name (CI Text)
description Html Maybe description Html Maybe
linkExternal Text Maybe linkExternal Text Maybe
shorthand Text shorthand (CI Text)
term TermId term TermId
school SchoolId school SchoolId
capacity Int64 Maybe capacity Int64 Maybe
@ -72,6 +73,7 @@ Course
registerSecret Text Maybe -- Falls ein Passwort erforderlich ist registerSecret Text Maybe -- Falls ein Passwort erforderlich ist
materialFree Bool materialFree Bool
CourseTermShort term shorthand CourseTermShort term shorthand
CourseTermName term name
CourseEdit CourseEdit
user UserId user UserId
time UTCTime time UTCTime
@ -81,6 +83,7 @@ CourseFavourite
time UTCTime time UTCTime
course CourseId course CourseId
UniqueCourseFavourite user course UniqueCourseFavourite user course
deriving Show
Lecturer Lecturer
user UserId user UserId
course CourseId course CourseId
@ -92,7 +95,7 @@ CourseParticipant
UniqueParticipant user course UniqueParticipant user course
Sheet Sheet
course CourseId course CourseId
name Text name (CI Text)
description Html Maybe description Html Maybe
type SheetType type SheetType
grouping SheetGroup grouping SheetGroup

6
routes
View File

@ -50,14 +50,14 @@
-- For Pattern Synonyms see Foundation -- For Pattern Synonyms see Foundation
/course/ CourseListR GET !free /course/ CourseListR GET !free
!/course/new CourseNewR GET POST !lecturer !/course/new CourseNewR GET POST !lecturer
/course/#TermId/#Text CourseR !lecturer: /course/#TermId/#CourseShorthand CourseR !lecturer:
/ CShowR GET !free / CShowR GET !free
/register CRegisterR POST !timeANDcapacity /register CRegisterR POST !timeANDcapacity
/edit CEditR GET POST /edit CEditR GET POST
/subs CCorrectionsR GET POST /subs CCorrectionsR GET POST
/ex SheetListR GET !registered !materials /ex SheetListR GET !registered !materials
!/ex/new SheetNewR GET POST !/ex/new SheetNewR GET POST
/ex/#Text SheetR: /ex/#SheetName SheetR:
/ SShowR GET !timeANDregistered !timeANDmaterials !corrector / SShowR GET !timeANDregistered !timeANDmaterials !corrector
/edit SEditR GET POST /edit SEditR GET POST
/delete SDelR GET POST /delete SDelR GET POST
@ -67,7 +67,7 @@
/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 !ownerANDisRead /correction CorrectionR GET POST !corrector !ownerANDisReadANDrated
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner !/#SubmissionFileType/*FilePath SubDownloadR GET !owner
/correctors SCorrR GET POST /correctors SCorrR GET POST
!/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector

2
shell.nix
View File

@ -10,7 +10,7 @@ let
drv = haskellPackages.callPackage ./uniworx.nix {}; drv = haskellPackages.callPackage ./uniworx.nix {};
postgresSchema = pkgs.writeText "schema.sql" '' postgresSchema = pkgs.writeText "schema.sql" ''
CREATE USER uniworx; CREATE USER uniworx WITH SUPERUSER;
CREATE DATABASE uniworx_test; CREATE DATABASE uniworx_test;
GRANT ALL ON DATABASE uniworx_test TO uniworx; GRANT ALL ON DATABASE uniworx_test TO uniworx;
CREATE DATABASE uniworx; CREATE DATABASE uniworx;

2
src/Application.hs
View File

@ -98,7 +98,7 @@ makeFoundation appSettings@(AppSettings{..}) = do
(pgPoolSize appDatabaseConf) (pgPoolSize appDatabaseConf)
-- Perform database migration using our application's logging settings. -- Perform database migration using our application's logging settings.
runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc runLoggingT (runSqlPool (runMigration $ migrateAll) pool) logFunc
-- Return the foundation -- Return the foundation
return $ mkFoundation pool return $ mkFoundation pool

9
src/CryptoID.hs
View File

@ -20,6 +20,7 @@ import CryptoID.TH
import ClassyPrelude hiding (fromString) import ClassyPrelude hiding (fromString)
import Model import Model
import qualified Data.CryptoID as E
import Data.CryptoID.Poly.ImplicitNamespace import Data.CryptoID.Poly.ImplicitNamespace
import Data.UUID.Cryptographic.ImplicitNamespace import Data.UUID.Cryptographic.ImplicitNamespace
import System.FilePath.Cryptographic.ImplicitNamespace import System.FilePath.Cryptographic.ImplicitNamespace
@ -39,7 +40,7 @@ instance PathPiece UUID where
instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
fromPathPiece = fmap CI.mk . fromPathPiece fromPathPiece = fmap CI.mk . fromPathPiece
toPathPiece = toPathPiece . CI.foldedCase toPathPiece = toPathPiece . CI.original
instance {-# OVERLAPS #-} PathMultiPiece FilePath where instance {-# OVERLAPS #-} PathMultiPiece FilePath where
fromPathMultiPiece = Just . unpack . intercalate "/" fromPathMultiPiece = Just . unpack . intercalate "/"
@ -55,8 +56,12 @@ decCryptoIDs [ ''SubmissionId
, ''FileId , ''FileId
, ''UserId , ''UserId
] ]
{- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where
fromPathPiece (Text.unpack -> piece) = do
piece' <- (stripPrefix `on` map CI.mk) "uwa" piece
return . CryptoID . CI.mk $ map CI.original piece'
toPathPiece = Text.pack . ("uwa" <>) . CI.foldedCase . ciphertext
newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission) newtype SubmissionMode = SubmissionMode (Maybe CryptoFileNameSubmission)

183
src/Foundation.hs
View File

@ -9,9 +9,9 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternGuards, MultiWayIf #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE FlexibleInstances, UndecidableInstances, FlexibleContexts #-}
module Foundation where module Foundation where
@ -25,6 +25,8 @@ import Yesod.Auth.Message
import Yesod.Auth.Dummy import Yesod.Auth.Dummy
import Yesod.Auth.LDAP import Yesod.Auth.LDAP
import qualified Network.Wai as W (requestMethod, pathInfo)
import LDAP.Data (LDAPScope(..)) import LDAP.Data (LDAPScope(..))
import LDAP.Search (LDAPEntry(..)) import LDAP.Search (LDAPEntry(..))
@ -35,14 +37,14 @@ import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
import qualified Data.CryptoID as E
import Data.ByteArray (convert) import Data.ByteArray (convert)
import Crypto.Hash (Digest, SHAKE256) import Crypto.Hash (Digest, SHAKE256)
import Crypto.Hash.Conduit (sinkHash) import Crypto.Hash.Conduit (sinkHash)
import Yesod.Auth.Util.PasswordStore import Yesod.Auth.Util.PasswordStore
import qualified Data.CryptoID (CryptoID) -- for DisplayAble instance only
import qualified Data.ByteString.Base64.URL as Base64 (encode) import qualified Data.ByteString.Base64.URL as Base64 (encode)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
@ -58,6 +60,8 @@ 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 Data.Monoid (Any(..))
import Data.Conduit (($$)) import Data.Conduit (($$))
import Data.Conduit.List (sourceList) import Data.Conduit.List (sourceList)
@ -67,6 +71,9 @@ 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) import Control.Monad.Trans.Reader (runReader)
import Control.Monad.Trans.Writer (WriterT(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Catch (handleAll)
import System.FilePath import System.FilePath
@ -83,15 +90,15 @@ import qualified Data.Yaml as Yaml
import Text.Shakespeare.Text (st) import Text.Shakespeare.Text (st)
instance DisplayAble b => DisplayAble (E.CryptoID a b) where
display = display . ciphertext
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => DisplayAble (E.CryptoID namespace (CI FilePath)) where
display = toPathPiece
-- -- TODO: Move the following to the appropriate place, if DisplayAble is kept
instance DisplayAble TermId where instance DisplayAble TermId where
display = termToText . unTermKey display = termToText . unTermKey
instance (PathPiece b) => DisplayAble (Data.CryptoID.CryptoID a b) where
display = toPathPiece -- requires import of Data.CryptoID here
-- -- MOVE ABOVE
-- infixl 9 :$: -- infixl 9 :$:
-- pattern a :$: b = a b -- pattern a :$: b = a b
@ -170,6 +177,15 @@ instance RenderMessage UniWorX TermIdentifier where
Winter -> renderMessage' $ MsgWinterTerm year Winter -> renderMessage' $ MsgWinterTerm year
where renderMessage' = renderMessage foundation ls where renderMessage' = renderMessage foundation ls
newtype ShortTermIdentifier = ShortTermIdentifier TermIdentifier
deriving (Eq, Ord, Read, Show)
instance RenderMessage UniWorX ShortTermIdentifier where
renderMessage foundation ls (ShortTermIdentifier TermIdentifier{..}) = case season of
Summer -> renderMessage' $ MsgSummerTermShort year
Winter -> renderMessage' $ MsgWinterTermShort year
where renderMessage' = renderMessage foundation ls
instance RenderMessage UniWorX String where instance RenderMessage UniWorX String where
renderMessage f ls str = renderMessage f ls $ Text.pack str renderMessage f ls str = renderMessage f ls $ Text.pack str
@ -181,6 +197,9 @@ instance RenderMessage UniWorX SheetFileType where
SheetMarking -> renderMessage' MsgSheetMarking SheetMarking -> renderMessage' MsgSheetMarking
where renderMessage' = renderMessage foundation ls where renderMessage' = renderMessage foundation ls
instance RenderMessage UniWorX (UnsupportedAuthPredicate (Route UniWorX)) where
renderMessage f ls (UnsupportedAuthPredicate tag route) = renderMessage f ls $ MsgUnsupportedAuthPredicate tag (show route)
getTimeLocale' :: [Lang] -> TimeLocale getTimeLocale' :: [Lang] -> TimeLocale
getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")]) getTimeLocale' = $(timeLocaleMap [("de", "de_DE.utf8")])
@ -341,9 +360,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
&& NTop courseRegisterTo >= cTime && NTop courseRegisterTo >= cTime
return Authorized return Authorized
r -> do r -> $unsupportedAuthPredicate "time" r
$logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r
unauthorizedI MsgUnauthorized
) )
,("registered", APDB $ \route _ -> case route of ,("registered", APDB $ \route _ -> case route of
CourseR tid csh _ -> exceptT return return $ do CourseR tid csh _ -> exceptT return return $ do
@ -356,9 +373,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
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 -> do r -> $unsupportedAuthPredicate "registered" r
$logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r
unauthorizedI MsgUnauthorized
) )
,("capacity", APDB $ \route _ -> case route of ,("capacity", APDB $ \route _ -> case route of
CourseR tid csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do CourseR tid csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
@ -366,18 +381,14 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
guard $ NTop courseCapacity > NTop (Just registered) guard $ NTop courseCapacity > NTop (Just registered)
return Authorized return Authorized
r -> do r -> $unsupportedAuthPredicate "capacity" r
$logErrorS "AccessControl" $ "'!capacity' used on route that doesn't support it: " <> tshow r
unauthorizedI MsgUnauthorized
) )
,("materials", APDB $ \route _ -> case route of ,("materials", APDB $ \route _ -> case route of
CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
guard courseMaterialFree guard courseMaterialFree
return Authorized return Authorized
r -> do r -> $unsupportedAuthPredicate "materials" r
$logErrorS "AccessControl" $ "'!materials' used on route that doesn't support it: " <> tshow r
unauthorizedI MsgUnauthorized
) )
,("owner", APDB $ \route _ -> case route of ,("owner", APDB $ \route _ -> case route of
CSubmissionR _ _ _ cID _ -> exceptT return return $ do CSubmissionR _ _ _ cID _ -> exceptT return return $ do
@ -385,9 +396,15 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
return Authorized return Authorized
r -> do r -> $unsupportedAuthPredicate "owner" r
$logErrorS "AccessControl" $ "'!owner' used on route that doesn't support it: " <> tshow r )
unauthorizedI MsgUnauthorized ,("rated", APDB $ \route _ -> case route of
CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
sub <- MaybeT $ get sid
guard $ submissionRatingDone sub
return Authorized
r -> $unsupportedAuthPredicate "rated" r
) )
,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)) ,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite))
,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)) ,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized))
@ -446,33 +463,53 @@ instance Yesod UniWorX where
-- b) Validates that incoming write requests include that token in either a header or POST parameter. -- b) Validates that incoming write requests include that token in either a header or POST parameter.
-- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware -- To add it, chain it together with the defaultMiddleware: yesodMiddleware = defaultYesodMiddleware . defaultCsrfMiddleware
-- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package. -- For details, see the CSRF documentation in the Yesod.Core.Handler module of the yesod-core package.
yesodMiddleware handler = do yesodMiddleware = defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware
void . runMaybeT $ do where
route <- MaybeT getCurrentRoute updateFavouritesMiddleware :: Handler a -> Handler a
guardM . lift $ (== Authorized) <$> isAuthorized route False updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
case route of -- update Course Favourites here route <- MaybeT getCurrentRoute
CourseR tid csh _ -> do case route of -- update Course Favourites here
uid <- MaybeT maybeAuthId CourseR tid csh _ -> do
$(logDebug) "Favourites save" void . lift . runDB . runMaybeT $ do
now <- liftIO $ getCurrentTime guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid csh CShowR) False
void . lift . runDB . runMaybeT $ do $logDebugS "updateFavourites" "Updating favourites"
cid <- MaybeT . getKeyBy $ CourseTermShort tid csh
user <- MaybeT $ get uid
-- update Favourites
void . lift $ upsertBy
(UniqueCourseFavourite uid cid)
(CourseFavourite uid now cid)
[CourseFavouriteTime =. now]
-- prune Favourites to user-defined size
oldFavs <- lift $ selectKeysList
[ CourseFavouriteUser ==. uid]
[ Desc CourseFavouriteTime
, OffsetBy $ userMaxFavourites user
]
lift $ mapM_ delete oldFavs
_other -> return () now <- liftIO $ getCurrentTime
defaultYesodMiddleware handler -- handler is executed afterwards, so Favourites are updated immediately uid <- MaybeT $ liftHandlerT maybeAuthId
cid <- MaybeT . getKeyBy $ CourseTermShort tid csh
user <- MaybeT $ get uid
let courseFavourite = CourseFavourite uid now cid
$logDebugS "updateFavourites" [st|Updating/Inserting: #{tshow courseFavourite}|]
-- update Favourites
void . lift $ upsertBy
(UniqueCourseFavourite uid cid)
courseFavourite
[CourseFavouriteTime =. now]
-- prune Favourites to user-defined size
oldFavs <- lift $ selectKeysList
[ CourseFavouriteUser ==. uid]
[ Desc CourseFavouriteTime
, OffsetBy $ userMaxFavourites user
]
lift . forM_ oldFavs $ \fav -> do
$logDebugS "updateFavourites" "Deleting old favourite."
delete fav
_other -> return ()
normalizeRouteMiddleware :: Handler a -> Handler a
normalizeRouteMiddleware handler = (*> handler) . runMaybeT $ do
route <- MaybeT getCurrentRoute
(route', getAny -> changed) <- lift . runDB . runWriterT $ foldM (&) route routeNormalizers
when changed $ do
$logDebugS "normalizeRouteMiddleware" [st|Redirecting to #{tshow route'}|]
redirectWith movedPermanently301 route'
-- The following exception permits drive-by login via LDAP plugin. FIXME: Blocked by #17
isWriteRequest (AuthR (PluginR "LDAP" _)) = return False
isWriteRequest _ = do
wai <- waiRequest
return $ W.requestMethod wai `notElem`
["GET", "HEAD", "OPTIONS", "TRACE"]
defaultLayout widget = do defaultLayout widget = do
master <- getYesod master <- getYesod
@ -629,18 +666,18 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb TermCurrentR = return ("Aktuell" , Just TermShowR) breadcrumb TermCurrentR = return ("Aktuell" , Just TermShowR)
breadcrumb TermEditR = return ("Neu" , Just TermCurrentR) breadcrumb TermEditR = return ("Neu" , Just TermCurrentR)
breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid) breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid)
breadcrumb (TermCourseListR term) = return (display term, Just TermShowR) breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR)
breadcrumb CourseListR = return ("Kurs" , Just HomeR) breadcrumb CourseListR = return ("Kurs" , Just HomeR)
breadcrumb CourseNewR = return ("Neu" , Just CourseListR) breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
breadcrumb (CourseR tid csh CShowR) = return (csh , Just $ TermCourseListR tid) breadcrumb (CourseR tid csh CShowR) = return (CI.original csh, Just $ TermCourseListR tid)
-- (CourseR tid csh CRegisterR) -- is POST only -- (CourseR tid csh CRegisterR) -- is POST only
breadcrumb (CourseR tid csh CEditR) = return ("Editieren", Just $ CourseR tid csh CShowR) breadcrumb (CourseR tid csh CEditR) = return ("Editieren", Just $ CourseR tid csh CShowR)
breadcrumb (CourseR tid csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid csh CShowR) breadcrumb (CourseR tid csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid csh CShowR)
breadcrumb (CourseR tid csh SheetListR) = return ("Übungen" , Just $ CourseR tid csh CShowR) breadcrumb (CourseR tid csh SheetListR) = return ("Übungen" , Just $ CourseR tid csh CShowR)
breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR) breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR)
breadcrumb (CSheetR tid csh shn SShowR) = return (shn, Just $ CourseR tid csh SheetListR) breadcrumb (CSheetR tid csh shn SShowR) = return (CI.original shn, Just $ CourseR tid csh SheetListR)
breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR)
breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR)
breadcrumb (CSheetR tid csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid csh shn SShowR)
@ -657,7 +694,7 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR) breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR)
breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all
submissionList :: TermId -> Text -> Text -> UserId -> DB [E.Value SubmissionId] submissionList :: TermId -> CourseShorthand -> SheetName -> UserId -> DB [E.Value SubmissionId]
submissionList tid csh shn uid = E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do submissionList tid csh shn uid = E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
@ -975,6 +1012,42 @@ pageHeading _
= Nothing = Nothing
routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)]
routeNormalizers =
[ normalizeRender
, ncCourse
, ncSheet
]
where
normalizeRender route = route <$ do
YesodRequest{..} <- liftHandlerT getRequest
let original = (W.pathInfo reqWaiRequest, reqGetParams)
rendered = renderRoute route
if
| (isSuffixOf `on` fst) original rendered -> do -- FIXME: this breaks when subsite prefixes are dynamic
$logDebugS "normalizeRender" [st|#{tshow rendered} matches #{tshow original}|]
| otherwise -> do
$logDebugS "normalizeRender" [st|Redirecting because #{tshow rendered} does not match #{tshow original}|]
tell $ Any True
maybeOrig f route = maybeT (return route) $ f route
hasChanged a b
| ((/=) `on` CI.original) a b = do
$logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
tell $ Any True
| otherwise = return ()
ncCourse = maybeOrig $ \route -> do
CourseR tid csh subRoute <- return route
Entity _ Course{..} <- MaybeT . lift . getBy $ CourseTermShort tid csh
hasChanged csh courseShorthand
return $ CourseR tid courseShorthand subRoute
ncSheet = maybeOrig $ \route -> do
CSheetR tid csh shn subRoute <- return route
Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh
Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
hasChanged shn sheetName
return $ CSheetR tid csh sheetName subRoute
-- 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
@ -1021,7 +1094,7 @@ instance YesodAuth UniWorX where
userEmail' = lookup "mail" credsExtra userEmail' = lookup "mail" credsExtra
userDisplayName' = lookup "displayName" credsExtra userDisplayName' = lookup "displayName" credsExtra
userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") return userEmail' userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") (return . CI.mk) userEmail'
userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName' userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName'
AppSettings{..} <- getsYesod appSettings AppSettings{..} <- getsYesod appSettings

68
src/Handler/Corrections.hs
View File

@ -75,68 +75,84 @@ sheetIs :: Key Sheet -> CorrectionsWhere
sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (E.Value Text, E.Value Text, E.Value (Key Term), E.Value (Key School)), Maybe (Entity User)) type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (CourseName, CourseShorthand, Key Term, Key School), Maybe (Entity User), Map UserId User)
colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgTerm) colTerm = sortable (Just "term") (i18nCell MsgTerm)
$ \DBRow{ dbrOutput=(_, _, course, _) } -> $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
-- cell [whamlet| _{untermKey $ course ^. _3}|] -- lange, internationale Semester -- cell [whamlet| _{untermKey $ course ^. _3}|] -- lange, internationale Semester
textCell $ termToText $ unTermKey $ E.unValue $ course ^. _3 -- kurze Semsterkürzel textCell $ termToText $ unTermKey $ course ^. _3 -- kurze Semsterkürzel
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, _) } -> cell $ $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> cell $
let tid = E.unValue $ course ^. _3 let tid = course ^. _3
csh = E.unValue $ course ^. _2 csh = course ^. _2
in [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|] in [whamlet|<a href=@{CourseR tid csh CShowR}>#{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)
$ \DBRow{ dbrOutput=(_, sheet, course, _) } -> cell $ $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> cell $
let tid = E.unValue $ course ^. _3 let tid = course ^. _3
csh = E.unValue $ course ^. _2 csh = course ^. _2
shn = sheetName $ entityVal sheet shn = sheetName $ entityVal sheet
in [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|] in [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
-- textCell $ sheetName $ entityVal sheet -- textCell $ sheetName $ entityVal sheet
colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
DBRow{ dbrOutput = (_, _, _, Nothing) } -> cell mempty DBRow{ dbrOutput = (_, _, _, Nothing, _) } -> cell mempty
DBRow{ dbrOutput = (_, _, _, Just corr) } -> textCell . display . userDisplayName $ entityVal corr DBRow{ dbrOutput = (_, _, _, Just corr, _) } -> textCell . display . userDisplayName $ entityVal corr
colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
$ \DBRow{ dbrOutput=(submission, sheet, course, _) } -> cell $ do $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> cell $ do
let tid = E.unValue $ course ^. _3 let tid = course ^. _3
csh = E.unValue $ course ^. _2 csh = course ^. _2
shn = sheetName $ entityVal sheet shn = sheetName $ entityVal sheet
cid <- encrypt (entityKey submission :: SubmissionId) cid <- encrypt (entityKey submission :: SubmissionId)
[whamlet|<a href=@{CSubmissionR tid csh shn cid SubShowR}>#{display cid}|] [whamlet|<a href=@{CSubmissionR tid csh shn cid SubShowR}>#{display cid}|]
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _, _) } -> encrypt subId
colSubmittors :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutput=(_, _, _, _, users) } -> let
cell = listCell (Map.toList users) $ \(userId, User{..}) -> anchorCellM (AdminUserR <$> encrypt userId) (toWidget userDisplayName)
in cell & cellAttrs <>~ [("class", "list--inline list--comma-separated")]
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 colChoices psValidator = do makeCorrectionsTable whereClause colChoices psValidator = do
let tableData :: CorrectionTableExpr -> E.SqlQuery _ let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
tableData ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ whereClause (course,sheet,submission) E.where_ $ whereClause (course,sheet,submission)
let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value Text) let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value CourseName)
, course E.^. CourseShorthand , course E.^. CourseShorthand
, course E.^. CourseTerm , course E.^. CourseTerm
, course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId) , course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId)
) )
return (submission, sheet, crse, corrector) return (submission, sheet, crse, corrector)
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CorrectionTableData
dbtProj = traverse $ \(submission@(Entity sId _), sheet, (E.Value courseName, E.Value courseShorthand, E.Value courseTerm, E.Value courseSchool), mCorrector) -> do
submittors <- lift . E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
E.on $ submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId
E.where_ $ submissionUser E.^. SubmissionUserSubmission E.==. E.val sId
E.orderBy [E.asc $ user E.^. UserId]
return user
let
submittorMap = foldr (\(Entity userId user) -> Map.insert userId user) Map.empty submittors
return (submission, sheet, (courseName, courseShorthand, courseTerm, courseSchool), mCorrector, submittorMap)
dbTable psValidator $ DBTable dbTable psValidator $ DBTable
{ dbtSQLQuery = tableData { dbtSQLQuery
, dbtColonnade = colChoices , dbtColonnade = colChoices
, dbtProj = return , dbtProj
, dbtSorting = [ ( "term" , dbtSorting = [ ( "term"
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm , SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
) )
@ -207,7 +223,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
FormMissing -> return () FormMissing -> return ()
FormSuccess (CorrDownloadData, subs) -> do FormSuccess (CorrDownloadData, subs) -> do
ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
addHeader "Content-Disposition" "attachment; filename=\"corrections.zip\"" addHeader "Content-Disposition" [st|attachment; filename="corrections.zip"|]
sendResponse =<< submissionMultiArchive ids sendResponse =<< submissionMultiArchive ids
FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do
subs <- mapM decrypt $ Set.toList subs' subs <- mapM decrypt $ Set.toList subs'
@ -309,7 +325,7 @@ postCorrectionsR = do
[ downloadAction [ downloadAction
] ]
getCCorrectionsR, postCCorrectionsR :: TermId -> Text -> Handler TypedContent getCCorrectionsR, postCCorrectionsR :: TermId -> CourseShorthand -> Handler TypedContent
getCCorrectionsR = postCCorrectionsR getCCorrectionsR = postCCorrectionsR
postCCorrectionsR tid csh = do postCCorrectionsR tid csh = do
Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh
@ -319,6 +335,7 @@ postCCorrectionsR tid csh = do
, dbRow , dbRow
, colSheet , colSheet
, colCorrector , colCorrector
, colSubmittors
, colSubmissionLink , colSubmissionLink
] -- Continue here ] -- Continue here
psValidator = def psValidator = def
@ -327,7 +344,7 @@ postCCorrectionsR tid csh = do
, assignAction (Left cid) , assignAction (Left cid)
] ]
getSSubsR, postSSubsR :: TermId -> Text -> Text -> Handler TypedContent getSSubsR, postSSubsR :: TermId -> CourseShorthand -> SheetName -> Handler TypedContent
getSSubsR = postSSubsR getSSubsR = postSSubsR
postSSubsR tid csh shn = do postSSubsR tid csh shn = do
shid <- runDB $ fetchSheetId tid csh shn shid <- runDB $ fetchSheetId tid csh shn
@ -336,6 +353,7 @@ postSSubsR tid csh shn = do
[ colSelect [ colSelect
, dbRow , dbRow
, colCorrector , colCorrector
, colSubmittors
, colSubmissionLink , colSubmissionLink
] ]
psValidator = def psValidator = def
@ -357,7 +375,7 @@ correctionData tid csh shn sub = E.select . E.from $ \((course `E.InnerJoin` she
return (course, sheet, submission, corrector) return (course, sheet, submission, corrector)
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getCorrectionR tid csh shn cid = do getCorrectionR tid csh shn cid = do
mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True
bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid csh shn cid bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid csh shn cid
@ -371,7 +389,7 @@ postCorrectionR tid 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))
((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,) ((corrResult, corrForm), corrEncoding) <- runFormPost . identForm FIDcorrection . renderAForm FormStandard $ (,)
<$> aopt pointsField (fslI MsgRatingPoints) (Just $ submissionRatingPoints) <$> aopt pointsField (fslpI MsgRatingPoints "Punktezahl" & setTooltip "Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist") (Just $ submissionRatingPoints)
<*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment)) <*> (((\t -> t <$ guard (not $ null t)) =<<) . fmap (Text.strip . unTextarea) <$> aopt textareaField (fslI MsgRatingComment) (Just $ Textarea <$> submissionRatingComment))
<* submitButton <* submitButton

23
src/Handler/Course.hs
View File

@ -94,7 +94,7 @@ getTermCourseListR tid = do
setTitleI . MsgTermCourseListTitle $ tid setTitleI . MsgTermCourseListTitle $ tid
$(widgetFile "courses") $(widgetFile "courses")
getCShowR :: TermId -> Text -> Handler Html getCShowR :: TermId -> CourseShorthand -> Handler Html
getCShowR tid csh = do getCShowR tid csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
(courseEnt,(schoolMB,participants,registered)) <- runDB $ do (courseEnt,(schoolMB,participants,registered)) <- runDB $ do
@ -130,7 +130,7 @@ registerForm registered msecret extra = do
return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
postCRegisterR :: TermId -> Text -> Handler Html postCRegisterR :: TermId -> CourseShorthand -> Handler Html
postCRegisterR tid csh = do postCRegisterR tid csh = do
aid <- requireAuthId aid <- requireAuthId
(cid, course, registered) <- runDB $ do (cid, course, registered) <- runDB $ do
@ -159,12 +159,12 @@ getCourseNewR = do
postCourseNewR :: Handler Html postCourseNewR :: Handler Html
postCourseNewR = courseEditHandler False Nothing postCourseNewR = courseEditHandler False Nothing
getCEditR :: TermId -> Text -> Handler Html getCEditR :: TermId -> CourseShorthand -> Handler Html
getCEditR tid csh = do getCEditR tid csh = do
course <- runDB $ getBy $ CourseTermShort tid csh course <- runDB $ getBy $ CourseTermShort tid csh
courseEditHandler True course courseEditHandler True course
postCEditR :: TermId -> Text -> Handler Html postCEditR :: TermId -> CourseShorthand -> Handler Html
postCEditR tid csh = do postCEditR tid csh = do
course <- runDB $ getBy $ CourseTermShort tid csh course <- runDB $ getBy $ CourseTermShort tid csh
courseEditHandler False course courseEditHandler False course
@ -255,8 +255,7 @@ courseEditHandler isGet course = do
-- else addMessageI "danger" $ MsgCourseEditDupShort tid csh -- else addMessageI "danger" $ MsgCourseEditDupShort tid csh
(FormFailure _) -> addMessageI "warning" MsgInvalidInput (FormFailure _) -> addMessageI "warning" MsgInvalidInput
(FormMissing) | isGet -> return () (FormMissing) -> return ()
other -> addMessage "error" $ [shamlet| Error: #{show other}|]
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
defaultLayout $ do defaultLayout $ do
setTitleI MsgCourseEditTitle setTitleI MsgCourseEditTitle
@ -265,10 +264,10 @@ courseEditHandler isGet course = do
data CourseForm = CourseForm data CourseForm = CourseForm
{ cfCourseId :: Maybe CourseId -- Maybe CryptoUUIDCourse { cfCourseId :: Maybe CourseId -- Maybe CryptoUUIDCourse
, cfName :: Text , cfName :: CourseName
, cfDesc :: Maybe Html , cfDesc :: Maybe Html
, cfLink :: Maybe Text , cfLink :: Maybe Text
, cfShort :: Text , cfShort :: CourseShorthand
, cfTerm :: TermId , cfTerm :: TermId
, cfSchool :: SchoolId , cfSchool :: SchoolId
, cfCapacity :: Maybe Int64 , cfCapacity :: Maybe Int64
@ -279,10 +278,6 @@ data CourseForm = CourseForm
, cfDeRegUntil :: Maybe UTCTime , cfDeRegUntil :: Maybe UTCTime
} }
instance Show CourseForm where
show cf = T.unpack (cfShort cf) ++ ' ':(show $ cfCourseId cf)
courseToForm :: Entity Course -> CourseForm courseToForm :: Entity Course -> CourseForm
courseToForm cEntity = CourseForm courseToForm cEntity = CourseForm
{ cfCourseId = Just $ entityKey cEntity { cfCourseId = Just $ entityKey cEntity
@ -312,10 +307,10 @@ newCourseForm template = identForm FIDcourse $ \html -> do
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
-- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work? -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work?
<$> aopt hiddenField "KursId" (cfCourseId <$> template) <$> aopt hiddenField "KursId" (cfCourseId <$> template)
<*> areq textField (fsb "Name") (cfName <$> template) <*> areq (ciField textField) (fsb "Name") (cfName <$> template)
<*> aopt htmlField (fsb "Beschreibung") (cfDesc <$> template) <*> aopt htmlField (fsb "Beschreibung") (cfDesc <$> template)
<*> aopt urlField (fsb "Homepage") (cfLink <$> template) <*> aopt urlField (fsb "Homepage") (cfLink <$> template)
<*> areq textField (fsb "Kürzel" <*> areq (ciField textField) (fsb "Kürzel"
-- & addAttr "disabled" "disabled" -- & addAttr "disabled" "disabled"
& setTooltip "Muss innerhalb des Semesters eindeutig sein") & setTooltip "Muss innerhalb des Semesters eindeutig sein")
(cfShort <$> template) (cfShort <$> template)

20
src/Handler/CryptoIDDispatch.hs
View File

@ -21,7 +21,7 @@ import Import hiding (Proxy)
import Data.Proxy import Data.Proxy
import Handler.Utils import qualified Data.Text as Text
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..)) import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
@ -46,14 +46,16 @@ instance CryptoRoute UUID SubmissionId where
return $ CSubmissionR tid csh shn cID' SubShowR return $ CSubmissionR tid csh shn cID' SubShowR
instance CryptoRoute (CI FilePath) SubmissionId where instance CryptoRoute (CI FilePath) SubmissionId where
cryptoIDRoute _ (CryptoID -> cID) = do cryptoIDRoute _ ciphertext
(smid :: SubmissionId) <- decrypt cID | Just cID <- fromPathPiece . Text.pack $ CI.original ciphertext = do
(tid,csh,shn) <- runDB $ do smid <- decrypt cID
shid <- submissionSheet <$> get404 smid (tid,csh,shn) <- runDB $ do
Sheet{..} <- get404 shid shid <- submissionSheet <$> get404 smid
Course{..} <- get404 sheetCourse Sheet{..} <- get404 shid
return (courseTerm, courseShorthand, sheetName) Course{..} <- get404 sheetCourse
return $ CSubmissionR tid csh shn cID SubShowR return (courseTerm, courseShorthand, sheetName)
return $ CSubmissionR tid csh shn cID SubShowR
| otherwise = notFound
instance CryptoRoute UUID UserId where instance CryptoRoute UUID UserId where
cryptoIDRoute _ (CryptoID -> cID) = do cryptoIDRoute _ (CryptoID -> cID) = do

8
src/Handler/Home.hs
View File

@ -115,8 +115,8 @@ homeUser uid = do
-- (E.SqlExpr (Entity Course ))) -- (E.SqlExpr (Entity Course )))
-- (E.SqlExpr (Entity Sheet )) -- (E.SqlExpr (Entity Sheet ))
_ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term)) _ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
, E.SqlExpr (E.Value Text) , E.SqlExpr (E.Value CourseShorthand)
, E.SqlExpr (E.Value Text) , E.SqlExpr (E.Value SheetName)
, E.SqlExpr (E.Value UTCTime) , E.SqlExpr (E.Value UTCTime)
, E.SqlExpr (E.Value (Maybe SubmissionId))) , E.SqlExpr (E.Value (Maybe SubmissionId)))
tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do
@ -138,8 +138,8 @@ homeUser uid = do
) )
colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term) colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term)
, E.Value Text , E.Value CourseShorthand
, E.Value Text , E.Value SheetName
, E.Value UTCTime , E.Value UTCTime
, E.Value (Maybe SubmissionId) , E.Value (Maybe SubmissionId)
)) ))

86
src/Handler/Sheet.hs
View File

@ -34,6 +34,9 @@ import Text.Blaze (text)
import qualified Data.UUID.Cryptographic as UUID import qualified Data.UUID.Cryptographic as UUID
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E import qualified Database.Esqueleto.Internal.Sql as E
@ -68,7 +71,7 @@ instance Eq (Unique Sheet) where
-} -}
data SheetForm = SheetForm data SheetForm = SheetForm
{ sfName :: Text { sfName :: SheetName
, sfDescription :: Maybe Html , sfDescription :: Maybe Html
, sfType :: SheetType , sfType :: SheetType
, sfGrouping :: SheetGroup , sfGrouping :: SheetGroup
@ -85,21 +88,23 @@ data SheetForm = SheetForm
-- Keine SheetId im Formular! -- Keine SheetId im Formular!
} }
getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileId)
getFtIdMap sId = do
allfIds <- E.select . E.from $ \(sheetFile `E.InnerJoin` file) -> do
E.on $ sheetFile E.^. SheetFileFile E.==. file E.^. FileId
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
return (sheetFile E.^. SheetFileType, file E.^. FileId)
return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds]
makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
makeSheetForm msId template = identForm FIDsheet $ \html -> do makeSheetForm msId template = identForm FIDsheet $ \html -> do
-- TODO: SJ to refactor this; extract Code from getSEditR to joint code piece oldFileIds <- (return.) <$> case msId of
let oldFileIds fType Nothing -> return $ partitionFileType mempty
| Just sId <- msId = fmap setFromList . fmap (map E.unValue) . runDB . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
E.&&. sheetFile E.^. SheetFileType E.==. E.val fType
return (file E.^. FileId)
| otherwise = return Set.empty
mr <- getMsgRenderer mr <- getMsgRenderer
ctime <- liftIO $ getCurrentTime ctime <- liftIO $ getCurrentTime
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
<$> areq textField (fsb "Name") (sfName <$> template) <$> areq (ciField textField) (fsb "Name") (sfName <$> template)
<*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfDescription <$> template) <*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfDescription <$> template)
<*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template) <*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template)
<*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGrouping <$> template) <*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGrouping <$> template)
@ -149,7 +154,7 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
, ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly) , ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly)
] ] ] ]
getSheetListR :: TermId -> Text -> Handler Html getSheetListR :: TermId -> CourseShorthand -> Handler Html
getSheetListR tid csh = do getSheetListR tid csh = do
Entity cid _ <- runDB . getBy404 $ CourseTermShort tid csh Entity cid _ <- runDB . getBy404 $ CourseTermShort tid csh
let let
@ -206,7 +211,7 @@ getSheetListR tid csh = do
-- Show single sheet -- Show single sheet
getSShowR :: TermId -> Text -> Text -> Handler Html getSShowR :: TermId -> CourseShorthand -> SheetName -> Handler Html
getSShowR tid csh shn = do getSShowR tid csh shn = do
entSheet <- runDB $ fetchSheet tid csh shn entSheet <- runDB $ fetchSheet tid csh shn
let sheet = entityVal entSheet let sheet = entityVal entSheet
@ -265,16 +270,16 @@ getSShowR tid csh shn = do
hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ] hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ]
return (hasHints, hasSolution) return (hasHints, hasSolution)
defaultLayout $ do defaultLayout $ do
setTitle $ toHtml $ T.append "Übung " $ sheetName sheet setTitleI $ MsgSheetTitle tid csh shn
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
$(widgetFile "sheetShow") $(widgetFile "sheetShow")
getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent getSFileR :: TermId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
getSFileR tid csh shn typ title = do getSFileR tid csh shn typ title = do
content <- runDB $ E.select $ E.from $ results <- runDB $ E.select $ E.from $
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other -- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
@ -288,38 +293,36 @@ getSFileR tid csh shn typ title = do
E.&&. (course E.^. CourseTerm E.==. E.val tid ) E.&&. (course E.^. CourseTerm E.==. E.val tid )
) )
-- return desired columns -- return desired columns
return $ file E.^. FileContent return $ (file E.^. FileTitle, file E.^. FileContent)
let mimeType = defaultMimeLookup $ pack title let mimeType = defaultMimeLookup $ pack title
case content of case results of
[E.Value (Just nochmalContent)] -> do [(E.Value fileTitle, E.Value fileContent)]
addHeader "Content-Disposition" "attachment" | Just fileContent' <- fileContent -> do
respond mimeType nochmalContent addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
[] -> notFound return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
_other -> error "Multiple matching files found." | otherwise -> sendResponseStatus noContent204 ()
[] -> notFound
other -> do
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found."
getSheetNewR :: TermId -> CourseShorthand -> Handler Html
getSheetNewR :: TermId -> Text -> Handler Html
getSheetNewR tid csh = do getSheetNewR tid csh = do
let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
insertUnique $ newSheet insertUnique $ newSheet
handleSheetEdit tid csh Nothing template action handleSheetEdit tid csh Nothing template action
postSheetNewR :: TermId -> Text -> Handler Html postSheetNewR :: TermId -> CourseShorthand -> Handler Html
postSheetNewR = getSheetNewR postSheetNewR = getSheetNewR
getSEditR :: TermId -> Text -> Text -> Handler Html getSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html
getSEditR tid csh shn = do getSEditR tid csh shn = do
(sheetEnt, sheetFileIds) <- runDB $ do (sheetEnt, sheetFileIds) <- runDB $ do
ent <- fetchSheet tid csh shn ent <- fetchSheet tid csh shn
allfIds <- E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do fti <- getFtIdMap $ entityKey ent
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile return (ent, fti)
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val (entityKey ent)
return (sheetFile E.^. SheetFileType, file E.^. FileId)
let ftIds :: SheetFileType -> Set FileId
ftIds ft = Set.fromList $ mapMaybe (\(E.Value t, E.Value i) -> i <$ guard (ft==t)) allfIds
return (ent, ftIds)
let sid = entityKey sheetEnt let sid = entityKey sheetEnt
let oldSheet@(Sheet {..}) = entityVal sheetEnt let oldSheet@(Sheet {..}) = entityVal sheetEnt
let template = Just $ SheetForm let template = Just $ SheetForm
@ -345,10 +348,10 @@ getSEditR tid csh shn = do
(Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
handleSheetEdit tid csh (Just sid) template action handleSheetEdit tid csh (Just sid) template action
postSEditR :: TermId -> Text -> Text -> Handler Html postSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html
postSEditR = getSEditR postSEditR = getSEditR
handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html handleSheetEdit :: TermId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
handleSheetEdit tid csh msId template dbAction = do handleSheetEdit tid csh msId template dbAction = do
let mbshn = sfName <$> template let mbshn = sfName <$> template
aid <- requireAuthId aid <- requireAuthId
@ -396,7 +399,7 @@ handleSheetEdit tid csh msId template dbAction = do
getSDelR :: TermId -> Text -> Text -> Handler Html getSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html
getSDelR tid csh shn = do getSDelR tid csh shn = do
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
case result of case result of
@ -417,7 +420,7 @@ getSDelR tid csh shn = do
setTitleI $ MsgSheetTitle tid csh shn setTitleI $ MsgSheetTitle tid csh shn
$(widgetFile "formPageI18n") $(widgetFile "formPageI18n")
postSDelR :: TermId -> Text -> Text -> Handler Html postSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html
postSDelR = getSDelR postSDelR = getSDelR
@ -505,8 +508,8 @@ correctorForm shid = do
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads' (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads'
let let
tutorField :: Field Handler [Text] tutorField :: Field Handler [UserEmail]
tutorField = multiEmailField tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
{ fieldView = \theId name attrs val isReq -> asWidgetT $ do { fieldView = \theId name attrs val isReq -> asWidgetT $ do
listIdent <- newIdent listIdent <- newIdent
userId <- handlerToWidget requireAuthId userId <- handlerToWidget requireAuthId
@ -616,10 +619,7 @@ correctorForm shid = do
-- Eingabebox für Korrektor hinzufügen -- Eingabebox für Korrektor hinzufügen
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
getSCorrR, postSCorrR :: TermId getSCorrR, postSCorrR :: TermId -> CourseShorthand -> SheetName -> Handler Html
-> Text -- ^ Course shorthand
-> Text -- ^ Sheet name
-> Handler Html
postSCorrR = getSCorrR postSCorrR = getSCorrR
getSCorrR tid csh shn = do getSCorrR tid csh shn = do
Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn

79
src/Handler/Submission.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedLists #-}
@ -56,18 +56,16 @@ import Colonnade hiding (bool, fromMaybe)
import qualified Yesod.Colonnade as Yesod import qualified Yesod.Colonnade as Yesod
import qualified Text.Blaze.Html5.Attributes as HA import qualified Text.Blaze.Html5.Attributes as HA
import Text.Shakespeare.Text (st)
numberOfSubmissionEditDates :: Int64 numberOfSubmissionEditDates :: Int64
numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production. numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [Text] -> Form (Maybe (Source Handler File), [Text]) makeSubmissionForm :: Maybe SubmissionId -> Bool -> SheetGroup -> [UserEmail] -> Form (Maybe (Source Handler File), [UserEmail])
makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ \html -> do
flip (renderAForm FormStandard) html $ (,) flip (renderAForm FormStandard) html $ (,)
<$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing <$> (bool (\f fs _ -> Just <$> areq f fs Nothing) aopt $ isJust msmid) (zipFileField unpackZips) (fsm $ bool MsgSubmissionFile MsgSubmissionArchive unpackZips) Nothing
<*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies textField (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy <*> (catMaybes <$> sequenceA [bool aforced' aopt editableBuddies (ciField textField) (fslpI (MsgSubmissionMember g) "user@campus.lmu.de" ) buddy
| g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile | g <- [1..(max groupNr $ length buddies)] -- groupNr might have decreased meanwhile
| buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies | buddy <- map (Just . Just) buddies ++ repeat Nothing -- show current buddies
]) ])
@ -80,16 +78,16 @@ makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $
aforced' f fs (Just (Just v)) = Just <$> aforced f fs v aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary" aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary"
getSubmissionNewR, postSubmissionNewR :: TermId -> Text -> Text -> Handler Html getSubmissionNewR, postSubmissionNewR :: TermId -> CourseShorthand -> SheetName -> Handler Html
getSubmissionNewR = postSubmissionNewR getSubmissionNewR = postSubmissionNewR
postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission
getSubShowR, postSubShowR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html getSubShowR, postSubShowR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getSubShowR = postSubShowR getSubShowR = postSubShowR
postSubShowR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid postSubShowR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid
getSubmissionOwnR :: TermId -> Text -> Text -> Handler Html getSubmissionOwnR :: TermId -> CourseShorthand -> SheetName -> Handler Html
getSubmissionOwnR tid csh shn = do getSubmissionOwnR tid csh shn = do
authId <- requireAuthId authId <- requireAuthId
sid <- runDB $ do sid <- runDB $ do
@ -105,7 +103,7 @@ getSubmissionOwnR tid csh shn = do
cID <- encrypt sid cID <- encrypt sid
redirect $ CSubmissionR tid csh shn cID SubShowR redirect $ CSubmissionR tid csh shn cID SubShowR
submissionHelper :: TermId -> Text -> Text -> SubmissionMode -> Handler Html submissionHelper :: TermId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
submissionHelper tid csh shn (SubmissionMode mcid) = do submissionHelper tid csh shn (SubmissionMode mcid) = do
uid <- requireAuthId uid <- requireAuthId
msmid <- traverse decrypt mcid msmid <- traverse decrypt mcid
@ -143,7 +141,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
addMessageI "info" $ MsgSubmissionAlreadyExists addMessageI "info" $ MsgSubmissionAlreadyExists
redirect $ CSubmissionR tid csh shn cID SubShowR redirect $ CSubmissionR tid csh shn cID SubShowR
(Just smid) -> do (Just smid) -> do
submissionMatchesSheet tid csh shn (fromJust mcid) void $ submissionMatchesSheet tid csh shn (fromJust mcid)
shid' <- submissionSheet <$> get404 smid shid' <- submissionSheet <$> get404 smid
-- fetch buddies from current submission -- fetch buddies from current submission
@ -169,14 +167,13 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
(FormMissing ) -> return $ FormMissing (FormMissing ) -> return $ FormMissing
(FormFailure failmsgs) -> return $ FormFailure failmsgs (FormFailure failmsgs) -> return $ FormFailure failmsgs
(FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change (FormSuccess (mFiles,[])) -> return $ FormSuccess (mFiles,[]) -- Type change
(FormSuccess (mFiles, (map CI.mk -> gEMails@(_:_)))) -- Validate AdHoc Group Members (FormSuccess (mFiles,gEMails@(_:_))) -- Validate AdHoc Group Members
| (Arbitrary {..}) <- sheetGrouping -> do | (Arbitrary {..}) <- sheetGrouping -> do
-- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for -- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
let gemails = map CI.foldedCase gEMails let prep :: [(E.Value UserEmail, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool))
prep :: [(E.Value Text, (E.Value UserId, E.Value Bool, E.Value Bool))] -> Map (CI Text) (Maybe (UserId, Bool, Bool)) prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
prep ps = Map.filter (maybe True $ \(i,_,_) -> i /= uid) . Map.fromList $ map (, Nothing) gEMails ++ [(CI.mk m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
participants <- fmap prep . E.select . E.from $ \user -> do participants <- fmap prep . E.select . E.from $ \user -> do
E.where_ $ (E.lower_ $ user E.^. UserEmail) `E.in_` E.valList gemails E.where_ $ (user E.^. UserEmail) `E.in_` E.valList gEMails
let let
isParticipant = E.sub_select . E.from $ \courseParticipant -> do isParticipant = E.sub_select . E.from $ \courseParticipant -> do
E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
@ -198,9 +195,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
let let
failmsgs = (concat :: [[Text]] -> [Text]) failmsgs = (concat :: [[Text]] -> [Text])
[ flip Map.foldMapWithKey participants $ \email -> \case [ flip Map.foldMapWithKey participants $ \email -> \case
Nothing -> pure . mr $ MsgEMailUnknown $ CI.original email Nothing -> pure . mr $ MsgEMailUnknown email
(Just (_,False,_)) -> pure . mr $ MsgNotAParticipant (CI.original email) tid csh (Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
(Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor (CI.original email) (Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email
_other -> mempty _other -> mempty
, case length participants `compare` maxParticipants of , case length participants `compare` maxParticipants of
LT -> mempty LT -> mempty
@ -309,42 +306,54 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
$(widgetFile "submission") $(widgetFile "submission")
getSubDownloadR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent getSubDownloadR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
submissionID <- decrypt cID
runDB $ do runDB $ do
submissionMatchesSheet tid csh shn cID submissionID <- submissionMatchesSheet tid csh shn cID
isRating <- maybe False (== submissionID) <$> isRatingFile path isRating <- maybe False (== submissionID) <$> isRatingFile path
when (isUpdate || isRating) $
guardAuthResult =<< evalAccessDB (CSubmissionR tid csh shn cID CorrectionR) False
case isRating of case isRating of
True -> do True
file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID) | isUpdate -> do
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
| otherwise -> notFound
False -> do False -> do
results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
E.&&. f E.^. FileTitle E.==. E.val path E.&&. f E.^. FileTitle E.==. E.val path
E.&&. E.not_ (E.isNothing $ f E.^. FileContent)
E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion) E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
-- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
return f return f
let fileName = Text.pack $ takeFileName path let fileName = Text.pack $ takeFileName path
case results of case results of
[Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName <> "; charset=utf-8") (toContent c) [Entity _ File{ fileContent = Just c, fileTitle }] -> do
_ -> notFound addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent c)
[Entity _ File{ fileContent = Nothing }] -> sendResponseStatus noContent204 ()
other -> do
$logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found."
getSubArchiveR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent getSubArchiveR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
getSubArchiveR tid csh shn cID@CryptoID{..} (ZIPArchiveName sfType) = do getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do
submissionID <- decrypt cID when (sfType == SubmissionCorrected) $
guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece cID}-#{toPathPiece sfType}.zip"|] let filename
| SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType
| otherwise = ZIPArchiveName $ toPathPiece cID
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
respondSourceDB "application/zip" $ do respondSourceDB "application/zip" $ do
lift $ submissionMatchesSheet tid csh shn cID submissionID <- lift $ submissionMatchesSheet tid csh shn cID
rating <- lift $ getRating submissionID rating <- lift $ getRating submissionID
let let
@ -361,6 +370,6 @@ getSubArchiveR tid csh shn cID@CryptoID{..} (ZIPArchiveName sfType) = do
when (sfType == SubmissionCorrected) $ when (sfType == SubmissionCorrected) $
maybe (return ()) (yieldM . ratingFile cID) rating maybe (return ()) (yieldM . ratingFile cID) rating
zipComment = Text.encodeUtf8 . pack $ CI.foldedCase ciphertext zipComment = Text.encodeUtf8 $ toPathPiece cID
fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder

2
src/Handler/Term.hs
View File

@ -44,7 +44,7 @@ getTermShowR = do
let colonnadeTerms = widgetColonnade $ mconcat let colonnadeTerms = widgetColonnade $ mconcat
[ sortable Nothing "Kürzel" $ [ sortable Nothing "Kürzel" $
anchorCell' (\(Entity tid _, _) -> TermCourseListR tid) anchorCell' (\(Entity tid _, _) -> TermCourseListR tid)
(\(Entity tid _, _) -> [whamlet|#{display tid}|]) (\(Entity tid _, _) -> [whamlet|#{toPathPiece tid}|])
, sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) -> , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
cell $ formatTime SelFormatDate termLectureStart >>= toWidget cell $ formatTime SelFormatDate termLectureStart >>= toWidget
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) -> , sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->

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

@ -23,6 +23,9 @@ import Import
import qualified Data.Char as Char import qualified Data.Char as Char
import Data.String (IsString(..)) import Data.String (IsString(..))
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import qualified Data.Foldable as Foldable import qualified Data.Foldable as Foldable
-- import Yesod.Core -- import Yesod.Core
@ -263,6 +266,8 @@ buttonForm csrf = do
-- Fields -- -- Fields --
------------ ------------
ciField :: (Functor m, CI.FoldCase a) => Field m a -> Field m (CI a)
ciField = convertField CI.mk CI.original
natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
natFieldI msg = checkBool (>= 0) msg intField natFieldI msg = checkBool (>= 0) msg intField

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

@ -66,8 +66,8 @@ instance Pretty x => Pretty (CI x) where
data Rating = Rating data Rating = Rating
{ ratingCourseName :: Text { ratingCourseName :: CourseName
, ratingSheetName :: Text , ratingSheetName :: SheetName
, ratingCorrectorName :: Maybe Text , ratingCorrectorName :: Maybe Text
, ratingSheetType :: SheetType , ratingSheetType :: SheetType
, ratingValues :: Rating' , ratingValues :: Rating'
@ -133,7 +133,7 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
, ("Korrektor:" <+>) . pretty <$> ratingCorrectorName , ("Korrektor:" <+>) . pretty <$> ratingCorrectorName
, Just $ "Bewertung:" <+> pretty (display ratingSheetType) , Just $ "Bewertung:" <+> pretty (display ratingSheetType)
] ]
, "Abgabe-Id:" <+> pretty (ciphertext cID) , "Abgabe-Id:" <+> pretty (Text.unpack $ toPathPiece cID)
, "=============================================" , "============================================="
, "Bewertung:" <+> pretty ratingPoints , "Bewertung:" <+> pretty ratingPoints
, "=========== Beginn der Kommentare ===========" , "=========== Beginn der Kommentare ==========="
@ -145,7 +145,7 @@ ratingFile :: MonadIO m => CryptoFileNameSubmission -> Rating -> m File
ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do
fileModified <- maybe (liftIO getCurrentTime) return ratingTime fileModified <- maybe (liftIO getCurrentTime) return ratingTime
let let
fileTitle = "bewertung_" <> (CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)) <.> "txt" fileTitle = "bewertung_" <> (Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)) <.> "txt"
fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating fileContent = Just . Lazy.ByteString.toStrict $ formatRating cID rating
return File{..} return File{..}
@ -212,7 +212,8 @@ isRatingFile fName
isRatingFile' :: FilePath -> Maybe CryptoFileNameSubmission isRatingFile' :: FilePath -> Maybe CryptoFileNameSubmission
isRatingFile' (takeFileName -> fName) isRatingFile' (takeFileName -> fName)
| (bName, ".txt") <- splitExtension fName | (bName, ".txt") <- splitExtension fName
, Just (CI.mk -> ciphertext) <- stripPrefix "bewertung_" bName , Just piece <- stripPrefix "bewertung_" bName
= Just CryptoID{..} , Just cID <- fromPathPiece $ Text.pack piece
= Just cID
| otherwise | otherwise
= Nothing = Nothing

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

@ -24,7 +24,7 @@ fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
, PersistQueryRead backend, PersistUniqueRead backend , PersistQueryRead backend, PersistUniqueRead backend
) )
=> (E.SqlExpr (Entity Sheet) -> b) => (E.SqlExpr (Entity Sheet) -> b)
-> TermId -> Text -> Text -> ReaderT backend m a -> TermId -> CourseShorthand -> SheetName -> ReaderT backend m a
fetchSheetAux prj tid csh shn = fetchSheetAux prj tid csh shn =
let cachId = encodeUtf8 $ tshow (tid,csh,shn) let cachId = encodeUtf8 $ tshow (tid,csh,shn)
in cachedBy cachId $ do in cachedBy cachId $ do
@ -42,11 +42,11 @@ fetchSheetAux prj tid csh shn =
[sheet] -> return sheet [sheet] -> return sheet
_other -> notFound _other -> notFound
fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet) fetchSheet :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet)
fetchSheet = fetchSheetAux id fetchSheet = fetchSheetAux id
fetchSheetId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet) fetchSheetId :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet)
fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn
fetchSheetIdCourseId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet, Key Course) fetchSheetIdCourseId :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
fetchSheetIdCourseId tid cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid cid shn fetchSheetIdCourseId tid cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid cid shn

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

@ -10,6 +10,7 @@
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
module Handler.Utils.Submission module Handler.Utils.Submission
@ -43,6 +44,8 @@ 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 qualified Data.Text as Text
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
@ -159,7 +162,7 @@ submissionMultiArchive (Set.toList -> ids) = do
cID <- encrypt submissionID cID <- encrypt submissionID
let let
directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission) directoryName = Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)
fileEntitySource = do fileEntitySource = do
submissionFileSource submissionID =$= Conduit.map entityVal submissionFileSource submissionID =$= Conduit.map entityVal
@ -463,11 +466,7 @@ sinkMultiSubmission userId isUpdate = do
Submission{..} <- get404 sId Submission{..} <- get404 sId
Sheet{..} <- get404 submissionSheet Sheet{..} <- get404 submissionSheet
Course{..} <- get404 sheetCourse Course{..} <- get404 sheetCourse
authRes <- evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True
case authRes of
AuthenticationRequired -> notAuthenticated
Unauthorized t -> permissionDenied t
Authorized -> return ()
return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate
sink' <- lift $ yield val ++$$ sink sink' <- lift $ yield val ++$$ sink
case sink' of case sink' of
@ -484,9 +483,11 @@ sinkMultiSubmission userId isUpdate = do
acc (Just sId, fp) segment = return (Just sId, fp ++ [segment]) acc (Just sId, fp) segment = return (Just sId, fp ++ [segment])
acc (Nothing , fp) segment = do acc (Nothing , fp) segment = do
let let
tryDecrypt ciphertext = do tryDecrypt (Text.pack -> ciphertext)
sId <- decrypt (CryptoID (CI.mk segment) :: CryptoFileNameSubmission) | Just cID <- fromPathPiece ciphertext = do
Just sId <$ get404 sId sId <- decrypt (cID :: CryptoFileNameSubmission)
Just sId <$ get404 sId
| otherwise = return Nothing
msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ] msId <- lift (lift $ tryDecrypt segment) `catches` [ E.Handler handleCryptoID, E.Handler (handleHCError $ Right fileTitle) ]
return (msId, fp) return (msId, fp)
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
@ -513,9 +514,10 @@ sinkMultiSubmission userId isUpdate = do
handleCryptoID _ = return Nothing handleCryptoID _ = return Nothing
submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB () submissionMatchesSheet :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId
submissionMatchesSheet tid csh shn cid = do submissionMatchesSheet tid csh shn cid = do
sid <- decrypt cid sid <- decrypt cid
shid <- fetchSheetId tid csh shn shid <- fetchSheetId tid csh shn
Submission{..} <- get404 sid Submission{..} <- get404 sid
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet] when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
return sid

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

@ -24,6 +24,7 @@ module Handler.Utils.Table.Pagination
, DBRow(..) , DBRow(..)
, DBStyle(..), DBEmptyStyle(..) , DBStyle(..), DBEmptyStyle(..)
, DBTable(..), IsDBTable(..), DBCell(..) , DBTable(..), IsDBTable(..), DBCell(..)
, cellAttrs, cellContents
, PaginationSettings(..), PaginationInput(..), piIsUnset , PaginationSettings(..), PaginationInput(..), piIsUnset
, PSValidator(..) , PSValidator(..)
, defaultFilter, defaultSorting , defaultFilter, defaultSorting
@ -31,10 +32,13 @@ module Handler.Utils.Table.Pagination
, ToSortable(..), Sortable(..), sortable , ToSortable(..), Sortable(..), sortable
, dbTable , dbTable
, widgetColonnade, formColonnade, dbColonnade , widgetColonnade, formColonnade, dbColonnade
, textCell, stringCell, i18nCell, anchorCell, anchorCell', anchorCellM , cell, textCell, stringCell, i18nCell
, anchorCell, anchorCell', anchorCellM
, listCell
, formCell, DBFormResult, getDBFormResult , formCell, DBFormResult, getDBFormResult
, dbRow, dbSelect , dbRow, dbSelect
, (&) , (&)
, module Control.Monad.Trans.Maybe
) where ) where
import Handler.Utils.Table.Pagination.Types import Handler.Utils.Table.Pagination.Types
@ -59,6 +63,8 @@ import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_)
import Control.Monad.Reader (ReaderT(..), mapReaderT) import Control.Monad.Reader (ReaderT(..), mapReaderT)
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Data.Foldable (Foldable(foldMap))
import Data.Map (Map, (!)) import Data.Map (Map, (!))
import qualified Data.Map as Map import qualified Data.Map as Map
@ -123,6 +129,15 @@ data DBRow r = DBRow
, dbrIndex, dbrCount :: Int64 , dbrIndex, dbrCount :: Int64
} deriving (Show, Read, Eq, Ord) } deriving (Show, Read, Eq, Ord)
instance Functor DBRow where
fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. }
instance Foldable DBRow where
foldMap f DBRow{..} = f dbrOutput
instance Traversable DBRow where
traverse f DBRow{..} = DBRow <$> f dbrOutput <*> pure dbrIndex <*> pure dbrCount
data DBEmptyStyle = DBESNoHeading | DBESHeading data DBEmptyStyle = DBESNoHeading | DBESHeading
deriving (Enum, Bounded, Ord, Eq, Show, Read) deriving (Enum, Bounded, Ord, Eq, Show, Read)
@ -238,16 +253,19 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *)
-- type DBResult' m x :: * -- type DBResult' m x :: *
data DBCell m x :: * data DBCell m x :: *
cellAttrs :: Lens' (DBCell m x) [(Text, Text)] dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
cellContents :: DBCell m x -> WriterT x m Widget
cell :: Widget -> DBCell m x
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x) -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget
dbHandler :: forall m'. (MonadHandler m' , HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x) dbHandler :: forall m'. (MonadHandler m' , HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x)
runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x) runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x)
cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)]
cellAttrs = dbCell . _1
cellContents :: IsDBTable m x => Lens' (DBCell m x) (WriterT x m Widget)
cellContents = dbCell . _2
instance IsDBTable (WidgetT UniWorX IO) () where instance IsDBTable (WidgetT UniWorX IO) () where
type DBResult (WidgetT UniWorX IO) () = Widget type DBResult (WidgetT UniWorX IO) () = Widget
-- type DBResult' (WidgetT UniWorX IO) () = () -- type DBResult' (WidgetT UniWorX IO) () = ()
@ -256,10 +274,10 @@ instance IsDBTable (WidgetT UniWorX IO) () where
{ wgtCellAttrs :: [(Text, Text)] { wgtCellAttrs :: [(Text, Text)]
, wgtCellContents :: Widget , wgtCellContents :: Widget
} }
cellAttrs = lens wgtCellAttrs $ \w as -> w { wgtCellAttrs = as }
cellContents = return . wgtCellContents
cell = WidgetCell [] dbCell = iso
(\WidgetCell{..} -> (wgtCellAttrs, return wgtCellContents))
(\(attrs, mkWidget) -> WidgetCell attrs . join . fmap fst $ runWriterT mkWidget)
-- dbWidget Proxy Proxy = iso (, ()) $ view _1 -- dbWidget Proxy Proxy = iso (, ()) $ view _1
dbWidget _ = return dbWidget _ = return
@ -278,10 +296,9 @@ instance IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) () where
, dbCellContents :: ReaderT SqlBackend (HandlerT UniWorX IO) Widget , dbCellContents :: ReaderT SqlBackend (HandlerT UniWorX IO) Widget
} }
cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as } dbCell = iso
cellContents = lift . dbCellContents (\DBCell{..} -> (dbCellAttrs, lift dbCellContents))
(\(attrs, mkWidget) -> DBCell attrs . fmap fst $ runWriterT mkWidget)
cell = DBCell [] . return
dbWidget _ = return dbWidget _ = return
dbHandler _ f x = return $ f x dbHandler _ f x = return $ f x
@ -301,10 +318,13 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
{ formCellAttrs :: [(Text, Text)] { formCellAttrs :: [(Text, Text)]
, formCellContents :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) , formCellContents :: MForm (HandlerT UniWorX IO) (FormResult a, Widget)
} }
cellAttrs = lens formCellAttrs $ \w as -> w { formCellAttrs = as }
cellContents = WriterT . fmap swap . formCellContents
cell widget = FormCell [] $ return (mempty, widget) -- dbCell :: Iso'
-- (DBCell (RWST ... ... ... (HandlerT UniWorX IO)) (FormResult a))
-- ([(Text, Text)], WriterT (FormResult a) (RWST ... ... ... (HandlerT UniWorX IO)) Widget)
dbCell = iso
(\FormCell{..} -> (formCellAttrs, WriterT $ fmap swap formCellContents))
(\(attrs, mkWidget) -> FormCell attrs . fmap swap $ runWriterT mkWidget)
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2)) -- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2)) -- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
@ -393,7 +413,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
widget <- cellContents sortableContent widget <- sortableContent ^. cellContents
let let
directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ] directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
isSortable = isJust sortableKey isSortable = isJust sortableKey
@ -407,7 +427,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do
widget <- cellContents cell widget <- cell ^. cellContents
let attrs = cell ^. cellAttrs let attrs = cell ^. cellAttrs
return $(widgetFile "table/cell/body") return $(widgetFile "table/cell/body")
@ -444,6 +464,9 @@ dbColonnade :: Headedness h
-> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ()) -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ())
dbColonnade = id dbColonnade = id
cell :: IsDBTable m a => Widget -> DBCell m a
cell wgt = dbCell # ([], return wgt)
textCell, stringCell, i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a textCell, stringCell, i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
stringCell = textCell stringCell = textCell
i18nCell = textCell i18nCell = textCell
@ -467,6 +490,12 @@ anchorCellM routeM widget = cell $ do
| Authorized <- authResult -> $(widgetFile "table/cell/link") | Authorized <- authResult -> $(widgetFile "table/cell/link")
| otherwise -> widget | otherwise -> widget
listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a
listCell xs mkCell = review dbCell . ([], ) $ do
cells <- forM xs $
\(view dbCell . mkCell -> (attrs, mkWidget)) -> (attrs, ) <$> mkWidget
return $(widgetFile "table/cell/list")
newtype DBFormResult r i a = DBFormResult (Map i (r, a -> a)) newtype DBFormResult r i a = DBFormResult (Map i (r, a -> a))
instance Ord i => Monoid (DBFormResult r i a) where instance Ord i => Monoid (DBFormResult r i a) where

2
src/Import/NoFoundation.hs
View File

@ -19,3 +19,5 @@ import CryptoID as Import
import Data.UUID as Import (UUID) import Data.UUID as Import (UUID)
import Text.Lucius as Import import Text.Lucius as Import
import Text.Shakespeare.Text as Import hiding (text, stext)

15
src/Model.hs
View File

@ -7,6 +7,7 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-}
module Model module Model
( module Model ( module Model
, module Model.Types , module Model.Types
@ -14,20 +15,32 @@ module Model
import ClassyPrelude.Yesod import ClassyPrelude.Yesod
import Database.Persist.Quasi import Database.Persist.Quasi
import Database.Persist.Postgresql (migrateEnableExtension)
import Database.Persist.Sql (Migration)
-- import Data.Time -- import Data.Time
-- import Data.ByteString -- import Data.ByteString
import Model.Types import Model.Types
import Data.Aeson.TH import Data.Aeson.TH
import Data.CaseInsensitive (CI)
-- You can define all of your database entities in the entities file. -- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities -- You can find more information on persistent and how to declare entities
-- at: -- at:
-- http://www.yesodweb.com/book/persistent/ -- http://www.yesodweb.com/book/persistent/
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"] share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'"]
$(persistFileWith lowerCaseSettings "models") $(persistFileWith lowerCaseSettings "models")
migrateAll :: Migration
migrateAll = do
migrateEnableExtension "citext"
migrateAll'
data PWEntry = PWEntry data PWEntry = PWEntry
{ pwUser :: User { pwUser :: User
, pwHash :: Text , pwHash :: Text
} deriving (Show) } deriving (Show)
$(deriveJSON defaultOptions ''PWEntry) $(deriveJSON defaultOptions ''PWEntry)
submissionRatingDone :: Submission -> Bool
submissionRatingDone Submission{..} = isJust submissionRatingPoints

97
src/Model/Types.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternGuards #-} {-# LANGUAGE PatternGuards #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
@ -7,14 +8,18 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-- # LANGUAGE ExistentialQuantification #-} -- for DA type {-- # LANGUAGE ExistentialQuantification #-} -- for DA type
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Model.Types where module Model.Types where
import ClassyPrelude import ClassyPrelude
import Utils import Utils
import Control.Lens
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Fixed import Data.Fixed
import Database.Persist.TH import Database.Persist.TH
@ -25,10 +30,11 @@ import Web.HttpApiData
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Text.Read (readMaybe,readsPrec) import Text.Read (readMaybe,readsPrec)
-- import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Yesod.Core.Dispatch (PathPiece(..)) import Yesod.Core.Dispatch (PathPiece(..))
@ -38,6 +44,10 @@ import Data.Aeson.TH (deriveJSON, defaultOptions)
import GHC.Generics (Generic) import GHC.Generics (Generic)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Text.Shakespeare.I18N (ToMessage(..), RenderMessage(..))
import Text.Blaze (ToMarkup(..))
import Yesod.Core.Widget (ToWidget(..))
type Points = Centi type Points = Centi
@ -95,6 +105,23 @@ instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instan
display SheetSolution = "Musterlösung" display SheetSolution = "Musterlösung"
display SheetMarking = "Korrekturhinweise" display SheetMarking = "Korrekturhinweise"
-- partitionFileType' :: Ord a => [(SheetFileType,a)] -> Map SheetFileType (Set a)
-- partitionFileType' = groupMap
partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a
partitionFileType fts =
let (se,sh,ss,sm) = foldl' switchft (Set.empty,Set.empty,Set.empty,Set.empty) fts
in \case SheetExercise -> se
SheetHint -> sh
SheetSolution -> ss
SheetMarking -> sm
where
switchft :: Ord a => (Set a, Set a, Set a, Set a) -> (SheetFileType,a) -> (Set a, Set a, Set a, Set a)
switchft (se,sh,ss,sm) (SheetExercise,x) = (Set.insert x se, sh, ss, sm)
switchft (se,sh,ss,sm) (SheetHint ,x) = (se, Set.insert x sh, ss, sm)
switchft (se,sh,ss,sm) (SheetSolution,x) = (se, sh, Set.insert x ss, sm)
switchft (se,sh,ss,sm) (SheetMarking ,x) = (se, sh, ss, Set.insert x sm)
data SubmissionFileType = SubmissionOriginal | SubmissionCorrected data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
deriving (Show, Read, Eq, Ord, Enum, Bounded) deriving (Show, Read, Eq, Ord, Enum, Bounded)
@ -178,17 +205,35 @@ data TermIdentifier = TermIdentifier
-- from_TermId_to_TermIdentifier = unTermKey -- from_TermId_to_TermIdentifier = unTermKey
-- from_TermIdentifier_to_TermId = TermKey -- from_TermIdentifier_to_TermId = TermKey
instance DisplayAble TermIdentifier where shortened :: Iso' Integer Integer
display = termToText shortened = iso shorten expand
where
century = ($currentYear `div` 100) * 100
expand year
| 0 <= year
, year < 100 = let
options = [ expanded | offset <- [-1, 0, 1]
, let century' = century + offset * 100
expanded = century' + year
, $currentYear - 50 <= expanded
, expanded < $currentYear + 50
]
in case options of
[unique] -> unique
failed -> error $ "Could not expand year " ++ show year ++ ": " ++ show failed
| otherwise = year
shorten year
| $currentYear - 50 <= year
, year < $currentYear + 50 = year `mod` 100
| otherwise = year
--TODO: Enforce the number of digits within year, with parsing filling in the current leading digits? Goal: short urls
termToText :: TermIdentifier -> Text termToText :: TermIdentifier -> Text
termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show year termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)
termFromText :: Text -> Either Text TermIdentifier termFromText :: Text -> Either Text TermIdentifier
termFromText t termFromText t
| (s:ys) <- Text.unpack t | (s:ys) <- Text.unpack t
, Just year <- readMaybe ys , Just (review shortened -> year) <- readMaybe ys
, Right season <- seasonFromChar s , Right season <- seasonFromChar s
= Right TermIdentifier{..} = Right TermIdentifier{..}
| otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”"
@ -297,3 +342,43 @@ newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
deriving (Eq, Ord, Read, Show, Enum, Bounded) deriving (Eq, Ord, Read, Show, Enum, Bounded)
instance PersistField (CI Text) where
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 $ CI.original ciText
fromPersistValue (PersistDbSpecific bs) = Right . CI.mk $ Text.decodeUtf8 bs
fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
instance PersistField (CI String) where
toPersistValue ciText = PersistDbSpecific . Text.encodeUtf8 . pack $ CI.original ciText
fromPersistValue (PersistDbSpecific bs) = Right . CI.mk . unpack $ Text.decodeUtf8 bs
fromPersistValue x = Left . pack $ "Expected PersistDbSpecific, received: " ++ show x
instance PersistFieldSql (CI Text) where
sqlType _ = SqlOther "citext"
instance ToJSON a => ToJSON (CI a) where
toJSON = toJSON . CI.original
instance (FromJSON a, CI.FoldCase a) => FromJSON (CI a) where
parseJSON = fmap CI.mk . parseJSON
instance ToMessage a => ToMessage (CI a) where
toMessage = toMessage . CI.original
instance ToMarkup a => ToMarkup (CI a) where
toMarkup = toMarkup . CI.original
preEscapedToMarkup = preEscapedToMarkup . CI.original
instance ToWidget site a => ToWidget site (CI a) where
toWidget = toWidget . CI.original
instance RenderMessage site a => RenderMessage site (CI a) where
renderMessage f ls msg = renderMessage f ls $ CI.original msg
-- Type synonyms
type SheetName = CI Text
type CourseShorthand = CI Text
type CourseName = CI Text
type UserEmail = CI Text

63
src/Utils.hs
View File

@ -4,7 +4,8 @@
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, UndecidableInstances #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult {-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult
module Utils module Utils
@ -17,14 +18,19 @@ import Data.List (foldl)
import Data.Foldable as Fold import Data.Foldable as Fold
import qualified Data.Char as Char import qualified Data.Char as Char
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Utils.DB as Utils import Utils.DB as Utils
import Utils.Common as Utils import Utils.Common as Utils
import Utils.DateTime as Utils import Utils.DateTime as Utils
import Text.Blaze (Markup, ToMarkup) import Text.Blaze (Markup, ToMarkup)
-- import Data.Map (Map) import Data.Set (Set)
-- import qualified Data.Map as Map import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
-- import qualified Data.List as List -- import qualified Data.List as List
import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT) import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT)
@ -34,6 +40,11 @@ import Control.Monad.Catch
import qualified Database.Esqueleto as E (Value, unValue) import qualified Database.Esqueleto as E (Value, unValue)
import Language.Haskell.TH
import Instances.TH.Lift ()
import Text.Shakespeare.Text (st)
----------- -----------
-- Yesod -- -- Yesod --
----------- -----------
@ -51,6 +62,22 @@ instance Monad FormResult where
(FormFailure errs) >>= _ = FormFailure errs (FormFailure errs) >>= _ = FormFailure errs
(FormSuccess a) >>= f = f a (FormSuccess a) >>= f = f a
guardAuthResult :: MonadHandler m => AuthResult -> m ()
guardAuthResult AuthenticationRequired = notAuthenticated
guardAuthResult (Unauthorized t) = permissionDenied t
guardAuthResult Authorized = return ()
data UnsupportedAuthPredicate route = UnsupportedAuthPredicate String route
deriving (Eq, Ord, Typeable, Show)
instance (Show route, Typeable route) => Exception (UnsupportedAuthPredicate route)
unsupportedAuthPredicate :: ExpQ
unsupportedAuthPredicate = do
logFunc <- logErrorS
[e| \tag route -> do
$(return logFunc) "AccessControl" [st|"!#{tag}" used on route that doesn't support it: #{tshow route}|]
unauthorizedI (UnsupportedAuthPredicate tag route)
|]
--------------------- ---------------------
@ -116,6 +143,9 @@ instance DisplayAble a => DisplayAble (Maybe a) where
instance DisplayAble a => DisplayAble (E.Value a) where instance DisplayAble a => DisplayAble (E.Value a) where
display = display . E.unValue display = display . E.unValue
instance DisplayAble a => DisplayAble (CI a) where
display = display . CI.original
-- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated) -- The easy way out of UndecidableInstances (TypeFamilies would have been proper, but are much more complicated)
instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where
display = pack . show display = pack . show
@ -144,11 +174,38 @@ trd3 (_,_,z) = z
-- notNull = not . null -- notNull = not . null
mergeAttrs :: [(Text, Text)] -> [(Text, Text)] -> [(Text, Text)]
mergeAttrs = mergeAttrs' `on` sort
where
special = [ ("class", \v1 v2 -> v1 <> " " <> v2)
]
mergeAttrs' (x1@(n1, v1):xs1) (x2@(n2, v2):xs2)
| Just merge <- lookup n1 special
, n2 == n1
= mergeAttrs' ((n1, merge v1 v2) : xs1) xs2
| Just _ <- lookup n1 special
, n1 < n2
= x2 : mergeAttrs' (x1:xs1) xs2
| otherwise = x1 : mergeAttrs' xs1 (x2:xs2)
mergeAttrs' [] xs2 = xs2
mergeAttrs' xs1 [] = xs1
---------- ----------
-- Maps -- -- Maps --
---------- ----------
infixl 5 !!!
(!!!) :: (Ord k, Monoid v) => Map k v -> k -> v
(!!!) m k = (fromMaybe mempty) $ Map.lookup k m
groupMap :: (Ord k, Ord v) => [(k,v)] -> Map k (Set v)
groupMap l = Map.fromListWith mappend $ [(k, Set.singleton v) | (k,v) <- l]
partMap :: (Ord k, Monoid v) => [(k,v)] -> Map k v
partMap = Map.fromListWith mappend
----------- -----------
-- Maybe -- -- Maybe --

7
src/Utils/DateTime.hs
View File

@ -9,6 +9,7 @@
module Utils.DateTime module Utils.DateTime
( timeLocaleMap ( timeLocaleMap
, TimeLocale(..) , TimeLocale(..)
, currentYear
, module Data.Time.Zones , module Data.Time.Zones
, module Data.Time.Zones.TH , module Data.Time.Zones.TH
) where ) where
@ -55,3 +56,9 @@ timeLocaleMap extra@((_, defLocale):_) = do
localeExp = lift <=< runIO . getLocale . Just localeExp = lift <=< runIO . getLocale . Just
letE [localeMap'] (varE localeMap) letE [localeMap'] (varE localeMap)
currentYear :: ExpQ
currentYear = do
now <- runIO getCurrentTime
let (year, _, _) = toGregorian $ utctDay now
[e|year|]

4
templates/default-layout.lucius
View File

@ -428,10 +428,10 @@ input[type="button"].btn-info:hover,
display: inline-block; display: inline-block;
} }
.list--comma-separated > li { .list--comma-separated li {
&::after { &::after {
content: ', '; content: ', ';
white-space: pre;
} }
&:last-of-type::after { &:last-of-type::after {

3
templates/table/cell/body.hamlet
View File

@ -1,3 +1,4 @@
<td .table__td *{attrs}> $newline never
<td *{mergeAttrs attrs [("class", "table__td")]}>
<div .table__td-content> <div .table__td-content>
^{widget} ^{widget}

1
templates/table/cell/link.hamlet
View File

@ -1,2 +1,3 @@
$newline never
<a href=@{route}> <a href=@{route}>
^{widget} ^{widget}

5
templates/table/cell/list.hamlet Normal file
View File

@ -0,0 +1,5 @@
$newline never
<ul>
$forall (attrs, widget) <- cells
<li *{attrs}>
^{widget}