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

Default offered; unnecessarily complicated due using field studyFeature

Browse Source
This commit is contained in:
SJost 2019-02-28 18:04:22 +01:00
parent 933eaa7362
commit e446641666
3 changed files with 31 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
src/Handler/Course.hs
View File

@ -264,7 +264,7 @@ getTermCourseListR tid = do
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do getCShowR tid ssh csh = do
mbAid <- maybeAuthId 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)] [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
<- lift . E.select . E.from $ <- lift . E.select . E.from $
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do \((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 E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
return ( E.countRows :: E.SqlExpr (E.Value Int64)) return ( E.countRows :: E.SqlExpr (E.Value Int64))
return (course,school E.^. SchoolName, numParticipants, participant) 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 lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ] E.orderBy [ E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName ]
return (user E.^. UserDisplayName, user E.^. UserSurname, user E.^. UserEmail) 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 mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
mRegAt <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration 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 registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
siteLayout (toWgt $ courseName course) $ do siteLayout (toWgt $ courseName course) $ do
setTitle [shamlet| #{toPathPiece tid} - #{csh}|] setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
$(widgetFile "course") $(widgetFile "course")
-- | Registration button with primary study features if logged in -- | Registration button with maybe a userid if logged in
-- , existing features if already registered -- , maybe existing features if already registered
-- , and possibly a course secret -- , maybe some default study features
registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool) -- , 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 -- 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 -- secret fields
(msecretRes', msecretView) <- case msecret of (msecretRes', msecretView) <- case msecret of
(Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing (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) Nothing -> return (Nothing,Nothing)
Just _ -> bimap Just Just <$> case participant of Just _ -> bimap Just Just <$> case participant of
Just CourseParticipant{courseParticipantField=Just sfid} Just CourseParticipant{courseParticipantField=Just sfid}
-> mopt (studyFeaturesPrimaryFieldFor [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just $ Just sfid) -> mforced (studyFeaturesPrimaryFieldFor [sfid] loggedin) (fslI MsgCourseStudyFeature) (Just sfid)
_other -> mopt (studyFeaturesPrimaryFieldFor [ ] loggedin) (fslI MsgCourseStudyFeature _other -> mreq (studyFeaturesPrimaryFieldFor [ ] loggedin) (fslI MsgCourseStudyFeature
& setTooltip MsgCourseStudyFeatureTooltip) Nothing & setTooltip MsgCourseStudyFeatureTooltip) (Just defSFid)
-- button de-/register -- button de-/register
(btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing (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) registration <- getBy (UniqueParticipant aid cid)
return (cid, course, entityVal <$> registration) return (cid, course, entityVal <$> registration)
let isRegistered = isJust 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 formResult regResult $ \(mbSfId,codeOk) -> if
| isRegistered -> do | isRegistered -> do
runDB $ deleteBy $ UniqueParticipant aid cid runDB $ deleteBy $ UniqueParticipant aid cid

18
src/Handler/Utils/Form.hs
View File

@ -215,7 +215,7 @@ schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName 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) -- | 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 studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
-- we need a join, so we cannot just use optionsPersistCryptoId -- we need a join, so we cannot just use optionsPersistCryptoId
rawOptions <- runDB $ E.select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` field) -> do 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.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures)
E.||. isPrimaryActiveUserStudyFeature feature E.||. isPrimaryActiveUserStudyFeature feature
return (feature E.^. StudyFeaturesId, degree, field) return (feature E.^. StudyFeaturesId, degree, field)
mkOptionList <$> mapM procOptions rawOptions mkOptionList . nonEmptyOptions <$> mapM procOptions rawOptions
where where
isPrimaryActiveUserStudyFeature feature = case mbuid of isPrimaryActiveUserStudyFeature feature = case mbuid of
Nothing -> E.val False Nothing -> E.val False
@ -232,17 +232,27 @@ studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
E.&&. feature E.^. StudyFeaturesValid E.==. E.val True E.&&. feature E.^. StudyFeaturesValid E.==. E.val True
E.&&. feature E.^. StudyFeaturesType E.==. E.val FieldPrimary 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 procOptions (E.Value sfid, Entity dgid StudyDegree{..}, Entity stid StudyTerms{..}) = do
let dgname = fromMaybe (tshow dgid) (studyDegreeShorthand <|> studyDegreeName) let dgname = fromMaybe (tshow dgid) (studyDegreeShorthand <|> studyDegreeName)
stname = fromMaybe (tshow stid) (studyTermsShorthand <|> studyTermsName ) stname = fromMaybe (tshow stid) (studyTermsShorthand <|> studyTermsName )
cfid <- encrypt sfid cfid <- encrypt sfid
return Option return Option
{ optionDisplay = stname <> " (" <> dgname <> ")" { optionDisplay = stname <> " (" <> dgname <> ")"
, optionInternalValue = sfid , optionInternalValue = Just sfid
, optionExternalValue = toPathPiece (cfid :: CryptoID UUID StudyFeaturesId) , 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 :: Field Handler UploadMode
uploadModeField = selectField optionsFinite uploadModeField = selectField optionsFinite

3
templates/widgets/register-form/register-form.hamlet
View File

@ -2,9 +2,12 @@ $# extra protects us against CSRF
#{extra} #{extra}
$# Maybe display textField for passcode $# Maybe display textField for passcode
$maybe secretView <- msecretView $maybe secretView <- msecretView
^{fvLabel secretView}
^{fvInput secretView} ^{fvInput secretView}
$# Ask for associated primary field uf study, unless registered $# Ask for associated primary field uf study, unless registered
$maybe sfView <- msfView $maybe sfView <- msfView
^{fvLabel sfView}
^{fvInput sfView} ^{fvInput sfView}
$# Always display register/deregister button $# Always display register/deregister button
^{fvInput btnView} ^{fvInput btnView}