-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Course.ParticipantInvite ( getCAddUserR, postCAddUserR ) where import Import import Handler.Utils import Handler.Utils.Avs import Jobs.Queue import qualified Data.CaseInsensitive as CI import Data.List (genericLength) import qualified Data.Map as Map import qualified Data.Text as Text import qualified Data.Time.Zones as TZ import qualified Data.Set as Set import Control.Monad.Except (MonadError(..)) import Generics.Deriving.Monoid (memptydefault, mappenddefault) type TutorialIdent = CI Text data ButtonCourseRegisterMode = BtnCourseRegisterAdd | BtnCourseRegisterConfirm | BtnCourseRegisterAbort deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonCourseRegisterMode instance Finite ButtonCourseRegisterMode embedRenderMessage ''UniWorX ''ButtonCourseRegisterMode id nullaryPathPiece ''ButtonCourseRegisterMode $ camelToPathPiece' 1 instance Button UniWorX ButtonCourseRegisterMode where btnLabel x = [whamlet|_{x}|] btnClasses BtnCourseRegisterAdd = [BCIsButton, BCPrimary] 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, Typeable) instance Universe CourseRegisterAction instance Finite CourseRegisterAction data CourseRegisterActionData = CourseRegisterActionAddParticipantData { crActParticipantUser :: UserId , crActParticipantTutorial :: Maybe TutorialIdent } | CourseRegisterActionAddTutorialMemberData { crActTutorialMemberParticipant :: CourseParticipantId , crActTutorialMemberTutorial :: TutorialIdent } | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display { crActUnknownPersonIdent :: Text } deriving (Eq, Ord, Read, Show, Generic, Typeable) makeLenses_ ''CourseRegisterActionData classifyRegisterAction :: CourseRegisterActionData -> CourseRegisterAction classifyRegisterAction = \case CourseRegisterActionAddParticipantData{} -> CourseRegisterActionAddParticipant CourseRegisterActionAddTutorialMemberData{} -> CourseRegisterActionAddTutorialMember CourseRegisterActionUnknownPersonData{} -> CourseRegisterActionUnknownPerson data AddUsers = AddUsers { auUsers :: Set Text , auTutorial :: Maybe TutorialIdent } deriving (Eq, Ord, Read, Show, Generic, Typeable) data AddParticipantsResult = AddParticipantsResult { aurNotFound :: Set Text , aurAlreadyRegistered , aurAlreadyTutorialMember , aurRegisterSuccess , aurTutorialSuccess :: Set UserId } deriving (Read, Show, Generic, Typeable) 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 cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh -- mr <- getMessageRender today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime ((usersToRegister :: FormResult AddUsers, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do let cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text) cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList) auUsers <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty auTutorial <- optionalActionW ( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just . CI.mk $ tshow today) ) -- TODO: use user date display setting ( fslI MsgCourseParticipantsRegisterTutorialOption ) ( Just True ) return $ AddUsers <$> auUsers <*> auTutorial -- let dest = CourseR tid ssh csh . maybe CUsersR (flip TutorialR TUsersR . CI.mk) . join . fmap auTutorial $ formResult' usersToRegister let dest | Just AddUsers{auTutorial=Just tutn} <- formResult' usersToRegister = CTutorialR tid ssh csh tutn TUsersR | otherwise = CourseR tid ssh csh CUsersR formResultModal usersToRegister dest $ \AddUsers{..} -> hoist runDBJobs $ do avsUsers :: Map Text (Maybe UserId) <- sequenceA . flip Map.fromSet auUsers $ liftHandler . upsertAvsUser case catMaybes $ Map.elems avsUsers of [] -> tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven uids -> do registerUsers cid avsUsers for_ auTutorial $ \tutorialName -> lift $ do -- TODO: move somewhere else now <- liftIO getCurrentTime Entity tutId _ <- upsert Tutorial { tutorialCourse = cid , tutorialType = CI.mk mempty -- TODO: remove type? unneeded? , tutorialCapacity = Nothing , tutorialRoom = Nothing , tutorialRoomHidden = False , tutorialTime = Occurrences mempty mempty , tutorialRegGroup = Nothing -- TODO: remove , tutorialRegisterFrom = Nothing , tutorialRegisterTo = Nothing , tutorialDeregisterUntil = Nothing , tutorialLastChanged = now , tutorialTutorControlled = False , .. } [ TutorialName =. tutorialName , TutorialLastChanged =. now ] for_ uids $ \tutorialParticipantUser -> upsert TutorialParticipant { tutorialParticipantTutorial = tutId , .. } [] -- tell . pure <=< messageI Success . MsgCourseParticipantsRegisteredTutorial $ length uids let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading siteLayoutMsg heading $ do setTitleI heading wrapForm formWgt def { formEncoding , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR } confirmAddUser :: Handler Html confirmAddUser = do siteLayoutMsg MsgCourseParticipantsRegisterConfirmationHeading $ do setTitleI MsgCourseParticipantsRegisterConfirmationHeading let confirmCheckBox :: Widget confirmCheckBox = do let sJsonField :: Field (HandlerFor UniWorX) a sJsonField = secretJsonField' $ \theId name attrs val _isReq -> [whamlet| $newline never |] fieldView sJsonField act mempty vAttrs (Right act) False availableActs :: Widget availableActs = fieldView (secretJsonField :: Field Handler (Set csvAction)) "" mempty [] (Right . Set.empty) False (confirmForm', confirmEnctype) <- liftHandler . generateFormPost . withButtonForm' [BtnCourseRegisterConfirm, BtnCourseRegisterAbort] . identifyForm FIDCourseRegisterConfirm $ \csrf -> return (error "No meaningful FormResult", $(widgetFile "course/add-user/confirmation")) let confirmForm = wrapForm confirmForm' FormSettings { formMethod = POST , formAction = Just $ tblLink id , formEncoding = confirmEnctype , formAttrs = [] , formSubmit = FormNoSubmit , formAnchor = Nothing :: Maybe Text } $(widgetFile "course/add-user/confirmation-wrapper") registerUsers :: CourseId -> Map Text (Maybe UserId) -> WriterT [Message] (YesodJobDB UniWorX) () registerUsers cid users | null users = tell . pure =<< messageI Error MsgCourseParticipantsRegisterNoneGiven | otherwise = tell <=< lift . addParticipantsResultMessages <=< lift . execWriterT . mapM_ (registerUser cid) $ Map.toList users addParticipantsResultMessages :: (MonadHandler m, HandlerSite m ~ UniWorX) => AddParticipantsResult -> ReaderT (YesodPersistBackend UniWorX) m [Message] addParticipantsResultMessages AddParticipantsResult{..} = execWriterT $ do unless (null aurNotFound) $ do let modalTrigger = [whamlet|_{MsgCourseParticipantsRegisterNotFoundInAvs (length aurNotFound)}|] modalContent = $(widgetFile "messages/courseInvitationNotFoundInAvs") tell . pure <=< messageWidget Error $ msgModal modalTrigger (Right modalContent) aurAlreadyRegistered' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyRegistered) aurAlreadyTutorialMember' <- fmap sort (lift . mapM getJust $ Set.toList aurAlreadyTutorialMember) unless (null aurAlreadyRegistered) $ do let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyRegistered (length aurAlreadyRegistered)}|] modalContent = $(widgetFile "messages/courseInvitationAlreadyRegistered") tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) unless (null aurAlreadyTutorialMember) $ do let modalTrigger = [whamlet|_{MsgCourseParticipantsAlreadyTutorialMember (length aurAlreadyTutorialMember)}|] modalContent = $(widgetFile "messages/courseInvitationAlreadyTutorialMember") tell . pure <=< messageWidget Info $ msgModal modalTrigger (Right modalContent) unless (null aurRegisterSuccess) $ tell . pure <=< messageI Success . MsgCourseParticipantsRegistered $ length aurRegisterSuccess unless (null aurTutorialSuccess) $ tell . pure <=< messageI Success . MsgCourseUsersTutorialRegistered . genericLength $ Set.toList aurTutorialSuccess registerUser :: CourseId -> (Text, Maybe UserId) -> WriterT AddParticipantsResult (YesodJobDB UniWorX) () registerUser _cid ( avsIdent, Nothing ) = tell $ mempty { aurNotFound = Set.singleton avsIdent } registerUser cid (_avsIdent, Just uid) = exceptT tell tell $ do whenM (lift . lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $ throwError $ mempty { aurAlreadyRegistered = Set.singleton uid } courseParticipantRegistration <- liftIO getCurrentTime void . lift . lift $ upsert CourseParticipant { courseParticipantCourse = cid , courseParticipantUser = uid , courseParticipantAllocated = Nothing , courseParticipantState = CourseParticipantActive , .. } [ CourseParticipantRegistration =. courseParticipantRegistration , CourseParticipantAllocated =. Nothing , CourseParticipantState =. CourseParticipantActive ] lift . lift . audit $ TransactionCourseParticipantEdit cid uid lift . lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid -- TODO: send Notification at all? return $ mempty { aurRegisterSuccess = Set.singleton uid }