From 6a53a89faa142f0112b88cfca6963b4057387fb0 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 27 Feb 2019 17:36:39 +0100 Subject: [PATCH 1/2] does not compile, course register from broken --- messages/uniworx/de.msg | 1 + src/CryptoID.hs | 1 + src/Handler/Course.hs | 19 ++++++++++----- src/Handler/Utils/Form.hs | 23 +++++++++++++++++++ src/Handler/Utils/StudyFeatures.hs | 4 ++-- src/Utils/Form.hs | 1 + .../register-form/register-form.hamlet | 1 + 7 files changed, 42 insertions(+), 8 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 0f0344878..cd1425452 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -53,6 +53,7 @@ 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 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/CryptoID.hs b/src/CryptoID.hs index 58fa1a09a..899047c3b 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -36,6 +36,7 @@ decCryptoIDs [ ''SubmissionId , ''SheetId , ''SystemMessageId , ''SystemMessageTranslationId + , ''StudyFeaturesId ] instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index e635731b3..0ac01c4e9 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -5,6 +5,7 @@ module Handler.Course where import Import import Utils.Lens +import Utils.Form -- import Utils.DB import Handler.Utils import Handler.Utils.Table.Cells @@ -263,8 +264,8 @@ getTermCourseListR tid = do getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR tid ssh csh = do mbAid <- maybeAuthId - (course,schoolName,participants,registered,lecturers) <- runDB . maybeT notFound $ do - [(E.Entity cid course, E.Value schoolName, E.Value participants, E.Value registered)] + (course,schoolName,participants,registration,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 E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse @@ -276,17 +277,19 @@ getCShowR tid ssh csh = do let numParticipants = E.sub_select . E.from $ \part -> 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 E.?. CourseParticipantRegistration) + return (course,school E.^. SchoolName, numParticipants, participant) + 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 return $ user E.^. UserDisplayName - return (course,schoolName,participants,registered,map E.unValue lecturers) + + return (course,schoolName,participants,registration,map E.unValue lecturers) 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 + mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration + (regWidget, regEnctype) <- generateFormPost $ identForm FIDcourseRegister $ registerForm (isJust mRegAt) $ courseRegisterSecret course registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True siteLayout (toWgt $ courseName course) $ do setTitle [shamlet| #{toPathPiece tid} - #{csh}|] @@ -294,11 +297,15 @@ getCShowR tid ssh csh = do registerForm :: Bool -> Maybe Text -> Form 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) + (sfRes' , sfView) <- if not registered then return (Nothing,Nothing) else + mopt (studyFeaturesPrimaryFieldFor (error "TODO SJ REMOVE")) (fslI MsgCourseStudyFeature) Nothing (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing + let widget = $(widgetFile "widgets/register-form/register-form") let msecretRes | Just res <- msecretRes' = Just <$> res | otherwise = FormSuccess Nothing diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 2a568432e..840c0dbd2 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -214,6 +214,29 @@ 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 + 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 -- TODO SJ REMOVE + E.where_ $ feature E.^. StudyFeaturesType E.==. E.val FieldPrimary + return (feature E.^. StudyFeaturesId, degree, field) + mkOptionList <$> mapM procOptions rawOptions + where + 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 + , optionExternalValue = toPathPiece (cfid :: CryptoID UUID StudyFeaturesId) + } + uploadModeField :: Field Handler UploadMode uploadModeField = selectField optionsFinite diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index 9dbce258a..1de343aa7 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -11,13 +11,14 @@ import Text.Parsec.Text parseStudyFeatures :: UserId -> Text -> Either Text [StudyFeatures] parseStudyFeatures uId = first tshow . parse (pStudyFeatures uId <* eof) "" - + pStudyFeatures :: UserId -> Parser [StudyFeatures] pStudyFeatures studyFeaturesUser = do studyFeaturesDegree <- StudyDegreeKey' <$> pKey void $ string "$$" let + studyFeaturesUpdated = error "undefined" --TODO SJ REMOVE pStudyFeature = do _ <- pKey -- Meaning unknown at this time void $ char '!' @@ -28,7 +29,6 @@ pStudyFeatures studyFeaturesUser = do studyFeaturesType <- pType void $ char '!' studyFeaturesSemester <- decimal - return StudyFeatures{..} pStudyFeature `sepBy1` char '#' diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 8c53501f8..b007b0cb3 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -194,6 +194,7 @@ addAutosubmit = addAttr "data-autosubmit" "" data FormIdentifier = FIDcourse + | FIDcourseRegister | FIDsheet | FIDsubmission | FIDsettings diff --git a/templates/widgets/register-form/register-form.hamlet b/templates/widgets/register-form/register-form.hamlet index a2dd97af9..6bb3388fb 100644 --- a/templates/widgets/register-form/register-form.hamlet +++ b/templates/widgets/register-form/register-form.hamlet @@ -3,5 +3,6 @@ $# extra protects us against CSRF $# Maybe display textField for passcode $maybe secretView <- msecretView ^{fvInput secretView} +$# Ask for associated primary field uf study, unless registered $# Always display register/deregister button ^{fvInput btnView} From 9ca91b5ec882d65b1ad6d3799ba176ac61f90162 Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 27 Feb 2019 17:42:46 +0100 Subject: [PATCH 2/2] removed stubs for merge --- src/Handler/Utils/Form.hs | 2 +- src/Handler/Utils/StudyFeatures.hs | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 840c0dbd2..83c29a8c1 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -222,7 +222,7 @@ studyFeaturesPrimaryFieldFor uid = selectField $ 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 -- TODO SJ REMOVE + E.where_ $ feature E.^. StudyFeaturesValid E.==. E.val True E.where_ $ feature E.^. StudyFeaturesType E.==. E.val FieldPrimary return (feature E.^. StudyFeaturesId, degree, field) mkOptionList <$> mapM procOptions rawOptions diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index d84e79499..d2903309c 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -18,7 +18,6 @@ pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do void $ string "$$" let - studyFeaturesUpdated = error "undefined" --TODO SJ REMOVE pStudyFeature = do _ <- pKey -- Meaning unknown at this time void $ char '!' @@ -33,7 +32,7 @@ pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do return StudyFeatures{..} pStudyFeature `sepBy1` char '#' - + pKey :: Parser Int pKey = decimal