From c004a65b32e0d7ee89150ff730d989d48ec3c9e9 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 27 Nov 2017 14:52:54 +0100 Subject: [PATCH] Authorization checks --- src/Foundation.hs | 102 ++++++++++++++++++++++++++++++++++------------ 1 file changed, 75 insertions(+), 27 deletions(-) diff --git a/src/Foundation.hs b/src/Foundation.hs index c000c625d..dfed85e02 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -48,6 +48,10 @@ import Data.Conduit.List (sourceList) import Control.Monad.Except (MonadError(..), runExceptT) import Handler.Utils.StudyFeatures +import qualified Data.UUID.Cryptographic as UUID +import qualified System.FilePath.Cryptographic as FilePath +import System.FilePath + -- | The foundation datatype for your application. This can be a good place to -- keep settings and values requiring initialization before your application -- starts running, such as database connections. Every handler will have @@ -119,33 +123,19 @@ instance Yesod UniWorX where -- The page to be redirected to when authentication is required. authRoute _ = Just $ AuthR LoginR - -- Routes not requiring authentication. - isAuthorized (AuthR _) _ = return Authorized - isAuthorized HomeR _ = return Authorized - isAuthorized FaviconR _ = return Authorized - isAuthorized RobotsR _ = return Authorized - isAuthorized (StaticR _) _ = return Authorized - - isAuthorized ProfileR _ = isAuthenticated - - -- TODO: all? - isAuthorized TermShowR _ = return Authorized - isAuthorized CourseListR _ = return Authorized - isAuthorized (CourseShowR _ _) _ = return Authorized - isAuthorized (CourseListTermR _) _ = return Authorized - isAuthorized SubmissionListR _ = return Authorized - isAuthorized (SubmissionR _) _ = return Authorized - isAuthorized (SubmissionDownloadSingleR _ _) _ = return Authorized - isAuthorized (SubmissionDownloadArchiveR _) _ = return Authorized - isAuthorized SubmissionDownloadMultiArchiveR _ = return Authorized - -- TODO: change to Assistants - isAuthorized TermEditR _ = return Authorized - isAuthorized (TermEditExistR _) _ = return Authorized - isAuthorized CourseEditR _ = return Authorized - isAuthorized (CourseEditExistR _ _) _ = return Authorized - isAuthorized (CourseEditExistIDR _) _ = return Authorized - - + 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 (CourseShowR _ _) _ = return Authorized + isAuthorized SubmissionListR _ = isAuthenticated + isAuthorized SubmissionDownloadMultiArchiveR _ = isAuthenticated + isAuthorized route isWrite = runDB $ isAuthorizedDB route isWrite -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows @@ -186,6 +176,64 @@ instance Yesod UniWorX where makeLogger = return . appLogger +isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult +isAuthorizedDB (SubmissionR cID) _ = submissionAccess $ Right cID +isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID +isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName +isAuthorizedDB TermEditR _ = adminAccess Nothing +isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing +isAuthorizedDB CourseEditR _ = lecturerAccess Nothing +isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort (TermKey t) c) +isAuthorizedDB (CourseEditExistIDR cID) _ = do + cIDKey <- getsYesod appCryptoIDKey + courseId <- UUID.decrypt cIDKey cID + courseLecturerAccess courseId +isAuthorizedDB route isWrite = lift $ isAuthorized route isWrite + +submissionAccess :: Either CryptoFileNameSubmission CryptoUUIDSubmission -> YesodDB UniWorX AuthResult +submissionAccess cID = do + authId <- lift requireAuthId + cIDKey <- getsYesod appCryptoIDKey + submissionId <- either (FilePath.decrypt cIDKey) (UUID.decrypt cIDKey) cID + Submission{..} <- get404 submissionId + submissionUsers <- map (submissionUserUserId . entityVal) <$> selectList [SubmissionUserSubmissionId ==. submissionId] [] + let auth = authId `elem` submissionUsers || Just authId == submissionRatingBy + return $ case auth of + True -> Authorized + False -> Unauthorized "No access to this submission" + +adminAccess :: Maybe (Maybe SchoolId) -- ^ If @Just@, matched exactly against 'userAdminSchool' + -> YesodDB UniWorX AuthResult +adminAccess school = do + authId <- lift requireAuthId + schools <- map (userAdminSchool . entityVal) <$> selectList [UserAdminUser ==. authId] [] + return $ case maybe (not $ null schools) (`elem` schools) school of + True -> Authorized + False -> Unauthorized "No admin access" + +lecturerAccess :: Maybe SchoolId + -> YesodDB UniWorX AuthResult +lecturerAccess school = do + authId <- lift requireAuthId + schools <- map (userLecturerSchool . entityVal) <$> selectList [UserLecturerUser ==. authId] [] + return $ case maybe (not $ null schools) (`elem` schools) school of + True -> Authorized + False -> Unauthorized "No lecturer access" + +courseLecturerAccess :: CourseId -> YesodDB UniWorX AuthResult +courseLecturerAccess courseId = do + authId <- lift requireAuthId + users <- map (lecturerUserId . entityVal ) <$> selectList [ LecturerCourseId ==. courseId ] [] + return $ case authId `elem` users of + True -> Authorized + False -> Unauthorized "No lecturer access for this course" + +isAuthorizedDB' :: Route UniWorX -> Bool -> YesodDB UniWorX Bool +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 breadcrumb TermShowR = return ("Semester", Just HomeR)