AccessScaffold
This commit is contained in:
SJost
parent
546c7bde95
commit
f14bea4015
87
routes
87
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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user