Fixes #267 and related bugs

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

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

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

templates/course.hamlet

@@ -39,6 +39,10 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
           Ab #{regFrom}
           $maybe regTo <- mRegTo
             \ bis #{regTo}
+        $maybe dereg <- mDereg
+          <div>
+            \ <em>Achtung:</em>
+            \ Abmeldung nur bis #{dereg} erlaubt.
     $if registrationOpen || isJust mRegAt
       <dt .deflist__dt>
       <dd .deflist__dd>