From fd276879ad3e96cf5482fa07d04c6a32f143b1df Mon Sep 17 00:00:00 2001 From: Sarah Vaupel <> Date: Fri, 6 Nov 2020 15:55:06 +0100 Subject: [PATCH] feat(tutorials): first stub of schedule-opt buttons --- messages/uniworx/de-de-formal.msg | 6 +++++- messages/uniworx/en-eu.msg | 6 +++++- routes | 2 ++ src/Foundation/Navigation.hs | 6 ++++-- src/Handler/Course/Show.hs | 27 ++++++++++++++++++++++++++- src/Handler/Tutorial.hs | 1 + src/Handler/Tutorial/Schedule.hs | 16 ++++++++++++++++ src/Handler/Utils/Form.hs | 12 ++++++++++++ templates/course.hamlet | 2 ++ 9 files changed, 73 insertions(+), 5 deletions(-) create mode 100644 src/Handler/Tutorial/Schedule.hs diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index 5943d7e06..00197e05d 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -41,6 +41,10 @@ BtnSystemMessageUnhide: Nicht mehr verstecken BtnCommunicationSend: Senden BtnCommunicationTest: Test-Nachricht verschicken +BtnScheduleOptIn: Abonnieren +BtnScheduleOptOut: Deabonnieren +BtnScheduleOptDel: Standard-Abonnement + Aborted: Abgebrochen Remarks: Hinweise @@ -1494,7 +1498,7 @@ BreadcrumbSubmission: Abgabe BreadcrumbCourseNews: Kursnachricht BreadcrumbCourseNewsDelete: Kursnachricht löschen BreadcrumbCourseEventDelete: Kurstermin löschen -BreadcrumbCourseEventScheduleOpt: Kurstermin (de)abonnieren +BreadcrumbScheduleOpt: Termin (de)abonnieren BreadcrumbProfile: Einstellungen BreadcrumbAllocationInfo: Ablauf einer Zentralanmeldung BreadcrumbCourseParticipantInvitation: Einladung zum Kursteilnehmer diff --git a/messages/uniworx/en-eu.msg b/messages/uniworx/en-eu.msg index fb4d434ee..c32e0fefc 100644 --- a/messages/uniworx/en-eu.msg +++ b/messages/uniworx/en-eu.msg @@ -42,6 +42,10 @@ BtnScheduleViewWeek: Week BtnCommunicationSend: Send BtnCommunicationTest: Send test message +BtnScheduleOptIn: Subscribe +BtnScheduleOptOut: Unsubscribe +BtnScheduleOptDel: Default subscription + Aborted: Aborted Remarks: Remarks @@ -1495,7 +1499,7 @@ BreadcrumbSubmission: Submission BreadcrumbCourseNews: Course news BreadcrumbCourseNewsDelete: Delete course news BreadcrumbCourseEventDelete: Delete course occurrence -BreadcrumbCourseEventScheduleOpt: (Un)subscribe to/from course event +BreadcrumbScheduleOpt: (Un)subscribe to/from event BreadcrumbProfile: Settings BreadcrumbAllocationInfo: On central allocations BreadcrumbCourseParticipantInvitation: Invitation to be a course participant diff --git a/routes b/routes index 8bac50418..73998e05b 100644 --- a/routes +++ b/routes @@ -188,6 +188,8 @@ /register TRegisterR POST !timeANDcapacityANDcourse-registeredANDregister-group !timeANDtutorial-registered /communication TCommR GET POST !tutor /tutor-invite TInviteR GET POST !tutorANDtutor-control + /schedule-opt/set/#Bool TScheduleOptSetR GET POST !free + /schedule-opt/del TScheduleOptDelR GET POST !free /exams CExamListR GET !tutor !corrector !exam-corrector !course-registered !course-time !exam-office /exams/new CExamNewR GET POST /exams/#ExamName ExamR: diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 9a8bd4a14..6543fca02 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -207,8 +207,8 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where breadcrumb (CourseR tid ssh csh CEventsNewR) = i18nCrumb MsgMenuCourseEventNew . Just $ CourseR tid ssh csh CShowR breadcrumb (CourseR tid ssh csh (CourseEventR _cID sRoute)) = case sRoute of - CEvScheduleOptSetR _ -> i18nCrumb MsgBreadcrumbCourseEventScheduleOpt . Just $ CourseR tid ssh csh CShowR - CEvScheduleOptDelR -> i18nCrumb MsgBreadcrumbCourseEventScheduleOpt . Just $ CourseR tid ssh csh CShowR + CEvScheduleOptSetR _ -> i18nCrumb MsgBreadcrumbScheduleOpt . Just $ CourseR tid ssh csh CShowR + CEvScheduleOptDelR -> i18nCrumb MsgBreadcrumbScheduleOpt . Just $ CourseR tid ssh csh CShowR CEvEditR -> i18nCrumb MsgMenuCourseEventEdit . Just $ CourseR tid ssh csh CShowR CEvDeleteR -> i18nCrumb MsgBreadcrumbCourseEventDelete . Just $ CourseR tid ssh csh CShowR @@ -250,6 +250,8 @@ instance BearerAuthSite UniWorX => YesodBreadcrumbs UniWorX where TCommR -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR TRegisterR -> i18nCrumb MsgBreadcrumbTutorialRegister . Just $ CourseR tid ssh csh CShowR TInviteR -> i18nCrumb MsgBreadcrumbTutorInvite . Just $ CTutorialR tid ssh csh tutn TUsersR + (TScheduleOptSetR _) -> i18nCrumb MsgBreadcrumbScheduleOpt . Just $ CourseR tid ssh csh CTutorialListR + TScheduleOptDelR -> i18nCrumb MsgBreadcrumbScheduleOpt . Just $ CourseR tid ssh csh CTutorialListR breadcrumb (CourseR tid ssh csh (SheetR shn sRoute)) = case sRoute of SShowR -> maybeT (i18nCrumb MsgBreadcrumbSheet . Just $ CourseR tid ssh csh SheetListR) $ do diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs index ef0ab40ca..e2ad85f9a 100644 --- a/src/Handler/Course/Show.hs +++ b/src/Handler/Course/Show.hs @@ -178,7 +178,7 @@ getCShowR tid ssh csh = do isRegistered <- case mbAuth of Nothing -> return False Just (uid,_) -> existsBy $ UniqueTutorialParticipant tutId uid - if + tutRegister <- if | mayRegister -> do (tutRegisterForm, tutRegisterEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnRegister] [BtnDeregister] isRegistered return $ wrapForm tutRegisterForm def @@ -188,6 +188,31 @@ getCShowR tid ssh csh = do } | isRegistered -> return [whamlet|_{MsgTutorialRegistered}|] | otherwise -> return mempty + tutScheduleOptSet <- if + | Just (uid,User{..}) <- mbAuth -> do + mScheduleOpt <- getBy $ UniqueTutorialScheduleOpt tutId uid + let currentOpt = maybe userScheduleOccurrenceDisplayDefault tutorialScheduleOptOpt $ entityVal <$> mScheduleOpt + (tutScheduleForm, tutScheduleEnctype) <- liftHandler . generateFormPost . buttonForm' $ bool [BtnScheduleOptIn] [BtnScheduleOptOut] currentOpt + return $ wrapForm tutScheduleForm def + { formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName (TScheduleOptSetR $ not currentOpt) + , formEncoding = tutScheduleEnctype + , formSubmit = FormNoSubmit + } + | otherwise -> return mempty + tutScheduleOptDel <- if + | Just (uid,_) <- mbAuth -> do + mScheduleOpt <- getBy $ UniqueTutorialScheduleOpt tutId uid + if is _Just mScheduleOpt + then do + (tutScheduleOptDelForm, tutScheduleOptDelEnctype) <- liftHandler . generateFormPost . buttonForm' $ [BtnScheduleOptDel] + return $ wrapForm tutScheduleOptDelForm def + { formAction = Just . SomeRoute $ CTutorialR tid ssh csh tutorialName TScheduleOptDelR + , formEncoding = tutScheduleOptDelEnctype + , formSubmit = FormNoSubmit + } + else return mempty + | otherwise -> return mempty + return $ tutRegister <> tutScheduleOptSet <> tutScheduleOptDel ] dbtSorting = Map.fromList [ ("type", SortColumn $ \tutorial -> tutorial E.^. TutorialType ) diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 04fc02220..19a819fb5 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -9,5 +9,6 @@ import Handler.Tutorial.Form as Handler.Tutorial import Handler.Tutorial.List as Handler.Tutorial import Handler.Tutorial.New as Handler.Tutorial import Handler.Tutorial.Register as Handler.Tutorial +import Handler.Tutorial.Schedule as Handler.Tutorial import Handler.Tutorial.TutorInvite as Handler.Tutorial import Handler.Tutorial.Users as Handler.Tutorial diff --git a/src/Handler/Tutorial/Schedule.hs b/src/Handler/Tutorial/Schedule.hs new file mode 100644 index 000000000..4c84b6b4e --- /dev/null +++ b/src/Handler/Tutorial/Schedule.hs @@ -0,0 +1,16 @@ +module Handler.Tutorial.Schedule + ( getTScheduleOptSetR, postTScheduleOptSetR + , getTScheduleOptDelR, postTScheduleOptDelR + ) where + +import Import + + +getTScheduleOptSetR, postTScheduleOptSetR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Bool -> Handler Html +getTScheduleOptSetR = postTScheduleOptSetR +postTScheduleOptSetR _tid _ssh _csh _tutn _opt = error "WIP" + + +getTScheduleOptDelR, postTScheduleOptDelR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html +getTScheduleOptDelR = postTScheduleOptDelR +postTScheduleOptDelR _tid _ssh _csh _tutn = error "WIP" diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 2c3ee4dcd..498437c58 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -153,6 +153,18 @@ instance Button UniWorX ButtonSubmitDelete where nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'" +data ButtonScheduleOpt = BtnScheduleOptIn | BtnScheduleOptOut | BtnScheduleOptDel + deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) +instance Universe ButtonScheduleOpt +instance Finite ButtonScheduleOpt + +nullaryPathPiece ''ButtonScheduleOpt $ camelToPathPiece' 1 + +embedRenderMessage ''UniWorX ''ButtonScheduleOpt id +instance Button UniWorX ButtonScheduleOpt where + btnClasses = const [BCIsButton, BCPrimary] + + -- -- Looks like a button, but is just a link (e.g. for create course, etc.) -- data LinkButton = LinkButton (Route UniWorX) -- deriving (Enum, Eq, Ord, Bounded, Read, Show) diff --git a/templates/course.hamlet b/templates/course.hamlet index 5fc9403b3..492983963 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -260,6 +260,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course) _{MsgCourseEventRoom} _{MsgCourseEventNote} + $# TODO: merge with actions column $if is _Just mbAuth _{MsgScheduleOptActions} @@ -282,6 +283,7 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
#{courseEventNote} + $# TODO: merge with actions column $maybe (_, User{userScheduleOccurrenceDisplayDefault}) <- mbAuth