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

Halfway through with #162, still todo

Browse Source
This commit is contained in:
SJost 2018-08-21 13:34:32 +02:00
parent a8328204f7
commit a4dacc8d01
17 changed files with 314 additions and 267 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
messages/uniworx/de.msg
View File

@ -47,7 +47,7 @@ TermCourseListHeading tid@TermId: Kursübersicht #{display tid}
CourseListTitle: Alle Kurse CourseListTitle: Alle Kurse
TermCourseListTitle tid@TermId: Kurse #{display tid} TermCourseListTitle tid@TermId: Kurse #{display tid}
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 +68,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 +111,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 +156,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 +268,4 @@ DummyLoginTitle: Development-Login
CorrectorNormal: Normal CorrectorNormal: Normal
CorrectorMissing: Abwesend CorrectorMissing: Abwesend
CorrectorExcused: Entschuldigt CorrectorExcused: Entschuldigt

5
models
View File

@ -53,6 +53,7 @@ School json
shorthand (CI Text) shorthand (CI Text)
UniqueSchool name UniqueSchool name
UniqueSchoolShorthand shorthand UniqueSchoolShorthand shorthand
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 CourseTermSchoolShort term school shorthand
CourseTermName term name CourseTermSchoolName 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 SchoolCourseListR 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

216
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 $ CourseTermSchoolShort 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 $ CourseTermSchoolShort 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 $ CourseTermSchoolShort 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 $ CourseTermSchoolShort 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 $ CourseTermSchoolShort 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 $ CourseTermSchoolShort 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 $ CourseTermSchoolShort 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 (SchoolCourseListR 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 $ SchoolCourseListR 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 $ CourseTermSchoolShort 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
} }
] ]
@ -982,40 +989,40 @@ 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 $ CourseTermSchoolShort 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 +1037,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 +1058,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
SchoolCourseListR tid ssh <- return route
let schoolShort :: SchoolShorthand
schoolShort = unSchoolKey ssh
Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort
(hasChanged `on` unSchoolKey)ssh ssh'
return $ SchoolCourseListR 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 $ CourseTermSchoolShort 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 $ CourseTermSchoolShort 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.

54
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
@ -81,12 +81,12 @@ 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 _ School{..}) } ->
cell [whamlet|#{display schoolName}|] anchorCell (SchoolCourseListR 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 _ School{..}) } ->
cell [whamlet|#{display schoolShorthand}|] anchorCell (SchoolCourseListR 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)
@ -222,13 +222,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 $ CourseTermSchoolShort 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 +238,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 +258,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 $ CourseTermSchoolShort 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 +277,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 +287,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 $ CourseTermShort 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 $ CourseTermShort tid ssh csh
courseEditHandler False course courseEditHandler False course
@ -317,6 +317,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 +340,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 +374,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 ()

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

38
src/Handler/Home.hs
View File

@ -68,12 +68,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
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}) } -> , 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 +88,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
) )
@ -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,18 +155,21 @@ 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)]
@ -171,6 +182,9 @@ homeUser uid = do
[ ( "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
) )

6
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

89
src/Handler/Sheet.hs
View File

@ -156,10 +156,10 @@ 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 $ CourseTermSchoolShort 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
@ -221,7 +221,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
@ -256,9 +256,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
@ -285,7 +285,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
] ]
@ -326,12 +326,12 @@ getSShowR tid csh shn = do
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
@ -339,7 +339,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)
@ -356,21 +357,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
@ -396,13 +397,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
@ -410,7 +411,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 $ CourseTermSchoolShort tid ssh csh
let newSheet = Sheet let newSheet = Sheet
{ sheetCourse = cid { sheetCourse = cid
, sheetName = sfName , sheetName = sfName
@ -426,51 +427,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 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 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
@ -671,10 +672,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
@ -689,8 +690,8 @@ getSCorrR tid csh shn = do
let let
-- formTitle = MsgSheetCorrectorsTitle tid csh shn -- formTitle = MsgSheetCorrectorsTitle tid 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 csh shn SShowR
defaultLayout $ do defaultLayout $ do
setTitleI $ MsgSheetCorrectorsTitle tid csh shn setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn
$(widgetFile "formPageI18n") $(widgetFile "formPageI18n")

16
src/Handler/Submission.hs
View File

@ -87,11 +87,11 @@ getSubShowR, postSubShowR :: TermId -> CourseShorthand -> SheetName -> CryptoFil
getSubShowR = postSubShowR getSubShowR = postSubShowR
postSubShowR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid postSubShowR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid
getSubmissionOwnR :: TermId -> 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,10 +101,10 @@ 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
@ -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

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

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 $ CourseTermSchoolShort 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

4
src/Model/Migration.hs
View File

@ -17,7 +17,7 @@ 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
@ -67,7 +67,7 @@ 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

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

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.Valuse 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}