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

chore(tutorial): add name suggestions for mass registering

Browse Source
This commit is contained in:
Steffen Jost 2023-06-07 10:06:23 +00:00
parent e1093701ca
commit fa36cb4de1
2 changed files with 26 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
src/Handler/Course/ParticipantInvite.hs
View File

@ -156,27 +156,36 @@ postTAddUserR tid ssh csh tutn = handleAddUserR tid ssh csh (Left tutn) Nothing
handleAddUserR :: TermId -> SchoolId -> CourseShorthand -> Either TutorialName Day -> Maybe TutorialType -> Handler Html handleAddUserR :: TermId -> SchoolId -> CourseShorthand -> Either TutorialName Day -> Maybe TutorialType -> Handler Html
handleAddUserR tid ssh csh tdesc ttyp = do handleAddUserR tid ssh csh tdesc ttyp = do
(cid, tutTypes) <- runDB $ do (cid, tutTypes, tutNameSuggestions) <- runDB $ do
let plainTemplates = tutorialTemplateNames Nothing
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
tutTypes <- E.select $ E.distinct $ do tutTypes <- E.select $ E.distinct $ do
tutorial <- E.from $ E.table @Tutorial tutorial <- E.from $ E.table @Tutorial
let tuTyp = tutorial E.^. TutorialType let tuTyp = tutorial E.^. TutorialType
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
E.&&. E.not_ (E.any (E.hasPrefix_ tuTyp . E.val) (tutorialTemplateNames Nothing))
-- ((\pfx -> E.val pfx `E.isPrefixOf_` tutorial E.^. TutorialType) (tutorialTemplateNames Nothing))
E.orderBy [E.asc tuTyp] E.orderBy [E.asc tuTyp]
return tuTyp return tuTyp
let typeSet = Set.fromList [ maybe t CI.mk $ Text.stripPrefix temp_sep $ CI.original t let typeSet = Set.fromList [ maybe t CI.mk $ Text.stripPrefix temp_sep $ CI.original t
| temp <- tutorialTemplateNames Nothing | temp <- plainTemplates
, let temp_sep = CI.original (temp <> tutorialTypeSeparator) , let temp_sep = CI.original (temp <> tutorialTypeSeparator)
, E.Value t <- tutTypes , E.Value t <- tutTypes
] ]
return (cid, Set.toAscList typeSet) -- Set in order to remove duplicates and sort ascending at once tutNames <- E.select $ do
tutorial <- E.from $ E.table @Tutorial
let tuName = tutorial E.^. TutorialName
E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
E.&&. E.isJust (tutorial E.^. TutorialFirstDay)
E.&&. E.not_ (E.any (E.hasPrefix_ (tutorial E.^. TutorialType) . E.val) plainTemplates)
E.orderBy [E.desc $ tutorial E.^. TutorialFirstDay, E.asc tuName]
E.limit 7
return tuName
let tutNameSuggestions = return $ mkOptionList [Option tno tn tno | etn <- tutNames, let tn = E.unValue etn, let tno = CI.original tn]
return (cid, Set.toAscList typeSet, tutNameSuggestions) -- Set in order to remove duplicates and sort ascending at once
currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction
$logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs -- $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs
unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs
let let
users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs
@ -197,12 +206,15 @@ handleAddUserR tid ssh csh tdesc ttyp = do
auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
auReqTutorial <- optionalActionW auReqTutorial <- optionalActionW
( (,,) ( (,,)
<$> aopt (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) <$> aopt (textField & cfStrip & cfCI & addDatalist tutNameSuggestions)
(Just $ maybeLeft tdesc) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip)
<*> aopt (selectFieldList tutTypesMsg) (fslI MsgTableTutorialType) (Just $ maybeLeft tdesc)
(Just tutDefType) <*> aopt (selectFieldList tutTypesMsg)
<*> aopt dayField (fslI MsgTableTutorialFirstDay & setTooltip MsgCourseParticipantsRegisterTutorialFirstDayTip) (fslI MsgTableTutorialType)
(Just $ maybeRight tdesc) (Just tutDefType)
<*> aopt dayField
(fslI MsgTableTutorialFirstDay & setTooltip MsgCourseParticipantsRegisterTutorialFirstDayTip)
(Just $ maybeRight tdesc)
) )
( fslI MsgCourseParticipantsRegisterTutorialOption ) ( fslI MsgCourseParticipantsRegisterTutorialOption )
( Just True ) ( Just True )

1
src/Handler/Course/Show.hs
View File

@ -147,7 +147,6 @@ getCShowR tid ssh csh = do
-> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR -> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR
registrationOpen <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR registrationOpen <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR
mayMassRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR mayMassRegister <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
isRegistered <-
MsgRenderer mr <- getMsgRenderer MsgRenderer mr <- getMsgRenderer