diff --git a/src/Foundation.hs b/src/Foundation.hs index 47f7640f3..fe61d882a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -463,12 +463,22 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of return Authorized - CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do - Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh + CourseR tid ssh csh CRegisterR -> do + mbc <- getBy $ TermSchoolCourseShort tid ssh csh + mAid <- lift maybeAuthId + registered <- case (mbc,mAid) of + (Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid) + _ -> return False cTime <- (NTop . Just) <$> liftIO getCurrentTime - guard $ NTop courseRegisterFrom <= cTime - && NTop courseRegisterTo >= cTime - return Authorized + case mbc of + (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo})) + | not registered + , courseRegisterFrom <= nBot cTime + , NTop courseRegisterTo >= cTime -> return Authorized + (Just (Entity _ Course{courseDeregisterUntil})) + | registered + , NTop courseDeregisterUntil >= cTime -> return Authorized + _other -> unauthorizedI MsgUnauthorizedCourseTime MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do smId <- decrypt cID diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 7af4ae48f..203859d1b 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -278,8 +278,9 @@ getCShowR tid ssh csh = do E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid return $ user E.^. UserDisplayName return (course,schoolName,participants,registered,map E.unValue lecturers) - mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course - mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course + mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course + mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course + mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course mRegAt <- traverse (formatTime SelFormatDateTime) $ registered (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True diff --git a/src/Utils.hs b/src/Utils.hs index bc7d4fa4d..2990778dc 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -364,7 +364,7 @@ mcons :: Maybe a -> [a] -> [a] mcons Nothing xs = xs mcons (Just x) xs = x:xs -newtype NTop a = NTop a -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom +newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom instance Eq a => Eq (NTop (Maybe a)) where (NTop x) == (NTop y) = x == y diff --git a/templates/course.hamlet b/templates/course.hamlet index 6968b4b97..130fe7f0a 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -39,6 +39,10 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) Ab #{regFrom} $maybe regTo <- mRegTo \ bis #{regTo} + $maybe dereg <- mDereg +
+ \ Achtung: + \ Abmeldung nur bis #{dereg} erlaubt. $if registrationOpen || isJust mRegAt