From fa36cb4de1af158c4c72f8c4553b712c154276ad Mon Sep 17 00:00:00 2001
From: Steffen Jost <S.Jost@Fraport.de>
Date: Wed, 7 Jun 2023 10:06:23 +0000
Subject: [PATCH] chore(tutorial): add name suggestions for mass registering

---
 src/Handler/Course/ParticipantInvite.hs | 38 ++++++++++++++++---------
 src/Handler/Course/Show.hs              |  3 +-
 2 files changed, 26 insertions(+), 15 deletions(-)

diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs
index 7b2eb8157..e617e77dd 100644
--- a/src/Handler/Course/ParticipantInvite.hs
+++ b/src/Handler/Course/ParticipantInvite.hs
@@ -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 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
     tutTypes <- E.select $ E.distinct $ do
       tutorial <- E.from $ E.table @Tutorial
       let tuTyp = tutorial E.^. TutorialType
       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]
       return tuTyp
     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)
                                 , 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
 
   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
     let
       users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs
@@ -197,13 +206,16 @@ handleAddUserR tid ssh csh tdesc ttyp = do
     auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
     auReqTutorial <- optionalActionW
       ( (,,) 
-        <$> aopt  (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) 
-              (Just $ maybeLeft tdesc) 
-        <*> aopt  (selectFieldList tutTypesMsg) (fslI MsgTableTutorialType) 
-              (Just   tutDefType)
-        <*> aopt    dayField                    (fslI MsgTableTutorialFirstDay & setTooltip MsgCourseParticipantsRegisterTutorialFirstDayTip)
-              (Just $ maybeRight tdesc)
-      ) 
+        <$> aopt  (textField & cfStrip & cfCI & addDatalist tutNameSuggestions)
+                  (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip)
+                  (Just $ maybeLeft tdesc)
+        <*> aopt  (selectFieldList tutTypesMsg)
+                  (fslI MsgTableTutorialType)
+                  (Just tutDefType)
+        <*> aopt   dayField
+                  (fslI MsgTableTutorialFirstDay & setTooltip MsgCourseParticipantsRegisterTutorialFirstDayTip)
+                  (Just $ maybeRight tdesc)
+      )
       ( fslI MsgCourseParticipantsRegisterTutorialOption )
       ( Just True )
     return $ AddUserRequest <$> auReqUsers <*> auReqTutorial
diff --git a/src/Handler/Course/Show.hs b/src/Handler/Course/Show.hs
index 85be88849..78ddeecd5 100644
--- a/src/Handler/Course/Show.hs
+++ b/src/Handler/Course/Show.hs
@@ -146,8 +146,7 @@ getCShowR tid ssh csh = do
     | otherwise
       -> return . modal $(widgetFile "course/login-to-register") . Left . SomeRoute $ AuthR LoginR
   registrationOpen  <- hasWriteAccessTo $ CourseR tid ssh csh CRegisterR
-  mayMassRegister   <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR
-  isRegistered      <- 
+  mayMassRegister   <- hasWriteAccessTo $ CourseR tid ssh csh CAddUserR  
 
   MsgRenderer mr <- getMsgRenderer