From e446641666507041ac9a3f50413b1ab28d767cbe Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 28 Feb 2019 18:04:22 +0100 Subject: [PATCH] Default offered; unnecessarily complicated due using field studyFeature --- src/Handler/Course.hs | 27 ++++++++++--------- src/Handler/Utils/Form.hs | 18 ++++++++++--- .../register-form/register-form.hamlet | 3 +++ 3 files changed, 31 insertions(+), 17 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index b4a0c0526..70e38ae21 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -264,7 +264,7 @@ getTermCourseListR tid = do getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (course,schoolName,participants,registration,lecturers) <- runDB . maybeT notFound $ do + (course,schoolName,participants,registration,defSFid,lecturers) <- runDB . maybeT notFound $ do [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)] <- lift . E.select . E.from $ \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do @@ -278,30 +278,31 @@ getCShowR tid ssh csh = do E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId return ( E.countRows :: E.SqlExpr (E.Value Int64)) return (course,school E.^. SchoolName, numParticipants, participant) - + defSFid <- ifMaybeM mbAid Nothing $ \uid -> lift $ selectFirst [StudyFeaturesUser ==. uid, StudyFeaturesType ==. FieldPrimary, StudyFeaturesValid ==. True] [Desc StudyFeaturesUpdated, Desc StudyFeaturesDegree, Desc StudyFeaturesField] -- sorting by degree & field is an heuristic only, but this is okay for a default suggestion lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] return (user E.^. UserDisplayName, user E.^. UserSurname, user E.^. UserEmail) - return (course,schoolName,participants,registration,lecturers) + return (course,schoolName,participants,registration,entityKey <$> defSFid,lecturers) mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration - (regWidget, regEnctype) <- generateFormPost $ registerForm mbAid registration $ courseRegisterSecret course + (regWidget, regEnctype) <- generateFormPost $ registerForm mbAid registration defSFid $ courseRegisterSecret course registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True siteLayout (toWgt $ courseName course) $ do setTitle [shamlet| #{toPathPiece tid} - #{csh}|] $(widgetFile "course") --- | 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) +-- | Registration button with maybe a userid if logged in +-- , maybe existing features if already registered +-- , maybe some default study features +-- , maybe a course secret +registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe StudyFeaturesId -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool) -- unfinished WIP: must take study features if registred and show as mforced field -registerForm loggedin participant msecret = identForm FIDcourseRegister $ \extra -> do +registerForm loggedin participant defSFid msecret = identForm FIDcourseRegister $ \extra -> do -- secret fields (msecretRes', msecretView) <- case msecret of (Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing @@ -311,9 +312,9 @@ registerForm loggedin participant msecret = identForm FIDcourseRegister $ \extra 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 + -> mforced (studyFeaturesPrimaryFieldFor [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid) + _other -> mreq (studyFeaturesPrimaryFieldFor [ ] loggedin) (fslI MsgCourseStudyFeature + & setTooltip MsgCourseStudyFeatureTooltip) (Just defSFid) -- button de-/register (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing @@ -337,7 +338,7 @@ postCRegisterR tid ssh csh = do registration <- getBy (UniqueParticipant aid cid) return (cid, course, entityVal <$> registration) let isRegistered = isJust registration - ((regResult,_), _) <- runFormPost $ registerForm (Just aid) registration $ courseRegisterSecret course + ((regResult,_), _) <- runFormPost $ registerForm (Just aid) registration Nothing $ courseRegisterSecret course formResult regResult $ \(mbSfId,codeOk) -> if | isRegistered -> do runDB $ deleteBy $ UniqueParticipant aid cid diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 3951be40a..708b2bb40 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -215,7 +215,7 @@ schoolFieldFor :: [SchoolId] -> Field Handler SchoolId schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName -- | 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 :: [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe 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 @@ -224,7 +224,7 @@ studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do E.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures) E.||. isPrimaryActiveUserStudyFeature feature return (feature E.^. StudyFeaturesId, degree, field) - mkOptionList <$> mapM procOptions rawOptions + mkOptionList . nonEmptyOptions <$> mapM procOptions rawOptions where isPrimaryActiveUserStudyFeature feature = case mbuid of Nothing -> E.val False @@ -232,17 +232,27 @@ studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do 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 StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe 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 ) cfid <- encrypt sfid return Option { optionDisplay = stname <> " (" <> dgname <> ")" - , optionInternalValue = sfid + , optionInternalValue = Just sfid , optionExternalValue = toPathPiece (cfid :: CryptoID UUID StudyFeaturesId) } + nonEmptyOptions :: [Option (Maybe StudyFeaturesId)] -> [Option (Maybe StudyFeaturesId)] + nonEmptyOptions opts + | null opts = [ Option + { optionDisplay = "-----" + , optionInternalValue = Nothing + , optionExternalValue = "-----" + } ] + | otherwise = opts + + uploadModeField :: Field Handler UploadMode uploadModeField = selectField optionsFinite diff --git a/templates/widgets/register-form/register-form.hamlet b/templates/widgets/register-form/register-form.hamlet index 769c98c3b..c9a9fa1a3 100644 --- a/templates/widgets/register-form/register-form.hamlet +++ b/templates/widgets/register-form/register-form.hamlet @@ -2,9 +2,12 @@ $# extra protects us against CSRF #{extra} $# Maybe display textField for passcode $maybe secretView <- msecretView + ^{fvLabel secretView} ^{fvInput secretView} $# Ask for associated primary field uf study, unless registered $maybe sfView <- msfView + ^{fvLabel sfView} ^{fvInput sfView} + $# Always display register/deregister button ^{fvInput btnView}