Merge branch 'master' into 'live'
Deploy master Closes #96, #128, #129, and #130 See merge request !62
This commit is contained in:
Steffen Jost
commit
a2df941fbc
@ -12,7 +12,7 @@ DeRegUntil: Abmeldungen bis
|
||||
SummerTerm year@Integer: Sommersemester #{display year}
|
||||
WinterTerm year@Integer: Wintersemester #{display year}/#{display $ succ 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
|
||||
Page n@Int64: #{display n}
|
||||
|
||||
@ -34,29 +34,29 @@ CourseRegisterOk: Sie wurden angemeldet
|
||||
CourseDeregisterOk: Sie wurden abgemeldet
|
||||
CourseSecretWrong: Falsches Kennwort
|
||||
CourseSecret: Zugangspasswort
|
||||
CourseNewOk tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt.
|
||||
CourseEditOk tid@TermId courseShortHand@Text: 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.
|
||||
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.
|
||||
CourseNewOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt.
|
||||
CourseEditOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich geändert.
|
||||
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@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
|
||||
TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
|
||||
TermCourseListTitle tid@TermId: Kurse #{display tid}
|
||||
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
|
||||
|
||||
Sheet: Blatt
|
||||
SheetList tid@TermId courseShortHand@Text: #{display tid}-#{courseShortHand} Übersicht Übungsblätter
|
||||
SheetNewHeading tid@TermId courseShortHand@Text: #{display tid}-#{courseShortHand} Neues Übungsblatt anlegen
|
||||
SheetNewOk tid@TermId courseShortHand@Text sheetName@Text: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{courseShortHand} erfolgreich erstellt.
|
||||
SheetTitle tid@TermId courseShortHand@Text sheetName@Text: #{display tid}-#{courseShortHand} #{sheetName}
|
||||
SheetTitleNew tid@TermId courseShortHand@Text : #{display tid}-#{courseShortHand}: Neues Übungsblatt
|
||||
SheetEditHead tid@TermId courseShortHand@Text sheetName@Text: #{display tid}-#{courseShortHand} #{sheetName} editieren
|
||||
SheetEditOk tid@TermId courseShortHand@Text sheetName@Text: Ü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}.
|
||||
SheetDelHead tid@TermId courseShortHand@Text sheetName@Text: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{courseShortHand} herauslöschen?
|
||||
SheetList tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Übersicht Übungsblätter
|
||||
SheetNewHeading tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Neues Übungsblatt anlegen
|
||||
SheetNewOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{courseShortHand} erfolgreich erstellt.
|
||||
SheetTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName}
|
||||
SheetTitleNew tid@TermId courseShortHand@CourseShorthand : #{display tid}-#{courseShortHand}: Neues Übungsblatt
|
||||
SheetEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName} editieren
|
||||
SheetEditOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{courseShortHand} wurde gespeichert.
|
||||
SheetNameDup tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{courseShortHand}.
|
||||
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.
|
||||
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
|
||||
SheetHint: Hinweis
|
||||
@ -80,21 +80,21 @@ Deadline: Abgabe
|
||||
Done: Eingereicht
|
||||
|
||||
Submission: Abgabenummer
|
||||
SubmissionsCourse tid@TermId courseShortHand@Text: Alle Abgaben Kurs #{display tid}-#{courseShortHand}
|
||||
SubmissionsSheet sheetName@Text: Abgaben für Blatt #{sheetName}
|
||||
SubmissionsCourse tid@TermId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{courseShortHand}
|
||||
SubmissionsSheet sheetName@SheetName: Abgaben für Blatt #{sheetName}
|
||||
SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
|
||||
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
|
||||
SubmissionEditHead tid@TermId courseShortHand@Text sheetName@Text: #{display tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
|
||||
CorrectionHead tid@TermId courseShortHand@Text sheetName@Text cid@CryptoFileNameSubmission: #{display tid}-#{courseShortHand} #{sheetName}: Korrektur
|
||||
SubmissionEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
|
||||
CorrectionHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{courseShortHand} #{sheetName}: Korrektur
|
||||
SubmissionMember g@Int: Mitabgebende(r) ##{display g}
|
||||
SubmissionArchive: Zip-Archiv der Abgabedatei(en)
|
||||
SubmissionFile: Datei zur Abgabe
|
||||
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
|
||||
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.
|
||||
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.
|
||||
UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
|
||||
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.
|
||||
OnlyUploadOneFile: Bitte nur eine Datei hochladen.
|
||||
DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
|
||||
UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben.
|
||||
MaterialFree: Kursmaterialien ohne Anmeldung zugänglich
|
||||
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
|
||||
EMailUnknown email@Text: 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.
|
||||
EMailUnknown email@UserEmail: E-Mail #{email} gehört zu keinem bekannten Benutzer.
|
||||
NotAParticipant email@UserEmail tid@TermId csh@CourseShorthand: #{email} ist nicht im Kurs #{display tid}-#{csh} angemeldet.
|
||||
TooManyParticipants: Es wurden zu viele Mitabgebende angegeben
|
||||
|
||||
AddCorrector: Zusätzlicher Korrektor
|
||||
CorrectorExists user@Text: #{user} ist bereits als Korrektor eingetragen
|
||||
SheetCorrectorsTitle tid@TermId courseShortHand@Text sheetName@Text: Korrektoren für #{display tid}-#{courseShortHand} #{sheetName}
|
||||
CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
|
||||
SheetCorrectorsTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{courseShortHand} #{sheetName}
|
||||
CountTutProp: Tutorien zählen gegen Proportion
|
||||
Corrector: Korrektor
|
||||
Correctors: Korrektoren
|
||||
@ -187,6 +189,7 @@ Passed: Bestanden
|
||||
NotPassed: Nicht bestanden
|
||||
RatingTime: Korrigiert
|
||||
RatingComment: Kommentar
|
||||
SubmissionUsers: Studenten
|
||||
|
||||
RatingPoints: Punkte
|
||||
RatingFiles: Korrigierte Dateien
|
||||
|
||||
15
models
15
models
@ -2,7 +2,7 @@ User json
|
||||
plugin Text
|
||||
ident Text
|
||||
matrikelnummer Text Maybe
|
||||
email Text
|
||||
email (CI Text)
|
||||
displayName Text
|
||||
maxFavourites Int default=12
|
||||
theme Theme default='Default'
|
||||
@ -48,9 +48,10 @@ Term json
|
||||
Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
|
||||
deriving Show -- type TermId = Key Term
|
||||
School json
|
||||
name Text
|
||||
shorthand Text
|
||||
name (CI Text)
|
||||
shorthand (CI Text)
|
||||
UniqueSchool name
|
||||
UniqueSchoolShorthand shorthand
|
||||
deriving Eq
|
||||
DegreeCourse json
|
||||
course CourseId
|
||||
@ -58,10 +59,10 @@ DegreeCourse json
|
||||
terms StudyTermsId
|
||||
UniqueDegreeCourse course degree terms
|
||||
Course
|
||||
name Text
|
||||
name (CI Text)
|
||||
description Html Maybe
|
||||
linkExternal Text Maybe
|
||||
shorthand Text
|
||||
shorthand (CI Text)
|
||||
term TermId
|
||||
school SchoolId
|
||||
capacity Int64 Maybe
|
||||
@ -72,6 +73,7 @@ Course
|
||||
registerSecret Text Maybe -- Falls ein Passwort erforderlich ist
|
||||
materialFree Bool
|
||||
CourseTermShort term shorthand
|
||||
CourseTermName term name
|
||||
CourseEdit
|
||||
user UserId
|
||||
time UTCTime
|
||||
@ -81,6 +83,7 @@ CourseFavourite
|
||||
time UTCTime
|
||||
course CourseId
|
||||
UniqueCourseFavourite user course
|
||||
deriving Show
|
||||
Lecturer
|
||||
user UserId
|
||||
course CourseId
|
||||
@ -92,7 +95,7 @@ CourseParticipant
|
||||
UniqueParticipant user course
|
||||
Sheet
|
||||
course CourseId
|
||||
name Text
|
||||
name (CI Text)
|
||||
description Html Maybe
|
||||
type SheetType
|
||||
grouping SheetGroup
|
||||
|
||||
6
routes
6
routes
@ -50,14 +50,14 @@
|
||||
-- For Pattern Synonyms see Foundation
|
||||
/course/ CourseListR GET !free
|
||||
!/course/new CourseNewR GET POST !lecturer
|
||||
/course/#TermId/#Text CourseR !lecturer:
|
||||
/course/#TermId/#CourseShorthand CourseR !lecturer:
|
||||
/ CShowR GET !free
|
||||
/register CRegisterR POST !timeANDcapacity
|
||||
/edit CEditR GET POST
|
||||
/subs CCorrectionsR GET POST
|
||||
/ex SheetListR GET !registered !materials
|
||||
!/ex/new SheetNewR GET POST
|
||||
/ex/#Text SheetR:
|
||||
/ex/#SheetName SheetR:
|
||||
/ SShowR GET !timeANDregistered !timeANDmaterials !corrector
|
||||
/edit SEditR GET POST
|
||||
/delete SDelR GET POST
|
||||
@ -67,7 +67,7 @@
|
||||
/sub/#CryptoFileNameSubmission SubmissionR !correctorANDisRead:
|
||||
/ SubShowR GET POST !ownerANDtime !ownerANDisRead
|
||||
/archive/#{ZIPArchiveName SubmissionFileType} SubArchiveR GET !owner
|
||||
/correction CorrectionR GET POST !corrector !ownerANDisRead
|
||||
/correction CorrectionR GET POST !corrector !ownerANDisReadANDrated
|
||||
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner
|
||||
/correctors SCorrR GET POST
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
|
||||
|
||||
@ -10,7 +10,7 @@ let
|
||||
drv = haskellPackages.callPackage ./uniworx.nix {};
|
||||
|
||||
postgresSchema = pkgs.writeText "schema.sql" ''
|
||||
CREATE USER uniworx;
|
||||
CREATE USER uniworx WITH SUPERUSER;
|
||||
CREATE DATABASE uniworx_test;
|
||||
GRANT ALL ON DATABASE uniworx_test TO uniworx;
|
||||
CREATE DATABASE uniworx;
|
||||
|
||||
@ -98,7 +98,7 @@ makeFoundation appSettings@(AppSettings{..}) = do
|
||||
(pgPoolSize appDatabaseConf)
|
||||
|
||||
-- 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 $ mkFoundation pool
|
||||
|
||||
@ -20,6 +20,7 @@ import CryptoID.TH
|
||||
import ClassyPrelude hiding (fromString)
|
||||
import Model
|
||||
|
||||
import qualified Data.CryptoID as E
|
||||
import Data.CryptoID.Poly.ImplicitNamespace
|
||||
import Data.UUID.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
|
||||
fromPathPiece = fmap CI.mk . fromPathPiece
|
||||
toPathPiece = toPathPiece . CI.foldedCase
|
||||
toPathPiece = toPathPiece . CI.original
|
||||
|
||||
instance {-# OVERLAPS #-} PathMultiPiece FilePath where
|
||||
fromPathMultiPiece = Just . unpack . intercalate "/"
|
||||
@ -55,8 +56,12 @@ decCryptoIDs [ ''SubmissionId
|
||||
, ''FileId
|
||||
, ''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)
|
||||
|
||||
@ -9,9 +9,9 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE PatternGuards, MultiWayIf #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances, UndecidableInstances, FlexibleContexts #-}
|
||||
|
||||
module Foundation where
|
||||
|
||||
@ -25,6 +25,8 @@ import Yesod.Auth.Message
|
||||
import Yesod.Auth.Dummy
|
||||
import Yesod.Auth.LDAP
|
||||
|
||||
import qualified Network.Wai as W (requestMethod, pathInfo)
|
||||
|
||||
import LDAP.Data (LDAPScope(..))
|
||||
import LDAP.Search (LDAPEntry(..))
|
||||
|
||||
@ -35,14 +37,14 @@ import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import qualified Data.Text.Encoding as TE
|
||||
|
||||
import qualified Data.CryptoID as E
|
||||
|
||||
import Data.ByteArray (convert)
|
||||
import Crypto.Hash (Digest, SHAKE256)
|
||||
import Crypto.Hash.Conduit (sinkHash)
|
||||
|
||||
import Yesod.Auth.Util.PasswordStore
|
||||
|
||||
import qualified Data.CryptoID (CryptoID) -- for DisplayAble instance only
|
||||
|
||||
import qualified Data.ByteString.Base64.URL as Base64 (encode)
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
@ -58,6 +60,8 @@ import qualified Data.Set as Set
|
||||
import Data.Map (Map, (!?))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.Monoid (Any(..))
|
||||
|
||||
|
||||
import Data.Conduit (($$))
|
||||
import Data.Conduit.List (sourceList)
|
||||
@ -67,6 +71,9 @@ import qualified Database.Esqueleto as E
|
||||
import Control.Monad.Except (MonadError(..), runExceptT)
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
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
|
||||
|
||||
@ -83,15 +90,15 @@ import qualified Data.Yaml as Yaml
|
||||
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
|
||||
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 :$:
|
||||
-- pattern a :$: b = a b
|
||||
@ -170,6 +177,15 @@ instance RenderMessage UniWorX TermIdentifier where
|
||||
Winter -> renderMessage' $ MsgWinterTerm year
|
||||
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
|
||||
renderMessage f ls str = renderMessage f ls $ Text.pack str
|
||||
|
||||
@ -181,6 +197,9 @@ instance RenderMessage UniWorX SheetFileType where
|
||||
SheetMarking -> renderMessage' MsgSheetMarking
|
||||
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' = $(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
|
||||
return Authorized
|
||||
|
||||
r -> do
|
||||
$logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r
|
||||
unauthorizedI MsgUnauthorized
|
||||
r -> $unsupportedAuthPredicate "time" r
|
||||
)
|
||||
,("registered", APDB $ \route _ -> case route of
|
||||
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))
|
||||
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
|
||||
return Authorized
|
||||
r -> do
|
||||
$logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r
|
||||
unauthorizedI MsgUnauthorized
|
||||
r -> $unsupportedAuthPredicate "registered" r
|
||||
)
|
||||
,("capacity", APDB $ \route _ -> case route of
|
||||
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 ]
|
||||
guard $ NTop courseCapacity > NTop (Just registered)
|
||||
return Authorized
|
||||
r -> do
|
||||
$logErrorS "AccessControl" $ "'!capacity' used on route that doesn't support it: " <> tshow r
|
||||
unauthorizedI MsgUnauthorized
|
||||
r -> $unsupportedAuthPredicate "capacity" r
|
||||
)
|
||||
,("materials", APDB $ \route _ -> case route of
|
||||
CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
|
||||
Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
|
||||
guard courseMaterialFree
|
||||
return Authorized
|
||||
r -> do
|
||||
$logErrorS "AccessControl" $ "'!materials' used on route that doesn't support it: " <> tshow r
|
||||
unauthorizedI MsgUnauthorized
|
||||
r -> $unsupportedAuthPredicate "materials" r
|
||||
)
|
||||
,("owner", APDB $ \route _ -> case route of
|
||||
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
|
||||
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
|
||||
return Authorized
|
||||
r -> do
|
||||
$logErrorS "AccessControl" $ "'!owner' used on route that doesn't support it: " <> tshow r
|
||||
unauthorizedI MsgUnauthorized
|
||||
r -> $unsupportedAuthPredicate "owner" r
|
||||
)
|
||||
,("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))
|
||||
,("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.
|
||||
-- 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.
|
||||
yesodMiddleware handler = do
|
||||
void . runMaybeT $ do
|
||||
route <- MaybeT getCurrentRoute
|
||||
guardM . lift $ (== Authorized) <$> isAuthorized route False
|
||||
case route of -- update Course Favourites here
|
||||
CourseR tid csh _ -> do
|
||||
uid <- MaybeT maybeAuthId
|
||||
$(logDebug) "Favourites save"
|
||||
now <- liftIO $ getCurrentTime
|
||||
void . lift . runDB . runMaybeT $ do
|
||||
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
|
||||
yesodMiddleware = defaultYesodMiddleware . normalizeRouteMiddleware . defaultCsrfMiddleware . updateFavouritesMiddleware
|
||||
where
|
||||
updateFavouritesMiddleware :: Handler a -> Handler a
|
||||
updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
|
||||
route <- MaybeT getCurrentRoute
|
||||
case route of -- update Course Favourites here
|
||||
CourseR tid csh _ -> do
|
||||
void . lift . runDB . runMaybeT $ do
|
||||
guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid csh CShowR) False
|
||||
$logDebugS "updateFavourites" "Updating favourites"
|
||||
|
||||
_other -> return ()
|
||||
defaultYesodMiddleware handler -- handler is executed afterwards, so Favourites are updated immediately
|
||||
now <- liftIO $ getCurrentTime
|
||||
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
|
||||
master <- getYesod
|
||||
@ -629,18 +666,18 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb TermCurrentR = return ("Aktuell" , Just TermShowR)
|
||||
breadcrumb TermEditR = return ("Neu" , Just TermCurrentR)
|
||||
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 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
|
||||
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 SheetListR) = return ("Übungen" , Just $ CourseR tid csh CShowR)
|
||||
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 SDelR ) = return ("DELETE", 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 _ = 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
|
||||
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||||
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
@ -975,6 +1012,42 @@ pageHeading _
|
||||
= 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.
|
||||
instance YesodPersist UniWorX where
|
||||
type YesodPersistBackend UniWorX = SqlBackend
|
||||
@ -1021,7 +1094,7 @@ instance YesodAuth UniWorX where
|
||||
userEmail' = lookup "mail" 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'
|
||||
|
||||
AppSettings{..} <- getsYesod appSettings
|
||||
|
||||
@ -75,68 +75,84 @@ sheetIs :: Key Sheet -> CorrectionsWhere
|
||||
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 = sortable (Just "term") (i18nCell MsgTerm)
|
||||
$ \DBRow{ dbrOutput=(_, _, course, _) } ->
|
||||
$ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
|
||||
-- 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 = sortable (Just "course") (i18nCell MsgCourse)
|
||||
$ \DBRow{ dbrOutput=(_, _, course, _) } -> cell $
|
||||
let tid = E.unValue $ course ^. _3
|
||||
csh = E.unValue $ course ^. _2
|
||||
$ \DBRow{ dbrOutput=(_, _, course, _, _) } -> cell $
|
||||
let tid = course ^. _3
|
||||
csh = course ^. _2
|
||||
in [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
|
||||
|
||||
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
|
||||
$ \DBRow{ dbrOutput=(_, sheet, course, _) } -> cell $
|
||||
let tid = E.unValue $ course ^. _3
|
||||
csh = E.unValue $ course ^. _2
|
||||
$ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> cell $
|
||||
let tid = course ^. _3
|
||||
csh = course ^. _2
|
||||
shn = sheetName $ entityVal sheet
|
||||
in [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
|
||||
-- textCell $ sheetName $ entityVal sheet
|
||||
|
||||
colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
|
||||
DBRow{ dbrOutput = (_, _, _, Nothing) } -> cell mempty
|
||||
DBRow{ dbrOutput = (_, _, _, Just corr) } -> textCell . display . userDisplayName $ entityVal corr
|
||||
DBRow{ dbrOutput = (_, _, _, Nothing, _) } -> cell mempty
|
||||
DBRow{ dbrOutput = (_, _, _, Just corr, _) } -> textCell . display . userDisplayName $ entityVal corr
|
||||
|
||||
colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
|
||||
$ \DBRow{ dbrOutput=(submission, sheet, course, _) } -> cell $ do
|
||||
let tid = E.unValue $ course ^. _3
|
||||
csh = E.unValue $ course ^. _2
|
||||
$ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> cell $ do
|
||||
let tid = course ^. _3
|
||||
csh = course ^. _2
|
||||
shn = sheetName $ entityVal sheet
|
||||
cid <- encrypt (entityKey submission :: SubmissionId)
|
||||
[whamlet|<a href=@{CSubmissionR tid csh shn cid SubShowR}>#{display cid}|]
|
||||
|
||||
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))
|
||||
|
||||
makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h )
|
||||
=> _ -> Colonnade h CorrectionTableData (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
|
||||
makeCorrectionsTable whereClause colChoices psValidator = do
|
||||
let tableData :: CorrectionTableExpr -> E.SqlQuery _
|
||||
tableData ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
|
||||
let dbtSQLQuery :: CorrectionTableExpr -> E.SqlQuery _
|
||||
dbtSQLQuery ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
|
||||
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
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.^. CourseTerm
|
||||
, course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId)
|
||||
)
|
||||
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
|
||||
{ dbtSQLQuery = tableData
|
||||
{ dbtSQLQuery
|
||||
, dbtColonnade = colChoices
|
||||
, dbtProj = return
|
||||
, dbtProj
|
||||
, dbtSorting = [ ( "term"
|
||||
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
|
||||
)
|
||||
@ -207,7 +223,7 @@ correctionsR whereClause (formColonnade -> displayColumns) psValidator actions =
|
||||
FormMissing -> return ()
|
||||
FormSuccess (CorrDownloadData, subs) -> do
|
||||
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
|
||||
FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do
|
||||
subs <- mapM decrypt $ Set.toList subs'
|
||||
@ -309,7 +325,7 @@ postCorrectionsR = do
|
||||
[ downloadAction
|
||||
]
|
||||
|
||||
getCCorrectionsR, postCCorrectionsR :: TermId -> Text -> Handler TypedContent
|
||||
getCCorrectionsR, postCCorrectionsR :: TermId -> CourseShorthand -> Handler TypedContent
|
||||
getCCorrectionsR = postCCorrectionsR
|
||||
postCCorrectionsR tid csh = do
|
||||
Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh
|
||||
@ -319,6 +335,7 @@ postCCorrectionsR tid csh = do
|
||||
, dbRow
|
||||
, colSheet
|
||||
, colCorrector
|
||||
, colSubmittors
|
||||
, colSubmissionLink
|
||||
] -- Continue here
|
||||
psValidator = def
|
||||
@ -327,7 +344,7 @@ postCCorrectionsR tid csh = do
|
||||
, assignAction (Left cid)
|
||||
]
|
||||
|
||||
getSSubsR, postSSubsR :: TermId -> Text -> Text -> Handler TypedContent
|
||||
getSSubsR, postSSubsR :: TermId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||
getSSubsR = postSSubsR
|
||||
postSSubsR tid csh shn = do
|
||||
shid <- runDB $ fetchSheetId tid csh shn
|
||||
@ -336,6 +353,7 @@ postSSubsR tid csh shn = do
|
||||
[ colSelect
|
||||
, dbRow
|
||||
, colCorrector
|
||||
, colSubmittors
|
||||
, colSubmissionLink
|
||||
]
|
||||
psValidator = def
|
||||
@ -357,7 +375,7 @@ correctionData tid csh shn sub = E.select . E.from $ \((course `E.InnerJoin` she
|
||||
|
||||
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
|
||||
mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True
|
||||
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))
|
||||
|
||||
((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))
|
||||
<* submitButton
|
||||
|
||||
|
||||
@ -94,7 +94,7 @@ getTermCourseListR tid = do
|
||||
setTitleI . MsgTermCourseListTitle $ tid
|
||||
$(widgetFile "courses")
|
||||
|
||||
getCShowR :: TermId -> Text -> Handler Html
|
||||
getCShowR :: TermId -> CourseShorthand -> Handler Html
|
||||
getCShowR tid csh = do
|
||||
mbAid <- maybeAuthId
|
||||
(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
|
||||
|
||||
|
||||
postCRegisterR :: TermId -> Text -> Handler Html
|
||||
postCRegisterR :: TermId -> CourseShorthand -> Handler Html
|
||||
postCRegisterR tid csh = do
|
||||
aid <- requireAuthId
|
||||
(cid, course, registered) <- runDB $ do
|
||||
@ -159,12 +159,12 @@ getCourseNewR = do
|
||||
postCourseNewR :: Handler Html
|
||||
postCourseNewR = courseEditHandler False Nothing
|
||||
|
||||
getCEditR :: TermId -> Text -> Handler Html
|
||||
getCEditR :: TermId -> CourseShorthand -> Handler Html
|
||||
getCEditR tid csh = do
|
||||
course <- runDB $ getBy $ CourseTermShort tid csh
|
||||
courseEditHandler True course
|
||||
|
||||
postCEditR :: TermId -> Text -> Handler Html
|
||||
postCEditR :: TermId -> CourseShorthand -> Handler Html
|
||||
postCEditR tid csh = do
|
||||
course <- runDB $ getBy $ CourseTermShort tid csh
|
||||
courseEditHandler False course
|
||||
@ -255,8 +255,7 @@ courseEditHandler isGet course = do
|
||||
-- else addMessageI "danger" $ MsgCourseEditDupShort tid csh
|
||||
|
||||
(FormFailure _) -> addMessageI "warning" MsgInvalidInput
|
||||
(FormMissing) | isGet -> return ()
|
||||
other -> addMessage "error" $ [shamlet| Error: #{show other}|]
|
||||
(FormMissing) -> return ()
|
||||
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
|
||||
defaultLayout $ do
|
||||
setTitleI MsgCourseEditTitle
|
||||
@ -265,10 +264,10 @@ courseEditHandler isGet course = do
|
||||
|
||||
data CourseForm = CourseForm
|
||||
{ cfCourseId :: Maybe CourseId -- Maybe CryptoUUIDCourse
|
||||
, cfName :: Text
|
||||
, cfName :: CourseName
|
||||
, cfDesc :: Maybe Html
|
||||
, cfLink :: Maybe Text
|
||||
, cfShort :: Text
|
||||
, cfShort :: CourseShorthand
|
||||
, cfTerm :: TermId
|
||||
, cfSchool :: SchoolId
|
||||
, cfCapacity :: Maybe Int64
|
||||
@ -279,10 +278,6 @@ data CourseForm = CourseForm
|
||||
, cfDeRegUntil :: Maybe UTCTime
|
||||
}
|
||||
|
||||
instance Show CourseForm where
|
||||
show cf = T.unpack (cfShort cf) ++ ' ':(show $ cfCourseId cf)
|
||||
|
||||
|
||||
courseToForm :: Entity Course -> CourseForm
|
||||
courseToForm cEntity = CourseForm
|
||||
{ cfCourseId = Just $ entityKey cEntity
|
||||
@ -312,10 +307,10 @@ newCourseForm template = identForm FIDcourse $ \html -> do
|
||||
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
|
||||
-- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work?
|
||||
<$> 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 urlField (fsb "Homepage") (cfLink <$> template)
|
||||
<*> areq textField (fsb "Kürzel"
|
||||
<*> areq (ciField textField) (fsb "Kürzel"
|
||||
-- & addAttr "disabled" "disabled"
|
||||
& setTooltip "Muss innerhalb des Semesters eindeutig sein")
|
||||
(cfShort <$> template)
|
||||
|
||||
@ -21,7 +21,7 @@ import Import hiding (Proxy)
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
import Handler.Utils
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||
|
||||
@ -46,14 +46,16 @@ instance CryptoRoute UUID SubmissionId where
|
||||
return $ CSubmissionR tid csh shn cID' SubShowR
|
||||
|
||||
instance CryptoRoute (CI FilePath) SubmissionId where
|
||||
cryptoIDRoute _ (CryptoID -> cID) = do
|
||||
(smid :: SubmissionId) <- decrypt cID
|
||||
(tid,csh,shn) <- runDB $ do
|
||||
shid <- submissionSheet <$> get404 smid
|
||||
Sheet{..} <- get404 shid
|
||||
Course{..} <- get404 sheetCourse
|
||||
return (courseTerm, courseShorthand, sheetName)
|
||||
return $ CSubmissionR tid csh shn cID SubShowR
|
||||
cryptoIDRoute _ ciphertext
|
||||
| Just cID <- fromPathPiece . Text.pack $ CI.original ciphertext = do
|
||||
smid <- decrypt cID
|
||||
(tid,csh,shn) <- runDB $ do
|
||||
shid <- submissionSheet <$> get404 smid
|
||||
Sheet{..} <- get404 shid
|
||||
Course{..} <- get404 sheetCourse
|
||||
return (courseTerm, courseShorthand, sheetName)
|
||||
return $ CSubmissionR tid csh shn cID SubShowR
|
||||
| otherwise = notFound
|
||||
|
||||
instance CryptoRoute UUID UserId where
|
||||
cryptoIDRoute _ (CryptoID -> cID) = do
|
||||
|
||||
@ -115,8 +115,8 @@ homeUser uid = do
|
||||
-- (E.SqlExpr (Entity Course )))
|
||||
-- (E.SqlExpr (Entity Sheet ))
|
||||
_ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
|
||||
, E.SqlExpr (E.Value Text)
|
||||
, E.SqlExpr (E.Value Text)
|
||||
, E.SqlExpr (E.Value CourseShorthand)
|
||||
, E.SqlExpr (E.Value SheetName)
|
||||
, E.SqlExpr (E.Value UTCTime)
|
||||
, E.SqlExpr (E.Value (Maybe SubmissionId)))
|
||||
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)
|
||||
, E.Value Text
|
||||
, E.Value Text
|
||||
, E.Value CourseShorthand
|
||||
, E.Value SheetName
|
||||
, E.Value UTCTime
|
||||
, E.Value (Maybe SubmissionId)
|
||||
))
|
||||
|
||||
@ -34,6 +34,9 @@ import Text.Blaze (text)
|
||||
import qualified Data.UUID.Cryptographic as UUID
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E
|
||||
|
||||
@ -68,7 +71,7 @@ instance Eq (Unique Sheet) where
|
||||
-}
|
||||
|
||||
data SheetForm = SheetForm
|
||||
{ sfName :: Text
|
||||
{ sfName :: SheetName
|
||||
, sfDescription :: Maybe Html
|
||||
, sfType :: SheetType
|
||||
, sfGrouping :: SheetGroup
|
||||
@ -85,21 +88,23 @@ data SheetForm = SheetForm
|
||||
-- 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 msId template = identForm FIDsheet $ \html -> do
|
||||
-- TODO: SJ to refactor this; extract Code from getSEditR to joint code piece
|
||||
let oldFileIds fType
|
||||
| Just sId <- msId = fmap setFromList . fmap (map E.unValue) . runDB . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
|
||||
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
|
||||
oldFileIds <- (return.) <$> case msId of
|
||||
Nothing -> return $ partitionFileType mempty
|
||||
(Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
|
||||
mr <- getMsgRenderer
|
||||
ctime <- liftIO $ getCurrentTime
|
||||
(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)
|
||||
<*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> 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)
|
||||
] ]
|
||||
|
||||
getSheetListR :: TermId -> Text -> Handler Html
|
||||
getSheetListR :: TermId -> CourseShorthand -> Handler Html
|
||||
getSheetListR tid csh = do
|
||||
Entity cid _ <- runDB . getBy404 $ CourseTermShort tid csh
|
||||
let
|
||||
@ -206,7 +211,7 @@ getSheetListR tid csh = do
|
||||
|
||||
|
||||
-- Show single sheet
|
||||
getSShowR :: TermId -> Text -> Text -> Handler Html
|
||||
getSShowR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSShowR tid csh shn = do
|
||||
entSheet <- runDB $ fetchSheet tid csh shn
|
||||
let sheet = entityVal entSheet
|
||||
@ -265,16 +270,16 @@ getSShowR tid csh shn = do
|
||||
hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ]
|
||||
return (hasHints, hasSolution)
|
||||
defaultLayout $ do
|
||||
setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
|
||||
setTitleI $ MsgSheetTitle tid csh shn
|
||||
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
|
||||
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
|
||||
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
|
||||
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
|
||||
$(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
|
||||
content <- runDB $ E.select $ E.from $
|
||||
results <- runDB $ E.select $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
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 )
|
||||
)
|
||||
-- return desired columns
|
||||
return $ file E.^. FileContent
|
||||
return $ (file E.^. FileTitle, file E.^. FileContent)
|
||||
let mimeType = defaultMimeLookup $ pack title
|
||||
case content of
|
||||
[E.Value (Just nochmalContent)] -> do
|
||||
addHeader "Content-Disposition" "attachment"
|
||||
respond mimeType nochmalContent
|
||||
[] -> notFound
|
||||
_other -> error "Multiple matching files found."
|
||||
case results of
|
||||
[(E.Value fileTitle, E.Value fileContent)]
|
||||
| Just fileContent' <- fileContent -> do
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
|
||||
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
|
||||
| otherwise -> sendResponseStatus noContent204 ()
|
||||
[] -> notFound
|
||||
other -> do
|
||||
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
|
||||
error "Multiple matching files found."
|
||||
|
||||
|
||||
getSheetNewR :: TermId -> Text -> Handler Html
|
||||
getSheetNewR :: TermId -> CourseShorthand -> Handler Html
|
||||
getSheetNewR tid csh = do
|
||||
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
|
||||
insertUnique $ newSheet
|
||||
handleSheetEdit tid csh Nothing template action
|
||||
|
||||
postSheetNewR :: TermId -> Text -> Handler Html
|
||||
postSheetNewR :: TermId -> CourseShorthand -> Handler Html
|
||||
postSheetNewR = getSheetNewR
|
||||
|
||||
|
||||
getSEditR :: TermId -> Text -> Text -> Handler Html
|
||||
getSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSEditR tid csh shn = do
|
||||
(sheetEnt, sheetFileIds) <- runDB $ do
|
||||
ent <- fetchSheet tid csh shn
|
||||
allfIds <- E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
|
||||
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
|
||||
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)
|
||||
fti <- getFtIdMap $ entityKey ent
|
||||
return (ent, fti)
|
||||
let sid = entityKey sheetEnt
|
||||
let oldSheet@(Sheet {..}) = entityVal sheetEnt
|
||||
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
|
||||
handleSheetEdit tid csh (Just sid) template action
|
||||
|
||||
postSEditR :: TermId -> Text -> Text -> Handler Html
|
||||
postSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
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
|
||||
let mbshn = sfName <$> template
|
||||
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
|
||||
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
|
||||
case result of
|
||||
@ -417,7 +420,7 @@ getSDelR tid csh shn = do
|
||||
setTitleI $ MsgSheetTitle tid csh shn
|
||||
$(widgetFile "formPageI18n")
|
||||
|
||||
postSDelR :: TermId -> Text -> Text -> Handler Html
|
||||
postSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
postSDelR = getSDelR
|
||||
|
||||
|
||||
@ -505,8 +508,8 @@ correctorForm shid = do
|
||||
|
||||
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads'
|
||||
let
|
||||
tutorField :: Field Handler [Text]
|
||||
tutorField = multiEmailField
|
||||
tutorField :: Field Handler [UserEmail]
|
||||
tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField
|
||||
{ fieldView = \theId name attrs val isReq -> asWidgetT $ do
|
||||
listIdent <- newIdent
|
||||
userId <- handlerToWidget requireAuthId
|
||||
@ -616,10 +619,7 @@ correctorForm shid = do
|
||||
-- Eingabebox für Korrektor hinzufügen
|
||||
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
|
||||
|
||||
getSCorrR, postSCorrR :: TermId
|
||||
-> Text -- ^ Course shorthand
|
||||
-> Text -- ^ Sheet name
|
||||
-> Handler Html
|
||||
getSCorrR, postSCorrR :: TermId -> CourseShorthand -> SheetName -> Handler Html
|
||||
postSCorrR = getSCorrR
|
||||
getSCorrR tid csh shn = do
|
||||
Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
@ -56,18 +56,16 @@ import Colonnade hiding (bool, fromMaybe)
|
||||
import qualified Yesod.Colonnade as Yesod
|
||||
import qualified Text.Blaze.Html5.Attributes as HA
|
||||
|
||||
import Text.Shakespeare.Text (st)
|
||||
|
||||
|
||||
numberOfSubmissionEditDates :: Int64
|
||||
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
|
||||
flip (renderAForm FormStandard) html $ (,)
|
||||
<$> (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
|
||||
| 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' _ _ _ = 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
|
||||
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
|
||||
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
|
||||
authId <- requireAuthId
|
||||
sid <- runDB $ do
|
||||
@ -105,7 +103,7 @@ getSubmissionOwnR tid csh shn = do
|
||||
cID <- encrypt sid
|
||||
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
|
||||
uid <- requireAuthId
|
||||
msmid <- traverse decrypt mcid
|
||||
@ -143,7 +141,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
addMessageI "info" $ MsgSubmissionAlreadyExists
|
||||
redirect $ CSubmissionR tid csh shn cID SubShowR
|
||||
(Just smid) -> do
|
||||
submissionMatchesSheet tid csh shn (fromJust mcid)
|
||||
void $ submissionMatchesSheet tid csh shn (fromJust mcid)
|
||||
|
||||
shid' <- submissionSheet <$> get404 smid
|
||||
-- fetch buddies from current submission
|
||||
@ -169,14 +167,13 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
(FormMissing ) -> return $ FormMissing
|
||||
(FormFailure failmsgs) -> return $ FormFailure failmsgs
|
||||
(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
|
||||
-- , length gEMails < maxParticipants -> do -- < since submitting user is already accounted for
|
||||
let gemails = map CI.foldedCase gEMails
|
||||
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 ++ [(CI.mk m, Just (i,p,s))|(E.Value m, (E.Value i, E.Value p, E.Value s)) <- ps]
|
||||
let prep :: [(E.Value UserEmail, (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]
|
||||
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
|
||||
isParticipant = E.sub_select . E.from $ \courseParticipant -> do
|
||||
E.where_ $ user E.^. UserId E.==. courseParticipant E.^. CourseParticipantUser
|
||||
@ -198,9 +195,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
let
|
||||
failmsgs = (concat :: [[Text]] -> [Text])
|
||||
[ flip Map.foldMapWithKey participants $ \email -> \case
|
||||
Nothing -> pure . mr $ MsgEMailUnknown $ CI.original email
|
||||
(Just (_,False,_)) -> pure . mr $ MsgNotAParticipant (CI.original email) tid csh
|
||||
(Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor (CI.original email)
|
||||
Nothing -> pure . mr $ MsgEMailUnknown email
|
||||
(Just (_,False,_)) -> pure . mr $ MsgNotAParticipant email tid csh
|
||||
(Just (_,_, True)) -> pure . mr $ MsgSubmissionAlreadyExistsFor email
|
||||
_other -> mempty
|
||||
, case length participants `compare` maxParticipants of
|
||||
LT -> mempty
|
||||
@ -309,42 +306,54 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
$(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
|
||||
submissionID <- decrypt cID
|
||||
|
||||
runDB $ do
|
||||
submissionMatchesSheet tid csh shn cID
|
||||
submissionID <- submissionMatchesSheet tid csh shn cID
|
||||
|
||||
isRating <- maybe False (== submissionID) <$> isRatingFile path
|
||||
|
||||
when (isUpdate || isRating) $
|
||||
guardAuthResult =<< evalAccessDB (CSubmissionR tid csh shn cID CorrectionR) False
|
||||
|
||||
case isRating of
|
||||
True -> do
|
||||
file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
|
||||
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
|
||||
True
|
||||
| isUpdate -> do
|
||||
file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
|
||||
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
|
||||
| otherwise -> notFound
|
||||
False -> do
|
||||
results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
|
||||
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.&&. f E.^. FileTitle E.==. E.val path
|
||||
E.&&. E.not_ (E.isNothing $ f E.^. FileContent)
|
||||
E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
|
||||
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
|
||||
|
||||
let fileName = Text.pack $ takeFileName path
|
||||
case results of
|
||||
[Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName <> "; charset=utf-8") (toContent c)
|
||||
_ -> notFound
|
||||
[Entity _ File{ fileContent = Just c, fileTitle }] -> do
|
||||
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 tid csh shn cID@CryptoID{..} (ZIPArchiveName sfType) = do
|
||||
submissionID <- decrypt cID
|
||||
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece cID}-#{toPathPiece sfType}.zip"|]
|
||||
getSubArchiveR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
|
||||
getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do
|
||||
when (sfType == SubmissionCorrected) $
|
||||
guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False
|
||||
|
||||
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
|
||||
lift $ submissionMatchesSheet tid csh shn cID
|
||||
|
||||
submissionID <- lift $ submissionMatchesSheet tid csh shn cID
|
||||
rating <- lift $ getRating submissionID
|
||||
|
||||
let
|
||||
@ -361,6 +370,6 @@ getSubArchiveR tid csh shn cID@CryptoID{..} (ZIPArchiveName sfType) = do
|
||||
when (sfType == SubmissionCorrected) $
|
||||
maybe (return ()) (yieldM . ratingFile cID) rating
|
||||
|
||||
zipComment = Text.encodeUtf8 . pack $ CI.foldedCase ciphertext
|
||||
zipComment = Text.encodeUtf8 $ toPathPiece cID
|
||||
|
||||
fileSource' .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||||
|
||||
@ -44,7 +44,7 @@ getTermShowR = do
|
||||
let colonnadeTerms = widgetColonnade $ mconcat
|
||||
[ sortable Nothing "Kürzel" $
|
||||
anchorCell' (\(Entity tid _, _) -> TermCourseListR tid)
|
||||
(\(Entity tid _, _) -> [whamlet|#{display tid}|])
|
||||
(\(Entity tid _, _) -> [whamlet|#{toPathPiece tid}|])
|
||||
, sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
|
||||
cell $ formatTime SelFormatDate termLectureStart >>= toWidget
|
||||
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->
|
||||
|
||||
@ -23,6 +23,9 @@ import Import
|
||||
import qualified Data.Char as Char
|
||||
import Data.String (IsString(..))
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Foldable as Foldable
|
||||
|
||||
-- import Yesod.Core
|
||||
@ -263,6 +266,8 @@ buttonForm csrf = do
|
||||
-- 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 msg = checkBool (>= 0) msg intField
|
||||
|
||||
@ -66,8 +66,8 @@ instance Pretty x => Pretty (CI x) where
|
||||
|
||||
|
||||
data Rating = Rating
|
||||
{ ratingCourseName :: Text
|
||||
, ratingSheetName :: Text
|
||||
{ ratingCourseName :: CourseName
|
||||
, ratingSheetName :: SheetName
|
||||
, ratingCorrectorName :: Maybe Text
|
||||
, ratingSheetType :: SheetType
|
||||
, ratingValues :: Rating'
|
||||
@ -133,7 +133,7 @@ formatRating cID Rating{ ratingValues = Rating'{..}, ..} = let
|
||||
, ("Korrektor:" <+>) . pretty <$> ratingCorrectorName
|
||||
, Just $ "Bewertung:" <+> pretty (display ratingSheetType)
|
||||
]
|
||||
, "Abgabe-Id:" <+> pretty (ciphertext cID)
|
||||
, "Abgabe-Id:" <+> pretty (Text.unpack $ toPathPiece cID)
|
||||
, "============================================="
|
||||
, "Bewertung:" <+> pretty ratingPoints
|
||||
, "=========== Beginn der Kommentare ==========="
|
||||
@ -145,7 +145,7 @@ ratingFile :: MonadIO m => CryptoFileNameSubmission -> Rating -> m File
|
||||
ratingFile cID rating@(Rating{ ratingValues = Rating'{..}, .. }) = do
|
||||
fileModified <- maybe (liftIO getCurrentTime) return ratingTime
|
||||
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
|
||||
return File{..}
|
||||
|
||||
@ -212,7 +212,8 @@ isRatingFile fName
|
||||
isRatingFile' :: FilePath -> Maybe CryptoFileNameSubmission
|
||||
isRatingFile' (takeFileName -> fName)
|
||||
| (bName, ".txt") <- splitExtension fName
|
||||
, Just (CI.mk -> ciphertext) <- stripPrefix "bewertung_" bName
|
||||
= Just CryptoID{..}
|
||||
, Just piece <- stripPrefix "bewertung_" bName
|
||||
, Just cID <- fromPathPiece $ Text.pack piece
|
||||
= Just cID
|
||||
| otherwise
|
||||
= Nothing
|
||||
|
||||
@ -24,7 +24,7 @@ fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
|
||||
, PersistQueryRead backend, PersistUniqueRead backend
|
||||
)
|
||||
=> (E.SqlExpr (Entity Sheet) -> b)
|
||||
-> TermId -> Text -> Text -> ReaderT backend m a
|
||||
-> TermId -> CourseShorthand -> SheetName -> ReaderT backend m a
|
||||
fetchSheetAux prj tid csh shn =
|
||||
let cachId = encodeUtf8 $ tshow (tid,csh,shn)
|
||||
in cachedBy cachId $ do
|
||||
@ -42,11 +42,11 @@ fetchSheetAux prj tid csh shn =
|
||||
[sheet] -> return sheet
|
||||
_other -> notFound
|
||||
|
||||
fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
|
||||
fetchSheet :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet)
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
@ -10,6 +10,7 @@
|
||||
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
|
||||
|
||||
module Handler.Utils.Submission
|
||||
@ -43,6 +44,8 @@ import qualified Data.Set as Set
|
||||
import Data.Map (Map, (!?))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
@ -159,7 +162,7 @@ submissionMultiArchive (Set.toList -> ids) = do
|
||||
cID <- encrypt submissionID
|
||||
|
||||
let
|
||||
directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
|
||||
directoryName = Text.unpack $ toPathPiece (cID :: CryptoFileNameSubmission)
|
||||
|
||||
fileEntitySource = do
|
||||
submissionFileSource submissionID =$= Conduit.map entityVal
|
||||
@ -463,11 +466,7 @@ sinkMultiSubmission userId isUpdate = do
|
||||
Submission{..} <- get404 sId
|
||||
Sheet{..} <- get404 submissionSheet
|
||||
Course{..} <- get404 sheetCourse
|
||||
authRes <- evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True
|
||||
case authRes of
|
||||
AuthenticationRequired -> notAuthenticated
|
||||
Unauthorized t -> permissionDenied t
|
||||
Authorized -> return ()
|
||||
guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True
|
||||
return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate
|
||||
sink' <- lift $ yield val ++$$ sink
|
||||
case sink' of
|
||||
@ -484,9 +483,11 @@ sinkMultiSubmission userId isUpdate = do
|
||||
acc (Just sId, fp) segment = return (Just sId, fp ++ [segment])
|
||||
acc (Nothing , fp) segment = do
|
||||
let
|
||||
tryDecrypt ciphertext = do
|
||||
sId <- decrypt (CryptoID (CI.mk segment) :: CryptoFileNameSubmission)
|
||||
Just sId <$ get404 sId
|
||||
tryDecrypt (Text.pack -> ciphertext)
|
||||
| Just cID <- fromPathPiece ciphertext = do
|
||||
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) ]
|
||||
return (msId, fp)
|
||||
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
|
||||
@ -513,9 +514,10 @@ sinkMultiSubmission userId isUpdate = do
|
||||
handleCryptoID _ = return Nothing
|
||||
|
||||
|
||||
submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB ()
|
||||
submissionMatchesSheet :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId
|
||||
submissionMatchesSheet tid csh shn cid = do
|
||||
sid <- decrypt cid
|
||||
shid <- fetchSheetId tid csh shn
|
||||
Submission{..} <- get404 sid
|
||||
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
|
||||
return sid
|
||||
|
||||
@ -24,6 +24,7 @@ module Handler.Utils.Table.Pagination
|
||||
, DBRow(..)
|
||||
, DBStyle(..), DBEmptyStyle(..)
|
||||
, DBTable(..), IsDBTable(..), DBCell(..)
|
||||
, cellAttrs, cellContents
|
||||
, PaginationSettings(..), PaginationInput(..), piIsUnset
|
||||
, PSValidator(..)
|
||||
, defaultFilter, defaultSorting
|
||||
@ -31,10 +32,13 @@ module Handler.Utils.Table.Pagination
|
||||
, ToSortable(..), Sortable(..), sortable
|
||||
, dbTable
|
||||
, widgetColonnade, formColonnade, dbColonnade
|
||||
, textCell, stringCell, i18nCell, anchorCell, anchorCell', anchorCellM
|
||||
, cell, textCell, stringCell, i18nCell
|
||||
, anchorCell, anchorCell', anchorCellM
|
||||
, listCell
|
||||
, formCell, DBFormResult, getDBFormResult
|
||||
, dbRow, dbSelect
|
||||
, (&)
|
||||
, module Control.Monad.Trans.Maybe
|
||||
) where
|
||||
|
||||
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.Trans.Maybe
|
||||
|
||||
import Data.Foldable (Foldable(foldMap))
|
||||
|
||||
import Data.Map (Map, (!))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
@ -123,6 +129,15 @@ data DBRow r = DBRow
|
||||
, dbrIndex, dbrCount :: Int64
|
||||
} 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
|
||||
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 :: *
|
||||
|
||||
data DBCell m x :: *
|
||||
cellAttrs :: Lens' (DBCell m x) [(Text, Text)]
|
||||
cellContents :: DBCell m x -> WriterT x m Widget
|
||||
|
||||
cell :: Widget -> DBCell m x
|
||||
dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget)
|
||||
|
||||
-- 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
|
||||
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)
|
||||
|
||||
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
|
||||
type DBResult (WidgetT UniWorX IO) () = Widget
|
||||
-- type DBResult' (WidgetT UniWorX IO) () = ()
|
||||
@ -256,10 +274,10 @@ instance IsDBTable (WidgetT UniWorX IO) () where
|
||||
{ wgtCellAttrs :: [(Text, Text)]
|
||||
, 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 _ = return
|
||||
@ -278,10 +296,9 @@ instance IsDBTable (ReaderT SqlBackend (HandlerT UniWorX IO)) () where
|
||||
, dbCellContents :: ReaderT SqlBackend (HandlerT UniWorX IO) Widget
|
||||
}
|
||||
|
||||
cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as }
|
||||
cellContents = lift . dbCellContents
|
||||
|
||||
cell = DBCell [] . return
|
||||
dbCell = iso
|
||||
(\DBCell{..} -> (dbCellAttrs, lift dbCellContents))
|
||||
(\(attrs, mkWidget) -> DBCell attrs . fmap fst $ runWriterT mkWidget)
|
||||
|
||||
dbWidget _ = return
|
||||
dbHandler _ f x = return $ f x
|
||||
@ -301,10 +318,13 @@ instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enc
|
||||
{ formCellAttrs :: [(Text, Text)]
|
||||
, 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))
|
||||
-- ((,) <$> ((,) <$> 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
|
||||
|
||||
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
|
||||
widget <- cellContents sortableContent
|
||||
widget <- sortableContent ^. cellContents
|
||||
let
|
||||
directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
|
||||
isSortable = isJust sortableKey
|
||||
@ -407,7 +427,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
|
||||
wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
|
||||
|
||||
wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do
|
||||
widget <- cellContents cell
|
||||
widget <- cell ^. cellContents
|
||||
let attrs = cell ^. cellAttrs
|
||||
return $(widgetFile "table/cell/body")
|
||||
|
||||
@ -444,6 +464,9 @@ dbColonnade :: Headedness h
|
||||
-> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) ())
|
||||
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
|
||||
stringCell = textCell
|
||||
i18nCell = textCell
|
||||
@ -467,6 +490,12 @@ anchorCellM routeM widget = cell $ do
|
||||
| Authorized <- authResult -> $(widgetFile "table/cell/link")
|
||||
| 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))
|
||||
|
||||
instance Ord i => Monoid (DBFormResult r i a) where
|
||||
|
||||
@ -19,3 +19,5 @@ import CryptoID as Import
|
||||
import Data.UUID as Import (UUID)
|
||||
|
||||
import Text.Lucius as Import
|
||||
|
||||
import Text.Shakespeare.Text as Import hiding (text, stext)
|
||||
|
||||
15
src/Model.hs
15
src/Model.hs
@ -7,6 +7,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
module Model
|
||||
( module Model
|
||||
, module Model.Types
|
||||
@ -14,20 +15,32 @@ module Model
|
||||
|
||||
import ClassyPrelude.Yesod
|
||||
import Database.Persist.Quasi
|
||||
import Database.Persist.Postgresql (migrateEnableExtension)
|
||||
import Database.Persist.Sql (Migration)
|
||||
-- import Data.Time
|
||||
-- import Data.ByteString
|
||||
import Model.Types
|
||||
import Data.Aeson.TH
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
|
||||
-- You can define all of your database entities in the entities file.
|
||||
-- You can find more information on persistent and how to declare entities
|
||||
-- at:
|
||||
-- http://www.yesodweb.com/book/persistent/
|
||||
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll"]
|
||||
share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateAll'"]
|
||||
$(persistFileWith lowerCaseSettings "models")
|
||||
|
||||
migrateAll :: Migration
|
||||
migrateAll = do
|
||||
migrateEnableExtension "citext"
|
||||
migrateAll'
|
||||
|
||||
data PWEntry = PWEntry
|
||||
{ pwUser :: User
|
||||
, pwHash :: Text
|
||||
} deriving (Show)
|
||||
$(deriveJSON defaultOptions ''PWEntry)
|
||||
|
||||
submissionRatingDone :: Submission -> Bool
|
||||
submissionRatingDone Submission{..} = isJust submissionRatingPoints
|
||||
|
||||
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
@ -7,14 +8,18 @@
|
||||
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-- # LANGUAGE ExistentialQuantification #-} -- for DA type
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Model.Types where
|
||||
|
||||
import ClassyPrelude
|
||||
import Utils
|
||||
import Control.Lens
|
||||
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Fixed
|
||||
|
||||
import Database.Persist.TH
|
||||
@ -25,10 +30,11 @@ import Web.HttpApiData
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
|
||||
import Text.Read (readMaybe,readsPrec)
|
||||
|
||||
-- import Data.CaseInsensitive (CI)
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Yesod.Core.Dispatch (PathPiece(..))
|
||||
@ -38,6 +44,10 @@ import Data.Aeson.TH (deriveJSON, defaultOptions)
|
||||
import GHC.Generics (Generic)
|
||||
import Data.Typeable (Typeable)
|
||||
|
||||
import Text.Shakespeare.I18N (ToMessage(..), RenderMessage(..))
|
||||
import Text.Blaze (ToMarkup(..))
|
||||
import Yesod.Core.Widget (ToWidget(..))
|
||||
|
||||
|
||||
type Points = Centi
|
||||
|
||||
@ -95,6 +105,23 @@ instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instan
|
||||
display SheetSolution = "Musterlösung"
|
||||
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
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded)
|
||||
|
||||
@ -178,17 +205,35 @@ data TermIdentifier = TermIdentifier
|
||||
-- from_TermId_to_TermIdentifier = unTermKey
|
||||
-- from_TermIdentifier_to_TermId = TermKey
|
||||
|
||||
instance DisplayAble TermIdentifier where
|
||||
display = termToText
|
||||
shortened :: Iso' Integer Integer
|
||||
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.pack $ seasonToChar season : show year
|
||||
termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show (year ^. shortened)
|
||||
|
||||
termFromText :: Text -> Either Text TermIdentifier
|
||||
termFromText t
|
||||
| (s:ys) <- Text.unpack t
|
||||
, Just year <- readMaybe ys
|
||||
, Just (review shortened -> year) <- readMaybe ys
|
||||
, Right season <- seasonFromChar s
|
||||
= Right TermIdentifier{..}
|
||||
| otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”"
|
||||
@ -297,3 +342,43 @@ newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String }
|
||||
|
||||
data SelDateTimeFormat = SelFormatDateTime | SelFormatDate | SelFormatTime
|
||||
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
63
src/Utils.hs
@ -4,7 +4,8 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, UndecidableInstances #-}
|
||||
{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE QuasiQuotes, TemplateHaskell #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult
|
||||
|
||||
module Utils
|
||||
@ -17,14 +18,19 @@ import Data.List (foldl)
|
||||
import Data.Foldable as Fold
|
||||
import qualified Data.Char as Char
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Utils.DB as Utils
|
||||
import Utils.Common as Utils
|
||||
import Utils.DateTime as Utils
|
||||
|
||||
import Text.Blaze (Markup, ToMarkup)
|
||||
|
||||
-- import Data.Map (Map)
|
||||
-- import qualified Data.Map as Map
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
-- import qualified Data.List as List
|
||||
|
||||
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 Language.Haskell.TH
|
||||
import Instances.TH.Lift ()
|
||||
|
||||
import Text.Shakespeare.Text (st)
|
||||
|
||||
-----------
|
||||
-- Yesod --
|
||||
-----------
|
||||
@ -51,6 +62,22 @@ instance Monad FormResult where
|
||||
(FormFailure errs) >>= _ = FormFailure errs
|
||||
(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
|
||||
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)
|
||||
instance {-# OVERLAPPABLE #-} Show a => DisplayAble a where
|
||||
display = pack . show
|
||||
@ -144,11 +174,38 @@ trd3 (_,_,z) = z
|
||||
|
||||
-- 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 --
|
||||
----------
|
||||
|
||||
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 --
|
||||
|
||||
@ -9,6 +9,7 @@
|
||||
module Utils.DateTime
|
||||
( timeLocaleMap
|
||||
, TimeLocale(..)
|
||||
, currentYear
|
||||
, module Data.Time.Zones
|
||||
, module Data.Time.Zones.TH
|
||||
) where
|
||||
@ -55,3 +56,9 @@ timeLocaleMap extra@((_, defLocale):_) = do
|
||||
localeExp = lift <=< runIO . getLocale . Just
|
||||
|
||||
letE [localeMap'] (varE localeMap)
|
||||
|
||||
currentYear :: ExpQ
|
||||
currentYear = do
|
||||
now <- runIO getCurrentTime
|
||||
let (year, _, _) = toGregorian $ utctDay now
|
||||
[e|year|]
|
||||
|
||||
@ -428,10 +428,10 @@ input[type="button"].btn-info:hover,
|
||||
display: inline-block;
|
||||
}
|
||||
|
||||
.list--comma-separated > li {
|
||||
|
||||
.list--comma-separated li {
|
||||
&::after {
|
||||
content: ', ';
|
||||
white-space: pre;
|
||||
}
|
||||
|
||||
&:last-of-type::after {
|
||||
|
||||
@ -1,3 +1,4 @@
|
||||
<td .table__td *{attrs}>
|
||||
$newline never
|
||||
<td *{mergeAttrs attrs [("class", "table__td")]}>
|
||||
<div .table__td-content>
|
||||
^{widget}
|
||||
|
||||
@ -1,2 +1,3 @@
|
||||
$newline never
|
||||
<a href=@{route}>
|
||||
^{widget}
|
||||
|
||||
5
templates/table/cell/list.hamlet
Normal file
5
templates/table/cell/list.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
$newline never
|
||||
<ul>
|
||||
$forall (attrs, widget) <- cells
|
||||
<li *{attrs}>
|
||||
^{widget}
|
||||
Loading…
Reference in New Issue
Block a user