AuthTag Empty implemented.

messages/uniworx/de.msg

@@ -38,6 +38,7 @@ CourseShort: Kürzel
 CourseCapacity: Kapazität
 CourseCapacityTip: Falls angegeben wird die Anzahl an Kursanmeldungen, die zugelassen werden, beschränkt
 CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
+CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
 CourseRegisterOk: Sie wurden angemeldet
 CourseDeregisterOk: Sie wurden abgemeldet
 CourseSecretWrong: Falsches Kennwort
@@ -543,6 +544,7 @@ AuthTagCorrector: Nutzer ist Korrektor
 AuthTagTime: Zeitliche Einschränkungen sind erfüllt
 AuthTagRegistered: Nutzer ist Kursteilnehmer
 AuthTagCapacity: Kapazität ist ausreichend
+AuthTagEmpty: Kurs hat keine Teilnehmer
 AuthTagMaterials: Kursmaterialien sind freigegeben
 AuthTagOwner: Nutzer ist Besitzer
 AuthTagRated: Korrektur ist bewertet

routes

@@ -16,6 +16,7 @@
 --    !registered  -- participant for this course (no effect outside of courses)
 --    !owner       -- part of the group of owners of this submission
 --    !capacity    -- course this route is associated with has at least one unit of participant capacity
+--    !empty       -- course this route is associated with has no participants whatsoever
 --
 --    !materials   -- only if course allows all materials to be free (no meaning outside of courses)
 --    !time        -- access depends on time somehow

src/Foundation.hs

@@ -481,6 +481,14 @@ tagAccessPredicate AuthCapacity = APDB $ \route _ -> case route of
     guard $ NTop courseCapacity > NTop (Just registered)
     return Authorized
   r -> $unsupportedAuthPredicate "capacity" r
+tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
+  CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
+    -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+    cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
+    registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ]
+    guard $ registered <= 0
+    return Authorized
+  r -> $unsupportedAuthPredicate "empty" r
 tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of
   CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
     Entity _ Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
@@ -521,7 +529,7 @@ tagAccessPredicate AuthAuthentication = APDB $ \route _ -> case route of
     SystemMessage{..} <- MaybeT $ get smId
     isAuthenticated <- isJust <$> liftHandlerT maybeAuthId
     guard $ not systemMessageAuthenticatedOnly || isAuthenticated
-    return Authorized      
+    return Authorized
   r -> $unsupportedAuthPredicate "authentication" r
 tagAccessPredicate AuthRead = APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite)
 tagAccessPredicate AuthWrite = APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized)
@@ -565,7 +573,7 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toN
       mr <- lift getMsgRenderer
       let
         authTagIsInactive = not . authTagIsActive
-        
+
         evalAuthTag :: AuthTag -> MemoT AuthTag AuthResult (WriterT (Set AuthTag) m) AuthResult
         evalAuthTag = memo $ \authTag -> lift . lift $ evalAccessPred (tagAccessPredicate authTag) route isWrite
 
@@ -577,16 +585,16 @@ evalAuthTags AuthTagActive{..} (map (Set.toList . toNullable) . Set.toList . toN
         evalDNF = foldr (\ats ar -> ar `orAR'` foldr (\aTag ar' -> ar' `andAR'` evalAuthTag aTag) (return $ trueAR mr) ats) (return $ falseAR mr)
 
       lift . $logDebugS "evalAuthTags" . tshow . (route, isWrite, )$ map (map $ id &&& authTagIsActive) authDNF
-      
+
       result <- evalDNF $ filter (all authTagIsActive) authDNF
 
-      unless (is _Authorized result) . forM_ (filter (any authTagIsInactive) authDNF) $ \conj -> 
+      unless (is _Authorized result) . forM_ (filter (any authTagIsInactive) authDNF) $ \conj ->
         whenM (allM conj (\aTag -> (return . not $ authTagIsActive aTag) `or2M` (not . is _Unauthorized <$> evalAuthTag aTag))) $ do
           let pivots = filter authTagIsInactive conj
           whenM (allM pivots $ fmap (is _Authorized) . evalAuthTag) $ do
             lift $ $logDebugS "evalAuthTags" [st|Recording pivots: #{tshow pivots}|]
             lift . tell $ Set.fromList pivots
-  
+
       return result
 
 evalAccess :: (MonadLogger m, MonadHandler m, HandlerSite m ~ UniWorX) => Route UniWorX -> Bool -> m AuthResult

src/Model/Types.hs

@@ -121,10 +121,10 @@ data SheetGrading
   | PassBinary -- non-zero means passed
   deriving (Eq, Read, Show)
 
-deriveJSON defaultOptions 
+deriveJSON defaultOptions
   { constructorTagModifier = intercalate "-" . map toLower . splitCamel
   , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  , sumEncoding = TaggedObject "type" "data"  
+  , sumEncoding = TaggedObject "type" "data"
   } ''SheetGrading
 derivePersistFieldJSON ''SheetGrading
 
@@ -133,7 +133,7 @@ gradingPassed (Points {}) _ = Nothing
 gradingPassed (PassPoints {..}) pts = Just $ pts >= passingPoints
 gradingPassed (PassBinary {}) pts = Just $ pts /= 0
 
-data SheetGradeSummary = SheetGradeSummary 
+data SheetGradeSummary = SheetGradeSummary
   { sumGradePoints :: Sum Points
   , numGradePasses :: Sum Int
   , achievedPoints :: Maybe (Sum Points)
@@ -144,31 +144,31 @@ instance Monoid SheetGradeSummary where
   mempty  = memptydefault
   mappend = mappenddefault
 
-instance Semigroup SheetGradeSummary where 
+instance Semigroup SheetGradeSummary where
   (<>) = mappend -- remove for GHC > 8.4.x
 
-sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary                                              
-sheetGradeSum gr (Just p) = 
-  let baseSum = (sheetGradeSum gr Nothing) { achievedPasses = Sum . bool 0 1 <$> gradingPassed gr p } 
+sheetGradeSum :: SheetGrading -> Maybe Points -> SheetGradeSummary
+sheetGradeSum gr (Just p) =
+  let baseSum = (sheetGradeSum gr Nothing) { achievedPasses = Sum . bool 0 1 <$> gradingPassed gr p }
   in case gr of PassBinary -> baseSum
                 _other     -> baseSum { achievedPoints = Just $ Sum $ p }
 sheetGradeSum (Points {..})    Nothing = mempty { sumGradePoints = Sum maxPoints }
-sheetGradeSum (PassPoints{..}) Nothing = mempty { sumGradePoints = Sum maxPoints 
-                                                , numGradePasses = Sum 1 }   
-sheetGradeSum (PassBinary)     Nothing = mempty { numGradePasses = Sum 1 }   
-                                                                  
+sheetGradeSum (PassPoints{..}) Nothing = mempty { sumGradePoints = Sum maxPoints
+                                                , numGradePasses = Sum 1 }
+sheetGradeSum (PassBinary)     Nothing = mempty { numGradePasses = Sum 1 }
 
-data SheetType 
+
+data SheetType
   = Normal        { grading :: SheetGrading }
   | Bonus         { grading :: SheetGrading }
   | Informational { grading :: SheetGrading }
   | NotGraded
-  deriving (Eq, Read, Show) 
+  deriving (Eq, Read, Show)
 
 deriveJSON defaultOptions
   { constructorTagModifier = intercalate "-" . map toLower . splitCamel
   , fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-  , sumEncoding = TaggedObject "type" "data"  
+  , sumEncoding = TaggedObject "type" "data"
   } ''SheetType
 derivePersistFieldJSON ''SheetType
 
@@ -182,9 +182,9 @@ instance Monoid SheetTypeSummary where
   mappend = mappenddefault
 
 sheetTypeSum :: SheetType -> Maybe Points -> SheetTypeSummary
-sheetTypeSum Bonus{..}         mps = mempty { bonusSummary         = sheetGradeSum grading mps } 
-sheetTypeSum Normal{..}        mps = mempty { normalSummary        = sheetGradeSum grading mps } 
-sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps } 
+sheetTypeSum Bonus{..}         mps = mempty { bonusSummary         = sheetGradeSum grading mps }
+sheetTypeSum Normal{..}        mps = mempty { normalSummary        = sheetGradeSum grading mps }
+sheetTypeSum Informational{..} mps = mempty { informationalSummary = sheetGradeSum grading mps }
 sheetTypeSum NotGraded _           = mempty { numNotGraded = Sum 1 }
 
 data SheetGroup
@@ -680,6 +680,7 @@ data AuthTag
   | AuthTime
   | AuthRegistered
   | AuthCapacity
+  | AuthEmpty
   | AuthMaterials
   | AuthOwner
   | AuthRated