From a4dacc8d018723af50bee5b631ac90cf6b07e46b Mon Sep 17 00:00:00 2001 From: SJost Date: Tue, 21 Aug 2018 13:34:32 +0200 Subject: [PATCH 1/7] Halfway through with #162, still todo --- messages/uniworx/de.msg | 32 ++--- models | 5 +- routes | 4 +- src/CryptoID.hs | 20 +-- src/Foundation.hs | 216 +++++++++++++++++--------------- src/Handler/Course.hs | 54 ++++---- src/Handler/CryptoIDDispatch.hs | 12 +- src/Handler/Home.hs | 38 ++++-- src/Handler/Profile.hs | 6 +- src/Handler/Sheet.hs | 89 ++++++------- src/Handler/Submission.hs | 16 +-- src/Handler/Term.hs | 3 +- src/Handler/Utils/Sheet.hs | 25 ++-- src/Handler/Utils/Submission.hs | 8 +- src/Model/Migration.hs | 4 +- src/Model/Types.hs | 35 +++++- templates/profile.hamlet | 14 +-- 17 files changed, 314 insertions(+), 267 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 202bde31c..7a1d136b6 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -47,7 +47,7 @@ TermCourseListHeading tid@TermId: Kursübersicht #{display tid} CourseListTitle: Alle Kurse TermCourseListTitle tid@TermId: Kurse #{display tid} 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 +68,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 +111,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 +156,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 +268,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 a0e82edcd..f4874ebb3 100644 --- a/models +++ b/models @@ -53,6 +53,7 @@ School json shorthand (CI Text) UniqueSchool name UniqueSchoolShorthand shorthand + 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 + CourseTermSchoolShort term school shorthand + CourseTermSchoolName term school name CourseEdit user UserId time UTCTime diff --git a/routes b/routes index 097e6a0b8..8d17379bd 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 SchoolCourseListR 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..b7b796c22 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 $ CourseTermSchoolShort 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 $ CourseTermSchoolShort 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 $ CourseTermSchoolShort 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 $ CourseTermSchoolShort 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 $ CourseTermSchoolShort 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 $ CourseTermSchoolShort 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 $ CourseTermSchoolShort 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 (SchoolCourseListR 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 $ SchoolCourseListR 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 $ CourseTermSchoolShort 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 } ] @@ -982,40 +989,40 @@ 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 $ CourseTermSchoolShort 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 +1037,7 @@ pageHeading _ routeNormalizers :: [Route UniWorX -> WriterT Any (ReaderT (YesodPersistBackend UniWorX) (HandlerT UniWorX IO)) (Route UniWorX)] routeNormalizers = [ normalizeRender + , ncSchool , ncCourse , ncSheet ] @@ -1050,17 +1058,25 @@ routeNormalizers = $logDebugS "routeNormalizers" [st|#{tshow a} /= #{tshow b}|] tell $ Any True | otherwise = return () + ncSchool = maybeOrig $ \route -> do + SchoolCourseListR tid ssh <- return route + let schoolShort :: SchoolShorthand + schoolShort = unSchoolKey ssh + Entity ssh' _ <- MaybeT . lift . getBy $ UniqueSchoolShorthand schoolShort + (hasChanged `on` unSchoolKey)ssh ssh' + return $ SchoolCourseListR tid ssh' ncCourse = maybeOrig $ \route -> do - 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 $ CourseTermSchoolShort 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 $ CourseTermSchoolShort 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/Course.hs b/src/Handler/Course.hs index 2e7cdb0fe..0ad0e1637 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 @@ -81,12 +81,12 @@ 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}|] + anchorCell (SchoolCourseListR 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}|] + anchorCell (SchoolCourseListR courseTerm courseSchool) [whamlet|#{display schoolShorthand}|] colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a) colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom) @@ -222,13 +222,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 $ CourseTermSchoolShort 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 +238,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 +258,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 $ CourseTermSchoolShort tid ssh csh registered <- isJust <$> (getBy $ UniqueParticipant aid cid) return (cid, course, registered) ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course @@ -277,7 +277,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 +287,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 $ CourseTermShort 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 $ CourseTermShort tid ssh csh courseEditHandler False course @@ -317,6 +317,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 +340,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 +374,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 () 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..683abe697 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -68,12 +68,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}) } -> 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 +88,9 @@ homeAnonymous = do [ ( "term" , SortColumn $ \(course) -> course E.^. CourseTerm ) + , ( "school" + , SortColumn $ \(course) -> course E.^. CourseSchool + ) , ( "course" , SortColumn $ \(course) -> course E.^. CourseShorthand ) @@ -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,18 +155,21 @@ 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)] @@ -171,6 +182,9 @@ homeUser uid = do [ ( "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..5fa74b98c 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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 1335a25d0..8359e59ca 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -156,10 +156,10 @@ 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 $ CourseTermSchoolShort 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 @@ -221,7 +221,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 @@ -256,9 +256,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 @@ -285,7 +285,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 ] @@ -326,12 +326,12 @@ getSShowR tid csh shn = do 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 @@ -339,7 +339,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) @@ -356,21 +357,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 @@ -396,13 +397,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 @@ -410,7 +411,7 @@ handleSheetEdit tid csh msId template dbAction = do (FormSuccess SheetForm{..}) -> do saveOkay <- runDB $ do actTime <- liftIO getCurrentTime - cid <- getKeyBy404 $ CourseTermShort tid csh + cid <- getKeyBy404 $ CourseTermSchoolShort tid ssh csh let newSheet = Sheet { sheetCourse = cid , sheetName = sfName @@ -426,51 +427,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 -- 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 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 @@ -671,10 +672,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 @@ -689,8 +690,8 @@ getSCorrR tid csh shn = do let -- formTitle = MsgSheetCorrectorsTitle tid csh shn formText = Nothing :: Maybe (SomeMessage UniWorX) - actionUrl = CSheetR tid csh shn SCorrR + actionUrl = CSheetR tid ssh csh shn SCorrR -- actionUrl = CSheetR tid 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..09340ce3d 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -87,11 +87,11 @@ getSubShowR, postSubShowR :: TermId -> CourseShorthand -> SheetName -> CryptoFil getSubShowR = postSubShowR postSubShowR tid csh shn cid = submissionHelper tid 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,10 +101,10 @@ 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 @@ -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 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/Sheet.hs b/src/Handler/Utils/Sheet.hs index dbcd79dd9..e98182f9c 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 $ CourseTermSchoolShort 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..368b4b2cf 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -17,7 +17,7 @@ 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 @@ -67,7 +67,7 @@ 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 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/templates/profile.hamlet b/templates/profile.hamlet index c2f24454a..5a389a74d 100644 --- a/templates/profile.hamlet +++ b/templates/profile.hamlet @@ -27,16 +27,16 @@
Eigene Kurse