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

feat(users-add): redirect to different routes depending on tutorial

Browse Source
This commit is contained in:
Sarah Vaupel 2022-12-08 19:16:42 +01:00
parent e273c60a23
commit 93c6853b08
1 changed files with 21 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -14,7 +14,7 @@ import Handler.Utils.Avs
import Jobs.Queue
--import Data.Aeson hiding (Result(..))
--import qualified Data.CaseInsensitive as CI
import qualified Data.CaseInsensitive as CI
--import qualified Data.HashSet as HashSet
import Data.List (genericLength)
import qualified Data.Map as Map
@ -26,6 +26,12 @@ import Control.Monad.Except (MonadError(..))
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
data AddUsers = AddUsers
{ auUsers :: Set Text
, auTutorial :: Maybe Text
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
data AddParticipantsResult = AddParticipantsResult
{ aurNotFound :: Set Text
, aurAlreadyRegistered
@ -54,14 +60,20 @@ postCAddUserR tid ssh csh = do
cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList)
((usersToRegister, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
users <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
mTutorial <- optionalActionW
auUsers <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
auTutorial <- optionalActionW
( areq textField (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just $ tshow today) ) -- TODO: use user date display setting
( fslI MsgCourseParticipantsRegisterTutorialOption )
( Just True )
return $ Map.fromSet . const <$> mTutorial <*> users
return $ AddUsers <$> auUsers <*> auTutorial
formResultModal usersToRegister (CourseR tid ssh csh CUsersR) $
-- let dest = CourseR tid ssh csh . maybe CUsersR (flip TutorialR TUsersR . CI.mk) . join . fmap auTutorial $ formResult' usersToRegister
let dest | Just AddUsers{..} <- formResult' usersToRegister
, Just (CI.mk -> tutn) <- auTutorial
= CTutorialR tid ssh csh tutn TUsersR
| otherwise
= CourseR tid ssh csh CUsersR
formResultModal usersToRegister dest $
hoist runDBJobs . registerUsers cid -- TODO: register for tutorial, if specified
let heading = prependCourseTitle tid ssh csh MsgCourseParticipantsRegisterHeading
@ -74,10 +86,10 @@ postCAddUserR tid ssh csh = do
}
registerUsers :: CourseId -> Map Text (Maybe Text) -> WriterT [Message] (YesodJobDB UniWorX) ()
registerUsers cid usersToRegister = do
avsUsers :: Map Text (Maybe UserId) <- flip Map.traverseWithKey usersToRegister $ \userIdent _ ->
liftHandler $ upsertAvsUser userIdent -- TODO: upsertAvsUser should return whole Entity
registerUsers :: CourseId -> AddUsers -> WriterT [Message] (YesodJobDB UniWorX) ()
registerUsers cid AddUsers{..} = do
avsUsers :: Map Text (Maybe UserId) <- sequenceA . flip Map.fromSet auUsers $
liftHandler . upsertAvsUser -- TODO: upsertAvsUser should return whole Entity
if
| null avsUsers