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

fix(add-users): fix confirm secret field decoding

Browse Source
This commit is contained in:
Sarah Vaupel 2022-12-12 13:25:35 +01:00
parent 727d78cabc
commit 57c9535733
1 changed files with 13 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -71,6 +71,7 @@ data CourseRegisterActionData
deriving (Eq, Ord, Show, Generic, Typeable) deriving (Eq, Ord, Show, Generic, Typeable)
makeLenses_ ''CourseRegisterActionData makeLenses_ ''CourseRegisterActionData
makePrisms ''CourseRegisterActionData
instance Aeson.FromJSON CourseRegisterActionData where instance Aeson.FromJSON CourseRegisterActionData where
parseJSON = Aeson.genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 } parseJSON = Aeson.genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 }
@ -124,30 +125,28 @@ postCAddUserR tid ssh csh = do
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
confirmAvailableActs <- fmap (maybe FormMissing FormSuccess) . throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ toPathPiece PostCourseUserAddConfirmAvailableActions) confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction
confirmActs <- fmap (maybe FormMissing FormSuccess) . throwExceptT . runMaybeT $ encodedSecretBoxOpen =<< MaybeT (lift . lookupPostParam $ toPathPiece PostCourseUserAddConfirmAction) $logErrorS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs
$logErrorS "CAddUserR available" . tshow $ Aeson.encode (confirmAvailableActs :: Maybe (Set CourseRegisterActionData))
$logErrorS "CAddUserR acts" . tshow $ Aeson.encode (confirmActs :: Maybe (Set CourseRegisterActionData))
if if
| FormSuccess acts <- confirmActs | not $ Set.null confirmedActs
, FormSuccess _availableActs <- confirmAvailableActs
-> do -> do
-- TODO: check that all acts are member of availableActs! -- TODO: check that all acts are member of availableActs!
forM_ (Set.toList acts) $ \case forM_ (Set.toList confirmedActs) $ \case
CourseRegisterActionAddTutorialMemberData{..} -> do CourseRegisterActionAddTutorialMemberData{..} -> do
registeredUsers <- registerUsers cid $ Map.singleton crActAddTutorialMemberIdent (Just $ view _1 crActAddTutorialMemberUser) registeredUsers <- registerUsers cid $ Map.singleton crActAddTutorialMemberIdent (Just $ view _1 crActAddTutorialMemberUser)
tutId <- upsertNewTutorial cid crActAddTutorialMemberTutorial tutId <- upsertNewTutorial cid crActAddTutorialMemberTutorial
registerTutorialMembers tutId registeredUsers registerTutorialMembers tutId registeredUsers
redirect $ CTutorialR tid ssh csh crActAddTutorialMemberTutorial TUsersR
CourseRegisterActionAddParticipantData{..} -> do CourseRegisterActionAddParticipantData{..} -> do
void . registerUsers cid $ Map.singleton crActAddParticipantIdent (Just $ view _1 crActAddParticipantUser) void . registerUsers cid $ Map.singleton crActAddParticipantIdent (Just $ view _1 crActAddParticipantUser)
redirect $ CourseR tid ssh csh CUsersR if
| FormSuccess _ <- confirmActsRes | tutActs <- Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs
-> addMessageI Error MsgCourseParticipantsRegisterConfirmInvalid , CourseRegisterActionAddTutorialMemberData{..}:_ <- Set.toList tutActs
| FormMissing <- confirmActsRes , Set.size tutActs == Set.size confirmedActs
-> redirect $ CTutorialR tid ssh csh crActAddTutorialMemberTutorial TUsersR
| otherwise
-> redirect $ CourseR tid ssh csh CUsersR
| otherwise
-> return () -> return ()
| FormFailure errs <- confirmActsRes
-> forM_ errs $ addMessage Error . toHtml
((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime