feat(workflows): make admin or token sufficient for all roles

src/Foundation/Authorization.hs

@@ -1492,29 +1492,16 @@ authTagSpecificity = comparing $ NTop . flip findIndex eqClasses . elem
       ]
 
 defaultAuthDNF :: AuthDNF
-defaultAuthDNF = PredDNF $ Set.fromList
+defaultAuthDNF = predDNFVar AuthAdmin `predDNFOr` predDNFVar AuthToken
-  [ impureNonNull . Set.singleton $ PLVariable AuthAdmin
-  , impureNonNull . Set.singleton $ PLVariable AuthToken
-  ]
 
 routeAuthTags :: Route UniWorX -> Either InvalidAuthTag AuthDNF
--- ^ DNF up to entailment:
+-- ^ DNF up to entailment, see `predDNFEntail`
---
+routeAuthTags = fmap predDNFEntail . ofoldM parse defaultAuthDNF . routeAttrs
--- > (A_1 && A_2 && ...) OR' B OR' ...
---
--- > A OR' B := ((A |- B) ==> A) && (A || B)
-routeAuthTags = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM partition' (Set.mapMonotonic toNullable $ dnfTerms defaultAuthDNF) . routeAttrs
   where
-    partition' :: Set (Set AuthLiteral) -> Text -> Either InvalidAuthTag (Set (Set AuthLiteral))
+    parse :: AuthDNF -> Text -> Either InvalidAuthTag AuthDNF
-    partition' prev t
+    parse prev t = case fromNullable . Set.fromList =<< mapM fromPathPiece (Text.splitOn "AND" t) of
-      | Just (Set.fromList . toNullable -> authTags) <- fromNullable =<< mapM fromPathPiece (Text.splitOn "AND" t)
+      Just t' -> Right . predDNFOr prev . PredDNF $ Set.singleton t'
-        = if
+      Nothing -> Left $ InvalidAuthTag t
-           | oany (authTags `Set.isSubsetOf`) prev
-             -> Right prev
-           | otherwise
-             -> Right . Set.insert authTags $ Set.filter (not . (`Set.isSubsetOf` authTags)) prev
-      | otherwise
-        = Left $ InvalidAuthTag t
 
 evalAuthTags :: forall ctx m. (Binary ctx, MonadAP m) => ctx -> AuthTagActive -> (forall m'. MonadAP m' => AuthTagsEval m') -> AuthTagsEval m
 -- ^ `tell`s disabled predicates, identified as pivots
@@ -1651,32 +1638,41 @@ evalWorkflowRoleFor' :: forall m backend.
                      -> Route UniWorX
                      -> Bool
                      -> WriterT (Set AuthTag) (ReaderT backend m) AuthResult
-evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = case wRole of
+evalWorkflowRoleFor' eval mAuthId mwwId wRole route isWrite = do
-  WorkflowRoleUser{..} -> lift . exceptT return return $ do
+  mr <- getMsgRenderer
-    uid <- maybeExceptT AuthenticationRequired $ return mAuthId
+
-    unless (uid == workflowRoleUser) $
+  let
-      throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch
+    orAR' :: forall m'. Monad m' => m' AuthResult -> m' AuthResult -> m' AuthResult
-    return Authorized
+    orAR' = shortCircuitM (is _Authorized) (orAR mr)
-  -- `WorkflowRoleInitiator` now means "during initiation".
+
-  -- The old meaning can be emulated via `WorkflowRolePayloadReference`.
+    orDefault = orAR' $ eval defaultAuthDNF mAuthId route isWrite
-  WorkflowRoleInitiator{} -> if
+
-    | is _Nothing mwwId -> return Authorized
+  case wRole of
-    | otherwise -> unauthorizedI MsgWorkflowRoleAlreadyInitiated
+    WorkflowRoleUser{..} -> orDefault . lift . exceptT return return $ do
-  -- WorkflowRoleInitiator{} -> exceptT return return $ do
+      uid <- maybeExceptT AuthenticationRequired $ return mAuthId
-  --   wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoInitiator) $ return mwwId
+      unless (uid == workflowRoleUser) $
-  --   WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId
+        throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch
-  --   let WorkflowAction{..} = head workflowWorkflowState
+      return Authorized
-  --   wpUser' <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoInitiator) . return $ review _SqlKey <$> join wpUser
+    -- `WorkflowRoleInitiator` now means "during initiation".
-  --   lift $ evalWorkflowRoleFor' tagActive mAuthId mwwId (WorkflowRoleUser wpUser') route isWrite
+    -- The old meaning can be emulated via `WorkflowRolePayloadReference`.
-  WorkflowRolePayloadReference{..} ->  exceptT return return $ do
+    WorkflowRoleInitiator{} -> orDefault $ if
-    uid <- maybeExceptT AuthenticationRequired $ return mAuthId
+      | is _Nothing mwwId -> return Authorized
-    wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoPayload) $ return mwwId
+      | otherwise -> unauthorizedI MsgWorkflowRoleAlreadyInitiated
-    WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId
+    -- WorkflowRoleInitiator{} -> exceptT return return $ do
-    let uids = maybe Set.empty getLast . foldMap (fmap Last) . workflowStatePayload workflowRolePayloadLabel $ _DBWorkflowState # workflowWorkflowState
+    --   wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoInitiator) $ return mwwId
-    unless (uid `Set.member` uids) $ 
+    --   WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId
-      throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch
+    --   let WorkflowAction{..} = head workflowWorkflowState
-    return Authorized
+    --   wpUser' <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoInitiator) . return $ review _SqlKey <$> join wpUser
-  WorkflowRoleAuthorized{..} -> eval workflowRoleAuthorized mAuthId route isWrite
+    --   lift $ evalWorkflowRoleFor' tagActive mAuthId mwwId (WorkflowRoleUser wpUser') route isWrite
+    WorkflowRolePayloadReference{..} -> orDefault . exceptT return return $ do
+      uid <- maybeExceptT AuthenticationRequired $ return mAuthId
+      wwId <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoPayload) $ return mwwId
+      WorkflowWorkflow{..} <- maybeMExceptT (unauthorizedI MsgWorkflowRoleNoSuchWorkflowWorkflow) . lift . withReaderT (projectBackend @SqlReadBackend) $ get wwId
+      let uids = maybe Set.empty getLast . foldMap (fmap Last) . workflowStatePayload workflowRolePayloadLabel $ _DBWorkflowState # workflowWorkflowState
+      unless (uid `Set.member` uids) $ 
+        throwE =<< unauthorizedI MsgWorkflowRoleUserMismatch
+      return Authorized
+    WorkflowRoleAuthorized{..} -> eval (predDNFEntail $ workflowRoleAuthorized `predDNFOr` defaultAuthDNF) mAuthId route isWrite
 
 evalWorkflowRoleFor :: ( MonadHandler m
                        , HandlerSite m ~ UniWorX

src/Model/Types/Exam.hs

@@ -556,7 +556,7 @@ deriveFinite ''ExamModePredicate
 
 newtype ExamModeDNF = ExamModeDNF { examModeDNF :: PredDNF ExamModePredicate }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
-  deriving newtype (Semigroup, Monoid, ToJSON, FromJSON, PathPiece)
+  deriving newtype (ToJSON, FromJSON, PathPiece)
 
 derivePersistFieldJSON ''ExamModeDNF
 

src/Model/Types/Security.hs

@@ -176,7 +176,6 @@ instance PathPiece a => PathPiece (PredLiteral a) where
 
 newtype PredDNF a = PredDNF { dnfTerms :: Set (NonNull (Set (PredLiteral a))) }
   deriving (Eq, Ord, Read, Show, Data, Generic, Typeable)
-  deriving newtype (Semigroup, Monoid)
   deriving anyclass (Binary, Hashable)
 
 makeLenses_ ''PredDNF
@@ -216,6 +215,13 @@ predDNFFalse = PredDNF Set.empty
 predDNFSingleton :: Ord a => PredLiteral a -> PredDNF a
 predDNFSingleton = PredDNF . Set.singleton . impureNonNull . Set.singleton
 
+predDNFVar, predDNFNeg :: Ord a => a -> PredDNF a
+predDNFVar = predDNFSingleton . PLVariable
+predDNFNeg = predDNFSingleton . PLNegated
+
+infixr 3 `predDNFAnd`
+infixr 2 `predDNFOr`
+
 predDNFAnd, predDNFOr :: Ord a => PredDNF a -> PredDNF a -> PredDNF a
 predDNFAnd (PredDNF a) (PredDNF b) = PredDNF . Set.fromList $ do
   aConj <- Set.toList a
@@ -223,6 +229,20 @@ predDNFAnd (PredDNF a) (PredDNF b) = PredDNF . Set.fromList $ do
   return . impureNonNull $ toNullable aConj `Set.union` toNullable bConj
 predDNFOr (PredDNF a) (PredDNF b) = PredDNF $ a <> b
 
+predDNFEntail :: forall a. Ord a => PredDNF a -> PredDNF a
+-- ^ Conversion to “DNF up to entailment”:
+--
+-- > (A_1 && A_2 && ...) OR B OR ... -> (A_1 && A_2 && ...) OR' B OR' ...
+--
+-- > A OR' B := ((A |- B) ==> A) && (A || B)
+predDNFEntail = over _dnfTerms $ ofoldl' entail Set.empty
+  where entail :: Set (NonNull (Set (PredLiteral a))) -> NonNull (Set (PredLiteral a)) -> Set (NonNull (Set (PredLiteral a)))
+        entail prev t
+          | oany (t `isSubsetOf`) prev = prev
+          | otherwise = Set.insert t $ Set.filter (not . (`isSubsetOf` t)) prev
+          where isSubsetOf = Set.isSubsetOf `on` toNullable
+        
+
 
 data UserGroupName
   = UserGroupMetrics

test/Database/Fill.hs

@@ -28,6 +28,7 @@ import qualified Data.Csv as Csv
 
 import Crypto.Random (getRandomBytes)
 import Data.List (genericLength)
+import qualified Data.List as List (splitAt)
 
 import qualified Data.Conduit.Combinators as C
 
@@ -276,6 +277,35 @@ fillDb = do
     , userSex = Just SexFemale
     , userShowSex = userDefaultShowSex
     }
+  sbarth <- insert User
+    { userIdent = "Stephan.Barth@campus.lmu.de"
+     , userAuthentication = AuthLDAP
+    , userLastAuthentication = Nothing
+    , userTokensIssuedAfter = Nothing
+    , userMatrikelnummer = Nothing
+    , userEmail = "Stephan.Barth@lmu.de"
+    , userDisplayEmail = "stephan.barth@ifi.lmu.de"
+    , userDisplayName = "Stephan Barth"
+    , userSurname = "Barth"
+    , userFirstName = "Stephan"
+    , userTitle = Nothing
+    , userMaxFavourites = userDefaultMaxFavourites
+    , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms
+    , userTheme = ThemeMossGreen
+    , userDateTimeFormat = userDefaultDateTimeFormat
+    , userDateFormat = userDefaultDateFormat
+    , userTimeFormat = userDefaultTimeFormat
+    , userDownloadFiles = userDefaultDownloadFiles
+    , userWarningDays = userDefaultWarningDays
+    , userLanguages = Nothing
+    , userNotificationSettings = def
+    , userCreated = now
+    , userLastLdapSynchronisation = Nothing
+    , userLdapPrimaryKey = Nothing
+    , userCsvOptions = def
+    , userSex = Just SexMale
+    , userShowSex = userDefaultShowSex
+    }
 
   let
     firstNames = [ "James", "John", "Robert", "Michael"
@@ -386,8 +416,8 @@ fillDb = do
   void . insert' $ UserFunction jost ifi SchoolLecturer
   void . insert' $ UserFunction svaupel ifi SchoolLecturer
   void . insert' $ UserFunction gkleen ifi SchoolAllocation
-  void . insert' $ UserFunction gkleen ifi SchoolExamOffice
+  void . insert' $ UserFunction sbarth ifi SchoolLecturer
-  void . insert' $ UserFunction gkleen mi SchoolExamOffice
+  void . insert' $ UserFunction sbarth ifi SchoolExamOffice
   for_ [gkleen, fhamann, jost, maxMuster, svaupel] $ \uid ->
     void . insert' $ UserSchool uid ifi False
   for_ [gkleen, tinaTester] $ \uid ->
@@ -1202,9 +1232,11 @@ fillDb = do
     , allocationOverrideDeregister = Just $ termTime True Summer 1 False Monday toMidnight
     , allocationMatchingSeed = aSeedBig
     }
-  bigAllocCourses <- forM ([1..40] :: [Int]) $ \n -> do
+  bigAllocShorthands <-
-    csh <- ("ZA-" <>) . pack . take 3 <$> getRandomRs ('A', 'Z')
+    let go xs = let (csh, xs') = List.splitAt 3 xs
-
+                 in pack csh : go xs'
+     in take 40 . nub . go <$> getRandomRs ('A', 'Z')
+  bigAllocCourses <- forM (zip [1..] bigAllocShorthands) $ \(n :: Natural, csh) -> do
     cap <- getRandomR (10,50)
 
     minCap <- round . (* fromIntegral cap) <$> getRandomR (0, 0.5 :: Double)
@@ -1234,7 +1266,7 @@ fillDb = do
       , courseDeregisterNoShow = False
       }
     insert_ $ CourseEdit gkleen now cid
-    insert_ . AllocationCourse bigAlloc cid minCap $ Just substitutesUntil
+    void . insert' . AllocationCourse bigAlloc cid minCap $ Just substitutesUntil
     -- void . insert' $ Lecturer gkleen cid CourseLecturer
     return cid