Merge branch 'feat/routes' of gitlab.cip.ifi.lmu.de:jost/UniWorX into feat/routes

src/Foundation.hs

@@ -159,14 +159,12 @@ orAR  _  _ Authorized = Authorized
 orAR  _  AuthenticationRequired _  = AuthenticationRequired
 orAR  _  _ AuthenticationRequired  = AuthenticationRequired
 orAR  mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $  MsgUnauthorizedOr x y
-andAR _  Authorized Authorized = Authorized
-andAR _  Authorized other      = other
-andAR _  other      Authorized = other
-andAR _  AuthenticationRequired other = other
-andAR _  other AuthenticationRequired = other
+-- and
 andAR mr (Unauthorized x) (Unauthorized y) = Unauthorized . render mr $  MsgUnauthorizedAnd x y
-
-
+andAR _  reason@(Unauthorized x) _ = reason
+andAR _  _ reason@(Unauthorized x) = reason
+andAR _  Authorized          other = other
+andAR _  AuthenticationRequired  _ = AuthenticationRequired
 
 orAP,andAP :: AccessPredicate -> AccessPredicate -> AccessPredicate
 orAP  = liftAR  orAR (== Authorized)
@@ -190,8 +188,9 @@ trueAP  = APPure . const $ return Authorized
 falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask
 -- TODO: I believe falseAP := adminAP
 
-adminAP :: AccessPredicate
+adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes)
 adminAP = APDB $ \case
+    -- Courses: access only to school admins
     CourseR tid csh _ -> exceptT return return $ do
         authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
         [E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` userAdmin) -> do
@@ -200,15 +199,15 @@ adminAP = APDB $ \case
                 E.&&. course E.^. CourseTerm      E.==. E.val tid
                 E.&&. course E.^. CourseShorthand E.==. E.val csh
           return (E.countRows :: E.SqlExpr (E.Value Int64))
-        guardMExceptT (unauthorizedI MsgUnauthorizedSchoolAdmin) (c > 0)
+        guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedSchoolAdmin)
         return Authorized
-
+    -- other routes: access to any admin is granted here
     _other -> exceptT return return $ do
         authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
         adrights <- lift $ selectFirst [UserAdminUser ==. authId] []
-        case adrights of
-          (Just _) -> return Authorized
-          Nothing  -> lift $ unauthorizedI $ MsgUnauthorized
+        guardMExceptT (isJust adrights) (unauthorizedI $ MsgUnauthorized)
+        return Authorized
+
 
 knownTags :: Map (CI Text) AccessPredicate
 knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
@@ -227,7 +226,7 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
                  E.&&. course E.^. CourseTerm E.==. E.val tid
                  E.&&. course E.^. CourseShorthand E.==. E.val csh
             return (E.countRows :: E.SqlExpr (E.Value Int64))
-          guardMExceptT (unauthorizedI MsgUnauthorizedLecturer) (c > 0)
+          guardMExceptT (c>0) (unauthorizedI MsgUnauthorizedLecturer)
           return Authorized
       _ -> exceptT return return $ do
           authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
@@ -260,7 +259,7 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
            guard $ cid `Set.member` Map.keysSet resMap
            return Authorized
          _ -> do
-           guardMExceptT (unauthorizedI MsgUnauthorizedCorrectorAny) . not $ Map.null resMap
+           guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
            return Authorized
    )
   ,("time", APDB $ \case
@@ -287,7 +286,7 @@ knownTags = -- should not throw exceptions, i.e. no getBy404 or requireAuthId
                 E.&&. course E.^. CourseTerm E.==. E.val tid
                 E.&&. course E.^. CourseShorthand E.==. E.val csh
            return (E.countRows :: E.SqlExpr (E.Value Int64))
-         guardMExceptT (unauthorizedI MsgUnauthorizedParticipant) (c > 0)
+         guardMExceptT (c > 0) (unauthorizedI MsgUnauthorizedParticipant)
          return Authorized
        r -> do
          $logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r

src/Utils.hs

@@ -85,7 +85,7 @@ maybeT :: Monad m => m a -> MaybeT m a -> m a
 maybeT x m = runMaybeT m >>= maybe x return
 
 catchIfMaybeT :: (MonadCatch m, Exception e) => (e -> Bool) -> m a -> MaybeT m a
-catchIfMaybeT pred act = catchIf pred (lift act) (const mzero)
+catchIfMaybeT p act = catchIf p (lift act) (const mzero)
 
 ---------------
 -- Exception --
@@ -97,17 +97,23 @@ maybeExceptT err act = lift act >>= maybe (throwE err) return
 maybeMExceptT :: Monad m => (m e) -> m (Maybe b) -> ExceptT e m b
 maybeMExceptT err act = lift act >>= maybe (lift err >>= throwE) return
 
-guardExceptT :: Monad m => e -> Bool -> ExceptT e m ()
-guardExceptT err b = unless b $ throwE err
+whenExceptT :: Monad m => Bool -> e -> ExceptT e m ()
+whenExceptT b err = when b $ throwE err
 
-guardMExceptT :: Monad m => (m e) -> Bool -> ExceptT e m ()
-guardMExceptT err b = unless b $ lift err >>= throwE
+whenMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
+whenMExceptT b err = when b $ lift err >>= throwE
+
+guardExceptT :: Monad m => Bool -> e -> ExceptT e m ()
+guardExceptT b err = unless b $ throwE err
+
+guardMExceptT :: Monad m => Bool -> (m e) -> ExceptT e m ()
+guardMExceptT b err = unless b $ lift err >>= throwE
 
 exceptT :: Monad m => (e -> m b) -> (a -> m b) -> ExceptT e m a -> m b
 exceptT f g = either f g <=< runExceptT
 
 catchIfMExceptT :: (MonadCatch m, Exception e) => (e -> m e') -> (e -> Bool) -> m a -> ExceptT e' m a
-catchIfMExceptT err pred act = catchIf pred (lift act) (throwE <=< lift . err)
+catchIfMExceptT err p act = catchIf p (lift act) (throwE <=< lift . err)
 
 
 ------------

src/Utils/Common.hs

@@ -5,10 +5,10 @@ module Utils.Common where
 -- Common Utility Functions
 
 import Language.Haskell.TH
-import Control.Monad
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.Maybe
-import Control.Monad.Trans.Except
+-- import Control.Monad
+-- import Control.Monad.Trans.Class
+-- import Control.Monad.Trans.Maybe
+-- import Control.Monad.Trans.Except
 
 ------------
 -- Tuples --