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

Fixes #267 and related bugs

Browse Source
This commit is contained in:
SJost 2019-01-30 16:00:18 +01:00
parent 39da549461
commit 13b5671480
4 changed files with 23 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
src/Foundation.hs
View File

@ -463,12 +463,22 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
return Authorized return Authorized
CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do CourseR tid ssh csh CRegisterR -> do
Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh 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 cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop courseRegisterFrom <= cTime case mbc of
&& NTop courseRegisterTo >= cTime (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo}))
return Authorized | 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 MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
smId <- decrypt cID smId <- decrypt cID

5
src/Handler/Course.hs
View File

@ -278,8 +278,9 @@ getCShowR tid ssh csh = do
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
return $ user E.^. UserDisplayName return $ user E.^. UserDisplayName
return (course,schoolName,participants,registered,map E.unValue lecturers) return (course,schoolName,participants,registered,map E.unValue lecturers)
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
mRegAt <- traverse (formatTime SelFormatDateTime) $ registered mRegAt <- traverse (formatTime SelFormatDateTime) $ registered
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True

2
src/Utils.hs
View File

@ -364,7 +364,7 @@ mcons :: Maybe a -> [a] -> [a]
mcons Nothing xs = xs mcons Nothing xs = xs
mcons (Just x) xs = x: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 instance Eq a => Eq (NTop (Maybe a)) where
(NTop x) == (NTop y) = x == y (NTop x) == (NTop y) = x == y

4
templates/course.hamlet
View File

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