From 43f625ba0c009519f7e37b833e33a99f1ac97069 Mon Sep 17 00:00:00 2001
From: Sarah Vaupel <>
Date: Thu, 6 Aug 2020 19:46:15 +0200
Subject: [PATCH] fix(course-visibility): visibility for admin-like users

---
 src/Foundation.hs | 19 +++++++++++++++++++
 1 file changed, 19 insertions(+)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index b1c6fbfd3..8f72a6291 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -533,6 +533,15 @@ tagAccessPredicate AuthExamOffice = APDB $ \mAuthId route _ -> case route of
       E.where_ $ examOfficeExternalExamResultAuth (E.val authId) eexamResult
     guardMExceptT hasUsers $ unauthorizedI MsgUnauthorizedExternalExamExamOffice
     return Authorized
+  CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isExamOffice <- lift $ exists 
+      [ UserFunctionUser     ==. authId
+      , UserFunctionFunction ==. SchoolExamOffice
+      , UserFunctionSchool   ==. ssh
+      ]
+    guardMExceptT isExamOffice $ unauthorizedI MsgUnauthorizedExamExamOffice
+    return Authorized
   _other -> $cachedHereBinary mAuthId . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     isExamOffice <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolExamOffice]
@@ -544,6 +553,11 @@ tagAccessPredicate AuthEvaluation = APDB $ \mAuthId route _ -> case route of
     isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
     guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
     return Authorized
+  CourseR _ ssh _ _ -> $cachedHereBinary(mAuthId, ssh) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolEvaluation
+    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedEvaluation
+    return Authorized
   _other -> $cachedHereBinary mAuthId . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolEvaluation]
@@ -555,6 +569,11 @@ tagAccessPredicate AuthAllocationAdmin = APDB $ \mAuthId route _ -> case route o
     isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
     guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
     return Authorized
+  CourseR _ ssh _ _ -> $cachedHereBinary (mAuthId, ssh) . exceptT return return $ do
+    authId <- maybeExceptT AuthenticationRequired $ return mAuthId
+    isEvaluation <- lift . existsBy $ UniqueUserFunction authId ssh SchoolAllocation
+    guardMExceptT isEvaluation $ unauthorizedI MsgUnauthorizedAllocationAdmin
+    return Authorized
   _other -> $cachedHereBinary mAuthId . exceptT return return $ do
     authId <- maybeExceptT AuthenticationRequired $ return mAuthId
     isEvaluation <- lift $ exists [UserFunctionUser ==. authId, UserFunctionFunction ==. SchoolAllocation]