Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

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)