diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 202bde31c..35914e8ca 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -38,16 +38,18 @@ CourseRegisterOk: Sie wurden angemeldet CourseDeregisterOk: Sie wurden abgemeldet CourseSecretWrong: Falsches Kennwort CourseSecret: Zugangspasswort -CourseNewOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt. -CourseEditOk tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich geändert. -CourseNewDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. -CourseEditDupShort tid@TermId courseShortHand@CourseShorthand: Kurs #{display tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester. +CourseNewOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich erstellt. +CourseEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde erfolgreich geändert. +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 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 TermCourseListHeading tid@TermId: Kursübersicht #{display tid} +TermSchoolCourseListHeading tid@TermId school@SchoolName: Kursübersicht #{display tid} für #{display school} CourseListTitle: Alle Kurse TermCourseListTitle tid@TermId: Kurse #{display tid} +TermSchoolCourseListTitle tid@TermId school@SchoolName: Kurse #{display tid} für #{display school} 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 CourseMembers: Teilnehmer CourseMembersCount num@Int64: #{display num} @@ -68,17 +70,17 @@ CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein Sheet: Blatt -SheetList tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Übersicht Übungsblätter -SheetNewHeading tid@TermId courseShortHand@CourseShorthand: #{display tid}-#{courseShortHand} Neues Übungsblatt anlegen -SheetNewOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Neues Übungsblatt #{sheetName} wurde im Kurs #{display tid}-#{courseShortHand} erfolgreich erstellt. -SheetTitle tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName} -SheetTitleNew tid@TermId courseShortHand@CourseShorthand : #{display tid}-#{courseShortHand}: Neues Übungsblatt -SheetEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName} editieren -SheetEditOk tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{courseShortHand} wurde gespeichert. -SheetNameDup tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Es gibt bereits ein Übungsblatt #{sheetName} in diesem Kurs #{display tid}-#{courseShortHand}. -SheetDelHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} wirklich aus Kurs #{display tid}-#{courseShortHand} herauslöschen? +SheetList tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Übersicht Übungsblätter +SheetNewHeading tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: #{display tid}-#{display ssh}-#{courseShortHand} Neues Übungsblatt anlegen +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 ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} +SheetTitleNew tid@TermId ssh@SchoolId courseShortHand@CourseShorthand : #{display tid}-#{display ssh}-#{courseShortHand}: Neues Übungsblatt +SheetEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName} editieren +SheetEditOk tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: Übungsblatt #{sheetName} aus Kurs #{display tid}-#{display ssh}-#{courseShortHand} wurde gespeichert. +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 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. -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 SheetHint: Hinweis @@ -111,12 +113,12 @@ Deadline: Abgabe Done: Eingereicht 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} SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt. SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. -SubmissionEditHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen -CorrectionHead tid@TermId courseShortHand@CourseShorthand sheetName@SheetName cid@CryptoFileNameSubmission: #{display tid}-#{courseShortHand} #{sheetName}: Korrektur +SubmissionEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen +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} SubmissionArchive: Zip-Archiv der Abgabedatei(en) SubmissionFile: Datei zur Abgabe @@ -156,7 +158,7 @@ TooManyParticipants: Es wurden zu viele Mitabgebende angegeben AddCorrector: Zusätzlicher Korrektor 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 Corrector: Korrektor Correctors: Korrektoren @@ -268,4 +270,4 @@ DummyLoginTitle: Development-Login CorrectorNormal: Normal CorrectorMissing: Abwesend -CorrectorExcused: Entschuldigt \ No newline at end of file +CorrectorExcused: Entschuldigt diff --git a/models b/models index 58069cf13..c3cb175bf 100644 --- a/models +++ b/models @@ -52,7 +52,8 @@ School json name (CI Text) shorthand (CI Text) UniqueSchool name - UniqueSchoolShorthand shorthand + UniqueSchoolShorthand shorthand -- required for Normalisation of CI Text + Primary shorthand -- newtype Key School = School { unSchoolKey :: SchoolShorthand } deriving Eq DegreeCourse json course CourseId @@ -73,8 +74,8 @@ Course deregisterUntil UTCTime Maybe registerSecret Text Maybe -- Falls ein Passwort erforderlich ist materialFree Bool - CourseTermShort term shorthand - CourseTermName term name + TermSchoolCourseShort term school shorthand + TermSchoolCourseName term school name CourseEdit user UserId time UTCTime diff --git a/routes b/routes index 097e6a0b8..d58947041 100644 --- a/routes +++ b/routes @@ -46,11 +46,13 @@ /terms/edit TermEditR GET POST /terms/#TermId/edit TermEditExistR GET !/terms/#TermId TermCourseListR GET !free +!/terms/#TermId/#SchoolId TermSchoolCourseListR GET !free + -- For Pattern Synonyms see Foundation /course/ CourseListR GET !free !/course/new CourseNewR GET POST !lecturer -/course/#TermId/#CourseShorthand CourseR !lecturer: +/course/#TermId/#SchoolId/#CourseShorthand CourseR !lecturer: / CShowR GET !free /register CRegisterR POST !timeANDcapacity /edit CEditR GET POST diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 61fd5559c..e2f6361cb 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -27,35 +27,17 @@ import System.FilePath.Cryptographic.ImplicitNamespace import qualified Data.Text as Text -import Data.UUID.Types +-- import Data.UUID.Types import Web.PathPieces import Data.CaseInsensitive (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 decCryptoIDs [ ''SubmissionId , ''FileId , ''UserId - , ''SchoolId ] instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where diff --git a/src/Foundation.hs b/src/Foundation.hs index a17a74f1d..1144412ec 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -97,6 +97,8 @@ instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) Submission instance DisplayAble TermId where display = termToText . unTermKey +instance DisplayAble SchoolId where + display = CI.original . unSchoolKey -- infixl 9 :$: -- 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 -- Pattern Synonyms for convenience -pattern CSheetR tid csh shn ptn - = CourseR tid csh (SheetR shn ptn) +pattern CSheetR tid ssh csh shn ptn + = CourseR tid ssh csh (SheetR shn ptn) -pattern CSubmissionR tid csh shn cid ptn - = CSheetR tid csh shn (SubmissionR cid ptn) +pattern CSubmissionR tid ssh csh shn cid ptn + = CSheetR tid ssh csh shn (SubmissionR cid ptn) -- Menus and Favourites 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 = APDB $ \route _ -> case route of -- 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 [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do E.on $ course E.^. CourseSchool E.==. userAdmin E.^. UserAdminSchool E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val authId E.&&. course E.^. CourseTerm E.==. E.val tid + E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh return (E.countRows :: E.SqlExpr (E.Value Int64)) 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 ) ,("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 [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do E.on $ course E.^. CourseId E.==. lecturer E.^. LecturerCourse 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 return (E.countRows :: E.SqlExpr (E.Value Int64)) 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.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] case route of - CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do + CSubmissionR _ _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID Submission{..} <- MaybeT . lift $ get sid guard $ maybe False (== authId) submissionRatingBy return Authorized - CSheetR tid csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do - Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh + CSheetR tid ssh csh shn _ -> maybeT (unauthorizedI MsgUnauthorizedSheetCorrector) $ do + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh Entity sid _ <- MaybeT . lift . getBy $ CourseSheet cid shn guard $ sid `Set.member` fromMaybe Set.empty (resMap !? cid) return Authorized - CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do - Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnauthorizedCorrector) $ do + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh guard $ cid `Set.member` Map.keysSet resMap return Authorized _ -> do @@ -340,8 +344,8 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req return Authorized ) ,("time", APDB $ \route _ -> case route of - CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do - Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh + CSheetR tid ssh csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do + Entity cid _ <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh Entity _sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn cTime <- liftIO getCurrentTime let @@ -360,8 +364,8 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req return Authorized - CourseR tid csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do - Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh + CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do + Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh cTime <- (NTop . Just) <$> liftIO getCurrentTime guard $ NTop courseRegisterFrom <= 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 ) ,("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 [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do E.on $ course E.^. CourseId E.==. courseParticipant E.^. CourseParticipantCourse 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 return (E.countRows :: E.SqlExpr (E.Value Int64)) 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 ) ,("capacity", APDB $ \route _ -> case route of - CourseR tid csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do - Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNoCapacity) $ do + Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] guard $ NTop courseCapacity > NTop (Just registered) return Authorized r -> $unsupportedAuthPredicate "capacity" r ) ,("materials", APDB $ \route _ -> case route of - CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do - Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh + CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do + Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh guard courseMaterialFree return Authorized r -> $unsupportedAuthPredicate "materials" r ) ,("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 authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId 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 ) ,("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 sub <- MaybeT $ get sid guard $ submissionRatingDone sub @@ -476,14 +481,14 @@ instance Yesod UniWorX where updateFavouritesMiddleware handler = (*> handler) . runMaybeT $ do route <- MaybeT getCurrentRoute case route of -- update Course Favourites here - CourseR tid csh _ -> do + CourseR tid ssh csh _ -> 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" now <- liftIO $ getCurrentTime uid <- MaybeT $ liftHandlerT maybeAuthId - cid <- MaybeT . getKeyBy $ CourseTermShort tid csh + cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh user <- MaybeT $ get uid let courseFavourite = CourseFavourite uid now cid @@ -546,7 +551,7 @@ instance Yesod UniWorX where return (favs, userTheme user) favourites <- forM favourites' $ \(Entity _ c@Course{..}) -> let - courseRoute = CourseR courseTerm courseShorthand CShowR + courseRoute = CourseR courseTerm courseSchool courseShorthand CShowR in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute) 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 (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 CourseNewR = return ("Neu" , Just CourseListR) - breadcrumb (CourseR tid csh CShowR) = return (CI.original csh, Just $ TermCourseListR tid) - -- (CourseR tid csh CRegisterR) -- is POST only - breadcrumb (CourseR tid csh CEditR) = return ("Editieren", Just $ CourseR tid csh CShowR) - breadcrumb (CourseR tid csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid csh CShowR) - breadcrumb (CourseR tid csh SheetListR) = return ("Übungen" , Just $ CourseR tid csh CShowR) - breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR) + breadcrumb (CourseR tid ssh csh CShowR) = return (CI.original csh, Just $ TermSchoolCourseListR tid ssh) + -- (CourseR tid ssh csh CRegisterR) -- is POST only + breadcrumb (CourseR tid ssh csh CEditR) = return ("Editieren", Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh CCorrectionsR) = return ("Abgaben",Just $ CourseR tid ssh csh CShowR) + breadcrumb (CourseR tid ssh csh SheetListR) = return ("Übungen" , Just $ CourseR tid ssh csh CShowR) + 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 csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR) - breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR) - breadcrumb (CSheetR tid csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid csh shn SShowR) - breadcrumb (CSheetR tid csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) - breadcrumb (CSheetR tid csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) - breadcrumb (CSubmissionR tid csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) --- (CSubmissionR tid csh shn _ SubArchiveR) -- just for Download - breadcrumb (CSubmissionR tid csh shn cid CorrectionR) = return ("Korrektur", Just $ CSubmissionR tid csh shn cid SubShowR) --- (CSubmissionR tid csh shn _ SubDownloadR) -- just for Download - breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR) - -- (CSheetR tid csh shn SFileR) -- just for Downloads + breadcrumb (CSheetR tid ssh csh shn SShowR) = return (CI.original shn, Just $ CourseR tid ssh csh SheetListR) + breadcrumb (CSheetR tid ssh csh shn SEditR) = return ("Edit", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSheetR tid ssh csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSheetR tid ssh csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSheetR tid ssh csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSheetR tid ssh csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) + breadcrumb (CSubmissionR tid ssh csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid ssh csh shn SShowR) +-- (CSubmissionR tid ssh csh shn _ SubArchiveR) -- just for Download + breadcrumb (CSubmissionR tid ssh csh shn cid CorrectionR) = return ("Korrektur", Just $ CSubmissionR tid ssh csh shn cid SubShowR) +-- (CSubmissionR tid ssh csh shn _ SubDownloadR) -- just for Download + breadcrumb (CSheetR tid ssh csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid ssh csh shn SShowR) + -- (CSheetR tid ssh csh shn SFileR) -- just for Downloads -- Others breadcrumb (CorrectionsR) = return ("Korrekturen", Just HomeR) breadcrumb (CorrectionsUploadR) = return ("Hochladen", Just CorrectionsR) @@ -826,22 +833,22 @@ pageActions (CourseListR) = , menuItemAccessCallback' = return True } ] -pageActions (CourseR tid csh CShowR) = +pageActions (CourseR tid ssh csh CShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Kurs Editieren" , menuItemIcon = Nothing - , menuItemRoute = CourseR tid csh CEditR + , menuItemRoute = CourseR tid ssh csh CEditR , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Übungsblätter" , menuItemIcon = Nothing - , menuItemRoute = CourseR tid csh SheetListR + , menuItemRoute = CourseR tid ssh csh SheetListR , 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 (sheets,lecturer) <- runDB $ do - cid <- getKeyBy404 $ CourseTermShort tid csh + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh sheets <- map (sheetName.entityVal) <$> selectList [SheetCourse ==. cid] [Desc SheetActiveFrom] lecturer <- case muid of Nothing -> return False @@ -852,29 +859,29 @@ pageActions (CourseR tid csh CShowR) = , PageActionPrime $ MenuItem { menuItemLabel = "Abgaben" , menuItemIcon = Nothing - , menuItemRoute = CourseR tid csh CCorrectionsR + , menuItemRoute = CourseR tid ssh csh CCorrectionsR , menuItemAccessCallback' = return True } , PageActionSecondary $ MenuItem { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing - , menuItemRoute = CourseR tid csh SheetNewR + , menuItemRoute = CourseR tid ssh csh SheetNewR , menuItemAccessCallback' = return True } ] -pageActions (CourseR tid csh SheetListR) = +pageActions (CourseR tid ssh csh SheetListR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Neues Übungsblatt anlegen" , menuItemIcon = Nothing - , menuItemRoute = CourseR tid csh SheetNewR + , menuItemRoute = CourseR tid ssh csh SheetNewR , menuItemAccessCallback' = return True } ] -pageActions (CSheetR tid csh shn SShowR) = +pageActions (CSheetR tid ssh csh shn SShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Abgabe anlegen" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh shn SubmissionNewR + , menuItemRoute = CSheetR tid ssh csh shn SubmissionNewR , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId submissions <- lift $ submissionList tid csh shn uid @@ -884,7 +891,7 @@ pageActions (CSheetR tid csh shn SShowR) = , PageActionPrime $ MenuItem { menuItemLabel = "Abgabe ansehen" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh shn SubmissionOwnR + , menuItemRoute = CSheetR tid ssh csh shn SubmissionOwnR , menuItemAccessCallback' = runDB . maybeT (return False) $ do uid <- MaybeT $ liftHandlerT maybeAuthId submissions <- lift $ submissionList tid csh shn uid @@ -894,43 +901,43 @@ pageActions (CSheetR tid csh shn SShowR) = , PageActionPrime $ MenuItem { menuItemLabel = "Korrektoren" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh shn SCorrR + , menuItemRoute = CSheetR tid ssh csh shn SCorrR , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Abgaben" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh shn SSubsR + , menuItemRoute = CSheetR tid ssh csh shn SSubsR , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Blatt Editieren" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh shn SEditR + , menuItemRoute = CSheetR tid ssh csh shn SEditR , menuItemAccessCallback' = return True } ] -pageActions (CSheetR tid csh shn SSubsR) = +pageActions (CSheetR tid ssh csh shn SSubsR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Korrektoren" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh shn SCorrR + , menuItemRoute = CSheetR tid ssh csh shn SCorrR , menuItemAccessCallback' = return True } ] -pageActions (CSubmissionR tid csh shn cid SubShowR) = +pageActions (CSubmissionR tid ssh csh shn cid SubShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Korrektur" , menuItemIcon = Nothing - , menuItemRoute = CSubmissionR tid csh shn cid CorrectionR + , menuItemRoute = CSubmissionR tid ssh csh shn cid CorrectionR , menuItemAccessCallback' = return True } ] -pageActions (CSheetR tid csh shn SCorrR) = +pageActions (CSheetR tid ssh csh shn SCorrR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Abgaben" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh shn SSubsR + , menuItemRoute = CSheetR tid ssh csh shn SSubsR , menuItemAccessCallback' = return True } ] @@ -977,45 +984,49 @@ pageHeading (TermEditExistR tid) = Just $ i18nHeading $ MsgTermEditTid tid pageHeading (TermCourseListR tid) = Just . i18nHeading . MsgTermCourseListHeading $ tid +pageHeading (TermSchoolCourseListR tid ssh) + = Just $ do + School{schoolName=school} <- handlerToWidget $ runDB $ get404 ssh + i18nHeading $ MsgTermSchoolCourseListHeading tid school pageHeading (CourseListR) = Just $ i18nHeading $ MsgCourseListTitle pageHeading CourseNewR = Just $ i18nHeading MsgCourseNewHeading -pageHeading (CourseR tid csh CShowR) +pageHeading (CourseR tid ssh csh CShowR) = Just $ do - Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ CourseTermShort tid csh + Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ TermSchoolCourseShort tid ssh csh toWidget courseName -- (CourseR tid csh CRegisterR) -- just for POST -pageHeading (CourseR tid csh CEditR) - = Just $ i18nHeading $ MsgCourseEditHeading tid csh -pageHeading (CourseR tid csh CCorrectionsR) - = Just $ i18nHeading $ MsgSubmissionsCourse tid csh -pageHeading (CourseR tid csh SheetListR) - = Just $ i18nHeading $ MsgSheetList tid csh -pageHeading (CourseR tid csh SheetNewR) - = Just $ i18nHeading $ MsgSheetNewHeading tid csh -pageHeading (CSheetR tid csh shn SShowR) - = Just $ i18nHeading $ MsgSheetTitle tid csh shn -pageHeading (CSheetR tid csh shn SEditR) - = Just $ i18nHeading $ MsgSheetEditHead tid csh shn -pageHeading (CSheetR tid csh shn SDelR) - = Just $ i18nHeading $ MsgSheetDelHead tid csh shn -pageHeading (CSheetR tid csh shn SSubsR) +pageHeading (CourseR tid ssh csh CEditR) + = Just $ i18nHeading $ MsgCourseEditHeading tid ssh csh +pageHeading (CourseR tid ssh csh CCorrectionsR) + = Just $ i18nHeading $ MsgSubmissionsCourse tid ssh csh +pageHeading (CourseR tid ssh csh SheetListR) + = Just $ i18nHeading $ MsgSheetList tid ssh csh +pageHeading (CourseR tid ssh csh SheetNewR) + = Just $ i18nHeading $ MsgSheetNewHeading tid ssh csh +pageHeading (CSheetR tid ssh csh shn SShowR) + = Just $ i18nHeading $ MsgSheetTitle tid ssh csh shn +pageHeading (CSheetR tid ssh csh shn SEditR) + = Just $ i18nHeading $ MsgSheetEditHead tid ssh csh shn +pageHeading (CSheetR tid ssh csh shn SDelR) + = Just $ i18nHeading $ MsgSheetDelHead tid ssh csh shn +pageHeading (CSheetR tid ssh csh shn SSubsR) = Just $ i18nHeading $ MsgSubmissionsSheet shn -pageHeading (CSheetR tid csh shn SubmissionNewR) - = Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn -pageHeading (CSheetR tid csh shn SubmissionOwnR) - = Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn -pageHeading (CSubmissionR tid csh shn _ SubShowR) -- TODO: Rethink this one! - = Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn +pageHeading (CSheetR tid ssh csh shn SubmissionNewR) + = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn +pageHeading (CSheetR tid ssh csh shn SubmissionOwnR) + = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn +pageHeading (CSubmissionR tid ssh csh shn _ SubShowR) -- TODO: Rethink this one! + = Just $ i18nHeading $ MsgSubmissionEditHead tid ssh csh shn -- (CSubmissionR tid csh shn cid SubArchiveR) -- just a download -pageHeading (CSubmissionR tid csh shn cid CorrectionR) - = Just $ i18nHeading $ MsgCorrectionHead tid csh shn cid +pageHeading (CSubmissionR tid ssh csh shn cid CorrectionR) + = Just $ i18nHeading $ MsgCorrectionHead tid ssh csh shn cid -- (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 --- (CSheetR tid csh shn SFileR) -- just for Downloads +-- (CSheetR tid ssh csh shn SFileR) -- just for Downloads pageHeading CorrectionsR = Just $ i18nHeading MsgCorrectionsTitle @@ -1030,6 +1041,7 @@ pageHeading _ routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)] routeNormalizers = [ normalizeRender + , ncSchool , ncCourse , ncSheet ] @@ -1050,17 +1062,25 @@ routeNormalizers = $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|] tell $ Any True | 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 - CourseR tid csh subRoute <- return route - Entity _ Course{..} <- MaybeT . lift . getBy $ CourseTermShort tid csh + CourseR tid ssh csh subRoute <- return route + Entity _ Course{..} <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh hasChanged csh courseShorthand - return $ CourseR tid courseShorthand subRoute + (hasChanged `on` unSchoolKey) ssh courseSchool + return $ CourseR tid courseSchool courseShorthand subRoute ncSheet = maybeOrig $ \route -> do - CSheetR tid csh shn subRoute <- return route - Entity cid _ <- MaybeT . lift . getBy $ CourseTermShort tid csh + CSheetR tid ssh csh shn subRoute <- return route + Entity cid _ <- MaybeT . lift . getBy $ TermSchoolCourseShort tid ssh csh Entity _ Sheet{..} <- MaybeT . lift . getBy $ CourseSheet cid shn hasChanged shn sheetName - return $ CSheetR tid csh sheetName subRoute + return $ CSheetR tid ssh csh sheetName subRoute -- How to run database actions. diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index 96ad16794..5e587c624 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -86,17 +86,19 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm) colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(_, _, course, _, _) } -> - let tid = course ^. _3 - csh = course ^. _2 - in anchorCell (CourseR tid csh CShowR) [whamlet|#{display csh}|] + let csh = course ^. _2 + tid = course ^. _3 + ssh = course ^. _4 + in anchorCell (CourseR tid ssh csh CShowR) [whamlet|#{display csh}|] colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a) colSheet = sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(_, sheet, course, _, _) } -> - let tid = course ^. _3 - csh = course ^. _2 + let csh = course ^. _2 + tid = course ^. _3 + ssh = course ^. _4 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 = 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 = sortable Nothing (i18nCell MsgSubmission) $ \DBRow{ dbrOutput=(submission, sheet, course, _, _) } -> - let tid = course ^. _3 - csh = course ^. _2 + let csh = course ^. _2 + tid = course ^. _3 + ssh = course ^. _4 shn = sheetName $ entityVal sheet mkCid = encrypt (entityKey submission :: SubmissionId) -- TODO: executed twice mkRoute = do 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}|]) 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 = sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{ dbrOutput=(Entity subId Submission{..}, Entity _ Sheet{..}, course, _, _) } -> - let tid = course ^. _3 - csh = course ^. _2 + let csh = course ^. _2 + tid = course ^. _3 + ssh = course ^. _4 -- shn = sheetName mkRoute = do cid <- encrypt subId - return $ CSubmissionR tid csh sheetName cid CorrectionR + return $ CSubmissionR tid ssh csh sheetName cid CorrectionR 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)) @@ -340,10 +344,10 @@ postCorrectionsR = do [ downloadAction ] -getCCorrectionsR, postCCorrectionsR :: TermId -> CourseShorthand -> Handler TypedContent +getCCorrectionsR, postCCorrectionsR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent getCCorrectionsR = postCCorrectionsR -postCCorrectionsR tid csh = do - Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh +postCCorrectionsR tid ssh csh = do + Entity cid _ <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh let whereClause = courseIs cid colonnade = mconcat [ colSelect @@ -360,10 +364,10 @@ postCCorrectionsR tid csh = do , assignAction (Left cid) ] -getSSubsR, postSSubsR :: TermId -> CourseShorthand -> SheetName -> Handler TypedContent +getSSubsR, postSSubsR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSSubsR = postSSubsR -postSSubsR tid csh shn = do - shid <- runDB $ fetchSheetId tid csh shn +postSSubsR tid ssh csh shn = do + shid <- runDB $ fetchSheetId tid ssh csh shn let whereClause = sheetIs shid colonnade = mconcat [ colSelect @@ -380,26 +384,26 @@ postSSubsR tid csh shn = do , 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 $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId - - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. sheet E.^. SheetName E.==. E.val shn + 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.&&. sheet E.^. SheetName E.==. E.val shn E.&&. submission E.^. SubmissionId E.==. E.val sub - return (course, sheet, submission, corrector) -getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html -getCorrectionR tid csh shn cid = do - mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True - bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid csh shn cid -postCorrectionR tid csh shn cid = do +getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> Handler Html +getCorrectionR tid ssh csh shn cid = do + mayPost <- isAuthorized (CSubmissionR tid ssh csh shn cid CorrectionR) True + bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid ssh csh shn cid +postCorrectionR tid ssh csh shn cid = do sub <- decrypt cid - results <- runDB $ correctionData tid csh shn sub + results <- runDB $ correctionData tid ssh csh shn sub case results of [(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 - update sub [ SubmissionRatingBy =. (uid <$ guard rated) - , SubmissionRatingTime =. (now <$ guard rated) - , SubmissionRatingPoints =. ratingPoints + update sub [ SubmissionRatingBy =. (uid <$ guard rated) + , SubmissionRatingTime =. (now <$ guard rated) + , SubmissionRatingPoints =. ratingPoints , SubmissionRatingComment =. ratingComment ] addMessageI "success" $ bool MsgRatingDeleted MsgRatingUpdated rated - redirect $ CSubmissionR tid csh shn cid CorrectionR + redirect $ CSubmissionR tid ssh csh shn cid CorrectionR case uploadResult of FormMissing -> return () @@ -442,16 +446,16 @@ postCorrectionR tid csh shn cid = do runDB . runConduit $ transPipe lift fileSource .| extractRatingsMsg .| sinkSubmission uid (Right sub) True addMessageI "success" MsgRatingFilesUpdated - redirect $ CSubmissionR tid csh shn cid CorrectionR + redirect $ CSubmissionR tid ssh csh shn cid CorrectionR defaultLayout $ do let userCorrection = $(widgetFile "correction-user") $(widgetFile "correction") _ -> notFound -getCorrectionUserR tid csh shn cid = do +getCorrectionUserR tid ssh csh shn cid = do sub <- decrypt cid - results <- runDB $ correctionData tid csh shn sub + results <- runDB $ correctionData tid ssh csh shn sub case results of [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _))] -> do diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 2e7cdb0fe..465c8f73f 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -39,13 +39,13 @@ type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School) colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCourse = sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> - anchorCell (CourseR courseTerm courseShorthand CShowR) + anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseName}|] colCourseDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCourseDescr = sortable (Just "course") (i18nCell MsgCourse) $ \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 Nothing -> mempty (Just descr) -> cell [whamlet| ^{modalStatic descr} |] @@ -61,12 +61,12 @@ colDescription = sortable Nothing (i18nCell MsgCourseDescription) colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort) $ \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 = sortable (Just "cshort") (i18nCell MsgCourseShort) $ \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 Nothing -> mempty (Just descr) -> cell @@ -80,13 +80,13 @@ colTerm = sortable (Just "term") (i18nCell MsgTerm) colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colSchool = sortable (Just "school") (i18nCell MsgCourseSchool) - $ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } -> - cell [whamlet|#{display schoolName}|] + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } -> + anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolName}|] colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort) - $ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } -> - cell [whamlet|#{display schoolShorthand}|] + $ \DBRow{ dbrOutput=(Entity _ Course{..}, _, _, Entity _ School{..}) } -> + anchorCell (TermSchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|] colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) @@ -201,6 +201,30 @@ getTermCurrentR = do (Just (maximum -> tid)) -> -- getTermCourseListR tid 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 tid = do void . runDB $ get404 tid -- Just ensure the term exists @@ -222,13 +246,13 @@ getTermCourseListR tid = do setTitleI . MsgTermCourseListTitle $ tid $(widgetFile "courses") -getCShowR :: TermId -> CourseShorthand -> Handler Html -getCShowR tid csh = do +getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCShowR tid ssh csh = do mbAid <- maybeAuthId (courseEnt,(schoolMB,participants,registered)) <- runDB $ do - courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh + courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh dependent <- (,,) - <$> get (courseSchool course) -- join + <$> get (courseSchool course) -- join -- just fetch full school name here <*> count [CourseParticipantCourse ==. cid] -- join <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here! Nothing -> return False @@ -238,7 +262,7 @@ getCShowR tid csh = do return $ (courseEnt,dependent) let course = entityVal courseEnt (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 mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course 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 -postCRegisterR :: TermId -> CourseShorthand -> Handler Html -postCRegisterR tid csh = do +postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +postCRegisterR tid ssh csh = do aid <- requireAuthId (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) return (cid, course, registered) ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course @@ -277,7 +301,7 @@ postCRegisterR tid csh = do when (isJust regOk) $ addMessageI "success" MsgCourseRegisterOk | otherwise -> addMessageI "danger" MsgCourseSecretWrong (_other) -> return () -- TODO check this! - redirect $ CourseR tid csh CShowR + redirect $ CourseR tid ssh csh CShowR getCourseNewR :: Handler Html getCourseNewR = do @@ -287,14 +311,14 @@ getCourseNewR = do postCourseNewR :: Handler Html postCourseNewR = courseEditHandler False Nothing -getCEditR :: TermId -> CourseShorthand -> Handler Html -getCEditR tid csh = do - course <- runDB $ getBy $ CourseTermShort tid csh +getCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getCEditR tid ssh csh = do + course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh courseEditHandler True course -postCEditR :: TermId -> CourseShorthand -> Handler Html -postCEditR tid csh = do - course <- runDB $ getBy $ CourseTermShort tid csh +postCEditR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +postCEditR tid ssh csh = do + course <- runDB $ getBy $ TermSchoolCourseShort tid ssh csh courseEditHandler False course @@ -317,6 +341,7 @@ courseEditHandler isGet course = do (FormSuccess res@( CourseForm { cfCourseId = Nothing , cfShort = csh + , cfSchool = ssh , cfTerm = tid })) -> do -- create new course now <- liftIO getCurrentTime @@ -339,14 +364,15 @@ courseEditHandler isGet course = do runDB $ do insert_ $ CourseEdit aid now cid insert_ $ Lecturer aid cid - addMessageI "info" $ MsgCourseNewOk tid csh + addMessageI "info" $ MsgCourseNewOk tid ssh csh redirect $ TermCourseListR tid Nothing -> - addMessageI "danger" $ MsgCourseNewDupShort tid csh + addMessageI "danger" $ MsgCourseNewDupShort tid ssh csh (FormSuccess res@( CourseForm { cfCourseId = Just cid , cfShort = csh + , cfSchool = ssh , cfTerm = tid })) -> do -- edit existing course now <- liftIO getCurrentTime @@ -372,12 +398,12 @@ courseEditHandler isGet course = do } ) case updOkay of - (Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid csh) $> False + (Just _) -> addMessageI "danger" (MsgCourseEditDupShort tid ssh csh) $> False Nothing -> do insert_ $ CourseEdit aid now cid - addMessageI "success" $ MsgCourseEditOk tid csh + addMessageI "success" $ MsgCourseEditOk tid ssh csh return True - when success $ redirect $ CourseR tid csh CShowR + when success $ redirect $ CourseR tid ssh csh CShowR (FormFailure _) -> addMessageI "warning" MsgInvalidInput (FormMissing) -> return () @@ -429,7 +455,6 @@ newCourseForm template = identForm FIDcourse $ \html -> do [ map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. 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 <$> pure (cfCourseId =<< template) <*> areq (ciField textField) (fslI MsgCourseName) (cfName <$> template) @@ -440,24 +465,19 @@ newCourseForm template = identForm FIDcourse $ \html -> do -- & addAttr "disabled" "disabled" & setTooltip MsgCourseShorthandUnique) (cfShort <$> template) - <*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template) - <*> areq schoolField (fslI MsgCourseSchool) (cfSchool <$> template) - <*> aopt (natField "Kapazität") (fslI MsgCourseCapacity - & setTooltip MsgCourseCapacityTip - ) (cfCapacity <$> template) - <*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette" - & setTooltip MsgCourseSecretTip) - (cfSecret <$> template) - <*> areq checkBoxField (fslI MsgMaterialFree)(cfMatFree <$> template) - <*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum" - & setTooltip MsgCourseRegisterFromTip) - (cfRegFrom <$> template) - <*> aopt utcTimeField (fslpI MsgRegisterTo "Datum" - & setTooltip MsgCourseRegisterToTip) - (cfRegTo <$> template) - <*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum" - & setTooltip MsgCourseDeregisterUntilTip) - (cfDeRegUntil <$> template) + <*> areq termActiveField (fslI MsgCourseSemester) (cfTerm <$> template) + <*> areq (schoolFieldFor userSchools) (fslI MsgCourseSchool) (cfSchool <$> template) + <*> aopt (natField "Kapazität") (fslI MsgCourseCapacity + & setTooltip MsgCourseCapacityTip) (cfCapacity <$> template) + <*> aopt textField (fslpI MsgCourseSecret "beliebige Zeichenkette" + & setTooltip MsgCourseSecretTip) (cfSecret <$> template) + <*> areq checkBoxField (fslI MsgMaterialFree) (cfMatFree <$> template) + <*> aopt utcTimeField (fslpI MsgRegisterFrom "Datum" + & setTooltip MsgCourseRegisterFromTip) (cfRegFrom <$> template) + <*> aopt utcTimeField (fslpI MsgRegisterTo "Datum" + & setTooltip MsgCourseRegisterToTip) (cfRegTo <$> template) + <*> aopt utcTimeField (fslpI MsgDeRegUntil "Datum" + & setTooltip MsgCourseDeregisterUntilTip) (cfDeRegUntil <$> template) <* submitButton return $ case result of FormSuccess courseResult diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index 6f198828b..9a744f208 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -38,23 +38,23 @@ instance CryptoRoute UUID SubmissionId where cryptoIDRoute _ (CryptoID -> cID) = do (smid :: SubmissionId) <- decrypt cID cID' <- encrypt smid - (tid,csh,shn) <- runDB $ do + (tid,ssh,csh,shn) <- runDB $ do shid <- submissionSheet <$> get404 smid Sheet{..} <- get404 shid Course{..} <- get404 sheetCourse - return (courseTerm, courseShorthand, sheetName) - return $ CSubmissionR tid csh shn cID' SubShowR + return (courseTerm, courseSchool, courseShorthand, sheetName) + return $ CSubmissionR tid ssh csh shn cID' SubShowR instance CryptoRoute (CI FilePath) SubmissionId where cryptoIDRoute _ ciphertext | Just cID <- fromPathPiece . Text.pack $ CI.original ciphertext = do smid <- decrypt cID - (tid,csh,shn) <- runDB $ do + (tid,ssh,csh,shn) <- runDB $ do shid <- submissionSheet <$> get404 smid Sheet{..} <- get404 shid Course{..} <- get404 sheetCourse - return (courseTerm, courseShorthand, sheetName) - return $ CSubmissionR tid csh shn cID SubShowR + return (courseTerm, courseSchool, courseShorthand, sheetName) + return $ CSubmissionR tid ssh csh shn cID SubShowR | otherwise = notFound instance CryptoRoute UUID UserId where diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index adca2c28a..41207f774 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -22,12 +22,12 @@ import Data.Time hiding (formatTime) -- import Web.PathPieces (showToPathPiece, readFromPathPiece) -import Control.Lens -import Colonnade hiding (fromMaybe, singleton) +-- import Control.Lens +-- import Colonnade hiding (fromMaybe, singleton) -- import Yesod.Colonnade import qualified Database.Esqueleto as E -import Text.Shakespeare.Text +-- import Text.Shakespeare.Text import Development.GitRev @@ -55,7 +55,6 @@ getHomeR = do homeAnonymous :: Handler Html homeAnonymous = do cTime <- liftIO getCurrentTime - let fTime = addUTCTime (offCourseDeadlines * nominalDay) cTime let tableData :: E.SqlExpr (Entity Course) -> E.SqlQuery (E.SqlExpr (Entity Course)) tableData course = do @@ -68,12 +67,15 @@ homeAnonymous = do colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ()) colonnade = mconcat [ -- dbRow - sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do - let tid = courseTerm course - csh = courseShorthand course - cell [whamlet|#{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 + , 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}) } -> cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget ] @@ -85,6 +87,9 @@ homeAnonymous = do [ ( "term" , SortColumn $ \(course) -> course E.^. CourseTerm ) + , ( "school" + , SortColumn $ \(course) -> course E.^. CourseSchool + ) , ( "course" , SortColumn $ \(course) -> course E.^. CourseShorthand ) @@ -116,6 +121,7 @@ homeUser uid = do -- (E.SqlExpr (Entity Course ))) -- (E.SqlExpr (Entity Sheet )) _ -> E.SqlQuery ( E.SqlExpr (E.Value (Key Term)) + , E.SqlExpr (E.Value SchoolId) , E.SqlExpr (E.Value CourseShorthand) , E.SqlExpr (E.Value SheetName) , E.SqlExpr (E.Value UTCTime) @@ -132,6 +138,7 @@ homeUser uid = do -- E.limit nrSheetDeadlines -- arbitrary limits are not intuitive return ( course E.^. CourseTerm + , course E.^. CourseSchool , course E.^. CourseShorthand , sheet E.^. SheetName , sheet E.^. SheetActiveTo @@ -139,6 +146,7 @@ homeUser uid = do ) colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term) + , E.Value SchoolId , E.Value CourseShorthand , E.Value SheetName , E.Value UTCTime @@ -147,30 +155,36 @@ homeUser uid = do (DBCell (HandlerT UniWorX IO) ()) colonnade = mconcat [ -- dbRow - sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _, _) } -> - anchorCell (CourseR tid csh CShowR) (toWidget $ display csh) - , sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid, _,_,_,_) } -> + -- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } -> + sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } -> textCell $ display tid - , sortable (Just "sheet") (textCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _, _) } -> - anchorCell (CSheetR tid csh shn SShowR) (toWidget $ display shn) - , sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline, _) } -> + , sortable (Just "school") (textCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } -> + textCell $ display ssh + , 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 - , 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 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 ] let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)] ((), sheetTable) <- dbTable validator $ DBTable { dbtSQLQuery = tableData , dbtColonnade = colonnade - , dbtProj = \dbRow@DBRow{ dbrOutput = (E.Value tid, E.Value csh, E.Value shn, _, _) } - -> dbRow <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh shn SShowR) False) + , dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } + -> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False) , dbtSorting = Map.fromList [ ( "term" , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm ) + , ( "school" + , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseSchool + ) , ( "course" , SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseShorthand ) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index f869efc37..c54945b70 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -99,7 +99,7 @@ getProfileR = do (E.select $ E.from $ \(lecturer `E.InnerJoin` course) -> do E.where_ $ lecturer ^. LecturerUser E.==. E.val uid 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 @@ -107,13 +107,13 @@ getProfileR = do E.on $ sheet ^. SheetId E.==. corrector ^. SheetCorrectorSheet 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.where_ $ participant ^. CourseParticipantUser E.==. E.val uid 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 @@ -141,7 +141,7 @@ postProfileR = do getProfileDataR :: Handler Html getProfileDataR = do - (uid, User{..}) <- requireAuthPair + (_uid, User{..}) <- requireAuthPair -- mr <- getMessageRender defaultLayout $ do diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index c46a95095..dd2d7dd7e 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -21,31 +21,31 @@ import Import import System.FilePath (takeFileName) import Handler.Utils -import Handler.Utils.Zip +-- import Handler.Utils.Zip -- import Data.Time -import qualified Data.Text as T +-- import qualified Data.Text as T -- import Data.Function ((&)) -- -import Colonnade hiding (fromMaybe, singleton, bool) +-- import Colonnade hiding (fromMaybe, singleton, bool) import qualified Yesod.Colonnade as Yesod 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 Data.CaseInsensitive (CI) +-- import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI 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.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 @@ -59,7 +59,7 @@ import qualified Data.Map as Map import Data.Monoid (Sum(..)) import Control.Lens -import Utils.Lens +-- import Utils.Lens instance Eq (Unique Sheet) where @@ -146,24 +146,24 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do , ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly) ] ] -getSheetListR :: TermId -> CourseShorthand -> Handler Html -getSheetListR tid csh = do +getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getSheetListR tid ssh csh = do muid <- maybeAuthId - Entity cid _ <- runDB . getBy404 $ CourseTermShort tid csh + Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh 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 (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid - let sheetEdit = E.sub_select . E.from $ \sheetEdit -> do - E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId - return . E.max_ $ sheetEdit E.^. SheetEditTime + let sheetEdit = E.sub_select . E.from $ \sheetEdit' -> do + E.where_ $ sheetEdit' E.^. SheetEditSheet E.==. sheet E.^. SheetId + return . E.max_ $ sheetEdit' E.^. SheetEditTime E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return (sheet, sheetEdit, submission) sheetCol = widgetColonnade . mconcat $ [ 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) $ \(_, E.Value mEditTime, _) -> case mEditTime of Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget @@ -180,9 +180,9 @@ getSheetListR tid csh = do (Just (Entity sid Submission{..})) -> let mkCid = encrypt sid -- TODO: executed twice mkRoute = do - cid <- mkCid - return $ CSubmissionR tid csh sheetName cid SubShowR - in anchorCellM mkRoute (mkCid >>= \cid -> [whamlet|#{display cid}|]) + cid' <- mkCid + return $ CSubmissionR tid ssh csh sheetName cid' SubShowR + in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|]) , sortable (Just "rating") (i18nCell MsgRating) $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of Nothing -> mempty @@ -190,7 +190,7 @@ getSheetListR tid csh = do let mkCid = encrypt sid mkRoute = do cid <- mkCid - return $ CSubmissionR tid csh sheetName cid CorrectionR + return $ CSubmissionR tid ssh csh sheetName cid CorrectionR protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating") in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints))) , sortable Nothing -- (Just "percent") @@ -211,7 +211,7 @@ getSheetListR tid csh = do { dbtSQLQuery = sheetData , dbtColonnade = sheetCol , 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 [ ( "name" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName @@ -246,9 +246,9 @@ getSheetListR tid csh = do $(widgetFile "widgets/sheetTypeSummary") -- Show single sheet -getSShowR :: TermId -> CourseShorthand -> SheetName -> Handler Html -getSShowR tid csh shn = do - entSheet <- runDB $ fetchSheet tid csh shn +getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +getSShowR tid ssh csh shn = do + entSheet <- runDB $ fetchSheet tid ssh csh shn let sheet = entityVal entSheet sid = entityKey entSheet -- without Colonnade @@ -261,7 +261,7 @@ getSShowR tid csh shn = do -- E.where_ (sheet E.^. SheetId E.==. E.val sid ) -- -- return desired columns -- 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 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) let colonnadeFiles = widgetColonnade $ mconcat [ 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) , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget ] @@ -285,7 +285,7 @@ getSShowR tid csh shn = do { dbtSQLQuery = fileData , dbtColonnade = colonnadeFiles , 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 , dbtFilter = Map.empty , dbtIdent = "files" :: Text @@ -309,19 +309,19 @@ getSShowR tid csh shn = do when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI "warning" $ maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom defaultLayout $ do - setTitleI $ MsgSheetTitle tid csh shn + setTitleI $ MsgSheetTitle tid ssh csh shn sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet $(widgetFile "sheetShow") -getSFileR :: TermId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent -getSFileR tid csh shn typ title = do +getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent +getSFileR tid ssh csh shn typ title = do results <- runDB $ E.select $ E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do -- Restrict to consistent rows that correspond to each other - E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) + E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) -- filter to requested file @@ -329,7 +329,8 @@ getSFileR tid csh shn typ title = do E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ ) E.&&. (sheet E.^. SheetName E.==. E.val shn ) 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 $ (file E.^. FileTitle, file E.^. FileContent) @@ -346,21 +347,21 @@ getSFileR tid csh shn typ title = do $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other error "Multiple matching files found." -getSheetNewR :: TermId -> CourseShorthand -> Handler Html -getSheetNewR tid csh = do +getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getSheetNewR tid ssh csh = do let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing insertUnique $ newSheet - handleSheetEdit tid csh Nothing template action + handleSheetEdit tid ssh csh Nothing template action -postSheetNewR :: TermId -> CourseShorthand -> Handler Html +postSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html postSheetNewR = getSheetNewR -getSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html -getSEditR tid csh shn = do +getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +getSEditR tid ssh csh shn = do (sheetEnt, sheetFileIds) <- runDB $ do - ent <- fetchSheet tid csh shn + ent <- fetchSheet tid ssh csh shn fti <- getFtIdMap $ entityKey ent return (ent, fti) let sid = entityKey sheetEnt @@ -386,13 +387,13 @@ getSEditR tid csh shn = do case replaceRes of Nothing -> return $ Just sid (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 -handleSheetEdit :: TermId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html -handleSheetEdit tid csh msId template dbAction = do +handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html +handleSheetEdit tid ssh csh msId template dbAction = do let mbshn = sfName <$> template aid <- requireAuthId ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template @@ -400,7 +401,7 @@ handleSheetEdit tid csh msId template dbAction = do (FormSuccess SheetForm{..}) -> do saveOkay <- runDB $ do actTime <- liftIO getCurrentTime - cid <- getKeyBy404 $ CourseTermShort tid csh + cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh let newSheet = Sheet { sheetCourse = cid , sheetName = sfName @@ -416,51 +417,51 @@ handleSheetEdit tid csh msId template dbAction = do } mbsid <- dbAction newSheet 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: whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise whenIsJust sfHintF $ insertSheetFile' sid SheetHint whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking insert_ $ SheetEdit aid actTime sid - addMessageI "info" $ MsgSheetEditOk tid csh sfName + addMessageI "info" $ MsgSheetEditOk tid ssh csh sfName 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 _ -> return () - let pageTitle = maybe (MsgSheetTitleNew tid csh) - (MsgSheetTitle tid csh) mbshn + let pageTitle = maybe (MsgSheetTitleNew tid ssh csh) + (MsgSheetTitle tid ssh csh) mbshn -- let formTitle = pageTitle -- no longer used in template let formText = Nothing :: Maybe UniWorXMessage - actionUrl <- fromMaybe (CourseR tid csh SheetNewR) <$> getCurrentRoute + actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute defaultLayout $ do setTitleI pageTitle $(widgetFile "formPageI18n") -getSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html -getSDelR tid csh shn = do +getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +getSDelR tid ssh csh shn = do ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) case result of - (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh shn SShowR + (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid ssh csh shn SShowR (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!!! - addMessageI "info" $ MsgSheetDelOk tid csh shn - redirect $ CourseR tid csh SheetListR + addMessageI "info" $ MsgSheetDelOk tid ssh csh shn + redirect $ CourseR tid ssh csh SheetListR _other -> do submissionno <- runDB $ do - sid <- fetchSheetId tid csh shn + sid <- fetchSheetId tid ssh csh shn count [SubmissionSheet ==. sid] - let formTitle = MsgSheetDelHead tid csh shn + let formTitle = MsgSheetDelHead tid ssh csh shn let formText = Just $ MsgSheetDelText submissionno - let actionUrl = CSheetR tid csh shn SDelR + let actionUrl = CSheetR tid ssh csh shn SDelR defaultLayout $ do - setTitleI $ MsgSheetTitle tid csh shn + setTitleI $ MsgSheetTitle tid ssh csh shn $(widgetFile "formPageI18n") -postSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html +postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html postSDelR = getSDelR @@ -661,10 +662,10 @@ correctorForm shid = do -- Eingabebox für Korrektor hinzufügen -- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen -getSCorrR, postSCorrR :: TermId -> CourseShorthand -> SheetName -> Handler Html +getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html postSCorrR = getSCorrR -getSCorrR tid csh shn = do - Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn +getSCorrR tid ssh csh shn = do + Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn ((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton @@ -677,10 +678,10 @@ getSCorrR tid csh shn = do FormMissing -> return () let - -- formTitle = MsgSheetCorrectorsTitle tid csh shn + -- formTitle = MsgSheetCorrectorsTitle tid ssh csh shn formText = Nothing :: Maybe (SomeMessage UniWorX) - actionUrl = CSheetR tid csh shn SCorrR - -- actionUrl = CSheetR tid csh shn SShowR + actionUrl = CSheetR tid ssh csh shn SCorrR + -- actionUrl = CSheetR tid ssh csh shn SShowR defaultLayout $ do - setTitleI $ MsgSheetCorrectorsTitle tid csh shn + setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn $(widgetFile "formPageI18n") diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 8c1987bf5..e55a8a25f 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -78,20 +78,20 @@ makeSubmissionForm msmid unpackZips grouping buddies = identForm FIDsubmission $ aforced' f fs (Just (Just v)) = Just <$> aforced f fs v aforced' _ _ _ = error "Cannot happen since groupNr==0 if grouping/=Arbitrary" -getSubmissionNewR, postSubmissionNewR :: TermId -> CourseShorthand -> SheetName -> Handler Html +getSubmissionNewR, postSubmissionNewR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html 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 -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 tid csh shn = do +getSubmissionOwnR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +getSubmissionOwnR tid ssh csh shn = do authId <- requireAuthId sid <- runDB $ do - shid <- fetchSheetId tid csh shn + shid <- fetchSheetId tid ssh csh shn submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do E.on (submission E.^. SubmissionId E.==. submissionUser E.^. SubmissionUserSubmission) E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val authId @@ -101,14 +101,14 @@ getSubmissionOwnR tid csh shn = do ((E.Value sid):_) -> return sid [] -> notFound 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 tid csh shn (SubmissionMode mcid) = do +submissionHelper :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SubmissionMode -> Handler Html +submissionHelper tid ssh csh shn (SubmissionMode mcid) = do uid <- requireAuthId msmid <- traverse decrypt mcid (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 Nothing -> 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 cID <- encrypt smid addMessageI "info" $ MsgSubmissionAlreadyExists - redirect $ CSubmissionR tid csh shn cID SubShowR + redirect $ CSubmissionR tid ssh csh shn cID SubShowR (Just smid) -> do - void $ submissionMatchesSheet tid csh shn (fromJust mcid) + void $ submissionMatchesSheet tid ssh csh shn (fromJust mcid) shid' <- submissionSheet <$> get404 smid -- fetch buddies from current submission @@ -239,7 +239,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do _other -> return Nothing case mCID of - Just cID -> redirect $ CSubmissionR tid csh shn cID SubShowR + Just cID -> redirect $ CSubmissionR tid ssh csh shn cID SubShowR Nothing -> return () actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute @@ -254,13 +254,13 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do corrIsFile = fmap (isJust . fileContent . entityVal . snd) mCorr Just isFile = origIsFile <|> corrIsFile 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'}|]) | otherwise -> textCell $ bool (<> "/") id isFile fileTitle' , sortable Nothing (cell mempty) $ \(coalesce -> (_, mCorr)) -> case mCorr of Nothing -> cell mempty 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}|]) | otherwise -> textCell MsgFileCorrected , 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 defaultLayout $ do - setTitleI $ MsgSubmissionEditHead tid csh shn + setTitleI $ MsgSubmissionEditHead tid ssh csh shn $(widgetFile "submission") -getSubDownloadR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent -getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do +getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent +getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do runDB $ do - submissionID <- submissionMatchesSheet tid csh shn cID + submissionID <- submissionMatchesSheet tid ssh csh shn cID isRating <- maybe False (== submissionID) <$> isRatingFile path 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 True @@ -343,10 +343,10 @@ getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = $logErrorS "SubDownloadR" $ "Multiple matching files: " <> tshow other error "Multiple matching files found." -getSubArchiveR :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent -getSubArchiveR tid csh shn cID (ZIPArchiveName sfType) = do +getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> ZIPArchiveName SubmissionFileType -> Handler TypedContent +getSubArchiveR tid ssh csh shn cID (ZIPArchiveName sfType) = do when (sfType == SubmissionCorrected) $ - guardAuthResult =<< evalAccess (CSubmissionR tid csh shn cID CorrectionR) False + guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False let filename | 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}"|] respondSourceDB "application/zip" $ do - submissionID <- lift $ submissionMatchesSheet tid csh shn cID + submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID rating <- lift $ getRating submissionID let diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 27e66a957..f02a6f9a8 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -17,8 +17,7 @@ import Handler.Utils -- import qualified Data.Text as T import Yesod.Form.Bootstrap3 - -import Colonnade hiding (bool) +-- import Colonnade hiding (bool) import qualified Database.Esqueleto as E diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index c415769a7..fbb5ed22c 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -219,7 +219,15 @@ pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..} return . fromRational $ round (sci * 100) % 100 --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? -> Field Handler (Source Handler File) diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index dbcd79dd9..d38d2e10a 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/src/Handler/Utils/Sheet.hs @@ -24,29 +24,30 @@ fetchSheetAux :: ( BaseBackend backend ~ SqlBackend , PersistQueryRead backend, PersistUniqueRead backend ) => (E.SqlExpr (Entity Sheet) -> b) - -> TermId -> CourseShorthand -> SheetName -> ReaderT backend m a -fetchSheetAux prj tid csh shn = - let cachId = encodeUtf8 $ tshow (tid,csh,shn) + -> TermId -> SchoolId -> CourseShorthand -> SheetName -> ReaderT backend m a +fetchSheetAux prj tid ssh csh shn = + let cachId = encodeUtf8 $ tshow (tid,ssh,csh,shn) in cachedBy cachId $ do -- Mit Yesod: - -- cid <- getKeyBy404 $ CourseTermShort tid csh + -- cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh -- getBy404 $ CourseSheet cid shn -- Mit Esqueleto: sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - E.where_ $ course E.^. CourseTerm E.==. E.val tid - E.&&. course E.^. CourseShorthand E.==. E.val csh - E.&&. sheet E.^. SheetName E.==. E.val shn + 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.&&. sheet E.^. SheetName E.==. E.val shn return $ prj sheet case sheetList of [sheet] -> return sheet _other -> notFound -fetchSheet :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet) +fetchSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Entity Sheet) fetchSheet = fetchSheetAux id -fetchSheetId :: TermId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet) -fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn +fetchSheetId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet) +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 tid cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid cid shn +fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> YesodDB UniWorX (Key Sheet, Key Course) +fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux ((,) <$> (E.^. SheetId) <*> (E.^. SheetCourse)) tid ssh cid shn diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 06f8ec024..bd4f44daa 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -551,7 +551,7 @@ sinkMultiSubmission userId isUpdate = do Submission{..} <- get404 sId Sheet{..} <- get404 submissionSheet 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 sink' <- lift $ yield val ++$$ sink case sink' of @@ -599,10 +599,10 @@ sinkMultiSubmission userId isUpdate = do handleCryptoID _ = return Nothing -submissionMatchesSheet :: TermId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId -submissionMatchesSheet tid csh shn cid = do +submissionMatchesSheet :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> DB SubmissionId +submissionMatchesSheet tid ssh csh shn cid = do sid <- decrypt cid - shid <- fetchSheetId tid csh shn + shid <- fetchSheetId tid ssh csh shn Submission{..} <- get404 sid when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet] return sid diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index 30614eaae..76a93e5ac 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -17,12 +17,13 @@ import Model.Migration.Version import Data.Map (Map) import qualified Data.Map as Map -import Data.Set (Set) +import Data.Set () import qualified Data.Set as Set import Database.Persist.Sql import Database.Persist.Postgresql +import Data.CaseInsensitive (CI) -- 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) @@ -67,13 +68,21 @@ migrateAll = do doCustomMigration acc desc migration = acc <* do let AppliedMigrationKey appliedMigrationFrom appliedMigrationTo = desc appliedMigrationTime <- liftIO getCurrentTime - migration + _ <- migration insert AppliedMigration{..} -- Map.foldlWithKey traverses migrations in ascending order of AppliedMigrationKey Map.foldlWithKey doCustomMigration (return ()) missingMigrations 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 = Map.fromListWith (>>) @@ -92,6 +101,7 @@ customMigrations = Map.fromListWith (>>) ) , ( AppliedMigrationKey [migrationVersion|0.0.0|] [version|1.0.0|] , do -- Better JSON encoding + haveSheetTable <- [sqlQQ| SELECT to_regclass('sheet'); |] case haveSheetTable :: [Maybe (Single Text)] of @@ -102,4 +112,63 @@ customMigrations = Map.fromListWith (>>) |] _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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 14bd4308a..959432f68 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} {-# LANGUAGE ViewPatterns #-} {-- # LANGUAGE ExistentialQuantification #-} -- for DA type +{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) module Model.Types where @@ -23,6 +24,7 @@ import Data.Monoid (Sum(..)) import Data.Maybe (fromJust) import Data.Universe import Data.Universe.Helpers +import Data.UUID.Types import Text.Read (readMaybe) @@ -32,6 +34,7 @@ import Database.Persist.Class import Database.Persist.Sql import Web.HttpApiData +import Web.PathPieces import Data.Text (Text) import qualified Data.Text as Text @@ -50,6 +53,30 @@ import Generics.Deriving.Monoid (gmemptydefault, gmappenddefault) 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 toPoints :: Integral a => a -> Points -- deprecated @@ -368,7 +395,9 @@ derivePersistField "CorrectorState" -- Type synonyms -type SheetName = CI Text +type SchoolName = CI Text +type SchoolShorthand = CI Text +type CourseName = CI Text type CourseShorthand = CI Text -type CourseName = CI Text -type UserEmail = CI Text +type SheetName = CI Text +type UserEmail = CI Text diff --git a/src/Utils.hs b/src/Utils.hs index 67dfbdd18..d3549bc97 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -86,6 +86,11 @@ unsupportedAuthPredicate = do tickmark :: IsString a => a tickmark = fromString "✔" +-- Avoid annoying warnings: +tickmarkS :: String +tickmarkS = tickmark +tickmarkT :: Text +tickmarkT = tickmark text2Html :: Text -> Html text2Html = toHtml -- prevents ambiguous types diff --git a/templates/course.hamlet b/templates/course.hamlet index f45717007..f63629fee 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -33,7 +33,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
-
+ $# regWidget is defined through templates/widgets/registerForm ^{regWidget}
diff --git a/templates/profile.hamlet b/templates/profile.hamlet index c2f24454a..51cbc913c 100644 --- a/templates/profile.hamlet +++ b/templates/profile.hamlet @@ -27,16 +27,16 @@
Eigene Kurse