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

Merge branch 'feat/nonCourseShorts' into 'master'

Browse Source 
Feat/non course shorts

See merge request !70
This commit is contained in:
Steffen Jost 2018-08-29 10:04:45 +02:00
commit d4de1da4e5
23 changed files with 542 additions and 385 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
messages/uniworx/de.msg
View File

@ -38,16 +38,18 @@ CourseRegisterOk: Sie wurden angemeldet
CourseDeregisterOk: Sie wurden abgemeldet CourseDeregisterOk: Sie wurden abgemeldet
CourseSecretWrong: Falsches Kennwort CourseSecretWrong: Falsches Kennwort
CourseSecret: Zugangspasswort CourseSecret: Zugangspasswort
CourseNewOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt. CourseNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich erstellt.
CourseEditOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich geändert. CourseEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{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. CourseNewDupShort tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{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. CourseEditDupShort tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
FFSheetName: Name FFSheetName: Name
TermCourseListHeading tid@TermId: Kursübersicht #{display tid} TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{display school}
CourseListTitle: Alle Kurse CourseListTitle: Alle Kurse
TermCourseListTitle tid@TermId: Kurse #{display tid} TermCourseListTitle tid@TermId: Kurse #{display tid}
TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{display school}
CourseNewHeading: Neuen Kurs anlegen CourseNewHeading: Neuen Kurs anlegen
CourseEditHeading tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} editieren CourseEditHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} editieren
CourseEditTitle: Kurs editieren/anlegen CourseEditTitle: Kurs editieren/anlegen
CourseMembers: Teilnehmer CourseMembers: Teilnehmer
CourseMembersCount num@Int64: #{display num} CourseMembersCount num@Int64: #{display num}
@ -68,17 +70,17 @@ CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
Sheet: Blatt Sheet: Blatt
SheetList tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Übersicht Übungsblätter SheetList tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Übersicht Übungsblätter
SheetNewHeading tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Neues Übungsblatt anlegen SheetNewHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Neues Übungsblatt anlegen
SheetNewOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{courseShortHand} erfolgreich erstellt. SheetNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{display ssh}-#{courseShortHand} erfolgreich erstellt.
SheetTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName} SheetTitle tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
SheetTitleNew tid@TermId courseShortHand@CourseShorthand : #{display tid}-#{courseShortHand}: Neues Übungsblatt SheetTitleNew tid@TermId ssh@SchoolId courseShortHand@CourseShorthand : #{display tid}-#{display ssh}-#{courseShortHand}: Neues Übungsblatt
SheetEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName} editieren SheetEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} editieren
SheetEditOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{courseShortHand} wurde gespeichert. SheetEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde gespeichert.
SheetNameDup tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{courseShortHand}. SheetNameDup tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{display ssh}-#{courseShortHand}.
SheetDelHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{courseShortHand} herauslöschen? SheetDelHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} herauslöschen?
SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben. SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{display submissionNo} Abgaben.
SheetDelOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht. SheetDelOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht.
SheetExercise: Aufgabenstellung SheetExercise: Aufgabenstellung
SheetHint: Hinweis SheetHint: Hinweis
@ -111,12 +113,12 @@ Deadline: Abgabe
Done: Eingereicht Done: Eingereicht
Submission: Abgabenummer Submission: Abgabenummer
SubmissionsCourse tid@TermId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{courseShortHand} SubmissionsCourse tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{display ssh}-#{courseShortHand}
SubmissionsSheet sheetName@SheetName: Abgaben für Blatt #{sheetName} SubmissionsSheet sheetName@SheetName: Abgaben für Blatt #{sheetName}
SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt. SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
SubmissionEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen SubmissionEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen
CorrectionHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{courseShortHand} #{sheetName}: Korrektur CorrectionHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Korrektur
SubmissionMember g@Int: Mitabgebende(r) ##{display g} SubmissionMember g@Int: Mitabgebende(r) ##{display g}
SubmissionArchive: Zip-Archiv der Abgabedatei(en) SubmissionArchive: Zip-Archiv der Abgabedatei(en)
SubmissionFile: Datei zur Abgabe SubmissionFile: Datei zur Abgabe
@ -156,7 +158,7 @@ TooManyParticipants: Es wurden zu viele Mitabgebende angegeben
AddCorrector: Zusätzlicher Korrektor AddCorrector: Zusätzlicher Korrektor
CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen CorrectorExists email@UserEmail: #{email} ist bereits als Korrektor eingetragen
SheetCorrectorsTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{courseShortHand} #{sheetName} SheetCorrectorsTitle tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Korrektoren für #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}
CountTutProp: Tutorien zählen gegen Proportion CountTutProp: Tutorien zählen gegen Proportion
Corrector: Korrektor Corrector: Korrektor
Correctors: Korrektoren Correctors: Korrektoren
@ -268,4 +270,4 @@ DummyLoginTitle: Development-Login
CorrectorNormal: Normal CorrectorNormal: Normal
CorrectorMissing: Abwesend CorrectorMissing: Abwesend
CorrectorExcused: Entschuldigt CorrectorExcused: Entschuldigt

7
models
View File

@ -52,7 +52,8 @@ School json
name (CI Text) name (CI Text)
shorthand (CI Text) shorthand (CI Text)
UniqueSchool name UniqueSchool name
UniqueSchoolShorthand shorthand UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text
Primary shorthand -- newtype Key School = School { unSchoolKey :: SchoolShorthand }
deriving Eq deriving Eq
DegreeCourse json DegreeCourse json
course CourseId course CourseId
@ -73,8 +74,8 @@ Course
deregisterUntil UTCTime Maybe deregisterUntil UTCTime Maybe
registerSecret Text Maybe -- Falls ein Passwort erforderlich ist registerSecret Text Maybe -- Falls ein Passwort erforderlich ist
materialFree Bool materialFree Bool
CourseTermShort term shorthand TermSchoolCourseShort term school shorthand
CourseTermName term name TermSchoolCourseName term school name
CourseEdit CourseEdit
user UserId user UserId
time UTCTime time UTCTime

4
routes
View File

@ -46,11 +46,13 @@
/terms/edit TermEditR GET POST /terms/edit TermEditR GET POST
/terms/#TermId/edit TermEditExistR GET /terms/#TermId/edit TermEditExistR GET
!/terms/#TermId TermCourseListR GET !free !/terms/#TermId TermCourseListR GET !free
!/terms/#TermId/#SchoolId TermSchoolCourseListR GET !free
-- For Pattern Synonyms see Foundation -- For Pattern Synonyms see Foundation
/course/ CourseListR GET !free /course/ CourseListR GET !free
!/course/new CourseNewR GET POST !lecturer !/course/new CourseNewR GET POST !lecturer
/course/#TermId/#CourseShorthand CourseR !lecturer: /course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer:
/ CShowR GET !free / CShowR GET !free
/register CRegisterR POST !timeANDcapacity /register CRegisterR POST !timeANDcapacity
/edit CEditR GET POST /edit CEditR GET POST

20
src/CryptoID.hs
View File

@ -27,35 +27,17 @@ import System.FilePath.Cryptographic.ImplicitNamespace
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.UUID.Types -- import Data.UUID.Types
import Web.PathPieces import Web.PathPieces
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
instance PathPiece UUID where
fromPathPiece = fromString . unpack
toPathPiece = pack . toString
instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
fromPathPiece = fmap CI.mk . fromPathPiece
toPathPiece = toPathPiece . CI.original
instance {-# OVERLAPS #-} PathMultiPiece FilePath where
fromPathMultiPiece = Just . unpack . intercalate "/"
toPathMultiPiece = Text.splitOn "/" . pack
instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
toPathMultiPiece = toPathMultiPiece . CI.foldedCase
-- Generates CryptoUUID... and CryptoFileName... Datatypes -- Generates CryptoUUID... and CryptoFileName... Datatypes
decCryptoIDs [ ''SubmissionId decCryptoIDs [ ''SubmissionId
, ''FileId , ''FileId
, ''UserId , ''UserId
, ''SchoolId
] ]
instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where

220
src/Foundation.hs
View File

@ -97,6 +97,8 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission
instance DisplayAble TermId where instance DisplayAble TermId where
display = termToText . unTermKey display = termToText . unTermKey
instance DisplayAble SchoolId where
display = CI.original . unSchoolKey
-- infixl 9 :$: -- infixl 9 :$:
-- pattern a :$: b = a b -- pattern a :$: b = a b
@ -134,11 +136,11 @@ type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
type MsgRenderer = MsgRendererS UniWorX -- see Utils type MsgRenderer = MsgRendererS UniWorX -- see Utils
-- Pattern Synonyms for convenience -- Pattern Synonyms for convenience
pattern CSheetR tid csh shn ptn pattern CSheetR tid ssh csh shn ptn
= CourseR tid csh (SheetR shn ptn) = CourseR tid ssh csh (SheetR shn ptn)
pattern CSubmissionR tid csh shn cid ptn pattern CSubmissionR tid ssh csh shn cid ptn
= CSheetR tid csh shn (SubmissionR cid ptn) = CSheetR tid ssh csh shn (SubmissionR cid ptn)
-- Menus and Favourites -- Menus and Favourites
data MenuItem = MenuItem data MenuItem = MenuItem
@ -267,12 +269,13 @@ falseAP = APPure . const . const $ Unauthorized . ($ MsgUnauthorized) . render <
adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes) adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes)
adminAP = APDB $ \route _ -> case route of adminAP = APDB $ \route _ -> case route of
-- Courses: access only to school admins -- Courses: access only to school admins
CourseR tid csh _ -> exceptT return return $ do CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool
E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64)) return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
@ -295,12 +298,13 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
return $ bool (Unauthorized "Deprecated Route") Authorized allow return $ bool (Unauthorized "Deprecated Route") Authorized allow
) )
,("lecturer", APDB $ \route _ -> case route of ,("lecturer", APDB $ \route _ -> case route of
CourseR tid csh _ -> exceptT return return $ do CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse
E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId E.where_ $ lecturer E.^. LecturerUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64)) return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer) guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
@ -321,18 +325,18 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
resMap :: Map CourseId (Set SheetId) resMap :: Map CourseId (Set SheetId)
resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
case route of case route of
CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
Submission{..} <- MaybeT . lift $ get sid Submission{..} <- MaybeT . lift $ get sid
guard $ maybe False (== authId) submissionRatingBy guard $ maybe False (== authId) submissionRatingBy
return Authorized return Authorized
CSheetR tid csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do
Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn
guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid)
return Authorized return Authorized
CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do
Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
guard $ cid `Set.member` Map.keysSet resMap guard $ cid `Set.member` Map.keysSet resMap
return Authorized return Authorized
_ -> do _ -> do
@ -340,8 +344,8 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
return Authorized return Authorized
) )
,("time", APDB $ \route _ -> case route of ,("time", APDB $ \route _ -> case route of
CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
cTime <- liftIO getCurrentTime cTime <- liftIO getCurrentTime
let let
@ -360,8 +364,8 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
return Authorized return Authorized
CourseR tid csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
cTime <- (NTop . Just) <$> liftIO getCurrentTime cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop courseRegisterFrom <= cTime guard $ NTop courseRegisterFrom <= cTime
&& NTop courseRegisterTo >= cTime && NTop courseRegisterTo >= cTime
@ -370,12 +374,13 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
r -> $unsupportedAuthPredicate "time" r r -> $unsupportedAuthPredicate "time" r
) )
,("registered", APDB $ \route _ -> case route of ,("registered", APDB $ \route _ -> case route of
CourseR tid csh _ -> exceptT return return $ do CourseR tid ssh csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val authId
E.&&. course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
return (E.countRows :: E.SqlExpr (E.Value Int64)) return (E.countRows :: E.SqlExpr (E.Value Int64))
guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant) guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
@ -383,22 +388,22 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
r -> $unsupportedAuthPredicate "registered" r r -> $unsupportedAuthPredicate "registered" r
) )
,("capacity", APDB $ \route _ -> case route of ,("capacity", APDB $ \route _ -> case route of
CourseR tid csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do
Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
guard $ NTop courseCapacity > NTop (Just registered) guard $ NTop courseCapacity > NTop (Just registered)
return Authorized return Authorized
r -> $unsupportedAuthPredicate "capacity" r r -> $unsupportedAuthPredicate "capacity" r
) )
,("materials", APDB $ \route _ -> case route of ,("materials", APDB $ \route _ -> case route of
CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
guard courseMaterialFree guard courseMaterialFree
return Authorized return Authorized
r -> $unsupportedAuthPredicate "materials" r r -> $unsupportedAuthPredicate "materials" r
) )
,("owner", APDB $ \route _ -> case route of ,("owner", APDB $ \route _ -> case route of
CSubmissionR _ _ _ cID _ -> exceptT return return $ do CSubmissionR _ _ _ _ cID _ -> exceptT return return $ do
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
@ -406,7 +411,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
r -> $unsupportedAuthPredicate "owner" r r -> $unsupportedAuthPredicate "owner" r
) )
,("rated", APDB $ \route _ -> case route of ,("rated", APDB $ \route _ -> case route of
CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionRated) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
sub <- MaybeT $ get sid sub <- MaybeT $ get sid
guard $ submissionRatingDone sub guard $ submissionRatingDone sub
@ -476,14 +481,14 @@ instance Yesod UniWorX where
updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do
route <- MaybeT getCurrentRoute route <- MaybeT getCurrentRoute
case route of -- update Course Favourites here case route of -- update Course Favourites here
CourseR tid csh _ -> do CourseR tid ssh csh _ -> do
void . lift . runDB . runMaybeT $ do void . lift . runDB . runMaybeT $ do
guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid csh CShowR) False guardM . lift $ (== Authorized) <$> evalAccessDB (CourseR tid ssh csh CShowR) False
$logDebugS "updateFavourites" "Updating favourites" $logDebugS "updateFavourites" "Updating favourites"
now <- liftIO $ getCurrentTime now <- liftIO $ getCurrentTime
uid <- MaybeT $ liftHandlerT maybeAuthId uid <- MaybeT $ liftHandlerT maybeAuthId
cid <- MaybeT . getKeyBy $ CourseTermShort tid csh cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
user <- MaybeT $ get uid user <- MaybeT $ get uid
let courseFavourite = CourseFavourite uid now cid let courseFavourite = CourseFavourite uid now cid
@ -546,7 +551,7 @@ instance Yesod UniWorX where
return (favs, userTheme user) return (favs, userTheme user)
favourites <- forM favourites' $ \(Entity _ c@Course{..}) favourites <- forM favourites' $ \(Entity _ c@Course{..})
-> let -> let
courseRoute = CourseR courseTerm courseShorthand CShowR courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR
in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute) in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute)
let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority let highlight :: Route UniWorX -> Bool -- highlight last route in breadcrumbs, favorites taking priority
@ -666,27 +671,29 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid) breadcrumb (TermEditExistR tid) = return ("Editieren" , Just $ TermCourseListR tid)
breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR) breadcrumb (TermCourseListR (unTermKey -> tid)) = getMessageRender <&> \mr -> (mr $ ShortTermIdentifier tid, Just TermShowR)
breadcrumb (TermSchoolCourseListR tid ssh) = return (CI.original $ unSchoolKey ssh, Just $ TermCourseListR tid)
breadcrumb CourseListR = return ("Kurse" , Just HomeR) breadcrumb CourseListR = return ("Kurse" , Just HomeR)
breadcrumb CourseNewR = return ("Neu" , Just CourseListR) breadcrumb CourseNewR = return ("Neu" , Just CourseListR)
breadcrumb (CourseR tid csh CShowR) = return (CI.original csh, Just $ TermCourseListR tid) breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ TermSchoolCourseListR tid ssh)
-- (CourseR tid csh CRegisterR) -- is POST only -- (CourseR tid ssh csh CRegisterR) -- is POST only
breadcrumb (CourseR tid csh CEditR) = return ("Editieren", Just $ CourseR tid csh CShowR) breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren", Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid csh CShowR) breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid csh SheetListR) = return ("Übungen" , Just $ CourseR tid csh CShowR) breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR)
breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR) breadcrumb (CourseR tid ssh csh SheetNewR ) = return ("Neu", Just $ CourseR tid ssh csh SheetListR)
breadcrumb (CSheetR tid csh shn SShowR) = return (CI.original shn, Just $ CourseR tid csh SheetListR) breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR)
breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSheetR tid csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
breadcrumb (CSubmissionR tid csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSubmissionR tid ssh csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR)
-- (CSubmissionR tid csh shn _ SubArchiveR) -- just for Download -- (CSubmissionR tid ssh csh shn _ SubArchiveR) -- just for Download
breadcrumb (CSubmissionR tid csh shn cid CorrectionR) = return ("Korrektur", Just $ CSubmissionR tid csh shn cid SubShowR) breadcrumb (CSubmissionR tid ssh csh shn cid CorrectionR) = return ("Korrektur", Just $ CSubmissionR tid ssh csh shn cid SubShowR)
-- (CSubmissionR tid csh shn _ SubDownloadR) -- just for Download -- (CSubmissionR tid ssh csh shn _ SubDownloadR) -- just for Download
breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR) breadcrumb (CSheetR tid ssh csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid ssh csh shn SShowR)
-- (CSheetR tid csh shn SFileR) -- just for Downloads -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads
-- Others -- Others
breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR) breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR)
breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR) breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR)
@ -826,22 +833,22 @@ pageActions (CourseListR) =
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CourseR tid csh CShowR) = pageActions (CourseR tid ssh csh CShowR) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Kurs Editieren" { menuItemLabel = "Kurs Editieren"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh CEditR , menuItemRoute = CourseR tid ssh csh CEditR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , PageActionPrime $ MenuItem
{ menuItemLabel = "Übungsblätter" { menuItemLabel = "Übungsblätter"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh SheetListR , menuItemRoute = CourseR tid ssh csh SheetListR
, menuItemAccessCallback' = do --TODO always show for lecturer , menuItemAccessCallback' = do --TODO always show for lecturer
let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid csh shn SShowR) False) let sheetRouteAccess shn = (== Authorized) <$> (isAuthorized (CSheetR tid ssh csh shn SShowR) False)
muid <- maybeAuthId muid <- maybeAuthId
(sheets,lecturer) <- runDB $ do (sheets,lecturer) <- runDB $ do
cid <- getKeyBy404 $ CourseTermShort tid csh cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom] sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
lecturer <- case muid of lecturer <- case muid of
Nothing -> return False Nothing -> return False
@ -852,29 +859,29 @@ pageActions (CourseR tid csh CShowR) =
, PageActionPrime $ MenuItem , PageActionPrime $ MenuItem
{ menuItemLabel = "Abgaben" { menuItemLabel = "Abgaben"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh CCorrectionsR , menuItemRoute = CourseR tid ssh csh CCorrectionsR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionSecondary $ MenuItem , PageActionSecondary $ MenuItem
{ menuItemLabel = "Neues Übungsblatt anlegen" { menuItemLabel = "Neues Übungsblatt anlegen"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh SheetNewR , menuItemRoute = CourseR tid ssh csh SheetNewR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CourseR tid csh SheetListR) = pageActions (CourseR tid ssh csh SheetListR) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Neues Übungsblatt anlegen" { menuItemLabel = "Neues Übungsblatt anlegen"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CourseR tid csh SheetNewR , menuItemRoute = CourseR tid ssh csh SheetNewR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CSheetR tid csh shn SShowR) = pageActions (CSheetR tid ssh csh shn SShowR) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Abgabe anlegen" { menuItemLabel = "Abgabe anlegen"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SubmissionNewR , menuItemRoute = CSheetR tid ssh csh shn SubmissionNewR
, menuItemAccessCallback' = runDB . maybeT (return False) $ do , menuItemAccessCallback' = runDB . maybeT (return False) $ do
uid <- MaybeT $ liftHandlerT maybeAuthId uid <- MaybeT $ liftHandlerT maybeAuthId
submissions <- lift $ submissionList tid csh shn uid submissions <- lift $ submissionList tid csh shn uid
@ -884,7 +891,7 @@ pageActions (CSheetR tid csh shn SShowR) =
, PageActionPrime $ MenuItem , PageActionPrime $ MenuItem
{ menuItemLabel = "Abgabe ansehen" { menuItemLabel = "Abgabe ansehen"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SubmissionOwnR , menuItemRoute = CSheetR tid ssh csh shn SubmissionOwnR
, menuItemAccessCallback' = runDB . maybeT (return False) $ do , menuItemAccessCallback' = runDB . maybeT (return False) $ do
uid <- MaybeT $ liftHandlerT maybeAuthId uid <- MaybeT $ liftHandlerT maybeAuthId
submissions <- lift $ submissionList tid csh shn uid submissions <- lift $ submissionList tid csh shn uid
@ -894,43 +901,43 @@ pageActions (CSheetR tid csh shn SShowR) =
, PageActionPrime $ MenuItem , PageActionPrime $ MenuItem
{ menuItemLabel = "Korrektoren" { menuItemLabel = "Korrektoren"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SCorrR , menuItemRoute = CSheetR tid ssh csh shn SCorrR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , PageActionPrime $ MenuItem
{ menuItemLabel = "Abgaben" { menuItemLabel = "Abgaben"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SSubsR , menuItemRoute = CSheetR tid ssh csh shn SSubsR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
, PageActionPrime $ MenuItem , PageActionPrime $ MenuItem
{ menuItemLabel = "Blatt Editieren" { menuItemLabel = "Blatt Editieren"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SEditR , menuItemRoute = CSheetR tid ssh csh shn SEditR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CSheetR tid csh shn SSubsR) = pageActions (CSheetR tid ssh csh shn SSubsR) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Korrektoren" { menuItemLabel = "Korrektoren"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SCorrR , menuItemRoute = CSheetR tid ssh csh shn SCorrR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CSubmissionR tid csh shn cid SubShowR) = pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Korrektur" { menuItemLabel = "Korrektur"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSubmissionR tid csh shn cid CorrectionR , menuItemRoute = CSubmissionR tid ssh csh shn cid CorrectionR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
pageActions (CSheetR tid csh shn SCorrR) = pageActions (CSheetR tid ssh csh shn SCorrR) =
[ PageActionPrime $ MenuItem [ PageActionPrime $ MenuItem
{ menuItemLabel = "Abgaben" { menuItemLabel = "Abgaben"
, menuItemIcon = Nothing , menuItemIcon = Nothing
, menuItemRoute = CSheetR tid csh shn SSubsR , menuItemRoute = CSheetR tid ssh csh shn SSubsR
, menuItemAccessCallback' = return True , menuItemAccessCallback' = return True
} }
] ]
@ -977,45 +984,49 @@ pageHeading (TermEditExistR tid)
= Just $ i18nHeading $ MsgTermEditTid tid = Just $ i18nHeading $ MsgTermEditTid tid
pageHeading (TermCourseListR tid) pageHeading (TermCourseListR tid)
= Just . i18nHeading . MsgTermCourseListHeading $ tid = Just . i18nHeading . MsgTermCourseListHeading $ tid
pageHeading (TermSchoolCourseListR tid ssh)
= Just $ do
School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh
i18nHeading $ MsgTermSchoolCourseListHeading tid school
pageHeading (CourseListR) pageHeading (CourseListR)
= Just $ i18nHeading $ MsgCourseListTitle = Just $ i18nHeading $ MsgCourseListTitle
pageHeading CourseNewR pageHeading CourseNewR
= Just $ i18nHeading MsgCourseNewHeading = Just $ i18nHeading MsgCourseNewHeading
pageHeading (CourseR tid csh CShowR) pageHeading (CourseR tid ssh csh CShowR)
= Just $ do = Just $ do
Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ CourseTermShort tid csh Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
toWidget courseName toWidget courseName
-- (CourseR tid csh CRegisterR) -- just for POST -- (CourseR tid csh CRegisterR) -- just for POST
pageHeading (CourseR tid csh CEditR) pageHeading (CourseR tid ssh csh CEditR)
= Just $ i18nHeading $ MsgCourseEditHeading tid csh = Just $ i18nHeading $ MsgCourseEditHeading tid ssh csh
pageHeading (CourseR tid csh CCorrectionsR) pageHeading (CourseR tid ssh csh CCorrectionsR)
= Just $ i18nHeading $ MsgSubmissionsCourse tid csh = Just $ i18nHeading $ MsgSubmissionsCourse tid ssh csh
pageHeading (CourseR tid csh SheetListR) pageHeading (CourseR tid ssh csh SheetListR)
= Just $ i18nHeading $ MsgSheetList tid csh = Just $ i18nHeading $ MsgSheetList tid ssh csh
pageHeading (CourseR tid csh SheetNewR) pageHeading (CourseR tid ssh csh SheetNewR)
= Just $ i18nHeading $ MsgSheetNewHeading tid csh = Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh
pageHeading (CSheetR tid csh shn SShowR) pageHeading (CSheetR tid ssh csh shn SShowR)
= Just $ i18nHeading $ MsgSheetTitle tid csh shn = Just $ i18nHeading $ MsgSheetTitle tid ssh csh shn
pageHeading (CSheetR tid csh shn SEditR) pageHeading (CSheetR tid ssh csh shn SEditR)
= Just $ i18nHeading $ MsgSheetEditHead tid csh shn = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn
pageHeading (CSheetR tid csh shn SDelR) pageHeading (CSheetR tid ssh csh shn SDelR)
= Just $ i18nHeading $ MsgSheetDelHead tid csh shn = Just $ i18nHeading $ MsgSheetDelHead tid ssh csh shn
pageHeading (CSheetR tid csh shn SSubsR) pageHeading (CSheetR tid ssh csh shn SSubsR)
= Just $ i18nHeading $ MsgSubmissionsSheet shn = Just $ i18nHeading $ MsgSubmissionsSheet shn
pageHeading (CSheetR tid csh shn SubmissionNewR) pageHeading (CSheetR tid ssh csh shn SubmissionNewR)
= Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
pageHeading (CSheetR tid csh shn SubmissionOwnR) pageHeading (CSheetR tid ssh csh shn SubmissionOwnR)
= Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
pageHeading (CSubmissionR tid csh shn _ SubShowR) -- TODO: Rethink this one! pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one!
= Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn
-- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download -- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download
pageHeading (CSubmissionR tid csh shn cid CorrectionR) pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR)
= Just $ i18nHeading $ MsgCorrectionHead tid csh shn cid = Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid
-- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download -- (CSubmissionR tid csh shn cid SubDownloadR) -- just a download
pageHeading (CSheetR tid csh shn SCorrR) pageHeading (CSheetR tid ssh csh shn SCorrR)
= Just $ i18nHeading $ MsgCorrectorsHead shn = Just $ i18nHeading $ MsgCorrectorsHead shn
-- (CSheetR tid csh shn SFileR) -- just for Downloads -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads
pageHeading CorrectionsR pageHeading CorrectionsR
= Just $ i18nHeading MsgCorrectionsTitle = Just $ i18nHeading MsgCorrectionsTitle
@ -1030,6 +1041,7 @@ pageHeading _
routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)] routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)]
routeNormalizers = routeNormalizers =
[ normalizeRender [ normalizeRender
, ncSchool
, ncCourse , ncCourse
, ncSheet , ncSheet
] ]
@ -1050,17 +1062,25 @@ routeNormalizers =
$logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|] $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|]
tell $ Any True tell $ Any True
| otherwise = return () | otherwise = return ()
ncSchool = maybeOrig $ \route -> do
TermSchoolCourseListR tid ssh <- return route
let schoolShort :: SchoolShorthand
schoolShort = unSchoolKey ssh
Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
(hasChanged `on` unSchoolKey)ssh ssh'
return $ TermSchoolCourseListR tid ssh'
ncCourse = maybeOrig $ \route -> do ncCourse = maybeOrig $ \route -> do
CourseR tid csh subRoute <- return route CourseR tid ssh csh subRoute <- return route
Entity _ Course{..} <- MaybeT . lift . getBy $ CourseTermShort tid csh Entity _ Course{..} <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
hasChanged csh courseShorthand hasChanged csh courseShorthand
return $ CourseR tid courseShorthand subRoute (hasChanged `on` unSchoolKey) ssh courseSchool
return $ CourseR tid courseSchool courseShorthand subRoute
ncSheet = maybeOrig $ \route -> do ncSheet = maybeOrig $ \route -> do
CSheetR tid csh shn subRoute <- return route CSheetR tid ssh csh shn subRoute <- return route
Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh
Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn
hasChanged shn sheetName hasChanged shn sheetName
return $ CSheetR tid csh sheetName subRoute return $ CSheetR tid ssh csh sheetName subRoute
-- How to run database actions. -- How to run database actions.

78
src/Handler/Corrections.hs
View File

@ -86,17 +86,19 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse) colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(_, _, course, _, _) } -> $ \DBRow{ dbrOutput=(_, _, course, _, _) } ->
let tid = course ^. _3 let csh = course ^. _2
csh = course ^. _2 tid = course ^. _3
in anchorCell (CourseR tid csh CShowR) [whamlet|#{display csh}|] ssh = course ^. _4
in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|]
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSheet = sortable (Just "sheet") (i18nCell MsgSheet) colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
$ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } ->
let tid = course ^. _3 let csh = course ^. _2
csh = course ^. _2 tid = course ^. _3
ssh = course ^. _4
shn = sheetName $ entityVal sheet shn = sheetName $ entityVal sheet
in anchorCell (CSheetR tid csh shn SShowR) [whamlet|#{display shn}|] in anchorCell (CSheetR tid ssh csh shn SShowR) [whamlet|#{display shn}|]
colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
@ -106,13 +108,14 @@ colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission) colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
$ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } ->
let tid = course ^. _3 let csh = course ^. _2
csh = course ^. _2 tid = course ^. _3
ssh = course ^. _4
shn = sheetName $ entityVal sheet shn = sheetName $ entityVal sheet
mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice
mkRoute = do mkRoute = do
cid <- mkCid cid <- mkCid
return $ CSubmissionR tid csh shn cid SubShowR return $ CSubmissionR tid ssh csh shn cid SubShowR
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|])
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool))) colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
@ -125,12 +128,13 @@ colSubmittors = sortable Nothing (i18nCell MsgSubmissionUsers) $ \DBRow{ dbrOutp
colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colRating :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } -> colRating = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } ->
let tid = course ^. _3 let csh = course ^. _2
csh = course ^. _2 tid = course ^. _3
ssh = course ^. _4
-- shn = sheetName -- shn = sheetName
mkRoute = do mkRoute = do
cid <- encrypt subId cid <- encrypt subId
return $ CSubmissionR tid csh sheetName cid CorrectionR return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
in anchorCellM mkRoute $(widgetFile "widgets/rating") in anchorCellM mkRoute $(widgetFile "widgets/rating")
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
@ -340,10 +344,10 @@ postCorrectionsR = do
[ downloadAction [ downloadAction
] ]
getCCorrectionsR, postCCorrectionsR :: TermId -> CourseShorthand -> Handler TypedContent getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
getCCorrectionsR = postCCorrectionsR getCCorrectionsR = postCCorrectionsR
postCCorrectionsR tid csh = do postCCorrectionsR tid ssh csh = do
Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh
let whereClause = courseIs cid let whereClause = courseIs cid
colonnade = mconcat colonnade = mconcat
[ colSelect [ colSelect
@ -360,10 +364,10 @@ postCCorrectionsR tid csh = do
, assignAction (Left cid) , assignAction (Left cid)
] ]
getSSubsR, postSSubsR :: TermId -> CourseShorthand -> SheetName -> Handler TypedContent getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
getSSubsR = postSSubsR getSSubsR = postSSubsR
postSSubsR tid csh shn = do postSSubsR tid ssh csh shn = do
shid <- runDB $ fetchSheetId tid csh shn shid <- runDB $ fetchSheetId tid ssh csh shn
let whereClause = sheetIs shid let whereClause = sheetIs shid
colonnade = mconcat colonnade = mconcat
[ colSelect [ colSelect
@ -380,26 +384,26 @@ postSSubsR tid csh shn = do
, autoAssignAction shid , autoAssignAction shid
] ]
correctionData tid csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. sheet E.^. SheetName E.==. E.val shn
E.&&. submission E.^. SubmissionId E.==. E.val sub E.&&. submission E.^. SubmissionId E.==. E.val sub
return (course, sheet, submission, corrector) return (course, sheet, submission, corrector)
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getCorrectionR tid csh shn cid = do getCorrectionR tid ssh csh shn cid = do
mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True
bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid csh shn cid bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid
postCorrectionR tid csh shn cid = do postCorrectionR tid ssh csh shn cid = do
sub <- decrypt cid sub <- decrypt cid
results <- runDB $ correctionData tid csh shn sub results <- runDB $ correctionData tid ssh csh shn sub
case results of case results of
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector)] -> do
@ -424,14 +428,14 @@ postCorrectionR tid csh shn cid = do
let rated = isJust $ void ratingPoints <|> void ratingComment let rated = isJust $ void ratingPoints <|> void ratingComment
update sub [ SubmissionRatingBy =. (uid <$ guard rated) update sub [ SubmissionRatingBy =. (uid <$ guard rated)
, SubmissionRatingTime =. (now <$ guard rated) , SubmissionRatingTime =. (now <$ guard rated)
, SubmissionRatingPoints =. ratingPoints , SubmissionRatingPoints =. ratingPoints
, SubmissionRatingComment =. ratingComment , SubmissionRatingComment =. ratingComment
] ]
addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated
redirect $ CSubmissionR tid csh shn cid CorrectionR redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
case uploadResult of case uploadResult of
FormMissing -> return () FormMissing -> return ()
@ -442,16 +446,16 @@ postCorrectionR tid csh shn cid = do
runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
addMessageI "success" MsgRatingFilesUpdated addMessageI "success" MsgRatingFilesUpdated
redirect $ CSubmissionR tid csh shn cid CorrectionR redirect $ CSubmissionR tid ssh csh shn cid CorrectionR
defaultLayout $ do defaultLayout $ do
let userCorrection = $(widgetFile "correction-user") let userCorrection = $(widgetFile "correction-user")
$(widgetFile "correction") $(widgetFile "correction")
_ -> notFound _ -> notFound
getCorrectionUserR tid csh shn cid = do getCorrectionUserR tid ssh csh shn cid = do
sub <- decrypt cid sub <- decrypt cid
results <- runDB $ correctionData tid csh shn sub results <- runDB $ correctionData tid ssh csh shn sub
case results of case results of
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do

114
src/Handler/Course.hs
View File

@ -39,13 +39,13 @@ type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School)
colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse) colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
anchorCell (CourseR courseTerm courseShorthand CShowR) anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
[whamlet|#{display courseName}|] [whamlet|#{display courseName}|]
colCourseDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCourseDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) colCourseDescr = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
( anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseName}|] ) ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseName}|] )
( case courseDescription of ( case courseDescription of
Nothing -> mempty Nothing -> mempty
(Just descr) -> cell [whamlet| <span style="float:right"> ^{modalStatic descr} |] (Just descr) -> cell [whamlet| <span style="float:right"> ^{modalStatic descr} |]
@ -61,12 +61,12 @@ colDescription = sortable Nothing (i18nCell MsgCourseDescription)
colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseShorthand}|] anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort) colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
( anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseShorthand}|] ) ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
( case courseDescription of ( case courseDescription of
Nothing -> mempty Nothing -> mempty
(Just descr) -> cell (Just descr) -> cell
@ -80,13 +80,13 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm)
colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
$ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
cell [whamlet|#{display schoolName}|] anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|]
colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
$ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } -> $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } ->
cell [whamlet|#{display schoolShorthand}|] anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|]
colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
@ -201,6 +201,30 @@ getTermCurrentR = do
(Just (maximum -> tid)) -> -- getTermCourseListR tid (Just (maximum -> tid)) -> -- getTermCourseListR tid
redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc. redirect $ TermCourseListR tid -- redirect avoids problematic breadcrumbs, headings, etc.
getTermSchoolCourseListR :: TermId -> SchoolId -> Handler Html
getTermSchoolCourseListR tid ssh = do
void . runDB $ get404 tid -- Just ensure the term exists
School{schoolName=school} <- runDB $ get404 ssh -- Just ensure the term exists
muid <- maybeAuthId
let colonnade = widgetColonnade $ mconcat
[ dbRow
, colCShortDescr
, colRegFrom
, colRegTo
, colParticipants
, maybe mempty (const colRegistered) muid
]
whereClause = \(course, _, _) ->
course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
validator = def
& defaultSorting [("cshort", SortAsc)]
((), coursesTable) <- makeCourseTable whereClause colonnade validator
defaultLayout $ do
setTitleI $ MsgTermSchoolCourseListTitle tid school
$(widgetFile "courses")
getTermCourseListR :: TermId -> Handler Html getTermCourseListR :: TermId -> Handler Html
getTermCourseListR tid = do getTermCourseListR tid = do
void . runDB $ get404 tid -- Just ensure the term exists void . runDB $ get404 tid -- Just ensure the term exists
@ -222,13 +246,13 @@ getTermCourseListR tid = do
setTitleI . MsgTermCourseListTitle $ tid setTitleI . MsgTermCourseListTitle $ tid
$(widgetFile "courses") $(widgetFile "courses")
getCShowR :: TermId -> CourseShorthand -> Handler Html getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid csh = do getCShowR tid ssh csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
(courseEnt,(schoolMB,participants,registered)) <- runDB $ do (courseEnt,(schoolMB,participants,registered)) <- runDB $ do
courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
dependent <- (,,) dependent <- (,,)
<$> get (courseSchool course) -- join <$> get (courseSchool course) -- join -- just fetch full school name here
<*> count [CourseParticipantCourse ==. cid] -- join <*> count [CourseParticipantCourse ==. cid] -- join
<*> (case mbAid of -- TODO: Someone please refactor this late-night mess here! <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
Nothing -> return False Nothing -> return False
@ -238,7 +262,7 @@ getCShowR tid csh = do
return $ (courseEnt,dependent) return $ (courseEnt,dependent)
let course = entityVal courseEnt let course = entityVal courseEnt
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid csh CRegisterR) True registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
defaultLayout $ do defaultLayout $ do
@ -258,11 +282,11 @@ registerForm registered msecret extra = do
return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
postCRegisterR :: TermId -> CourseShorthand -> Handler Html postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCRegisterR tid csh = do postCRegisterR tid ssh csh = do
aid <- requireAuthId aid <- requireAuthId
(cid, course, registered) <- runDB $ do (cid, course, registered) <- runDB $ do
(Entity cid course) <- getBy404 $ CourseTermShort tid csh (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
registered <- isJust <$> (getBy $ UniqueParticipant aid cid) registered <- isJust <$> (getBy $ UniqueParticipant aid cid)
return (cid, course, registered) return (cid, course, registered)
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
@ -277,7 +301,7 @@ postCRegisterR tid csh = do
when (isJust regOk) $ addMessageI "success" MsgCourseRegisterOk when (isJust regOk) $ addMessageI "success" MsgCourseRegisterOk
| otherwise -> addMessageI "danger" MsgCourseSecretWrong | otherwise -> addMessageI "danger" MsgCourseSecretWrong
(_other) -> return () -- TODO check this! (_other) -> return () -- TODO check this!
redirect $ CourseR tid csh CShowR redirect $ CourseR tid ssh csh CShowR
getCourseNewR :: Handler Html getCourseNewR :: Handler Html
getCourseNewR = do getCourseNewR = do
@ -287,14 +311,14 @@ getCourseNewR = do
postCourseNewR :: Handler Html postCourseNewR :: Handler Html
postCourseNewR = courseEditHandler False Nothing postCourseNewR = courseEditHandler False Nothing
getCEditR :: TermId -> CourseShorthand -> Handler Html getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCEditR tid csh = do getCEditR tid ssh csh = do
course <- runDB $ getBy $ CourseTermShort tid csh course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
courseEditHandler True course courseEditHandler True course
postCEditR :: TermId -> CourseShorthand -> Handler Html postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postCEditR tid csh = do postCEditR tid ssh csh = do
course <- runDB $ getBy $ CourseTermShort tid csh course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh
courseEditHandler False course courseEditHandler False course
@ -317,6 +341,7 @@ courseEditHandler isGet course = do
(FormSuccess res@( (FormSuccess res@(
CourseForm { cfCourseId = Nothing CourseForm { cfCourseId = Nothing
, cfShort = csh , cfShort = csh
, cfSchool = ssh
, cfTerm = tid , cfTerm = tid
})) -> do -- create new course })) -> do -- create new course
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
@ -339,14 +364,15 @@ courseEditHandler isGet course = do
runDB $ do runDB $ do
insert_ $ CourseEdit aid now cid insert_ $ CourseEdit aid now cid
insert_ $ Lecturer aid cid insert_ $ Lecturer aid cid
addMessageI "info" $ MsgCourseNewOk tid csh addMessageI "info" $ MsgCourseNewOk tid ssh csh
redirect $ TermCourseListR tid redirect $ TermCourseListR tid
Nothing -> Nothing ->
addMessageI "danger" $ MsgCourseNewDupShort tid csh addMessageI "danger" $ MsgCourseNewDupShort tid ssh csh
(FormSuccess res@( (FormSuccess res@(
CourseForm { cfCourseId = Just cid CourseForm { cfCourseId = Just cid
, cfShort = csh , cfShort = csh
, cfSchool = ssh
, cfTerm = tid , cfTerm = tid
})) -> do -- edit existing course })) -> do -- edit existing course
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
@ -372,12 +398,12 @@ courseEditHandler isGet course = do
} }
) )
case updOkay of case updOkay of
(Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid csh) $> False (Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid ssh csh) $> False
Nothing -> do Nothing -> do
insert_ $ CourseEdit aid now cid insert_ $ CourseEdit aid now cid
addMessageI "success" $ MsgCourseEditOk tid csh addMessageI "success" $ MsgCourseEditOk tid ssh csh
return True return True
when success $ redirect $ CourseR tid csh CShowR when success $ redirect $ CourseR tid ssh csh CShowR
(FormFailure _) -> addMessageI "warning" MsgInvalidInput (FormFailure _) -> addMessageI "warning" MsgInvalidInput
(FormMissing) -> return () (FormMissing) -> return ()
@ -429,7 +455,6 @@ newCourseForm template = identForm FIDcourse $ \html -> do
[ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] [] [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. userId] []
, map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] [] , map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. userId] []
] ]
let schoolField = selectField $ fmap entityKey <$> optionsPersistCryptoId [SchoolId <-. userSchools] [Asc SchoolName] schoolName
(result, widget) <- flip (renderAForm FormStandard) html $ CourseForm (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm
<$> pure (cfCourseId =<< template) <$> pure (cfCourseId =<< template)
<*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template) <*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template)
@ -440,24 +465,19 @@ newCourseForm template = identForm FIDcourse $ \html -> do
-- & addAttr "disabled" "disabled" -- & addAttr "disabled" "disabled"
& setTooltip MsgCourseShorthandUnique) & setTooltip MsgCourseShorthandUnique)
(cfShort <$> template) (cfShort <$> template)
<*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template) <*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template)
<*> areq schoolField (fslI MsgCourseSchool) (cfSchool <$> template) <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template)
<*> aopt (natField "Kapazität") (fslI MsgCourseCapacity <*> aopt (natField "Kapazität") (fslI MsgCourseCapacity
& setTooltip MsgCourseCapacityTip & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template)
) (cfCapacity <$> template) <*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette"
<*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette" & setTooltip MsgCourseSecretTip) (cfSecret <$> template)
& setTooltip MsgCourseSecretTip) <*> areq checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template)
(cfSecret <$> template) <*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum"
<*> areq checkBoxField (fslI MsgMaterialFree)(cfMatFree <$> template) & setTooltip MsgCourseRegisterFromTip) (cfRegFrom <$> template)
<*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum" <*> aopt utcTimeField (fslpI MsgRegisterTo "Datum"
& setTooltip MsgCourseRegisterFromTip) & setTooltip MsgCourseRegisterToTip) (cfRegTo <$> template)
(cfRegFrom <$> template) <*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum"
<*> aopt utcTimeField (fslpI MsgRegisterTo "Datum" & setTooltip MsgCourseDeregisterUntilTip) (cfDeRegUntil <$> template)
& setTooltip MsgCourseRegisterToTip)
(cfRegTo <$> template)
<*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum"
& setTooltip MsgCourseDeregisterUntilTip)
(cfDeRegUntil <$> template)
<* submitButton <* submitButton
return $ case result of return $ case result of
FormSuccess courseResult FormSuccess courseResult

12
src/Handler/CryptoIDDispatch.hs
View File

@ -38,23 +38,23 @@ instance CryptoRoute UUID SubmissionId where
cryptoIDRoute _ (CryptoID -> cID) = do cryptoIDRoute _ (CryptoID -> cID) = do
(smid :: SubmissionId) <- decrypt cID (smid :: SubmissionId) <- decrypt cID
cID' <- encrypt smid cID' <- encrypt smid
(tid,csh,shn) <- runDB $ do (tid,ssh,csh,shn) <- runDB $ do
shid <- submissionSheet <$> get404 smid shid <- submissionSheet <$> get404 smid
Sheet{..} <- get404 shid Sheet{..} <- get404 shid
Course{..} <- get404 sheetCourse Course{..} <- get404 sheetCourse
return (courseTerm, courseShorthand, sheetName) return (courseTerm, courseSchool, courseShorthand, sheetName)
return $ CSubmissionR tid csh shn cID' SubShowR return $ CSubmissionR tid ssh csh shn cID' SubShowR
instance CryptoRoute (CI FilePath) SubmissionId where instance CryptoRoute (CI FilePath) SubmissionId where
cryptoIDRoute _ ciphertext cryptoIDRoute _ ciphertext
| Just cID <- fromPathPiece . Text.pack $ CI.original ciphertext = do | Just cID <- fromPathPiece . Text.pack $ CI.original ciphertext = do
smid <- decrypt cID smid <- decrypt cID
(tid,csh,shn) <- runDB $ do (tid,ssh,csh,shn) <- runDB $ do
shid <- submissionSheet <$> get404 smid shid <- submissionSheet <$> get404 smid
Sheet{..} <- get404 shid Sheet{..} <- get404 shid
Course{..} <- get404 sheetCourse Course{..} <- get404 sheetCourse
return (courseTerm, courseShorthand, sheetName) return (courseTerm, courseSchool, courseShorthand, sheetName)
return $ CSubmissionR tid csh shn cID SubShowR return $ CSubmissionR tid ssh csh shn cID SubShowR
| otherwise = notFound | otherwise = notFound
instance CryptoRoute UUID UserId where instance CryptoRoute UUID UserId where

52
src/Handler/Home.hs
View File

@ -22,12 +22,12 @@ import Data.Time hiding (formatTime)
-- import Web.PathPieces (showToPathPiece, readFromPathPiece) -- import Web.PathPieces (showToPathPiece, readFromPathPiece)
import Control.Lens -- import Control.Lens
import Colonnade hiding (fromMaybe, singleton) -- import Colonnade hiding (fromMaybe, singleton)
-- import Yesod.Colonnade -- import Yesod.Colonnade
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Text.Shakespeare.Text -- import Text.Shakespeare.Text
import Development.GitRev import Development.GitRev
@ -55,7 +55,6 @@ getHomeR = do
homeAnonymous :: Handler Html homeAnonymous :: Handler Html
homeAnonymous = do homeAnonymous = do
cTime <- liftIO getCurrentTime cTime <- liftIO getCurrentTime
let fTime = addUTCTime (offCourseDeadlines * nominalDay) cTime
let tableData :: E.SqlExpr (Entity Course) let tableData :: E.SqlExpr (Entity Course)
-> E.SqlQuery (E.SqlExpr (Entity Course)) -> E.SqlQuery (E.SqlExpr (Entity Course))
tableData course = do tableData course = do
@ -68,12 +67,15 @@ homeAnonymous = do
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ()) colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
colonnade = mconcat colonnade = mconcat
[ -- dbRow [ -- dbRow
sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
let tid = courseTerm course
csh = courseShorthand course
cell [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
, sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
textCell $ display $ courseTerm course textCell $ display $ courseTerm course
, sortable (Just "school") (textCell MsgCourseSchool) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
textCell $ display $ courseSchool course
, sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
let tid = courseTerm course
ssh = courseSchool course
csh = courseShorthand course
anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh)
, sortable (Just "deadline") (textCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> , sortable (Just "deadline") (textCell MsgRegisterTo) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
] ]
@ -85,6 +87,9 @@ homeAnonymous = do
[ ( "term" [ ( "term"
, SortColumn $ \(course) -> course E.^. CourseTerm , SortColumn $ \(course) -> course E.^. CourseTerm
) )
, ( "school"
, SortColumn $ \(course) -> course E.^. CourseSchool
)
, ( "course" , ( "course"
, SortColumn $ \(course) -> course E.^. CourseShorthand , SortColumn $ \(course) -> course E.^. CourseShorthand
) )
@ -116,6 +121,7 @@ homeUser uid = do
-- (E.SqlExpr (Entity Course ))) -- (E.SqlExpr (Entity Course )))
-- (E.SqlExpr (Entity Sheet )) -- (E.SqlExpr (Entity Sheet ))
_ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term)) _ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
, E.SqlExpr (E.Value SchoolId)
, E.SqlExpr (E.Value CourseShorthand) , E.SqlExpr (E.Value CourseShorthand)
, E.SqlExpr (E.Value SheetName) , E.SqlExpr (E.Value SheetName)
, E.SqlExpr (E.Value UTCTime) , E.SqlExpr (E.Value UTCTime)
@ -132,6 +138,7 @@ homeUser uid = do
-- E.limit nrSheetDeadlines -- arbitrary limits are not intuitive -- E.limit nrSheetDeadlines -- arbitrary limits are not intuitive
return return
( course E.^. CourseTerm ( course E.^. CourseTerm
, course E.^. CourseSchool
, course E.^. CourseShorthand , course E.^. CourseShorthand
, sheet E.^. SheetName , sheet E.^. SheetName
, sheet E.^. SheetActiveTo , sheet E.^. SheetActiveTo
@ -139,6 +146,7 @@ homeUser uid = do
) )
colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term) colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term)
, E.Value SchoolId
, E.Value CourseShorthand , E.Value CourseShorthand
, E.Value SheetName , E.Value SheetName
, E.Value UTCTime , E.Value UTCTime
@ -147,30 +155,36 @@ homeUser uid = do
(DBCell (HandlerT UniWorX IO) ()) (DBCell (HandlerT UniWorX IO) ())
colonnade = mconcat colonnade = mconcat
[ -- dbRow [ -- dbRow
sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _, _) } -> -- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } ->
anchorCell (CourseR tid csh CShowR) (toWidget $ display csh) sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } ->
, sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid, _,_,_,_) } ->
textCell $ display tid textCell $ display tid
, sortable (Just "sheet") (textCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, _) } -> , sortable (Just "school") (textCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } ->
anchorCell (CSheetR tid csh shn SShowR) (toWidget $ display shn) textCell $ display ssh
, sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline, _) } -> , sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } ->
anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh)
, sortable (Just "sheet") (textCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } ->
anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget $ display shn)
, sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
cell $ formatTime SelFormatDateTime deadline >>= toWidget cell $ formatTime SelFormatDateTime deadline >>= toWidget
, sortable (Just "done") (textCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, E.Value mbsid) }) -> , sortable (Just "done") (textCell MsgDone) $ \(DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) }) ->
case mbsid of case mbsid of
Nothing -> mempty Nothing -> mempty
(Just sid) -> anchorCellM (CSubmissionR tid csh shn <$> encrypt sid <*> pure SubShowR) (Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
tickmark tickmark
] ]
let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)] let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)]
((), sheetTable) <- dbTable validator $ DBTable ((), sheetTable) <- dbTable validator $ DBTable
{ dbtSQLQuery = tableData { dbtSQLQuery = tableData
, dbtColonnade = colonnade , dbtColonnade = colonnade
, dbtProj = \dbRow@DBRow{ dbrOutput = (E.Value tid, E.Value csh, E.Value shn, _, _) } , dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
-> dbRow <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh shn SShowR) False) -> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "term" [ ( "term"
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm
) )
, ( "school"
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseSchool
)
, ( "course" , ( "course"
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseShorthand , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
) )

8
src/Handler/Profile.hs
View File

@ -99,7 +99,7 @@ getProfileR = do
(E.select $ E.from $ \(lecturer `E.InnerJoin` course) -> do (E.select $ E.from $ \(lecturer `E.InnerJoin` course) -> do
E.where_ $ lecturer ^. LecturerUser E.==. E.val uid E.where_ $ lecturer ^. LecturerUser E.==. E.val uid
E.on $ lecturer ^. LecturerCourse E.==. course ^. CourseId E.on $ lecturer ^. LecturerCourse E.==. course ^. CourseId
return (course ^. CourseShorthand, course ^. CourseTerm) return (course ^. CourseTerm, course ^.CourseSchool, course ^. CourseShorthand)
) )
<*> <*>
(E.select $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do (E.select $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do
@ -107,13 +107,13 @@ getProfileR = do
E.on $ sheet ^. SheetId E.==. corrector ^. SheetCorrectorSheet E.on $ sheet ^. SheetId E.==. corrector ^. SheetCorrectorSheet
E.where_ $ corrector ^. SheetCorrectorUser E.==. E.val uid E.where_ $ corrector ^. SheetCorrectorUser E.==. E.val uid
return (course ^. CourseShorthand, course ^. CourseTerm) return (course ^. CourseTerm, course ^. CourseSchool, course ^. CourseShorthand)
) )
<*> <*>
(E.select $ E.from $ \(participant `E.InnerJoin` course) -> do (E.select $ E.from $ \(participant `E.InnerJoin` course) -> do
E.where_ $ participant ^. CourseParticipantUser E.==. E.val uid E.where_ $ participant ^. CourseParticipantUser E.==. E.val uid
E.on $ participant ^. CourseParticipantCourse E.==. course ^. CourseId E.on $ participant ^. CourseParticipantCourse E.==. course ^. CourseId
return (course ^. CourseShorthand, course ^. CourseTerm, participant ^. CourseParticipantRegistration) return (course ^. CourseTerm, course ^. CourseSchool, course ^. CourseShorthand, participant ^. CourseParticipantRegistration)
) )
<*> <*>
(E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do (E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do
@ -141,7 +141,7 @@ postProfileR = do
getProfileDataR :: Handler Html getProfileDataR :: Handler Html
getProfileDataR = do getProfileDataR = do
(uid, User{..}) <- requireAuthPair (_uid, User{..}) <- requireAuthPair
-- mr <- getMessageRender -- mr <- getMessageRender
defaultLayout $ do defaultLayout $ do

139
src/Handler/Sheet.hs
View File

@ -21,31 +21,31 @@ import Import
import System.FilePath (takeFileName) import System.FilePath (takeFileName)
import Handler.Utils import Handler.Utils
import Handler.Utils.Zip -- import Handler.Utils.Zip
-- import Data.Time -- import Data.Time
import qualified Data.Text as T -- import qualified Data.Text as T
-- import Data.Function ((&)) -- import Data.Function ((&))
-- --
import Colonnade hiding (fromMaybe, singleton, bool) -- import Colonnade hiding (fromMaybe, singleton, bool)
import qualified Yesod.Colonnade as Yesod import qualified Yesod.Colonnade as Yesod
import Text.Blaze (text) import Text.Blaze (text)
-- --
import qualified Data.UUID.Cryptographic as UUID -- import qualified Data.UUID.Cryptographic as UUID
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import Data.CaseInsensitive (CI) -- import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E -- import qualified Database.Esqueleto.Internal.Sql as E
import Control.Monad.Writer (MonadWriter(..), execWriterT) import Control.Monad.Writer (MonadWriter(..), execWriterT)
import Control.Monad.Trans.RWS.Lazy (RWST, local) -- import Control.Monad.Trans.RWS.Lazy (RWST, local)
import qualified Text.Email.Validate as Email -- import qualified Text.Email.Validate as Email
import qualified Data.List as List -- import qualified Data.List as List
import Network.Mime import Network.Mime
@ -59,7 +59,7 @@ import qualified Data.Map as Map
import Data.Monoid (Sum(..)) import Data.Monoid (Sum(..))
import Control.Lens import Control.Lens
import Utils.Lens -- import Utils.Lens
instance Eq (Unique Sheet) where instance Eq (Unique Sheet) where
@ -146,24 +146,24 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
, ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly) , ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly)
] ] ] ]
getSheetListR :: TermId -> CourseShorthand -> Handler Html getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetListR tid csh = do getSheetListR tid ssh csh = do
muid <- maybeAuthId muid <- maybeAuthId
Entity cid _ <- runDB . getBy404 $ CourseTermShort tid csh Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
let let
sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)),E.SqlExpr (Maybe (Entity Submission))) sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)),E.SqlExpr (Maybe (Entity Submission)))
sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
let sheetEdit = E.sub_select . E.from $ \sheetEdit -> do let sheetEdit = E.sub_select . E.from $ \sheetEdit' -> do
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId E.where_ $ sheetEdit' E.^. SheetEditSheet E.==. sheet E.^. SheetId
return . E.max_ $ sheetEdit E.^. SheetEditTime return . E.max_ $ sheetEdit' E.^. SheetEditTime
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return (sheet, sheetEdit, submission) return (sheet, sheetEdit, submission)
sheetCol = widgetColonnade . mconcat $ sheetCol = widgetColonnade . mconcat $
[ sortable (Just "name") (i18nCell MsgSheet) [ sortable (Just "name") (i18nCell MsgSheet)
$ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid csh sheetName SShowR) (toWidget sheetName) $ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
, sortable (Just "last-edit") (i18nCell MsgLastEdit) , sortable (Just "last-edit") (i18nCell MsgLastEdit)
$ \(_, E.Value mEditTime, _) -> case mEditTime of $ \(_, E.Value mEditTime, _) -> case mEditTime of
Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget
@ -180,9 +180,9 @@ getSheetListR tid csh = do
(Just (Entity sid Submission{..})) -> (Just (Entity sid Submission{..})) ->
let mkCid = encrypt sid -- TODO: executed twice let mkCid = encrypt sid -- TODO: executed twice
mkRoute = do mkRoute = do
cid <- mkCid cid' <- mkCid
return $ CSubmissionR tid csh sheetName cid SubShowR return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
, sortable (Just "rating") (i18nCell MsgRating) , sortable (Just "rating") (i18nCell MsgRating)
$ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of
Nothing -> mempty Nothing -> mempty
@ -190,7 +190,7 @@ getSheetListR tid csh = do
let mkCid = encrypt sid let mkCid = encrypt sid
mkRoute = do mkRoute = do
cid <- mkCid cid <- mkCid
return $ CSubmissionR tid csh sheetName cid CorrectionR return $ CSubmissionR tid ssh csh sheetName cid CorrectionR
protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating") protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating")
in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints))) in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints)))
, sortable Nothing -- (Just "percent") , sortable Nothing -- (Just "percent")
@ -211,7 +211,7 @@ getSheetListR tid csh = do
{ dbtSQLQuery = sheetData { dbtSQLQuery = sheetData
, dbtColonnade = sheetCol , dbtColonnade = sheetCol
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) } , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) }
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh sheetName SShowR) False) -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False)
, dbtSorting = Map.fromList , dbtSorting = Map.fromList
[ ( "name" [ ( "name"
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
@ -246,9 +246,9 @@ getSheetListR tid csh = do
$(widgetFile "widgets/sheetTypeSummary") $(widgetFile "widgets/sheetTypeSummary")
-- Show single sheet -- Show single sheet
getSShowR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSShowR tid csh shn = do getSShowR tid ssh csh shn = do
entSheet <- runDB $ fetchSheet tid csh shn entSheet <- runDB $ fetchSheet tid ssh csh shn
let sheet = entityVal entSheet let sheet = entityVal entSheet
sid = entityKey entSheet sid = entityKey entSheet
-- without Colonnade -- without Colonnade
@ -261,7 +261,7 @@ getSShowR tid csh shn = do
-- E.where_ (sheet E.^. SheetId E.==. E.val sid ) -- E.where_ (sheet E.^. SheetId E.==. E.val sid )
-- -- return desired columns -- -- return desired columns
-- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) -- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
-- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid csh (SheetFileR shn fType fName),modified)) fileNameTypes -- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes
-- with Colonnade -- with Colonnade
let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do
@ -275,7 +275,7 @@ getSShowR tid csh shn = do
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
let colonnadeFiles = widgetColonnade $ mconcat let colonnadeFiles = widgetColonnade $ mconcat
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> stringCell ftype [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> stringCell ftype
, sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName)) , sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid ssh csh shn (SFileR fType fName))
(\(E.Value fName,_,_) -> str2widget fName) (\(E.Value fName,_,_) -> str2widget fName)
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
] ]
@ -285,7 +285,7 @@ getSShowR tid csh shn = do
{ dbtSQLQuery = fileData { dbtSQLQuery = fileData
, dbtColonnade = colonnadeFiles , dbtColonnade = colonnadeFiles
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh shn $ SFileR fType fName) False) -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
, dbtStyle = def , dbtStyle = def
, dbtFilter = Map.empty , dbtFilter = Map.empty
, dbtIdent = "files" :: Text , dbtIdent = "files" :: Text
@ -309,19 +309,19 @@ getSShowR tid csh shn = do
when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $ when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $
maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSheetTitle tid csh shn setTitleI $ MsgSheetTitle tid ssh csh shn
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
$(widgetFile "sheetShow") $(widgetFile "sheetShow")
getSFileR :: TermId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
getSFileR tid csh shn typ title = do getSFileR tid ssh csh shn typ title = do
results <- runDB $ E.select $ E.from $ results <- runDB $ E.select $ E.from $
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other -- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
-- filter to requested file -- filter to requested file
@ -329,7 +329,8 @@ getSFileR tid csh shn typ title = do
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ ) E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
E.&&. (sheet E.^. SheetName E.==. E.val shn ) E.&&. (sheet E.^. SheetName E.==. E.val shn )
E.&&. (course E.^. CourseShorthand E.==. E.val csh ) E.&&. (course E.^. CourseShorthand E.==. E.val csh )
E.&&. (course E.^. CourseTerm E.==. E.val tid ) E.&&. (course E.^. CourseSchool E.==. E.val ssh )
E.&&. (course E.^. CourseTerm E.==. E.val tid )
) )
-- return desired columns -- return desired columns
return $ (file E.^. FileTitle, file E.^. FileContent) return $ (file E.^. FileTitle, file E.^. FileContent)
@ -346,21 +347,21 @@ getSFileR tid csh shn typ title = do
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found." error "Multiple matching files found."
getSheetNewR :: TermId -> CourseShorthand -> Handler Html getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetNewR tid csh = do getSheetNewR tid ssh csh = do
let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
insertUnique $ newSheet insertUnique $ newSheet
handleSheetEdit tid csh Nothing template action handleSheetEdit tid ssh csh Nothing template action
postSheetNewR :: TermId -> CourseShorthand -> Handler Html postSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
postSheetNewR = getSheetNewR postSheetNewR = getSheetNewR
getSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSEditR tid csh shn = do getSEditR tid ssh csh shn = do
(sheetEnt, sheetFileIds) <- runDB $ do (sheetEnt, sheetFileIds) <- runDB $ do
ent <- fetchSheet tid csh shn ent <- fetchSheet tid ssh csh shn
fti <- getFtIdMap $ entityKey ent fti <- getFtIdMap $ entityKey ent
return (ent, fti) return (ent, fti)
let sid = entityKey sheetEnt let sid = entityKey sheetEnt
@ -386,13 +387,13 @@ getSEditR tid csh shn = do
case replaceRes of case replaceRes of
Nothing -> return $ Just sid Nothing -> return $ Just sid
(Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
handleSheetEdit tid csh (Just sid) template action handleSheetEdit tid ssh csh (Just sid) template action
postSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSEditR = getSEditR postSEditR = getSEditR
handleSheetEdit :: TermId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
handleSheetEdit tid csh msId template dbAction = do handleSheetEdit tid ssh csh msId template dbAction = do
let mbshn = sfName <$> template let mbshn = sfName <$> template
aid <- requireAuthId aid <- requireAuthId
((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template
@ -400,7 +401,7 @@ handleSheetEdit tid csh msId template dbAction = do
(FormSuccess SheetForm{..}) -> do (FormSuccess SheetForm{..}) -> do
saveOkay <- runDB $ do saveOkay <- runDB $ do
actTime <- liftIO getCurrentTime actTime <- liftIO getCurrentTime
cid <- getKeyBy404 $ CourseTermShort tid csh cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
let newSheet = Sheet let newSheet = Sheet
{ sheetCourse = cid { sheetCourse = cid
, sheetName = sfName , sheetName = sfName
@ -416,51 +417,51 @@ handleSheetEdit tid csh msId template dbAction = do
} }
mbsid <- dbAction newSheet mbsid <- dbAction newSheet
case mbsid of case mbsid of
Nothing -> False <$ addMessageI "danger" (MsgSheetNameDup tid csh sfName) Nothing -> False <$ addMessageI "danger" (MsgSheetNameDup tid ssh csh sfName)
(Just sid) -> do -- save files in DB: (Just sid) -> do -- save files in DB:
whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise
whenIsJust sfHintF $ insertSheetFile' sid SheetHint whenIsJust sfHintF $ insertSheetFile' sid SheetHint
whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution
whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking
insert_ $ SheetEdit aid actTime sid insert_ $ SheetEdit aid actTime sid
addMessageI "info" $ MsgSheetEditOk tid csh sfName addMessageI "info" $ MsgSheetEditOk tid ssh csh sfName
return True return True
when saveOkay $ redirect $ CSheetR tid csh sfName SShowR -- redirect must happen outside of runDB when saveOkay $ redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
_ -> return () _ -> return ()
let pageTitle = maybe (MsgSheetTitleNew tid csh) let pageTitle = maybe (MsgSheetTitleNew tid ssh csh)
(MsgSheetTitle tid csh) mbshn (MsgSheetTitle tid ssh csh) mbshn
-- let formTitle = pageTitle -- no longer used in template -- let formTitle = pageTitle -- no longer used in template
let formText = Nothing :: Maybe UniWorXMessage let formText = Nothing :: Maybe UniWorXMessage
actionUrl <- fromMaybe (CourseR tid csh SheetNewR) <$> getCurrentRoute actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute
defaultLayout $ do defaultLayout $ do
setTitleI pageTitle setTitleI pageTitle
$(widgetFile "formPageI18n") $(widgetFile "formPageI18n")
getSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSDelR tid csh shn = do getSDelR tid ssh csh shn = do
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
case result of case result of
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh shn SShowR (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid ssh csh shn SShowR
(FormSuccess BtnDelete) -> do (FormSuccess BtnDelete) -> do
runDB $ fetchSheetId tid csh shn >>= deleteCascade runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade
-- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
addMessageI "info" $ MsgSheetDelOk tid csh shn addMessageI "info" $ MsgSheetDelOk tid ssh csh shn
redirect $ CourseR tid csh SheetListR redirect $ CourseR tid ssh csh SheetListR
_other -> do _other -> do
submissionno <- runDB $ do submissionno <- runDB $ do
sid <- fetchSheetId tid csh shn sid <- fetchSheetId tid ssh csh shn
count [SubmissionSheet ==. sid] count [SubmissionSheet ==. sid]
let formTitle = MsgSheetDelHead tid csh shn let formTitle = MsgSheetDelHead tid ssh csh shn
let formText = Just $ MsgSheetDelText submissionno let formText = Just $ MsgSheetDelText submissionno
let actionUrl = CSheetR tid csh shn SDelR let actionUrl = CSheetR tid ssh csh shn SDelR
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSheetTitle tid csh shn setTitleI $ MsgSheetTitle tid ssh csh shn
$(widgetFile "formPageI18n") $(widgetFile "formPageI18n")
postSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSDelR = getSDelR postSDelR = getSDelR
@ -661,10 +662,10 @@ correctorForm shid = do
-- Eingabebox für Korrektor hinzufügen -- Eingabebox für Korrektor hinzufügen
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
getSCorrR, postSCorrR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
postSCorrR = getSCorrR postSCorrR = getSCorrR
getSCorrR tid csh shn = do getSCorrR tid ssh csh shn = do
Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
@ -677,10 +678,10 @@ getSCorrR tid csh shn = do
FormMissing -> return () FormMissing -> return ()
let let
-- formTitle = MsgSheetCorrectorsTitle tid csh shn -- formTitle = MsgSheetCorrectorsTitle tid ssh csh shn
formText = Nothing :: Maybe (SomeMessage UniWorX) formText = Nothing :: Maybe (SomeMessage UniWorX)
actionUrl = CSheetR tid csh shn SCorrR actionUrl = CSheetR tid ssh csh shn SCorrR
-- actionUrl = CSheetR tid csh shn SShowR -- actionUrl = CSheetR tid ssh csh shn SShowR
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSheetCorrectorsTitle tid csh shn setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn
$(widgetFile "formPageI18n") $(widgetFile "formPageI18n")

50
src/Handler/Submission.hs
View File

@ -78,20 +78,20 @@ makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $
aforced' f fs (Just (Just v)) = Just <$> aforced f fs v aforced' f fs (Just (Just v)) = Just <$> aforced f fs v
aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary" aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary"
getSubmissionNewR, postSubmissionNewR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSubmissionNewR = postSubmissionNewR getSubmissionNewR = postSubmissionNewR
postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission postSubmissionNewR tid ssh csh shn = submissionHelper tid ssh csh shn NewSubmission
getSubShowR, postSubShowR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html getSubShowR, postSubShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html
getSubShowR = postSubShowR getSubShowR = postSubShowR
postSubShowR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid postSubShowR tid ssh csh shn cid = submissionHelper tid ssh csh shn $ ExistingSubmission cid
getSubmissionOwnR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
getSubmissionOwnR tid csh shn = do getSubmissionOwnR tid ssh csh shn = do
authId <- requireAuthId authId <- requireAuthId
sid <- runDB $ do sid <- runDB $ do
shid <- fetchSheetId tid csh shn shid <- fetchSheetId tid ssh csh shn
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission)
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId
@ -101,14 +101,14 @@ getSubmissionOwnR tid csh shn = do
((E.Value sid):_) -> return sid ((E.Value sid):_) -> return sid
[] -> notFound [] -> notFound
cID <- encrypt sid cID <- encrypt sid
redirect $ CSubmissionR tid csh shn cID SubShowR redirect $ CSubmissionR tid ssh csh shn cID SubShowR
submissionHelper :: TermId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html
submissionHelper tid csh shn (SubmissionMode mcid) = do submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
uid <- requireAuthId uid <- requireAuthId
msmid <- traverse decrypt mcid msmid <- traverse decrypt mcid
(Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do (Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do
sheet@(Entity shid Sheet{..}) <- fetchSheet tid csh shn sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
case msmid of case msmid of
Nothing -> do Nothing -> do
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
@ -139,9 +139,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
(E.Value smid:_) -> do (E.Value smid:_) -> do
cID <- encrypt smid cID <- encrypt smid
addMessageI "info" $ MsgSubmissionAlreadyExists addMessageI "info" $ MsgSubmissionAlreadyExists
redirect $ CSubmissionR tid csh shn cID SubShowR redirect $ CSubmissionR tid ssh csh shn cID SubShowR
(Just smid) -> do (Just smid) -> do
void $ submissionMatchesSheet tid csh shn (fromJust mcid) void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid)
shid' <- submissionSheet <$> get404 smid shid' <- submissionSheet <$> get404 smid
-- fetch buddies from current submission -- fetch buddies from current submission
@ -239,7 +239,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
_other -> return Nothing _other -> return Nothing
case mCID of case mCID of
Just cID -> redirect $ CSubmissionR tid csh shn cID SubShowR Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR
Nothing -> return () Nothing -> return ()
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
@ -254,13 +254,13 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr
Just isFile = origIsFile <|> corrIsFile Just isFile = origIsFile <|> corrIsFile
in if in if
| Just True <- origIsFile -> anchorCell (CSubmissionR tid csh shn cid $ SubDownloadR SubmissionOriginal fileTitle') | Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle')
([whamlet|#{fileTitle'}|]) ([whamlet|#{fileTitle'}|])
| otherwise -> textCell $ bool (<> "/") id isFile fileTitle' | otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
, sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of , sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of
Nothing -> cell mempty Nothing -> cell mempty
Just (_, Entity _ File{..}) Just (_, Entity _ File{..})
| isJust fileContent -> anchorCell (CSubmissionR tid csh shn cid $ SubDownloadR SubmissionCorrected fileTitle) | isJust fileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected fileTitle)
([whamlet|_{MsgFileCorrected}|]) ([whamlet|_{MsgFileCorrected}|])
| otherwise -> textCell MsgFileCorrected | otherwise -> textCell MsgFileCorrected
, sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let , sortable (Just "time") (textCell MsgFileModified) $ \(coalesce -> (mOrig, mCorr)) -> let
@ -302,19 +302,19 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid mFileTable <- traverse (fmap snd . dbTable def) . fmap smid2ArchiveTable $ (,) <$> msmid <*> mcid
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSubmissionEditHead tid csh shn setTitleI $ MsgSubmissionEditHead tid ssh csh shn
$(widgetFile "submission") $(widgetFile "submission")
getSubDownloadR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
runDB $ do runDB $ do
submissionID <- submissionMatchesSheet tid csh shn cID submissionID <- submissionMatchesSheet tid ssh csh shn cID
isRating <- maybe False (== submissionID) <$> isRatingFile path isRating <- maybe False (== submissionID) <$> isRatingFile path
when (isUpdate || isRating) $ when (isUpdate || isRating) $
guardAuthResult =<< evalAccessDB (CSubmissionR tid csh shn cID CorrectionR) False guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
case isRating of case isRating of
True True
@ -343,10 +343,10 @@ getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path =
$logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found." error "Multiple matching files found."
getSubArchiveR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent
getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do
when (sfType == SubmissionCorrected) $ when (sfType == SubmissionCorrected) $
guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False
let filename let filename
| SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType | SubmissionOriginal <- sfType = ZIPArchiveName $ toPathPiece cID <> "-" <> toPathPiece sfType
@ -354,7 +354,7 @@ getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|] addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
respondSourceDB "application/zip" $ do respondSourceDB "application/zip" $ do
submissionID <- lift $ submissionMatchesSheet tid csh shn cID submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
rating <- lift $ getRating submissionID rating <- lift $ getRating submissionID
let let

3
src/Handler/Term.hs
View File

@ -17,8 +17,7 @@ import Handler.Utils
-- import qualified Data.Text as T -- import qualified Data.Text as T
import Yesod.Form.Bootstrap3 import Yesod.Form.Bootstrap3
-- import Colonnade hiding (bool)
import Colonnade hiding (bool)
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E

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

@ -219,7 +219,15 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
return . fromRational $ round (sci * 100) % 100 return . fromRational $ round (sci * 100) % 100
--termField: see Utils.Term --termField: see Utils.Term
--schoolField: see Handler.Course
schoolField :: Field Handler SchoolId
schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName
schoolFieldEnt :: Field Handler (Entity School)
schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolId <-. userSchools] [Asc SchoolName] schoolName
zipFileField :: Bool -- ^ Unpack zips? zipFileField :: Bool -- ^ Unpack zips?
-> Field Handler (Source Handler File) -> Field Handler (Source Handler File)

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

@ -24,29 +24,30 @@ fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
, PersistQueryRead backend, PersistUniqueRead backend , PersistQueryRead backend, PersistUniqueRead backend
) )
=> (E.SqlExpr (Entity Sheet) -> b) => (E.SqlExpr (Entity Sheet) -> b)
-> TermId -> CourseShorthand -> SheetName -> ReaderT backend m a -> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a
fetchSheetAux prj tid csh shn = fetchSheetAux prj tid ssh csh shn =
let cachId = encodeUtf8 $ tshow (tid,csh,shn) let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn)
in cachedBy cachId $ do in cachedBy cachId $ do
-- Mit Yesod: -- Mit Yesod:
-- cid <- getKeyBy404 $ CourseTermShort tid csh -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-- getBy404 $ CourseSheet cid shn -- getBy404 $ CourseSheet cid shn
-- Mit Esqueleto: -- Mit Esqueleto:
sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseShorthand E.==. E.val csh E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. sheet E.^. SheetName E.==. E.val shn E.&&. course E.^. CourseShorthand E.==. E.val csh
E.&&. sheet E.^. SheetName E.==. E.val shn
return $ prj sheet return $ prj sheet
case sheetList of case sheetList of
[sheet] -> return sheet [sheet] -> return sheet
_other -> notFound _other -> notFound
fetchSheet :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet) fetchSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet)
fetchSheet = fetchSheetAux id fetchSheet = fetchSheetAux id
fetchSheetId :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet) fetchSheetId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet)
fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn fetchSheetId tid ssh cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid ssh cid shn
fetchSheetIdCourseId :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course) fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course)
fetchSheetIdCourseId tid cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid cid shn fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid ssh cid shn

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

@ -551,7 +551,7 @@ sinkMultiSubmission userId isUpdate = do
Submission{..} <- get404 sId Submission{..} <- get404 sId
Sheet{..} <- get404 submissionSheet Sheet{..} <- get404 submissionSheet
Course{..} <- get404 sheetCourse Course{..} <- get404 sheetCourse
guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseShorthand sheetName cID CorrectionR) True guardAuthResult =<< evalAccessDB (CSubmissionR courseTerm courseSchool courseShorthand sheetName cID CorrectionR) True
return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate
sink' <- lift $ yield val ++$$ sink sink' <- lift $ yield val ++$$ sink
case sink' of case sink' of
@ -599,10 +599,10 @@ sinkMultiSubmission userId isUpdate = do
handleCryptoID _ = return Nothing handleCryptoID _ = return Nothing
submissionMatchesSheet :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId submissionMatchesSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId
submissionMatchesSheet tid csh shn cid = do submissionMatchesSheet tid ssh csh shn cid = do
sid <- decrypt cid sid <- decrypt cid
shid <- fetchSheetId tid csh shn shid <- fetchSheetId tid ssh csh shn
Submission{..} <- get404 sid Submission{..} <- get404 sid
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet] when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
return sid return sid

73
src/Model/Migration.hs
View File

@ -17,12 +17,13 @@ import Model.Migration.Version
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Set (Set) import Data.Set ()
import qualified Data.Set as Set import qualified Data.Set as Set
import Database.Persist.Sql import Database.Persist.Sql
import Database.Persist.Postgresql import Database.Persist.Postgresql
import Data.CaseInsensitive (CI)
-- Database versions must follow https://pvp.haskell.org: -- Database versions must follow https://pvp.haskell.org:
-- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format) -- - Breaking changes are instances where manual migration is necessary (via customMigrations; i.e. changing a columns format)
@ -67,13 +68,21 @@ migrateAll = do
doCustomMigration acc desc migration = acc <* do doCustomMigration acc desc migration = acc <* do
let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc
appliedMigrationTime <- liftIO getCurrentTime appliedMigrationTime <- liftIO getCurrentTime
migration _ <- migration
insert AppliedMigration{..} insert AppliedMigration{..}
-- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey -- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey
Map.foldlWithKey doCustomMigration (return ()) missingMigrations Map.foldlWithKey doCustomMigration (return ()) missingMigrations
runMigration migrateAll' runMigration migrateAll'
{-
Confusion about quotes, from the PostgreSQL Manual:
Single quotes for string constants, double quotes for table/column names.
QuasiQuoter: ^{TableName} @{ColumnName} (includes Escaping);
#{anything} (no escaping);
-}
customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ()) customMigrations :: MonadIO m => Map (Key AppliedMigration) (ReaderT SqlBackend m ())
customMigrations = Map.fromListWith (>>) customMigrations = Map.fromListWith (>>)
@ -92,6 +101,7 @@ customMigrations = Map.fromListWith (>>)
) )
, ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|] , ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|]
, do -- Better JSON encoding , do -- Better JSON encoding
haveSheetTable <- [sqlQQ| SELECT to_regclass('sheet'); |] haveSheetTable <- [sqlQQ| SELECT to_regclass('sheet'); |]
case haveSheetTable :: [Maybe (Single Text)] of case haveSheetTable :: [Maybe (Single Text)] of
@ -102,4 +112,63 @@ customMigrations = Map.fromListWith (>>)
|] |]
_other -> return () _other -> return ()
) )
, ( AppliedMigrationKey [migrationVersion|1.0.0|] [version|2.0.0|]
, whenM (tableExists "school") $ do -- SchoolId is the Shorthand CI Text now
-- Read old table into memory
schoolTable <- [sqlQQ| SELECT "id", "shorthand" FROM "school"; |]
let _sT = schoolTable :: [(Single Int64, Single (CI Text))] -- Types needed
-- Convert columns containing SchoolId
whenM (tableExists "user_admin") $ do
[executeQQ|
ALTER TABLE "user_admin" DROP CONSTRAINT user_admin_school_fkey;
ALTER TABLE "user_admin" ALTER COLUMN school TYPE citext USING school::citext;
|]
forM_ schoolTable $ \(Single idnr, Single ssh) ->
[executeQQ|
UPDATE "user_admin" SET "school" = #{ssh} WHERE school = #{tshow idnr};
|]
[executeQQ|
ALTER TABLE "user_admin" ADD CONSTRAINT "user_admin_school_fkey"
FOREIGN KEY (school) REFERENCES school(shorthand);
|]
whenM (tableExists "user_lecturer") $ do
[executeQQ|
ALTER TABLE "user_lecturer" DROP CONSTRAINT user_lecturer_school_fkey;
ALTER TABLE "user_lecturer" ALTER COLUMN school TYPE citext USING school::citext;
|]
forM_ schoolTable $ \(Single idnr, Single ssh) ->
[executeQQ|
UPDATE "user_lecturer" SET "school" = #{ssh} WHERE school = #{tshow idnr};
|]
[executeQQ|
ALTER TABLE "user_lecturer" ADD CONSTRAINT "user_lecturer_school_fkey"
FOREIGN KEY (school) REFERENCES school(shorthand);;
|]
whenM (tableExists "course") $ do
[executeQQ|
ALTER TABLE "course" DROP CONSTRAINT course_school_fkey;
ALTER TABLE "course" ALTER COLUMN school TYPE citext USING school::citext;
|]
forM_ schoolTable $ \(Single idnr, Single ssh) ->
[executeQQ|
UPDATE "course" SET "school" = #{ssh} WHERE school = #{tshow idnr};
|]
[executeQQ|
ALTER TABLE "course" ADD CONSTRAINT "course_school_fkey"
FOREIGN KEY (school) REFERENCES school(shorthand);
|]
[executeQQ|
ALTER TABLE "school" DROP COLUMN "id";
ALTER TABLE "school" ADD PRIMARY KEY (shorthand);
|]
)
] ]
tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
tableExists table = do
haveSchoolTable <- [sqlQQ| SELECT to_regclass(#{table}); |]
case haveSchoolTable :: [Maybe (Single Text)] of
[Just _] -> return True
_other -> return False

35
src/Model/Types.hs
View File

@ -8,6 +8,7 @@
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-- # LANGUAGE ExistentialQuantification #-} -- for DA type {-- # LANGUAGE ExistentialQuantification #-} -- for DA type
{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text)
module Model.Types where module Model.Types where
@ -23,6 +24,7 @@ import Data.Monoid (Sum(..))
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Data.Universe import Data.Universe
import Data.Universe.Helpers import Data.Universe.Helpers
import Data.UUID.Types
import Text.Read (readMaybe) import Text.Read (readMaybe)
@ -32,6 +34,7 @@ import Database.Persist.Class
import Database.Persist.Sql import Database.Persist.Sql
import Web.HttpApiData import Web.HttpApiData
import Web.PathPieces
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
@ -50,6 +53,30 @@ import Generics.Deriving.Monoid (gmemptydefault, gmappenddefault)
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
instance PathPiece UUID where
fromPathPiece = Data.UUID.Types.fromString . unpack
toPathPiece = pack . toString
instance (CI.FoldCase s, PathPiece s) => PathPiece (CI s) where
fromPathPiece = fmap CI.mk . fromPathPiece
toPathPiece = toPathPiece . CI.original
instance {-# OVERLAPS #-} PathMultiPiece FilePath where
fromPathMultiPiece = Just . unpack . intercalate "/"
toPathMultiPiece = Text.splitOn "/" . pack
instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
fromPathMultiPiece = fmap CI.mk . fromPathMultiPiece
toPathMultiPiece = toPathMultiPiece . CI.foldedCase
instance ToHttpApiData (CI Text) where
toUrlPiece = CI.original
instance FromHttpApiData (CI Text) where
parseUrlPiece = return . CI.mk
type Points = Centi type Points = Centi
toPoints :: Integral a => a -> Points -- deprecated toPoints :: Integral a => a -> Points -- deprecated
@ -368,7 +395,9 @@ derivePersistField "CorrectorState"
-- Type synonyms -- Type synonyms
type SheetName = CI Text type SchoolName = CI Text
type SchoolShorthand = CI Text
type CourseName = CI Text
type CourseShorthand = CI Text type CourseShorthand = CI Text
type CourseName = CI Text type SheetName = CI Text
type UserEmail = CI Text type UserEmail = CI Text

5
src/Utils.hs
View File

@ -86,6 +86,11 @@ unsupportedAuthPredicate = do
tickmark :: IsString a => a tickmark :: IsString a => a
tickmark = fromString "✔" tickmark = fromString "✔"
-- Avoid annoying warnings:
tickmarkS :: String
tickmarkS = tickmark
tickmarkT :: Text
tickmarkT = tickmark
text2Html :: Text -> Html text2Html :: Text -> Html
text2Html = toHtml -- prevents ambiguous types text2Html = toHtml -- prevents ambiguous types

2
templates/course.hamlet
View File

@ -33,7 +33,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
<dt .deflist__dt> <dt .deflist__dt>
<dd .deflist__dd> <dd .deflist__dd>
<div .course__registration> <div .course__registration>
<form method=post action=@{CourseR tid csh CRegisterR} enctype=#{regEnctype}> <form method=post action=@{CourseR tid ssh csh CRegisterR} enctype=#{regEnctype}>
$# regWidget is defined through templates/widgets/registerForm $# regWidget is defined through templates/widgets/registerForm
^{regWidget} ^{regWidget}
<dt .deflist__dt> <dt .deflist__dt>

14
templates/profile.hamlet
View File

@ -27,16 +27,16 @@
<dt .deflist__dt> Eigene Kurse <dt .deflist__dt> Eigene Kurse
<dd .deflist__dd> <dd .deflist__dd>
<ul .list-ul> <ul .list-ul>
$forall (E.Value csh, E.Value tid) <- lecture_owner $forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_owner
<li .list-ul__item> <li .list-ul__item>
<a href=@{CourseR tid csh CShowR}>#{display tid} - #{csh} <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
$if not $ null lecture_corrector $if not $ null lecture_corrector
<dt .deflist__dt> Korrektor <dt .deflist__dt> Korrektor
<dd .deflist__dd> <dd .deflist__dd>
<ul .list-ul> <ul .list-ul>
$forall (E.Value csh, E.Value tid) <- lecture_corrector $forall (E.Value tid, E.Value ssh, E.Value csh) <- lecture_corrector
<li .list-ul__item> <li .list-ul__item>
<a href=@{CourseR tid csh CShowR}>#{display tid} - #{csh} <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
$if not $ null studies $if not $ null studies
<dt .deflist__dt> Studiengänge <dt .deflist__dt> Studiengänge
<dd .deflist__dd> <dd .deflist__dd>
@ -59,10 +59,10 @@
<dt .deflist__dt> Teilnehmer <dt .deflist__dt> Teilnehmer
<dd .deflist__dd> <dd .deflist__dd>
<dl .deflist> <dl .deflist>
$forall (E.Value csh, E.Value tid, regSince) <- participant $forall (E.Value tid, E.Value ssh, E.Value csh, regSince) <- participant
<dt .deflist__dt> <dt .deflist__dt>
<a href=@{CourseR tid csh CShowR}>#{display tid} - #{csh} <a href=@{CourseR tid ssh csh CShowR}>#{display tid}-#{display ssh}-#{display csh}
<dd .deflist__dd> <dd .deflist__dd>
seit #{display regSince} seit #{display regSince}
^{settingsForm} ^{settingsForm}

4
templates/submission.hamlet
View File

@ -1,8 +1,8 @@
$maybe cID <- mcid $maybe cID <- mcid
<section> <section>
<h2> <h2>
<a href=@{CSubmissionR tid csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))}>Archiv <a href=@{CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionCorrected))}>Archiv
(<a href=@{CSubmissionR tid csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))}>Original</a>) (<a href=@{CSubmissionR tid ssh csh shn cID (SubArchiveR (ZIPArchiveName SubmissionOriginal))}>Original</a>)
$if not (null lastEdits) $if not (null lastEdits)
<h3>_{MsgLastEdits} <h3>_{MsgLastEdits}
<ul> <ul>

2
templates/widgets/rating.hamlet
View File

@ -13,4 +13,4 @@ $maybe points <- submissionRatingPoints
$else $else
_{MsgNotPassed} _{MsgNotPassed}
$of NotGraded $of NotGraded
#{show tickmark} #{display tickmarkS}