From c013ae9efcd7df812b26ae32ce04ba3da4e6aef4 Mon Sep 17 00:00:00 2001 From: Sarah Vaupel Date: Mon, 12 Dec 2022 10:54:01 +0100 Subject: [PATCH] feat(add-users): connect confirmation form with handler --- src/Handler/Course/ParticipantInvite.hs | 285 +++++------------------- 1 file changed, 55 insertions(+), 230 deletions(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 59de5ab53..386013fb3 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -13,14 +13,8 @@ import Handler.Utils.Avs import Jobs.Queue ---import qualified Database.Esqueleto.Legacy as E - ---import qualified Data.Conduit.List as C (sourceList) ---import qualified Data.Conduit.Combinators as C - import qualified Data.Aeson as Aeson import qualified Data.CaseInsensitive as CI ---import Data.List (genericLength) import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.Text as Text @@ -28,9 +22,6 @@ import qualified Data.Time.Zones as TZ import qualified Data.Set as Set import Control.Monad.Except (MonadError(..)) ---import Control.Monad.State (evalStateT) ---import Control.Monad.State.Class (modify) ---import qualified Control.Monad.State as State import Generics.Deriving.Monoid (memptydefault, mappenddefault) @@ -80,7 +71,7 @@ data CourseRegisterActionData -- | CourseRegisterActionUnknownPersonData -- pseudo-action; just for display -- { crActUnknownPersonIdent :: Text -- } - deriving (Eq, Ord, Generic, Typeable) + deriving (Eq, Ord, Show, Generic, Typeable) makeLenses_ ''CourseRegisterActionData @@ -107,74 +98,12 @@ courseRegisterRenderAction = \case CourseRegisterActionAddParticipantData{..} -> [whamlet|^{userWidget (view _2 crActAddParticipantUser)} (#{crActAddParticipantIdent})|] CourseRegisterActionAddTutorialMemberData{..} -> [whamlet|^{userWidget (view _2 crActAddTutorialMemberUser)} (#{crActAddTutorialMemberIdent}), _{MsgCourseParticipantsRegisterTutorialField}: #{crActAddTutorialMemberTutorial}|] ---data CourseRegisterActionClass --- = CourseRegisterActionClassNew --- | CourseRegisterActionClassExisting --- | CourseRegisterActionClassMissing --- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) ---instance Universe CourseRegisterActionClass ---instance Finite CourseRegisterActionClass - ---courseRegisterCoarsenActionClass :: CourseRegisterAction -> CourseRegisterActionClass ---courseRegisterCoarsenActionClass = \case --- CourseRegisterActionAddParticipant -> CourseRegisterActionClassNew --- CourseRegisterActionAddTutorialMember -> CourseRegisterActionClassExisting --- CourseRegisterActionUnknownPerson -> CourseRegisterActionClassMissing --- ---data CourseRegisterActionDiff -- old new key --- = CourseRegisterActionDiffNew --- { crActKey :: Text --- , crActNewUser :: UserId -- crActNewKey :: Maybe key --- , crActNewTutorial :: Maybe TutorialIdent -- crActNew :: new --- } --- | CourseRegisterActionDiffExisting --- { crActKey :: Text --- , crActOldUser :: UserId -- crActOldKey :: key --- , crActOldTutorial :: TutorialIdent -- crActOld :: old --- , crActNewTutorial :: Maybe TutorialIdent -- crActNew :: new --- } --- | CourseRegisterActionDiffMissing --- { crActKey :: Text --- --{ crActOldKey :: key --- --, crActOld :: old --- } --- ---makeLenses_ ''CourseRegisterActionDiff ---makePrisms ''CourseRegisterActionDiff - ---data CourseRegisterException --- = CourseRegisterExceptionDuplicateIdent --- { crExcptDuplicateIdent :: Text --- } --- | CourseRegisterException --- { crExcpt :: Text --- } --- deriving (Show, Typeable) --- ---makeLenses_ ''CourseRegisterException --- ---instance Exception CourseRegisterException - ---courseRegisterRenderException :: CourseRegisterException -> DB Text ---courseRegisterRenderException = ap getMessageRender . pure --- ---registerActionDefaultChecked :: CourseRegisterAction -> Bool ---registerActionDefaultChecked = (/=) CourseRegisterActionUnknownPerson --- ---registerActionDisabled :: CourseRegisterAction -> Bool ---registerActionDisabled = (==) CourseRegisterActionUnknownPerson - data AddUserRequest = AddUserRequest { auReqUsers :: Set UserSearchKey , auReqTutorial :: Maybe TutorialIdent } deriving (Eq, Ord, Read, Show, Generic, Typeable) ---data AddUser = AddUser --- { addUserIdent :: Text --- , addUserTutorial :: Maybe TutorialIdent --- } deriving (Eq, Ord, Read, Show, Generic, Typeable) - data AddParticipantsResult = AddParticipantsResult { aurNotFound :: Set UserSearchKey @@ -195,10 +124,30 @@ instance Monoid AddParticipantsResult where getCAddUserR, postCAddUserR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCAddUserR = postCAddUserR postCAddUserR tid ssh csh = do - _cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh + cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute + piConfirmPost <- throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ toPathPiece PostCourseUserAddConfirmAction) + $logErrorS "CAddUserR" . tshow $ Aeson.encode piConfirmPost + let + piConfirmRes :: FormResult CourseRegisterActionData + piConfirmRes = maybe FormMissing FormSuccess piConfirmPost + case piConfirmRes of + FormSuccess res'' -> do + let res' = [res''] + forM_ res' $ \case + CourseRegisterActionAddTutorialMemberData{..} -> do + registeredUsers <- registerUsers cid $ Map.singleton crActAddTutorialMemberIdent (Just $ view _1 crActAddTutorialMemberUser) + tutId <- upsertNewTutorial cid crActAddTutorialMemberTutorial + registerTutorialMembers tutId registeredUsers + redirect $ CTutorialR tid ssh csh crActAddTutorialMemberTutorial TUsersR + CourseRegisterActionAddParticipantData{..} -> do + void . registerUsers cid $ Map.singleton crActAddParticipantIdent (Just $ view _1 crActAddParticipantUser) + redirect $ CourseR tid ssh csh CUsersR + FormMissing -> return () + FormFailure errs -> forM_ errs $ addMessage Error . toHtml + ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do let cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text) @@ -267,14 +216,6 @@ postCAddUserR tid ssh csh = do } $(widgetFile "course/add-user/confirmation-wrapper") - --registeredUsers <- registerUsers cid avsUsers - --case auReqTutorial of - -- Nothing -> redirect $ CourseR tid ssh csh CUsersR - -- Just tutorialName -> do - -- tutId <- upsertNewTutorial cid tutorialName - -- registerTutorialMembers tutId registeredUsers - -- redirect $ CTutorialR tid ssh csh tutorialName TUsersR - let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading siteLayoutMsg heading $ do @@ -284,110 +225,48 @@ postCAddUserR tid ssh csh = do , formAction = Just . SomeRoute $ CourseR tid ssh csh CAddUserR } ---getRowKey :: AddUser -> MaybeT DB UserId ---getRowKey AddUser{..} = MaybeT . liftHandler $ upsertAvsUser addUserIdent ---confirmAddUser :: SomeRoute UniWorX -> Handler Html ---confirmAddUser srcRoute = do --- let --- existing = Map.fromList $ zip currentKeys rows --- sourceDiff :: ConduitT () CourseRegisterActionDiff (StateT (Map CourseRegisterActionClass CourseRegisterActionData) DB) () --- sourceDiff = do --- let --- toDiff :: CourseRegisterActionData -> StateT (Map CourseRegisterActionClass CourseRegisterActionData) DB CourseRegisterActionDiff --- toDiff row = do --- rowKey <- lift $ handle (throwM . (CourseRegisterException :: Text -> CourseRegisterException) <=< courseRegisterRenderException) . runMaybeT $ getRowKey row --- seenKeys <- State.get --- (<* modify (maybe id (flip Map.insert row) rowKey)) $ if --- | Just rowKey' <- rowKey --- , Just oldRow <- Map.lookup rowKey' seenKeys --- -> throwM $ CourseRegisterExceptionDuplicateIdent rowKey' --- | Just rowKey' <- rowKey --- , Just oldRow <- Map.lookup rowKey' existing --- -> return $ CourseRegisterActionDiffExisting rowKey' oldRow row --- | otherwise --- -> return $ CourseRegisterActionDiffNew rowKey' oldRow row --- transPipe liftHandler blubb .| C.mapM toDiff --- seen <- State.get --- forM_ (Map.toList existing) $ \(rowKey, oldRow) -> if --- | Map.member rowKey seen -> return () --- | otherwise -> yield $ CourseRegisterActionDiffMissing rowKey --- --- accActionMap :: Map CourseRegisterActionClass (Set CourseRegisterActionData) -> CourseRegisterActionData -> Map CourseRegisterActionClass (Set CourseRegisterActionData) --- accActionMap acc act = Map.insertWith Set.union (courseRegisterCoarsenActionClass $ classifyRegisterAction act) (Set.singleton act) acc --- --- courseRegisterComputeActions :: CourseRegisterActionDiff -> ConduitT () CourseRegisterActionData DB () --- courseRegisterComputeActions = \case --- CourseRegisterActionDiffNew{..} -> return () -- crActKey, crActNewUser, crActNewTutorial --- -- TODO: fetch course participant, if any --- -- TODO: if course participant was found, fetch tutorial member and (if yes) yield CourseRegisterActionAddTutorialMemberData --- -- TODO: if no course participant was found, yield CourseRegisterActionAddParticipantData --- CourseRegisterActionDiffExisting{..} -> return () -- TODO --- CourseRegisterActionDiffMissing{} -> return () -- pseudo-action; no deletion -- TODO: yield smth? --- courseRegisterComputeActions' :: ConduitT CourseRegisterActionDiff Void DB (Map CourseRegisterActionClass (Set CourseRegisterActionData)) --- courseRegisterComputeActions' = do --- let innerAct = awaitForever $ \x --- -> let doHandle = handle $ throwM CourseRegisterException <=< courseRegisterRenderException --- in C.sourceList <=< lift . doHandle . runConduit $ courseRegisterComputeActions x .| C.foldMap pure --- innerAct .| C.foldl accActionMap Map.empty --- actionMap <- flip evalStateT Map.empty . runConduit $ sourceDiff .| transPipe lift courseRegisterComputeActions' --- --- when (Map.null actionMap) $ --- addMessageI Info MsgCourseParticipantsRegisterUnnecessary --- redirect srcRoute --- --- E.transactionSave -- Commit side-effects of courseRegisterComputeActions --- --- liftHandler . (>>= sendResponse) $ --- siteLayoutMsg MsgCourseParticipantsRegisterConfirmationHeading $ do --- setTitleI MsgCourseParticipantsRegisterConfirmationHeading --- let precomputeIdents :: forall f m. (Eq (Element f), MonoFoldable f, MonadHandler m) => f -> m (Element f -> Text) --- precomputeIdents = foldM (\f act -> (\id' x -> bool (f x) id' $ act == x) <$> newIdent) (\_ -> error "No id precomputed") --- actionClassIdent <- precomputeIdents $ Map.keys actionMap --- actionIdent <- precomputeIdents . Set.union $ Map.elems actionMap --- let --- --defaultChecked actClass = case courseRegisterCoarsenActionClass actClass of --- -- CourseRegisterActionDiffMissing -> False --- -- _other -> True --- defaultChecked = const True --- confirmCheckBox :: [(Text,Text)] -> CourseRegisterActionData -> Widget --- confirmCheckBox vAttrs act = do --- let sJsonField :: Field (HandlerFor UniWorX) CourseRegisterAction --- 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 CourseRegisterAction)) "" mempty [] (Right . Set.unions $ Map.elems actionMap) 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 UserSearchKey (Maybe UserId) -> Handler (Set UserId) -- WriterT [Message] (YesodJobDB UniWorX) () -_registerUsers cid users +registerUsers :: CourseId -> Map UserSearchKey (Maybe UserId) -> Handler (Set UserId) +registerUsers cid users | Map.null users = do addMessageI Error MsgCourseParticipantsRegisterNoneGiven return Set.empty | otherwise = do - (mconcat -> AddParticipantsResult{..}) <- runDBJobs . mapM (_registerUser cid) $ Map.toList users + (mconcat -> AddParticipantsResult{..}) <- runDBJobs . mapM (registerUser cid) $ Map.toList users unless (Set.null aurRegisterSuccess) $ addMessageI Success . MsgCourseParticipantsRegistered $ Set.size aurRegisterSuccess unless (Set.null aurAlreadyRegistered) $ addMessageI Info . MsgCourseParticipantsAlreadyRegistered $ Set.size aurAlreadyRegistered return $ aurRegisterSuccess `Set.union` aurAlreadyRegistered -_upsertNewTutorial :: CourseId -> TutorialIdent -> Handler TutorialId -_upsertNewTutorial cid tutorialName = do +registerUser :: CourseId + -> (UserSearchKey, Maybe UserId) + -> YesodJobDB UniWorX AddParticipantsResult +registerUser _cid ( avsIdent, Nothing ) = return $ mempty { aurNotFound = Set.singleton avsIdent } +registerUser cid (_avsIdent, Just uid) = exceptT return return $ do + whenM (lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $ + throwError $ mempty { aurAlreadyRegistered = Set.singleton uid } + + courseParticipantRegistration <- liftIO getCurrentTime + void . lift $ upsert + CourseParticipant -- TODO: use participantId instead of userId for aurRegisterSuccess + { courseParticipantCourse = cid + , courseParticipantUser = uid + , courseParticipantAllocated = Nothing + , courseParticipantState = CourseParticipantActive + , .. + } + [ CourseParticipantRegistration =. courseParticipantRegistration + , CourseParticipantAllocated =. Nothing + , CourseParticipantState =. CourseParticipantActive + ] + lift . audit $ TransactionCourseParticipantEdit cid uid + lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid -- TODO: send Notification at all? + + return $ mempty { aurRegisterSuccess = Set.singleton uid } + +upsertNewTutorial :: CourseId -> TutorialIdent -> Handler TutorialId +upsertNewTutorial cid tutorialName = do now <- liftIO getCurrentTime Entity tutId _ <- runDB $ upsert Tutorial @@ -410,8 +289,8 @@ _upsertNewTutorial cid tutorialName = do ] return tutId -_registerTutorialMembers :: TutorialId -> Set UserId -> Handler () -_registerTutorialMembers tutId (Set.toList -> users) = runDB $ do +registerTutorialMembers :: TutorialId -> Set UserId -> Handler () +registerTutorialMembers tutId (Set.toList -> users) = runDB $ do prevParticipants <- fmap Set.fromList $ selectList [TutorialParticipantUser <-. users, TutorialParticipantTutorial ==. tutId] [] participants <- fmap Set.fromList . for users $ \tutorialParticipantUser -> upsert TutorialParticipant @@ -424,57 +303,3 @@ _registerTutorialMembers tutId (Set.toList -> users) = runDB $ do addMessageI Success . MsgCourseParticipantsRegisteredTutorial $ Set.size newParticipants unless (Set.null prevParticipants) $ addMessageI Info . MsgCourseParticipantsAlreadyTutorialMember $ length prevParticipants - ---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 - -> (UserSearchKey, Maybe UserId) - -> YesodJobDB UniWorX AddParticipantsResult - -- -> WriterT AddParticipantsResult (YesodJobDB UniWorX) () -_registerUser _cid ( avsIdent, Nothing ) = return $ mempty { aurNotFound = Set.singleton avsIdent } -- tell $ mempty { aurNotFound = Set.singleton avsIdent } -_registerUser cid (_avsIdent, Just uid) = exceptT return return $ do - whenM (lift $ exists [CourseParticipantCourse ==. cid, CourseParticipantUser ==. uid, CourseParticipantState ==. CourseParticipantActive]) $ - throwError $ mempty { aurAlreadyRegistered = Set.singleton uid } - - courseParticipantRegistration <- liftIO getCurrentTime - void . lift $ upsert - CourseParticipant -- TODO: use participantId instead of userId for aurRegisterSuccess - { courseParticipantCourse = cid - , courseParticipantUser = uid - , courseParticipantAllocated = Nothing - , courseParticipantState = CourseParticipantActive - , .. - } - [ CourseParticipantRegistration =. courseParticipantRegistration - , CourseParticipantAllocated =. Nothing - , CourseParticipantState =. CourseParticipantActive - ] - lift . audit $ TransactionCourseParticipantEdit cid uid - lift . queueDBJob . JobQueueNotification $ NotificationCourseRegistered uid cid -- TODO: send Notification at all? - - return $ mempty { aurRegisterSuccess = Set.singleton uid }