From 933eaa73625c96dd844b4fc6925b767b591d7f3d Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 28 Feb 2019 17:17:34 +0100 Subject: [PATCH] Registration takes Field of Studies now --- messages/uniworx/de.msg | 3 +- src/Handler/Course.hs | 62 ++++++++++++++++++++++++--------------- src/Handler/Utils/Form.hs | 24 +++++++++------ test/Database.hs | 4 +-- 4 files changed, 58 insertions(+), 35 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index eeadac9d9..713524bf1 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -53,7 +53,8 @@ CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei. CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet. CourseRegisterOk: Sie wurden angemeldet CourseDeregisterOk: Sie wurden abgemeldet -CourseStudyFeature: Relevantes Hauptfach +CourseStudyFeature: Asoziiertes Hauptfach +CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen CourseSecretWrong: Falsches Kennwort CourseSecret: Zugangspasswort CourseNewOk tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt. diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 60febf6f0..b4a0c0526 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -290,48 +290,64 @@ getCShowR tid ssh csh = do mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration - (regWidget, regEnctype) <- generateFormPost $ identForm FIDcourseRegister $ registerForm (isJust mRegAt) $ courseRegisterSecret course + (regWidget, regEnctype) <- generateFormPost $ registerForm mbAid registration $ courseRegisterSecret course registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True siteLayout (toWgt $ courseName course) $ do setTitle [shamlet| #{toPathPiece tid} - #{csh}|] $(widgetFile "course") - -registerForm :: Bool -> Maybe Text -> Form Bool +-- | Registration button with primary study features if logged in +-- , existing features if already registered +-- , and possibly a course secret +registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool) -- unfinished WIP: must take study features if registred and show as mforced field -registerForm registered msecret extra = do - (msecretRes', msecretView) <- case msecret of - (Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing - _ -> return (Nothing,Nothing) - (_msfRes, msfView) <- if not registered then return (Nothing, Nothing) else - bimap Just Just <$> mopt (studyFeaturesPrimaryFieldFor (error "TODO SJ REMOVE")) (fslI MsgCourseStudyFeature) Nothing - (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing +registerForm loggedin participant msecret = identForm FIDcourseRegister $ \extra -> do + -- secret fields + (msecretRes', msecretView) <- case msecret of + (Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing + _ -> return (Nothing,Nothing) + -- study features + (msfRes', msfView) <- case loggedin of + Nothing -> return (Nothing,Nothing) + Just _ -> bimap Just Just <$> case participant of + Just CourseParticipant{courseParticipantField=Just sfid} + -> mopt (studyFeaturesPrimaryFieldFor [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just $ Just sfid) + _other -> mopt (studyFeaturesPrimaryFieldFor [ ] loggedin) (fslI MsgCourseStudyFeature + & setTooltip MsgCourseStudyFeatureTooltip) Nothing + -- button de-/register + (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing - let widget = $(widgetFile "widgets/register-form/register-form") - let msecretRes | Just res <- msecretRes' = Just <$> res - | otherwise = FormSuccess Nothing - return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes + let widget = $(widgetFile "widgets/register-form/register-form") + let msecretRes | Just res <- msecretRes' = Just <$> res + | otherwise = FormSuccess Nothing + let msfRes | Just res <- msfRes' = res + | otherwise = FormSuccess Nothing + -- checks that correct button was pressed, and ignores result of btnRes + let formRes = (,) <$ btnRes <*> msfRes <*> ((==msecret) <$> msecretRes) + return (formRes, widget) + where + isRegistered = isJust participant postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html postCRegisterR tid ssh csh = do aid <- requireAuthId - (cid, course, registered) <- runDB $ do + (cid, course, registration) <- runDB $ do (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh - registered <- isJust <$> getBy (UniqueParticipant aid cid) - return (cid, course, registered) - ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course - case regResult of - (FormSuccess codeOk) - | registered -> do + registration <- getBy (UniqueParticipant aid cid) + return (cid, course, entityVal <$> registration) + let isRegistered = isJust registration + ((regResult,_), _) <- runFormPost $ registerForm (Just aid) registration $ courseRegisterSecret course + formResult regResult $ \(mbSfId,codeOk) -> if + | isRegistered -> do runDB $ deleteBy $ UniqueParticipant aid cid addMessageI Info MsgCourseDeregisterOk | codeOk -> do actTime <- liftIO getCurrentTime - regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime Nothing -- TODO + regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk | otherwise -> addMessageI Warning MsgCourseSecretWrong - _other -> return () -- TODO check this! + -- addMessage Info $ toHtml $ show regResult -- For debugging only redirect $ CourseR tid ssh csh CShowR diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 83c29a8c1..3951be40a 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -214,19 +214,25 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName schoolFieldFor :: [SchoolId] -> Field Handler SchoolId schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName --- | Select one of the user's primary courses -studyFeaturesPrimaryFieldFor :: UserId -> Field Handler StudyFeaturesId -studyFeaturesPrimaryFieldFor uid = selectField $ do - -- we wanted to use optionsPersistCryptoId, but we need a join here +-- | Select one of the user's primary active courses, or from a given list of StudyFeatures (regardless of user) +studyFeaturesPrimaryFieldFor :: [StudyFeaturesId] -> Maybe UserId -> Field Handler StudyFeaturesId +studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do + -- we need a join, so we cannot just use optionsPersistCryptoId rawOptions <- runDB $ E.select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` field) -> do - E.on $ feature E.^. StudyFeaturesField E.==. field E.^. StudyTermsId - E.on $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId - E.where_ $ feature E.^. StudyFeaturesUser E.==. E.val uid - E.where_ $ feature E.^. StudyFeaturesValid E.==. E.val True - E.where_ $ feature E.^. StudyFeaturesType E.==. E.val FieldPrimary + E.on $ feature E.^. StudyFeaturesField E.==. field E.^. StudyTermsId + E.on $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId + E.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures) + E.||. isPrimaryActiveUserStudyFeature feature return (feature E.^. StudyFeaturesId, degree, field) mkOptionList <$> mapM procOptions rawOptions where + isPrimaryActiveUserStudyFeature feature = case mbuid of + Nothing -> E.val False + (Just uid) -> feature E.^. StudyFeaturesUser E.==. E.val uid + E.&&. feature E.^. StudyFeaturesValid E.==. E.val True + E.&&. feature E.^. StudyFeaturesType E.==. E.val FieldPrimary + + procOptions :: (E.Value StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option StudyFeaturesId) procOptions (E.Value sfid, Entity dgid StudyDegree{..}, Entity stid StudyTerms{..}) = do let dgname = fromMaybe (tshow dgid) (studyDegreeShorthand <|> studyDegreeName) stname = fromMaybe (tshow stid) (studyTermsShorthand <|> studyTermsName ) diff --git a/test/Database.hs b/test/Database.hs index 1d2b903ba..aa6d5a0f0 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -448,8 +448,8 @@ fillDb = do , courseRegisterFrom = Nothing , courseRegisterTo = Nothing , courseDeregisterUntil = Nothing - , courseRegisterSecret = Nothing - , courseMaterialFree = True + , courseRegisterSecret = Just "dbs" + , courseMaterialFree = False } insert_ $ CourseEdit gkleen now dbs void . insert' $ DegreeCourse dbs sdBsc sdInf