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
|
Access permission is the disjunction of permit tags
|
||||||
/robots.txt RobotsR GET
|
Tags are split on "AND" to encode conjunction.
|
||||||
|
|
||||||
/ HomeR GET POST
|
Note that nested routes automatically inherit all tags from the parent.
|
||||||
/profile ProfileR GET
|
|
||||||
/users UsersR GET !adminAny
|
|
||||||
|
|
||||||
/term TermShowR GET
|
Admins always have access to entities within their assigned schools.
|
||||||
/term/edit TermEditR GET POST !adminAny
|
|
||||||
/term/#TermId/edit TermEditExistR GET !adminAny
|
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
|
-- For Pattern Synonyms see Foundation
|
||||||
/course/ CourseListR GET
|
/course/ CourseListR GET !free
|
||||||
!/course/new CourseNewR GET POST !lecturerAny
|
!/course/new CourseNewR GET POST !lecturer
|
||||||
!/course/#TermId CourseListTermR GET
|
/course/#TermId/#Text CourseR !lecturer !updateFavourite:
|
||||||
/course/#TermId/#Text CourseR !updateFavourite:
|
/show CShowR GET POST !free
|
||||||
/show CourseShowR GET POST
|
/edit CEditR GET POST
|
||||||
/edit CourseEditR GET POST !lecturer
|
/ex SheetListR GET !materials
|
||||||
|
!/ex/new SheetNewR GET POST
|
||||||
/ex SheetR !registered:
|
/ex/#Text SheetR !materials:
|
||||||
/ SheetListR GET
|
/show SShowR GET !time !corrector
|
||||||
/#Text/show SheetShowR GET !time
|
/#SheetFileType/#FilePath SFileR GET !time !corrector
|
||||||
/#Text/#SheetFileType/#FilePath SheetFileR GET !time
|
/edit SEditR GET POST
|
||||||
/new SheetNewR GET POST !lecturer
|
/delete SDelR GET POST
|
||||||
/#Text/edit SheetEditR GET POST !lecturer
|
!/submission/#SubmissionMode SubmissionR GET POST !timeANDregistered
|
||||||
/#Text/delete SheetDelR GET POST !lecturer
|
|
||||||
!/#Text/submission/#SubmissionMode SubmissionR GET POST !time
|
|
||||||
|
|
||||||
|
|
||||||
!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET
|
!/#UUID CryptoUUIDDispatchR GET !free
|
||||||
!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET
|
|
||||||
|
|
||||||
!/#UUID CryptoUUIDDispatchR GET
|
|
||||||
|
|
||||||
-- TODO below
|
-- TODO below
|
||||||
/submission SubmissionListR GET POST
|
!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated
|
||||||
/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST
|
!/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET !deprecated
|
||||||
/submissions.zip SubmissionDownloadMultiArchiveR POST
|
|
||||||
|
|
||||||
-- For demonstration
|
/submission SubmissionListR GET !deprecated
|
||||||
/course/#CryptoUUIDCourse/edit CourseEditIDR GET
|
/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST !deprecated
|
||||||
|
/submissions.zip SubmissionDownloadMultiArchiveR POST !deprecated
|
||||||
|
|||||||
@ -1,9 +1,11 @@
|
|||||||
{-# LANGUAGE NoImplicitPrelude #-}
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE OverloadedLists #-}
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
{-# LANGUAGE TypeFamilies #-}
|
{-# LANGUAGE TypeFamilies #-}
|
||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
|
{-# LANGUAGE LambdaCase #-}
|
||||||
{-# LANGUAGE PatternSynonyms #-}
|
{-# LANGUAGE PatternSynonyms #-}
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
{-# LANGUAGE RecordWildCards #-}
|
{-# LANGUAGE RecordWildCards #-}
|
||||||
@ -90,9 +92,77 @@ data UniWorX = UniWorX
|
|||||||
mkYesodData "UniWorX" $(parseRoutesFile "routes")
|
mkYesodData "UniWorX" $(parseRoutesFile "routes")
|
||||||
|
|
||||||
-- Pattern Synonyms for convenience
|
-- 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
|
data MenuItem = MenuItem
|
||||||
{ menuItemLabel :: Text
|
{ menuItemLabel :: Text
|
||||||
, menuItemIcon :: Maybe Text
|
, menuItemIcon :: Maybe Text
|
||||||
@ -157,9 +227,9 @@ instance Yesod UniWorX where
|
|||||||
yesodMiddleware handler = do
|
yesodMiddleware handler = do
|
||||||
res <- defaultYesodMiddleware handler
|
res <- defaultYesodMiddleware handler
|
||||||
void . runMaybeT $ do
|
void . runMaybeT $ do
|
||||||
route@(routeAttrs -> attrs) <- MaybeT getCurrentRoute
|
route <- MaybeT getCurrentRoute
|
||||||
case route of
|
case route of -- update Course Favourites here
|
||||||
CourseR tid csh _ | "updateFavourite" `elem` attrs -> do
|
CourseR tid csh _ -> do
|
||||||
uid <- MaybeT maybeAuthId
|
uid <- MaybeT maybeAuthId
|
||||||
$(logDebug) "Favourites save"
|
$(logDebug) "Favourites save"
|
||||||
now <- liftIO $ getCurrentTime
|
now <- liftIO $ getCurrentTime
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user