From f14bea4015cabcb178e944d218cbdd97e46722ca Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 23 May 2018 15:43:12 +0200 Subject: [PATCH 01/13] AccessScaffold --- routes | 87 +++++++++++++++++++++++++++++------------------ src/Foundation.hs | 78 +++++++++++++++++++++++++++++++++++++++--- 2 files changed, 127 insertions(+), 38 deletions(-) diff --git a/routes b/routes index c04ca7ada..a92846b52 100644 --- a/routes +++ b/routes @@ -1,44 +1,63 @@ -/static StaticR Static appStatic -/auth AuthR Auth getAuth +{- + Accesss granted via tags; default is no accesss. + Permission must be explicitly granted. -/favicon.ico FaviconR GET -/robots.txt RobotsR GET + Access permission is the disjunction of permit tags + Tags are split on "AND" to encode conjunction. -/ HomeR GET POST -/profile ProfileR GET -/users UsersR GET !adminAny + Note that nested routes automatically inherit all tags from the parent. -/term TermShowR GET -/term/edit TermEditR GET POST !adminAny -/term/#TermId/edit TermEditExistR GET !adminAny + Admins always have access to entities within their assigned schools. + + Tags: + !free -- free for all + !lecturer -- lecturer for this course (or the school, if route is not connected to a course) + !corrector -- corrector for this sheet (or the course, if route is not connected to a sheet ) + !registered -- participant for this course (no effect outside of courses) + + !materials -- only if course allows all materials to be free (no meaning outside of courses) + !time -- access depends on time somehow + + !deprecated -- like free, but logs and gives a warning +-} + +/static StaticR Static appStatic !free +/auth AuthR Auth getAuth !free + +/favicon.ico FaviconR GET !free +/robots.txt RobotsR GET !free + +/ HomeR GET POST !free +/profile ProfileR GET !free +/users UsersR GET -- no tags, i.e. admins only + +/term TermShowR GET !free +/term/edit TermEditR GET POST +/term/#TermId/edit TermEditExistR GET +!/term/#TermId TermCourseListR GET !free -- For Pattern Synonyms see Foundation -/course/ CourseListR GET -!/course/new CourseNewR GET POST !lecturerAny -!/course/#TermId CourseListTermR GET -/course/#TermId/#Text CourseR !updateFavourite: - /show CourseShowR GET POST - /edit CourseEditR GET POST !lecturer - - /ex SheetR !registered: - / SheetListR GET - /#Text/show SheetShowR GET !time - /#Text/#SheetFileType/#FilePath SheetFileR GET !time - /new SheetNewR GET POST !lecturer - /#Text/edit SheetEditR GET POST !lecturer - /#Text/delete SheetDelR GET POST !lecturer - !/#Text/submission/#SubmissionMode SubmissionR GET POST !time +/course/ CourseListR GET !free +!/course/new CourseNewR GET POST !lecturer +/course/#TermId/#Text CourseR !lecturer !updateFavourite: + /show CShowR GET POST !free + /edit CEditR GET POST + /ex SheetListR GET !materials + !/ex/new SheetNewR GET POST + /ex/#Text SheetR !materials: + /show SShowR GET !time !corrector + /#SheetFileType/#FilePath SFileR GET !time !corrector + /edit SEditR GET POST + /delete SDelR GET POST + !/submission/#SubmissionMode SubmissionR GET POST !timeANDregistered -!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET -!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET - -!/#UUID CryptoUUIDDispatchR GET +!/#UUID CryptoUUIDDispatchR GET !free -- TODO below -/submission SubmissionListR GET POST -/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST -/submissions.zip SubmissionDownloadMultiArchiveR POST +!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated +!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET !deprecated --- For demonstration -/course/#CryptoUUIDCourse/edit CourseEditIDR GET +/submission SubmissionListR GET !deprecated +/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST !deprecated +/submissions.zip SubmissionDownloadMultiArchiveR POST !deprecated diff --git a/src/Foundation.hs b/src/Foundation.hs index 659b00513..8db9e39ce 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1,9 +1,11 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} @@ -90,9 +92,77 @@ data UniWorX = UniWorX mkYesodData "UniWorX" $(parseRoutesFile "routes") -- Pattern Synonyms for convenience -pattern CSheetR tid csh ptn = CourseR tid csh (SheetR ptn) +pattern CSheetR tid csh shn ptn = CourseR tid csh (SheetR shn ptn) + +-- Access Control + +data AccessPredicate + = APPure (Route UniWorX -> Reader (forall msg. RenderMessage UniWorX msg => msg -> Text) AuthResult) + | APHandler (Route UniWorX -> Handler UniWorX AuthResult) + | APDB (Route UniWorX -> YesodDB UniWorX AuthResult) +orAR, andAR :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> AuthResult -> AuthResult -> AuthResult +orAR _ Authorized _ = Authorized +orAR _ _ Authorized = Authorized +orAR _ AuthenticationRequired _ = AuthenticationRequired +orAR _ _ AuthenticationRequired = AuthenticationRequired +orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . mr $ MsgUnauthorizedOr x y +andAR _ Authorzied Authorized = Authorized +andAR _ Authorzied other = other +andAR _ other Authorized = other +andAR _ AuthenticationRequired other = other +andAR _ other AuthenticationRequired = other +andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . mr $ MsgUnauthorizedAnd x y + + +orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate +orAP = liftAR orAR +andAP = liftAR andAR + +liftAR :: ((forall msg. RenderMessage UniWorX msg => msg -> Text) -> AuthResult -> AuthResult -> AuthResult) + -> AccessPredicate -> AccessPredicate -> AccessPredicate +liftAR op (APPure f) (APPure g) = APPure $ \r -> op <$> ask <*> f r <*> g r +liftAR op (APHandler f) (APHandler g) = APHandler $ \r -> op <$> getMessageRender <*> f r <*> g r +liftAR op (APDB f) (APDB g) = APDB $ \r -> op <$> getMessageRender <*> f r <*> g r +liftAR op apf@(APPure _) apg@(APHandler _) = liftAR op apg apf +liftAR op apf (APPure g) = liftAR op apf (APHandler $ \r -> runReader (g r) <$> getMessageRender) +liftAR op apf (APHandler g) = liftAR op apf (APDB $ lift . g) +liftAR op apf apg = liftAR op apg apf + + +trueAP,falseAP :: AccessPredicate +trueAP = APPure . const $ return Authorized +falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) <$> ask + +knownTags :: Map (CI Text) AccessPredicate +knownTags = + [("free", trueAP) + ,("deprecated", APHandler $ \r -> do + $logWarnS "AccessControl" ("deprecated route: " <> tshow r) + setMessageI $ MsgDeprecatedRoute + return Authorized + ) + ,("lecturer", APDB $ \case + CourseR tid csh -> + (>>= maybe (unauthorizedI MsgUnauthorizedLecturer) return) . runMaybeT $ do + authId <- lift requireAuthId + Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh + void . MaybeT . getBy $ UniqueLecturer authId cid + return Authorized + + _ -> do + authId <- requireAuthId + mul <- selectFirst [UserLecturerUser ==. authId] [] + case mul of + Nothing -> unauthorizedI $ MsgUnauthorizedSchoolLecturer + (Just _) -> return Authorized + ) + ] + + + +-- Menus and Favourites data MenuItem = MenuItem { menuItemLabel :: Text , menuItemIcon :: Maybe Text @@ -157,9 +227,9 @@ instance Yesod UniWorX where yesodMiddleware handler = do res <- defaultYesodMiddleware handler void . runMaybeT $ do - route@(routeAttrs -> attrs) <- MaybeT getCurrentRoute - case route of - CourseR tid csh _ | "updateFavourite" `elem` attrs -> do + route <- MaybeT getCurrentRoute + case route of -- update Course Favourites here + CourseR tid csh _ -> do uid <- MaybeT maybeAuthId $(logDebug) "Favourites save" now <- liftIO $ getCurrentTime From f4964dcb55cb908b98c4cb59a8190bd5651ad31e Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 23 May 2018 20:01:52 +0200 Subject: [PATCH 02/13] after Discussion today --- messages/de.msg | 4 ++++ routes | 4 ++-- src/Foundation.hs | 28 +++++++++++++++++++--------- src/Utils/Common.hs | 10 +++++++++- 4 files changed, 34 insertions(+), 12 deletions(-) diff --git a/messages/de.msg b/messages/de.msg index d296157b4..a5fc04be3 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -21,12 +21,16 @@ SheetDelTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Übun SheetDelText submissionNo@Int: Dies kann nicht mehr rückgängig gemacht werden! Alle Einreichungen gehen ebenfalls verloren! Es gibt #{show submissionNo} Abgaben. SheetDelOk tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand}: Übungsblatt #{sheetName} gelöscht. +Unauthorized: Sie haben hierfür keine explizite Berechtigung. +UnauthorizedAnd l@Text r@Text: "#{l}" und "#{r}" +UnauthorizedOr l@Text r@Text: "#{l}" oder "#{r}" UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen. UnauthorizedSchoolLecturer: Sie sind nicht als Veranstalter für dieses Institut eingetragen. UnauthorizedLecturer: Sie sind nicht als Veranstalter für diese Veranstaltung eingetragen. UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung eingetragen. UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert. OnlyUploadOneFile: Bitte nur eine Datei hochladen. +DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen. SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt. SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. diff --git a/routes b/routes index a92846b52..d72557992 100644 --- a/routes +++ b/routes @@ -9,7 +9,7 @@ Admins always have access to entities within their assigned schools. - Tags: + Access Tags: !free -- free for all !lecturer -- lecturer for this course (or the school, if route is not connected to a course) !corrector -- corrector for this sheet (or the course, if route is not connected to a sheet ) @@ -39,7 +39,7 @@ -- For Pattern Synonyms see Foundation /course/ CourseListR GET !free !/course/new CourseNewR GET POST !lecturer -/course/#TermId/#Text CourseR !lecturer !updateFavourite: +/course/#TermId/#Text CourseR !lecturer: /show CShowR GET POST !free /edit CEditR GET POST /ex SheetListR GET !materials diff --git a/src/Foundation.hs b/src/Foundation.hs index 8db9e39ce..f488b367c 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -59,7 +59,8 @@ import System.FilePath import Handler.Utils.Templates import Handler.Utils.StudyFeatures - +import Control.Lens +import Utils.Lens -- infixl 9 :$: -- pattern a :$: b = a b @@ -144,22 +145,31 @@ knownTags = return Authorized ) ,("lecturer", APDB $ \case - CourseR tid csh -> - (>>= maybe (unauthorizedI MsgUnauthorizedLecturer) return) . runMaybeT $ do + CourseR tid csh -> maybeT (unauthorizedI MsgUnauthorizedLecturer) $ do authId <- lift requireAuthId Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh void . MaybeT . getBy $ UniqueLecturer authId cid return Authorized - _ -> do - authId <- requireAuthId - mul <- selectFirst [UserLecturerUser ==. authId] [] - case mul of - Nothing -> unauthorizedI $ MsgUnauthorizedSchoolLecturer - (Just _) -> return Authorized + authId <- requireAuthId + mul <- selectFirst [UserLecturerUser ==. authId] [] + case mul of + Nothing -> unauthorizedI $ MsgUnauthorizedSchoolLecturer + (Just _) -> return Authorized ) ] +declareWrapped [d| + newtype DNF a = DNF (Set (Set a)) -- disjunctive Normalform + |] + + +getAccess :: Route UniWorX -> DNF AccessPredicate +getAccess r = DNF $ Set.map attrsAND attrsOR + where + attrsOR = routeAttrs r + attrsAND = Set.fromList . Map.elems . Map.restrictKeys knownTags . Set.fromList . splitOn "AND" + -- Menus and Favourites diff --git a/src/Utils/Common.hs b/src/Utils/Common.hs index 7ef941d4d..c0e3dcb81 100644 --- a/src/Utils/Common.hs +++ b/src/Utils/Common.hs @@ -5,7 +5,7 @@ module Utils.Common where -- Common Utility Functions import Language.Haskell.TH - +import Control.Monad.Trans.Maybe ------------ -- Tuples -- @@ -50,3 +50,11 @@ altFun perm = lamE pat rhs ps = [ xs !! (j-1) | j <- perm ] fn = mkName "fn" + +----------- +-- Maybe -- +----------- + +maybeT :: Monad m => m a -> MaybeT m a -> m a +maybeT x m = runMaybeT m >>= maybe x return + From d5edf5ee7b9a7098554f596d9e481560266c018a Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 25 May 2018 10:11:06 +0200 Subject: [PATCH 03/13] liftAR refactored to avoid unnecessary DB access --- src/Foundation.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Foundation.hs b/src/Foundation.hs index f488b367c..10cded5a3 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -157,6 +157,7 @@ knownTags = Nothing -> unauthorizedI $ MsgUnauthorizedSchoolLecturer (Just _) -> return Authorized ) + -- TODO: Continue here!!! ] declareWrapped [d| @@ -170,6 +171,13 @@ getAccess r = DNF $ Set.map attrsAND attrsOR attrsOR = routeAttrs r attrsAND = Set.fromList . Map.elems . Map.restrictKeys knownTags . Set.fromList . splitOn "AND" +evalAccess :: Route -> DB Authorized +evalAccess = undefined -- TODO -- ^ uses `getAccess` + +evalAccess' :: Route -> Handler UniWorX Authorized +evalAccess = undefined -- TODO -- ^ uses `getAccess` + +-- TODO: isAuthorized = evalAccess' -- Menus and Favourites From 59423832e6a3dafd64b4ce2e7e505e7c47c1567b Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 25 May 2018 11:54:27 +0200 Subject: [PATCH 04/13] evalAccess is complete now --- src/Foundation.hs | 68 +++++++++++++++++++++++++++++++++-------------- 1 file changed, 48 insertions(+), 20 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index 10cded5a3..5edc7f765 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -102,7 +102,6 @@ data AccessPredicate | APHandler (Route UniWorX -> Handler UniWorX AuthResult) | APDB (Route UniWorX -> YesodDB UniWorX AuthResult) - orAR, andAR :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> AuthResult -> AuthResult -> AuthResult orAR _ Authorized _ = Authorized orAR _ _ Authorized = Authorized @@ -123,18 +122,37 @@ andAP = liftAR andAR liftAR :: ((forall msg. RenderMessage UniWorX msg => msg -> Text) -> AuthResult -> AuthResult -> AuthResult) -> AccessPredicate -> AccessPredicate -> AccessPredicate -liftAR op (APPure f) (APPure g) = APPure $ \r -> op <$> ask <*> f r <*> g r -liftAR op (APHandler f) (APHandler g) = APHandler $ \r -> op <$> getMessageRender <*> f r <*> g r -liftAR op (APDB f) (APDB g) = APDB $ \r -> op <$> getMessageRender <*> f r <*> g r -liftAR op apf@(APPure _) apg@(APHandler _) = liftAR op apg apf -liftAR op apf (APPure g) = liftAR op apf (APHandler $ \r -> runReader (g r) <$> getMessageRender) -liftAR op apf (APHandler g) = liftAR op apf (APDB $ lift . g) -liftAR op apf apg = liftAR op apg apf +-- Ensure to first evaluate Pure conditions, then Handler before DB +liftAR op (APPure f) (APPure g) = APPure $ \r -> op <$> ask <*> f r <*> g r +liftAR op (APHandler f) (APHandler g) = APHandler $ \r -> op <$> getMessageRender <*> f r <*> g r +liftAR op (APDB f) (APDB g) = APDB $ \r -> op <$> getMessageRender <*> f r <*> g r +liftAR op (APPure f) apg = liftAR op (APHandler $ \r -> runReader (f r) <$> getMessageRender) apg +liftAR op apf apg@(APPure _) = liftAR op apg apf +liftAR op (APHandler f) apdb = liftAR op (APDB $ lift . f) apdb +liftAR op apdb apg@(APHandler _) = liftAR op apg apdb trueAP,falseAP :: AccessPredicate trueAP = APPure . const $ return Authorized falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) <$> ask +-- TODO: I believe falseAP := adminAP + +adminAP :: AccessPredicate +adminAP = APDB $ \case + CourseR tid csh -> maybeT (unauthorizedI MsgUnauthorizedSchoolAdmin) $ do + authId <- lift requireAuthId + -- SQL JOIN: + Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh + -- get schoolId for cid + -- check adminrights for schoolId + undefined -- CONTINUE HERE + + _other -> do + authId <- lift requireAuthId + adrights <- selectFirst [UserAdminUser ==. authId] + case adright of + (Just _) -> return Authorized + Nothing -> unauthorizedI $ MsgUnauthorized knownTags :: Map (CI Text) AccessPredicate knownTags = @@ -160,22 +178,32 @@ knownTags = -- TODO: Continue here!!! ] -declareWrapped [d| - newtype DNF a = DNF (Set (Set a)) -- disjunctive Normalform - |] +tag2ap :: Text -> AccessPredicate +tag2ap t = case Map.lookup t knownTags of + (Just ap) -> ap + Nothing -> APHandler $ \r -> do --TODO: can this be pure like falseAP? + $logWarnS "AccessControl" ("route tag unknown for access control") + unauthorizedI $ MsgUnauthorized -getAccess :: Route UniWorX -> DNF AccessPredicate -getAccess r = DNF $ Set.map attrsAND attrsOR - where - attrsOR = routeAttrs r - attrsAND = Set.fromList . Map.elems . Map.restrictKeys knownTags . Set.fromList . splitOn "AND" +route2ap :: Route UniWorX -> AccessPredicate +route2ap r = Set.foldr orAP adminAP attrsAND + where + attrsAND = Set.map splitAnd $ routeAttrs r + splitAND = foldr1 andAP . map tag2access . splitOn "AND" -evalAccess :: Route -> DB Authorized -evalAccess = undefined -- TODO -- ^ uses `getAccess` +evalAccessDB :: Route -> DB Authorized +evalAccessDB r = case getAccess r of + (APPure p) -> lift $ runReader (p r) <$> getMessageRender + (APHandler p) -> lift $ p r + (APDB p) -> p r + +evalAccess :: Route -> Handler UniWorX Authorized +evalAccess r = case getAccess r of + (APPure p) -> runReader (p r) <$> getMessageRender + (APHandler p) -> p r + (APDB p) -> runDB $ p r -evalAccess' :: Route -> Handler UniWorX Authorized -evalAccess = undefined -- TODO -- ^ uses `getAccess` -- TODO: isAuthorized = evalAccess' From ad998b53d8a249afd6c6e12d4fead2a7f9d9f19a Mon Sep 17 00:00:00 2001 From: SJost Date: Fri, 25 May 2018 13:12:09 +0200 Subject: [PATCH 05/13] knownTags increased --- routes | 20 ++++++++++---------- src/Foundation.hs | 39 +++++++++++++++++++-------------------- 2 files changed, 29 insertions(+), 30 deletions(-) diff --git a/routes b/routes index d72557992..16cf1b3fd 100644 --- a/routes +++ b/routes @@ -40,19 +40,19 @@ /course/ CourseListR GET !free !/course/new CourseNewR GET POST !lecturer /course/#TermId/#Text CourseR !lecturer: - /show CShowR GET POST !free - /edit CEditR GET POST - /ex SheetListR GET !materials - !/ex/new SheetNewR GET POST + /show CShowR GET POST !free + /edit CEditR GET POST + /ex SheetListR GET !materials + !/ex/new SheetNewR GET POST /ex/#Text SheetR !materials: - /show SShowR GET !time !corrector - /#SheetFileType/#FilePath SFileR GET !time !corrector - /edit SEditR GET POST - /delete SDelR GET POST - !/submission/#SubmissionMode SubmissionR GET POST !timeANDregistered + /show SShowR GET !time !corrector + /#SheetFileType/#FilePath SFileR GET !time !corrector + /edit SEditR GET POST + /delete SDelR GET POST + !/submission/#SubmissionMode SubmissionR GET POST !timeANDregistered -!/#UUID CryptoUUIDDispatchR GET !free +!/#UUID CryptoUUIDDispatchR GET !free -- just redirect -- TODO below !/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated diff --git a/src/Foundation.hs b/src/Foundation.hs index 5edc7f765..d8bbd682d 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -161,10 +161,12 @@ knownTags = $logWarnS "AccessControl" ("deprecated route: " <> tshow r) setMessageI $ MsgDeprecatedRoute return Authorized - ) + ) ,("lecturer", APDB $ \case CourseR tid csh -> maybeT (unauthorizedI MsgUnauthorizedLecturer) $ do authId <- lift requireAuthId + -- TODO: why not a getBy404 if the course does not exist?hg getBy404 + Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh void . MaybeT . getBy $ UniqueLecturer authId cid return Authorized @@ -174,8 +176,16 @@ knownTags = case mul of Nothing -> unauthorizedI $ MsgUnauthorizedSchoolLecturer (Just _) -> return Authorized - ) + ) -- TODO: Continue here!!! + ,("corrector", undefined) + ,("time", undefined) + ,("registered", undefined) + ,("materials", APDB $ \case + CourseR tid csh -> + Entity cid _ <- getBy404 $ CourseTermShort tid csh + undefined -- CONTINUE HERE + ) ] @@ -192,7 +202,7 @@ route2ap r = Set.foldr orAP adminAP attrsAND attrsAND = Set.map splitAnd $ routeAttrs r splitAND = foldr1 andAP . map tag2access . splitOn "AND" -evalAccessDB :: Route -> DB Authorized +evalAccessDB :: Route -> DB Authorized -- all requests, regardless of POST/GET, use isWriteRequest otherwise evalAccessDB r = case getAccess r of (APPure p) -> lift $ runReader (p r) <$> getMessageRender (APHandler p) -> lift $ p r @@ -369,21 +379,7 @@ instance Yesod UniWorX where -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR - isAuthorized (AuthR _) _ = return Authorized - isAuthorized HomeR _ = return Authorized - isAuthorized FaviconR _ = return Authorized - isAuthorized RobotsR _ = return Authorized - isAuthorized (StaticR _) _ = return Authorized - isAuthorized ProfileR _ = isAuthenticated - isAuthorized TermShowR _ = return Authorized - isAuthorized CourseListR _ = return Authorized - isAuthorized (CourseListTermR _) _ = return Authorized - isAuthorized (CourseR _ _ CourseShowR) _ = return Authorized - isAuthorized (CryptoUUIDDispatchR _) _ = return Authorized - isAuthorized SubmissionListR _ = isAuthenticated - isAuthorized SubmissionDownloadMultiArchiveR _ = isAuthenticated --- isAuthorized TestR _ = return Authorized - isAuthorized route isWrite = runDB $ isAuthorizedDB route isWrite + isAuthorized route _isWrite = evalAccess route -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows @@ -424,13 +420,14 @@ instance Yesod UniWorX where makeLogger = return . appLogger + +{- ALL DEPRECATED and will be deleted, once knownTags is completed + isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult isAuthorizedDB route@(routeAttrs -> attrs) writeable | "adminAny" `member` attrs = adminAccess Nothing | "lecturerAny" `member` attrs = lecturerAccess Nothing - - isAuthorizedDB UsersR _ = adminAccess Nothing isAuthorizedDB (SubmissionDemoR cID) _ = return Authorized -- submissionAccess $ Right cID isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID @@ -511,6 +508,8 @@ isAuthorizedDB' route isWrite = (== Authorized) <$> isAuthorizedDB route isWrite isAuthorized' :: Route UniWorX -> Bool -> Handler Bool isAuthorized' route isWrite = runDB $ isAuthorizedDB' route isWrite +-} + -- Define breadcrumbs. instance YesodBreadcrumbs UniWorX where From c45fea6df3e6d998a607b3d4f642b25b515a2c63 Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 28 May 2018 18:27:30 +0200 Subject: [PATCH 06/13] New Rights Managament compiles and seems to work (apart from TODOs); Problem with ASIDENAV --- FragenSJ.txt | 6 +- README.md | 2 +- routes | 44 +++---- src/Foundation.hs | 192 ++++++++++++++++-------------- src/Handler/Course.hs | 36 +++--- src/Handler/CryptoIDDispatch.hs | 2 +- src/Handler/Sheet.hs | 44 +++---- src/Handler/Submission.hs | 6 +- src/Handler/Term.hs | 2 +- src/Utils.hs | 75 ++++++++++-- src/Utils/Common.hs | 10 +- templates/course.hamlet | 2 +- templates/widgets/asidenav.hamlet | 16 +-- 13 files changed, 253 insertions(+), 184 deletions(-) diff --git a/FragenSJ.txt b/FragenSJ.txt index c2219f2c1..6ddd8de2b 100644 --- a/FragenSJ.txt +++ b/FragenSJ.txt @@ -1,7 +1,7 @@ ** Sicherheitsabfragen? - Verschlüsselung des Zugriffs? - - SheetDelR tid csh sn : GET zeigt Sicherheitsabfrage + - SDelR tid csh sn : GET zeigt Sicherheitsabfrage POST löscht. Ist das so sinnvoll? Sicherheitsabfrage als PopUpMessage? @@ -9,7 +9,7 @@ - Utils.getKeyBy404 effiziente Variante, welche nur den Key liefert? Esq? (Sheet.hs -> fetchSheet) - - Handler.Sheet.postSheetDelR: deleteCascade für Files? Klappt das? + - Handler.Sheet.postSDelR: deleteCascade für Files? Klappt das? Kann man abfragen, was bei deleteCascade alles gelöscht wird? @@ -19,7 +19,7 @@ Links -> MenuItems verwenden wie bisher Page Titles -> setTitleI Buttons? -> Kann leicht geändert werden! - Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getCourseListTermR, Zeile 66 "pageActions" für menuItemLabel? + Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getTermCourseListR, Zeile 66 "pageActions" für menuItemLabel? ** Page pageActions - Berechtigungen prüfen? => Eigener Constructor statt NavbarLeft/Right?! diff --git a/README.md b/README.md index cf42dc5da..be734df7b 100644 --- a/README.md +++ b/README.md @@ -109,7 +109,7 @@ TABLE "user"; DROP TABLE "course" CASCADE; -- UserId 5 zum Lecturer in SchoolId 1 machen (27 ist laufende Nummer) -INSERT INTO "user_lecturer" (id,"user",school) VALUES (27,5,1); +INSERT INTO "user_lecturer" (id,"user","school") VALUES (27,5,1); -- Beenden: \q diff --git a/routes b/routes index 16cf1b3fd..d009d0e6e 100644 --- a/routes +++ b/routes @@ -1,25 +1,25 @@ -{- - Accesss granted via tags; default is no accesss. - Permission must be explicitly granted. - - Access permission is the disjunction of permit tags - Tags are split on "AND" to encode conjunction. - - Note that nested routes automatically inherit all tags from the parent. - - Admins always have access to entities within their assigned schools. - - Access Tags: - !free -- free for all - !lecturer -- lecturer for this course (or the school, if route is not connected to a course) - !corrector -- corrector for this sheet (or the course, if route is not connected to a sheet ) - !registered -- participant for this course (no effect outside of courses) - - !materials -- only if course allows all materials to be free (no meaning outside of courses) - !time -- access depends on time somehow - - !deprecated -- like free, but logs and gives a warning --} +-- +-- Accesss granted via tags; default is no accesss. +-- Permission must be explicitly granted. +-- +-- Access permission is the disjunction of permit tags +-- Tags are split on "AND" to encode conjunction. +-- +-- Note that nested routes automatically inherit all tags from the parent. +-- +-- Admins always have access to entities within their assigned schools. +-- +-- Access Tags: +-- !free -- free for all +-- !lecturer -- lecturer for this course (or the school, if route is not connected to a course) +-- !corrector -- corrector for this sheet (or the course, if route is not connected to a sheet ) +-- !registered -- participant for this course (no effect outside of courses) +-- +-- !materials -- only if course allows all materials to be free (no meaning outside of courses) +-- !time -- access depends on time somehow +-- +-- !deprecated -- like free, but logs and gives a warning +-- /static StaticR Static appStatic !free /auth AuthR Auth getAuth !free diff --git a/src/Foundation.hs b/src/Foundation.hs index d8bbd682d..51aa79102 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -32,6 +32,7 @@ import LDAP.Search (LDAPEntry(..)) import Yesod.Default.Util (addStaticContentExternal) import Yesod.Core.Types (Logger) import qualified Yesod.Core.Unsafe as Unsafe +import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import qualified Data.Text.Encoding as TE @@ -47,6 +48,13 @@ import qualified Data.ByteString.Lazy as Lazy.ByteString import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import Data.List (foldr1) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import qualified Data.Map as Map + + import Data.Conduit (($$)) import Data.Conduit.List (sourceList) @@ -54,6 +62,7 @@ import qualified Database.Esqueleto as E import Control.Monad.Except (MonadError(..), runExceptT) import Control.Monad.Trans.Maybe (MaybeT(..)) +import Control.Monad.Trans.Reader (runReader) import System.FilePath @@ -92,70 +101,95 @@ data UniWorX = UniWorX -- type Widget = WidgetT UniWorX IO () mkYesodData "UniWorX" $(parseRoutesFile "routes") +-- | Convenient Type Synonyms: +type DB a = YesodDB UniWorX a +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 csh shn ptn + = CourseR tid csh (SheetR shn ptn) + +-- Messages +mkMessage "UniWorX" "messages" "de" + +-- This instance is required to use forms. You can modify renderMessage to +-- achieve customized and internationalized form validation messages. +instance RenderMessage UniWorX FormMessage where + renderMessage _ _ = defaultFormMessage + +instance RenderMessage UniWorX TermIdentifier where + renderMessage foundation ls TermIdentifier{..} = case season of + Summer -> renderMessage' $ MsgSummerTerm year + Winter -> renderMessage' $ MsgWinterTerm year + where renderMessage' = renderMessage foundation ls -- Access Control data AccessPredicate - = APPure (Route UniWorX -> Reader (forall msg. RenderMessage UniWorX msg => msg -> Text) AuthResult) - | APHandler (Route UniWorX -> Handler UniWorX AuthResult) - | APDB (Route UniWorX -> YesodDB UniWorX AuthResult) + = APPure (Route UniWorX -> Reader MsgRenderer AuthResult) + | APHandler (Route UniWorX -> Handler AuthResult) + | APDB (Route UniWorX -> DB AuthResult) -orAR, andAR :: (forall msg. RenderMessage UniWorX msg => msg -> Text) -> AuthResult -> AuthResult -> AuthResult +orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult orAR _ Authorized _ = Authorized orAR _ _ Authorized = Authorized orAR _ AuthenticationRequired _ = AuthenticationRequired orAR _ _ AuthenticationRequired = AuthenticationRequired -orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . mr $ MsgUnauthorizedOr x y -andAR _ Authorzied Authorized = Authorized -andAR _ Authorzied other = other +orAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedOr x y +andAR _ Authorized Authorized = Authorized +andAR _ Authorized other = other andAR _ other Authorized = other andAR _ AuthenticationRequired other = other andAR _ other AuthenticationRequired = other -andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . mr $ MsgUnauthorizedAnd x y +andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $ MsgUnauthorizedAnd x y + orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate -orAP = liftAR orAR -andAP = liftAR andAR +orAP = liftAR orAR (== Authorized) +andAP = liftAR andAR (const False) -liftAR :: ((forall msg. RenderMessage UniWorX msg => msg -> Text) -> AuthResult -> AuthResult -> AuthResult) +liftAR :: (MsgRenderer -> AuthResult -> AuthResult -> AuthResult) + -> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument -> AccessPredicate -> AccessPredicate -> AccessPredicate -- Ensure to first evaluate Pure conditions, then Handler before DB -liftAR op (APPure f) (APPure g) = APPure $ \r -> op <$> ask <*> f r <*> g r -liftAR op (APHandler f) (APHandler g) = APHandler $ \r -> op <$> getMessageRender <*> f r <*> g r -liftAR op (APDB f) (APDB g) = APDB $ \r -> op <$> getMessageRender <*> f r <*> g r -liftAR op (APPure f) apg = liftAR op (APHandler $ \r -> runReader (f r) <$> getMessageRender) apg -liftAR op apf apg@(APPure _) = liftAR op apg apf -liftAR op (APHandler f) apdb = liftAR op (APDB $ lift . f) apdb -liftAR op apdb apg@(APHandler _) = liftAR op apg apdb +liftAR op sc (APPure f) (APPure g) = APPure $ \r -> shortCircuitM sc (f r) (g r) . op =<< ask +liftAR op sc (APHandler f) (APHandler g) = APHandler $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer +liftAR op sc (APDB f) (APDB g) = APDB $ \r -> shortCircuitM sc (f r) (g r) . op =<< getMsgRenderer +liftAR op sc (APPure f) apg = liftAR op sc (APHandler $ \r -> runReader (f r) <$> getMsgRenderer) apg +liftAR op sc apf apg@(APPure _) = liftAR op sc apg apf +liftAR op sc (APHandler f) apdb = liftAR op sc (APDB $ lift . f) apdb +liftAR op sc apdb apg@(APHandler _) = liftAR op sc apg apdb trueAP,falseAP :: AccessPredicate trueAP = APPure . const $ return Authorized -falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) <$> ask +falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask -- TODO: I believe falseAP := adminAP adminAP :: AccessPredicate adminAP = APDB $ \case - CourseR tid csh -> maybeT (unauthorizedI MsgUnauthorizedSchoolAdmin) $ do - authId <- lift requireAuthId - -- SQL JOIN: - Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh - -- get schoolId for cid - -- check adminrights for schoolId - undefined -- CONTINUE HERE + CourseR tid 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.^. CourseShorthand E.==. E.val csh + return (E.countRows :: E.SqlExpr (E.Value Int64)) + guardMExceptT (unauthorizedI MsgUnauthorizedSchoolAdmin) (c > 0) + return Authorized - _other -> do - authId <- lift requireAuthId - adrights <- selectFirst [UserAdminUser ==. authId] - case adright of + _other -> exceptT return return $ do + authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId + adrights <- lift $ selectFirst [UserAdminUser ==. authId] [] + case adrights of (Just _) -> return Authorized - Nothing -> unauthorizedI $ MsgUnauthorized + Nothing -> lift $ unauthorizedI $ MsgUnauthorized knownTags :: Map (CI Text) AccessPredicate -knownTags = +knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId [("free", trueAP) ,("deprecated", APHandler $ \r -> do $logWarnS "AccessControl" ("deprecated route: " <> tshow r) @@ -163,15 +197,14 @@ knownTags = return Authorized ) ,("lecturer", APDB $ \case - CourseR tid csh -> maybeT (unauthorizedI MsgUnauthorizedLecturer) $ do - authId <- lift requireAuthId - -- TODO: why not a getBy404 if the course does not exist?hg getBy404 - + CourseR tid csh _ -> maybeT (unauthorizedI MsgUnauthorizedLecturer) $ do + authId <- lift $ lift requireAuthId -- TODO SJ Continue + -- getBy404 would disclose that the course exists Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh void . MaybeT . getBy $ UniqueLecturer authId cid return Authorized _ -> do - authId <- requireAuthId + authId <- lift requireAuthId -- TODO SJ Continue mul <- selectFirst [UserLecturerUser ==. authId] [] case mul of Nothing -> unauthorizedI $ MsgUnauthorizedSchoolLecturer @@ -182,7 +215,7 @@ knownTags = ,("time", undefined) ,("registered", undefined) ,("materials", APDB $ \case - CourseR tid csh -> + CourseR tid csh _ -> do Entity cid _ <- getBy404 $ CourseTermShort tid csh undefined -- CONTINUE HERE ) @@ -190,27 +223,27 @@ knownTags = tag2ap :: Text -> AccessPredicate -tag2ap t = case Map.lookup t knownTags of +tag2ap t = case Map.lookup (CI.mk t) knownTags of (Just ap) -> ap Nothing -> APHandler $ \r -> do --TODO: can this be pure like falseAP? $logWarnS "AccessControl" ("route tag unknown for access control") unauthorizedI $ MsgUnauthorized route2ap :: Route UniWorX -> AccessPredicate -route2ap r = Set.foldr orAP adminAP attrsAND +route2ap r = foldr orAP adminAP attrsAND --TODO: adminAP causes all to be in DB!!! where - attrsAND = Set.map splitAnd $ routeAttrs r - splitAND = foldr1 andAP . map tag2access . splitOn "AND" + attrsAND = map splitAND $ Set.toList $ routeAttrs r + splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND" -evalAccessDB :: Route -> DB Authorized -- all requests, regardless of POST/GET, use isWriteRequest otherwise -evalAccessDB r = case getAccess r of - (APPure p) -> lift $ runReader (p r) <$> getMessageRender +evalAccessDB :: Route UniWorX -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise +evalAccessDB r = case route2ap r of + (APPure p) -> lift $ runReader (p r) <$> getMsgRenderer (APHandler p) -> lift $ p r (APDB p) -> p r -evalAccess :: Route -> Handler UniWorX Authorized -evalAccess r = case getAccess r of - (APPure p) -> runReader (p r) <$> getMessageRender +evalAccess :: Route UniWorX -> Handler AuthResult +evalAccess r = case route2ap r of + (APPure p) -> runReader (p r) <$> getMsgRenderer (APHandler p) -> p r (APDB p) -> runDB $ p r @@ -239,23 +272,6 @@ data MenuTypes -- Semantische Rolle: | PageActionPrime { menuItem :: MenuItem } -- Seitenspezifische Aktion, häufig | PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten --- | Convenient Type Synonyms: -type DB a = YesodDB UniWorX a -type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) - -mkMessage "UniWorX" "messages" "de" - --- This instance is required to use forms. You can modify renderMessage to --- achieve customized and internationalized form validation messages. -instance RenderMessage UniWorX FormMessage where - renderMessage _ _ = defaultFormMessage - -instance RenderMessage UniWorX TermIdentifier where - renderMessage foundation ls TermIdentifier{..} = case season of - Summer -> renderMessage' $ MsgSummerTerm year - Winter -> renderMessage' $ MsgWinterTerm year - where renderMessage' = renderMessage foundation ls - -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. @@ -335,7 +351,7 @@ instance Yesod UniWorX where favourites <- forM favourites' $ \(Entity _ c@Course{..}) -> let - courseRoute = CourseR courseTerm courseShorthand CourseShowR + courseRoute = CourseR courseTerm courseShorthand CShowR in (c, courseRoute, ) <$> filterM (menuItemAccessCallback . menuItem) (pageActions courseRoute) -- We break up the default layout into two components: @@ -435,14 +451,14 @@ isAuthorizedDB (SubmissionDownloadArchiveR (ZIPArchiveName cID)) _ = submissionA isAuthorizedDB TermEditR _ = adminAccess Nothing isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing isAuthorizedDB CourseNewR _ = lecturerAccess Nothing -isAuthorizedDB (CourseR t c CourseEditR) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c CEditR) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseR t c (SheetR SheetListR)) False = return Authorized -- isAuthorizedDB (CourseR t c (SheetR SheetListR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR (SheetShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor +isAuthorizedDB (CourseR t c (SheetR (SShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor isAuthorizedDB (CourseR t c (SheetR SheetNewR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR (SheetEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (CourseR t c (SheetR (SheetDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c (SheetR (SEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c (SheetR (SDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseR t c (SheetR (SubmissionR s m))) _ = return Authorized -- TODO -- submissionAccess $ Right cID isAuthorizedDB (CourseEditIDR cID) _ = do courseId <- decrypt cID @@ -518,17 +534,17 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR) breadcrumb CourseListR = return ("Kurs", Just HomeR) - breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR) - breadcrumb (CourseR term course CourseShowR) = return (course, Just $ CourseListTermR term) + breadcrumb (TermCourseListR term) = return (toPathPiece term, Just TermShowR) + breadcrumb (CourseR term course CShowR) = return (course, Just $ TermCourseListR term) breadcrumb CourseNewR = return ("Neu", Just CourseListR) - breadcrumb (CourseR _ _ CourseEditR) = return ("Editieren", Just CourseListR) + breadcrumb (CourseR _ _ CEditR) = return ("Editieren", Just CourseListR) - breadcrumb (CourseR tid csh (SheetR SheetListR)) = return ("Übungen",Just $ CourseR tid csh CourseShowR) - breadcrumb (CourseR tid csh (SheetR SheetNewR )) = return ("Neu", Just $ CourseR tid csh $ SheetR SheetListR) - breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn, Just $ CourseR tid csh $ SheetR SheetListR) - breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) - breadcrumb (CourseR tid csh (SheetR (SheetDelR shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) - breadcrumb (CourseR tid csh (SheetR (SubmissionR shn _))) = return ("Abgabe", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) + breadcrumb (CourseR tid csh SheetListR) = return ("Übungen",Just $ CourseR tid csh CShowR) + breadcrumb (CourseR tid csh SheetNewR ) = return ("Neu", Just $ CourseR tid csh SheetListR) + breadcrumb (CSheetR tid csh shn SShowR) = return (shn, Just $ CourseR tid csh SheetListR) + breadcrumb (CSheetR tid csh shn 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 (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR) breadcrumb SubmissionListR = return ("Abgaben", Just HomeR) @@ -539,33 +555,33 @@ instance YesodBreadcrumbs UniWorX where breadcrumb _ = return ("home", Nothing) pageActions :: Route UniWorX -> [MenuTypes] -pageActions (CourseR tid csh CourseShowR) = +pageActions (CourseR tid csh CShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Übungsblätter" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh SheetListR + , menuItemRoute = CourseR tid csh SheetListR , menuItemAccessCallback' = return True } , PageActionPrime $ MenuItem { menuItemLabel = "Kurs Editieren" , menuItemIcon = Nothing - , menuItemRoute = CourseR tid csh CourseEditR + , menuItemRoute = CourseR tid csh CEditR , menuItemAccessCallback' = return True } ] -pageActions (CSheetR tid csh SheetListR) = +pageActions (CourseR tid csh SheetListR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Neues Übungsblatt" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh SheetNewR + , menuItemRoute = CourseR tid csh SheetNewR , menuItemAccessCallback' = return True } ] -pageActions (CSheetR tid csh (SheetShowR shn)) = +pageActions (CSheetR tid csh shn SShowR) = [ PageActionPrime $ MenuItem { menuItemLabel = "Abgabe" , menuItemIcon = Nothing - , menuItemRoute = CSheetR tid csh (SubmissionR shn newSubmission) + , menuItemRoute = CSheetR tid csh shn (SubmissionR newSubmission) , menuItemAccessCallback' = return True } ] @@ -577,7 +593,7 @@ pageActions TermShowR = , menuItemAccessCallback' = return True } ] -pageActions (CourseListTermR _) = +pageActions (TermCourseListR _) = [ PageActionPrime $ MenuItem { menuItemLabel = "Neuer Kurs" , menuItemIcon = Just "book" diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index a37acbbc4..555104172 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -26,8 +26,8 @@ import qualified Data.UUID.Cryptographic as UUID getCourseListR :: Handler TypedContent getCourseListR = redirect TermShowR -getCourseListTermR :: TermId -> Handler Html -getCourseListTermR tidini = do +getTermCourseListR :: TermId -> Handler Html +getTermCourseListR tidini = do (term,courses) <- runDB $ (,) <$> get tidini <*> selectList [CourseTerm ==. tidini] [Asc CourseShorthand] @@ -40,7 +40,7 @@ getCourseListTermR tidini = do let c = entityVal ckv shd = courseShorthand c tid = courseTerm c - in [whamlet| #{shd} |] ) + in [whamlet| #{shd} |] ) -- , headed "Institut" $ [shamlet| #{course} |] , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal , headed "Ende Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal @@ -54,11 +54,11 @@ getCourseListTermR tidini = do shd = courseShorthand c tid = courseTerm c in do - adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CourseEditR) False - -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else "" + adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CEditR) False + -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CEditR tid shd) else "" [whamlet| $if adminLink == Authorized - + editieren |] ) @@ -68,8 +68,8 @@ getCourseListTermR tidini = do setTitle "Semesterkurse" $(widgetFile "courses") -getCourseShowR :: TermId -> Text -> Handler Html -getCourseShowR tid csh = do +getCShowR :: TermId -> Text -> Handler Html +getCShowR tid csh = do mbAid <- maybeAuthId (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh @@ -95,8 +95,8 @@ registerButton registered = renderAForm FormStandard $ msg = if registered then "Abmelden" else "Anmelden" regMsg = msg :: BootstrapSubmit Text -postCourseShowR :: TermId -> Text -> Handler Html -postCourseShowR tid csh = do +postCShowR :: TermId -> Text -> Handler Html +postCShowR tid csh = do aid <- requireAuthId (cid, registered) <- runDB $ do (Entity cid _) <- getBy404 $ CourseTermShort tid csh @@ -114,7 +114,7 @@ postCourseShowR tid csh = do when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!" (_other) -> return () -- TODO check this! -- redirect or not?! I guess not, since we want GET now - getCourseShowR tid csh + getCShowR tid csh getCourseNewR :: Handler Html getCourseNewR = do @@ -124,13 +124,13 @@ getCourseNewR = do postCourseNewR :: Handler Html postCourseNewR = courseEditHandler Nothing -getCourseEditR :: TermId -> Text -> Handler Html -getCourseEditR tid csh = do +getCEditR :: TermId -> Text -> Handler Html +getCEditR tid csh = do course <- runDB $ getBy $ CourseTermShort tid csh courseEditHandler course -postCourseEditR :: TermId -> Text -> Handler Html -postCourseEditR = getCourseEditR +postCEditR :: TermId -> Text -> Handler Html +postCEditR = getCEditR getCourseEditIDR :: CryptoUUIDCourse -> Handler Html getCourseEditIDR cID = do @@ -147,7 +147,7 @@ courseDeleteHandler = undefined runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen! let cti = toPathPiece $ cfTerm res addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|] - redirect $ CourseListTermR $ cfTerm res + redirect $ TermCourseListR $ cfTerm res -} courseEditHandler :: Maybe (Entity Course) -> Handler Html @@ -183,7 +183,7 @@ courseEditHandler course = do insert_ $ CourseEdit aid now cid insert_ $ Lecturer aid cid addMessageI "info" $ MsgCourseNewOk tident csh - redirect $ CourseListTermR tid + redirect $ TermCourseListR tid Nothing -> addMessageI "danger" $ MsgCourseNewDupShort tident csh @@ -238,7 +238,7 @@ courseEditHandler course = do -- if (isNothing updOkay) -- then do addMessageI "info" $ MsgCourseEditOk tident csh - -- redirect $ CourseListTermR tid + -- redirect $ TermCourseListR tid -- else addMessageI "danger" $ MsgCourseEditDupShort tident csh (FormFailure _) -> addMessageI "warning" MsgInvalidInput diff --git a/src/Handler/CryptoIDDispatch.hs b/src/Handler/CryptoIDDispatch.hs index f5a77cdbd..b02e95a0c 100644 --- a/src/Handler/CryptoIDDispatch.hs +++ b/src/Handler/CryptoIDDispatch.hs @@ -38,7 +38,7 @@ instance CryptoRoute UUID SubmissionId where Sheet{..} <- get404 shid Course{..} <- get404 sheetCourse return (courseTerm, courseShorthand, sheetName) - return $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID + return $ CSheetR tid csh shn $ SubmissionR $ SubmissionMode $ Just cID class Dispatch ciphertext (x :: [*]) where diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 61b2c4eb3..80e636efa 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -154,7 +154,7 @@ getSheetList courseEnt = do rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub return (sid, sheet, (submissions, rated)) let colBase = mconcat - [ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CourseR tid csh $ SheetR $ SheetShowR $ sheetName sheet + [ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CSheetR tid csh (sheetName sheet) SShowR , headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3 , headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3 , headed "Bewertung" $ toWgt . show . sheetType . snd3 @@ -162,13 +162,13 @@ getSheetList courseEnt = do let colAdmin = mconcat -- only show edit button for allowed course assistants [ headed "Korrigiert" $ toWgt . snd . trd3 , headed "Eingereicht" $ toWgt . fst . trd3 - , headed "" $ \s -> linkButton "Edit" BCLink $ CourseR tid csh $ SheetR $ SheetEditR $ sheetName $ snd3 s - , headed "" $ \s -> linkButton "Delete" BCLink $ CourseR tid csh $ SheetR $ SheetDelR $ sheetName $ snd3 s + , headed "" $ \s -> linkButton "Edit" BCLink $ CSheetR tid csh (sheetName $ snd3 s) SEditR + , headed "" $ \s -> linkButton "Delete" BCLink $ CSheetR tid csh (sheetName $ snd3 s) SDelR ] showAdmin <- case sheets of ((_,firstSheet,_):_) -> do setUltDestCurrent - (Authorized ==) <$> isAuthorized (CourseR tid csh $ SheetR $ SheetEditR $ sheetName firstSheet) False + (Authorized ==) <$> isAuthorized (CSheetR tid csh (sheetName firstSheet) SEditR) False _otherwise -> return False let colSheets = if showAdmin then colBase `mappend` colAdmin @@ -181,8 +181,8 @@ getSheetList courseEnt = do -- Show single sheet -getSheetShowR :: TermId -> Text -> Text -> Handler Html -getSheetShowR tid csh shn = do +getSShowR :: TermId -> Text -> Text -> Handler Html +getSShowR tid csh shn = do entSheet <- runDB $ fetchSheet tid csh shn let sheet = entityVal entSheet sid = entityKey entSheet @@ -210,7 +210,7 @@ getSheetShowR tid csh shn = do return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = mconcat [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype - , sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh (SheetFileR shn fType fName)) + , sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName)) (\(E.Value fName,_,_) -> str2widget fName) , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT modified ] @@ -235,8 +235,8 @@ getSheetShowR tid csh shn = do $(widgetFile "sheetShow") [whamlet| Under Construction !!! |] -- TODO -getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent -getSheetFileR tid csh shn typ title = do +getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent +getSFileR tid csh shn typ title = do content <- 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 @@ -272,8 +272,8 @@ postSheetNewR :: TermId -> Text -> Handler Html postSheetNewR = getSheetNewR -getSheetEditR :: TermId -> Text -> Text -> Handler Html -getSheetEditR tid csh shn = do +getSEditR :: TermId -> Text -> Text -> Handler Html +getSEditR tid csh shn = do (sheetEnt, sheetFileIds) <- runDB $ do ent <- fetchSheet tid csh shn fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do @@ -307,8 +307,8 @@ getSheetEditR tid csh shn = do (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here handleSheetEdit tid csh (Just sid) template action -postSheetEditR :: TermId -> Text -> Text -> Handler Html -postSheetEditR = getSheetEditR +postSEditR :: TermId -> Text -> Text -> Handler Html +postSEditR = getSEditR handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html handleSheetEdit tid csh msId template dbAction = do @@ -344,44 +344,44 @@ handleSheetEdit tid csh msId template dbAction = do insert_ $ SheetEdit aid actTime sid addMessageI "info" $ MsgSheetEditOk tident csh sfName return True - when saveOkay $ redirect $ CSheetR tid csh $ SheetShowR sfName -- redirect must happen outside of runDB + when saveOkay $ redirect $ CSheetR tid csh sfName SShowR -- redirect must happen outside of runDB (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml _ -> return () let pageTitle = maybe (MsgSheetTitleNew tident csh) (MsgSheetTitle tident csh) mbshn let formTitle = pageTitle let formText = Nothing :: Maybe UniWorXMessage - actionUrl <- fromMaybe (CSheetR tid csh SheetNewR) <$> getCurrentRoute + actionUrl <- fromMaybe (CourseR tid csh SheetNewR) <$> getCurrentRoute defaultLayout $ do setTitleI pageTitle $(widgetFile "formPageI18n") -getSheetDelR :: TermId -> Text -> Text -> Handler Html -getSheetDelR tid csh shn = do +getSDelR :: TermId -> Text -> Text -> Handler Html +getSDelR tid csh shn = do let tident = unTermKey tid ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) case result of - (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh $ SheetShowR shn + (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh shn SShowR (FormSuccess BtnDelete) -> do runDB $ fetchSheetId tid csh shn >>= deleteCascade -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! addMessageI "info" $ MsgSheetDelOk tident csh shn - redirect $ CSheetR tid csh SheetListR + redirect $ CourseR tid csh SheetListR _other -> do submissionno <- runDB $ do sid <- fetchSheetId tid csh shn count [SubmissionSheet ==. sid] let formTitle = MsgSheetDelTitle tident csh shn let formText = Just $ MsgSheetDelText submissionno - let actionUrl = CSheetR tid csh $ SheetDelR shn + let actionUrl = CSheetR tid csh shn SDelR defaultLayout $ do setTitleI $ MsgSheetTitle tident csh shn $(widgetFile "formPageI18n") -postSheetDelR :: TermId -> Text -> Text -> Handler Html -postSheetDelR = getSheetDelR +postSDelR :: TermId -> Text -> Text -> Handler Html +postSDelR = getSDelR diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 08996f47e..becc5ed2c 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -112,7 +112,7 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do (E.Value smid:_) -> do cID <- encrypt smid addMessageI "info" $ MsgSubmissionAlreadyExists - redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID + redirect $ CSheetR tid csh shn $ SubmissionR $ SubmissionMode $ Just cID (Just smid) -> do shid' <- submissionSheet <$> get404 smid when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet] @@ -203,7 +203,7 @@ postSubmissionR tid csh shn (SubmissionMode mcid) = do _other -> return Nothing case mCID of - Just cID -> redirect $ CourseR tid csh $ SheetR $ SubmissionR shn $ SubmissionMode $ Just cID + Just cID -> redirect $ CSheetR tid csh shn $ SubmissionR $ SubmissionMode $ Just cID Nothing -> return () mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid @@ -327,7 +327,7 @@ submissionTable = do (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s let - anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CourseShowR + anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CShowR courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index cfbd92ced..e6fcc3615 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -60,7 +60,7 @@ getTermShowR = do textCell $ bool "" tickmark termActive , sortable Nothing "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) -> cell [whamlet| - + #{show numCourses} Kurse |] , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) -> diff --git a/src/Utils.hs b/src/Utils.hs index e1aebc0b6..0024dc117 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,5 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} {-# LANGUAGE QuasiQuotes #-} @@ -14,10 +16,29 @@ import Utils.Common as Utils import Text.Blaze (Markup, ToMarkup) -import Data.Map (Map) -import qualified Data.Map as Map -import qualified Data.List as List +-- import Data.Map (Map) +-- import qualified Data.Map as Map +-- import qualified Data.List as List +import Control.Monad.Trans.Except (ExceptT(..), throwE, runExceptT) +import Control.Monad.Trans.Maybe (MaybeT(..)) + + +----------- +-- Yesod -- +----------- + +newtype MsgRendererS site = MsgRenderer { render :: (forall msg. RenderMessage site msg => msg -> Text) } + +getMsgRenderer :: forall m site. (MonadHandler m, HandlerSite m ~ site) => m (MsgRendererS site) +getMsgRenderer = do + mr <- getMessageRender + return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text) + + +--------------------- +-- Text and String -- +--------------------- tickmark :: IsString a => a tickmark = fromString "✔" @@ -42,12 +63,6 @@ withFragment :: ( Monad m ) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ()) withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget) ------------ --- Maybe -- ------------ -whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () -whenIsJust (Just x) f = f x -whenIsJust Nothing _ = return () ------------ -- Tuples -- @@ -56,3 +71,45 @@ whenIsJust Nothing _ = return () ---------- -- Maps -- ---------- + + +----------- +-- Maybe -- +----------- +whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m () +whenIsJust (Just x) f = f x +whenIsJust Nothing _ = return () + +maybeT :: Monad m => m a -> MaybeT m a -> m a +maybeT x m = runMaybeT m >>= maybe x return + +--------------- +-- Exception -- +--------------- + +maybeExceptT :: Monad m => e -> m (Maybe b) -> ExceptT e m b +maybeExceptT err act = lift act >>= maybe (throwE err) return + +maybeMExceptT :: Monad m => (m e) -> m (Maybe b) -> ExceptT e m b +maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return + +guardExceptT :: Monad m => e -> Bool -> ExceptT e m () +guardExceptT err b = unless b $ throwE err + +guardMExceptT :: Monad m => (m e) -> Bool -> ExceptT e m () +guardMExceptT err b = unless b $ lift err >>= throwE + +exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b +exceptT f g = either f g <=< runExceptT + + +------------ +-- Monads -- +------------ + +shortCircuitM :: Monad m => (a -> Bool) -> m a -> m a -> (a -> a -> a) -> m a +shortCircuitM sc mx my op = do + x <- mx + case sc x of + True -> return x + False -> op <$> pure x <*> my diff --git a/src/Utils/Common.hs b/src/Utils/Common.hs index c0e3dcb81..56c437905 100644 --- a/src/Utils/Common.hs +++ b/src/Utils/Common.hs @@ -5,7 +5,10 @@ module Utils.Common where -- Common Utility Functions import Language.Haskell.TH +import Control.Monad +import Control.Monad.Trans.Class import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Except ------------ -- Tuples -- @@ -51,10 +54,3 @@ altFun perm = lamE pat rhs fn = mkName "fn" ------------ --- Maybe -- ------------ - -maybeT :: Monad m => m a -> MaybeT m a -> m a -maybeT x m = runMaybeT m >>= maybe x return - diff --git a/templates/course.hamlet b/templates/course.hamlet index 4b837d18d..958e4024a 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -34,7 +34,7 @@
Anmelden - $#
+ $# $# ^{regWidget}
diff --git a/templates/widgets/asidenav.hamlet b/templates/widgets/asidenav.hamlet index 8126fd770..1d8e82971 100644 --- a/templates/widgets/asidenav.hamlet +++ b/templates/widgets/asidenav.hamlet @@ -5,12 +5,12 @@ $newline never