-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# LANGUAGE TypeApplications #-} module Handler.Course.ParticipantInvite ( getCAddUserR, postCAddUserR , getTAddUserR, postTAddUserR ) where import Import import Handler.Utils import Handler.Utils.Avs import Jobs.Queue import qualified Data.Aeson as Aeson import qualified Data.CaseInsensitive as CI import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Time.Zones as TZ import qualified Data.Set as Set import qualified Data.Text as Text import Control.Monad.Except (MonadError(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) -- import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E import Utils.Occurrences type UserSearchKey = Text type TutorialType = CI Text defaultTutorialType :: TutorialType defaultTutorialType = "Schulung" tutorialTypeSeparator :: TutorialType tutorialTypeSeparator = "_" tutorialTemplateNames :: Maybe TutorialType -> [TutorialType] tutorialTemplateNames Nothing = ["Vorlage", "Template"] tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]] tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName tutorialDefaultName Nothing = formatDayForTutName tutorialDefaultName (Just ttyp) = let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp in (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing formatDayForTutName :: Day -> CI Text -- "%yy_%mm_%dd" -- Do not use user date display setting, since tutorial default names must be universal regardless of user -- formatDayForTutName = CI.mk . formatTime' "%y_%m_%d" -- we don't want to go monadic for this formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow where d2u '-' = '_' d2u c = c data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe ButtonCourseRegisterMode instance Finite ButtonCourseRegisterMode embedRenderMessage ''UniWorX ''ButtonCourseRegisterMode id nullaryPathPiece ''ButtonCourseRegisterMode $ camelToPathPiece' 1 instance Button UniWorX ButtonCourseRegisterMode where btnLabel x = [whamlet|_{x}|] btnClasses BtnCourseRegisterConfirm = [BCIsButton, BCPrimary] btnClasses BtnCourseRegisterAbort = [BCIsButton, BCDanger] btnValidate _ BtnCourseRegisterAbort = False btnValidate _ _ = True data CourseRegisterAction = CourseRegisterActionAddParticipant | CourseRegisterActionAddTutorialMember -- | CourseRegisterActionUnknownPerson deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe CourseRegisterAction instance Finite CourseRegisterAction data CourseRegisterActionData = CourseRegisterActionAddParticipantData { crActIdent :: UserSearchKey , crActUser :: (UserId, User) } | CourseRegisterActionAddTutorialMemberData { crActIdent :: UserSearchKey , crActUser :: (UserId, User) , crActTutorial :: (Maybe TutorialName, Maybe TutorialType, Maybe Day) } -- | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display -- { crActUnknownPersonIdent :: Text -- } deriving (Eq, Ord, Show, Generic) makeLenses_ ''CourseRegisterActionData makePrisms ''CourseRegisterActionData instance Aeson.FromJSON CourseRegisterActionData where parseJSON = Aeson.genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 } instance Aeson.ToJSON CourseRegisterActionData where toJSON = Aeson.genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 } toEncoding = Aeson.genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 2 } _classifyRegisterAction :: CourseRegisterActionData -> CourseRegisterAction _classifyRegisterAction = \case CourseRegisterActionAddParticipantData{} -> CourseRegisterActionAddParticipant CourseRegisterActionAddTutorialMemberData{} -> CourseRegisterActionAddTutorialMember --CourseRegisterActionUnknownPersonData{} -> CourseRegisterActionUnknownPerson courseRegisterRenderActionClass :: CourseRegisterAction -> Widget courseRegisterRenderActionClass = \case CourseRegisterActionAddParticipant -> [whamlet|_{MsgCourseParticipantsRegisterActionAddParticipants}|] CourseRegisterActionAddTutorialMember -> [whamlet|_{MsgCourseParticipantsRegisterActionAddTutorialMembers}|] courseRegisterRenderAction :: CourseRegisterActionData -> Widget courseRegisterRenderAction act = [whamlet|^{userWidget (view _2 (crActUser act))} (#{crActIdent act})|] data AddUserRequest = AddUserRequest { auReqUsers :: Set UserSearchKey , auReqTutorial :: Maybe (Maybe TutorialName, Maybe TutorialType, Maybe Day) } deriving (Eq, Ord, Read, Show, Generic) data AddParticipantsResult = AddParticipantsResult { aurNotFound :: Set UserSearchKey , aurAlreadyRegistered , aurAlreadyTutorialMember , aurRegisterSuccess , aurTutorialSuccess :: Set UserId } deriving (Read, Show, Generic) instance Semigroup AddParticipantsResult where (<>) = mappenddefault instance Monoid AddParticipantsResult where mempty = memptydefault mappend = (<>) getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAddUserR = postCAddUserR postCAddUserR tid ssh csh = do today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime handleAddUserR tid ssh csh (Right today) Nothing -- postTAddUserR tid ssh csh (CI.mk $ tshow today) -- Don't use user date display setting, so that tutorial default names conform to all users getTAddUserR, postTAddUserR :: TermId -> SchoolId -> CourseShorthand -> TutorialName -> Handler Html getTAddUserR = postTAddUserR 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, 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.orderBy [E.asc tuTyp] return tuTyp let typeSet = Set.fromList [ maybe t CI.mk $ Text.stripPrefix temp_sep $ CI.original t | temp <- plainTemplates , let temp_sep = CI.original (temp <> tutorialTypeSeparator) , E.Value t <- tutTypes ] 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 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 tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member! registeredUsers <- registerUsers cid users whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do tutId <- upsertNewTutorial cid tName tutType tutDay registerTutorialMembers tutId registeredUsers -- when (Set.size tutActs == Set.size confirmedActs) $ -- not sure how this condition might be false at this point redirect $ CTutorialR tid ssh csh tName TUsersR redirect $ CourseR tid ssh csh CUsersR ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do let tutTypesMsg = [(SomeMessage tt,tt) | tt <- tutTypes] tutDefType = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing) auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty auReqTutorial <- optionalActionW ( (,,) <$> 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 formResult usersToAdd $ \AddUserRequest{..} -> do avsUsers :: Map UserSearchKey (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser auReqUsers let (usersFound, usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers unless (null usersNotFound) $ let msgContent = [whamlet| $newline never