fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Tighten check for empty course

Browse Source
This commit is contained in:
Gregor Kleen 2018-12-19 18:28:53 +01:00
parent 842d7d85e3
commit 45182e5074
2 changed files with 8 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/Foundation.hs
View File

@ -491,8 +491,11 @@ tagAccessPredicate AuthEmpty = APDB $ \route _ -> case route of
CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do CourseR tid ssh csh _ -> maybeT (unauthorizedI MsgCourseNotEmpty) $ do
-- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh -- Entity cid Course{..} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
registered <- lift $ fromIntegral <$> count [ CourseParticipantCourse ==. cid ] assertM_ (<= 0) . lift $ count [ CourseParticipantCourse ==. cid ]
guard $ registered <= 0 assertM_ ((<= 0) :: Int -> Bool) . lift . fmap (E.unValue . unsafeHead) $ E.select . E.from $ \(sheet `E.InnerJoin` submission) -> do
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return E.countRows
return Authorized return Authorized
r -> $unsupportedAuthPredicate AuthEmpty r r -> $unsupportedAuthPredicate AuthEmpty r
tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of tagAccessPredicate AuthMaterials = APDB $ \route _ -> case route of

3
src/Utils.hs
View File

@ -448,6 +448,9 @@ guardM f = guard =<< f
assertM :: MonadPlus m => (a -> Bool) -> m a -> m a assertM :: MonadPlus m => (a -> Bool) -> m a -> m a
assertM f x = x >>= assertM' f assertM f x = x >>= assertM' f
assertM_ :: MonadPlus m => (a -> Bool) -> m a -> m ()
assertM_ f x = guard . f =<< x
assertM' :: MonadPlus m => (a -> Bool) -> a -> m a assertM' :: MonadPlus m => (a -> Bool) -> a -> m a
assertM' f x = x <$ guard (f x) assertM' f x = x <$ guard (f x)