From f14bea4015cabcb178e944d218cbdd97e46722ca Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 23 May 2018 15:43:12 +0200 Subject: [PATCH] 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