diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7ecb99df0..f2e5c81b6 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/routes b/routes index 448988d8a..a84d2842e 100644 --- a/routes +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index ea504444d..d2243550c 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 186bced96..e368419c4 100644 --- a/src/Model/Types.hs +++ b/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