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

fix(firm): sending messages works, but not test messages

Browse Source
This commit is contained in:
Steffen Jost 2023-11-14 12:57:51 +01:00
parent 25c4ba7136
commit 42ff02d27e
1 changed files with 32 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
src/Handler/Utils/Communication.hs
View File

@ -134,32 +134,29 @@ crTestFirmCommunication jCompany comm = do
commR :: CommunicationRoute -> Handler Html commR :: CommunicationRoute -> Handler Html
commR CommunicationRoute{..} = do commR CommunicationRoute{..} = do
$logWarnS "COMM" "Communication handleer started" let decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User))
cUser <- maybeAuth
MsgRenderer mr <- getMsgRenderer
mbCurrentRoute <- getCurrentRoute
(suggestedRecipients, chosenRecipients) <- runDB $ do
suggestedUsers <- for crRecipients $ \(_,user) -> E.select user
let suggested = zip (view _1 <$> crRecipients) suggestedUsers
let
decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User))
decrypt' cID = do decrypt' cID = do
uid <- decrypt cID uid <- decrypt cID
whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid) whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid)
getEntity uid getEntity uid
chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient cUser <- maybeAuth
return (suggested, chosen') MsgRenderer mr <- getMsgRenderer
mbCurrentRoute <- getCurrentRoute
(suggestedRecipients, chosenRecipients) <- runDB $ (,)
<$> for crRecipients (\(grp,usrQry) -> (grp,) <$> E.select usrQry)
<*> fmap (maybe id cons cUser . catMaybes) (mapM decrypt' =<< lookupGlobalGetParams GetRecipient)
$logWarnS "COMM" ("Communication handler DB done with (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")") $logWarnS "COMM" ("Communication handler DB done with (sugg:" <> tshow (length suggestedRecipients) <> ", chosen:" <> tshow (length chosenRecipients) <> ")")
let let
lookupUser :: UserId -> User lookupUser :: UserId -> (UserDisplayName,UserSurname)
lookupUser lId lookupUser =
= entityVal . headDef (error $ "this is it" <> show lId) . filter ((== lId) . entityKey) $ concatMap (view _2) suggestedRecipients ++ chosenRecipients let usrMap = Map.fromList $ fmap (\u -> (entityKey u, entityVal u)) $ chosenRecipients ++ concatMap (view _2) suggestedRecipients
usrNames Nothing = ("???","???") -- this case only happens during runFormPost when POST Data is present and no form is displayed
usrNames (Just User{userDisplayName, userSurname}) = (userDisplayName, userSurname)
in usrNames . flip Map.lookup usrMap
let chosenRecipients' = Map.fromList $ let chosenRecipients' = Map.fromList $
[ ( (BoundedPosition $ RecipientGroup g, pos) [ ( (BoundedPosition $ RecipientGroup g, pos)
@ -187,7 +184,7 @@ commR CommunicationRoute{..} = do
miCell _ (Left (CI.original -> email)) initRes nudge csrf = do miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
(tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True (tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
return (tickRes, $(widgetFile "widgets/communication/recipientEmail")) return (tickRes, $(widgetFile "widgets/communication/recipientEmail"))
miCell _ (Right uid@(lookupUser -> User{..})) initRes nudge csrf = do miCell _ (Right uid@(lookupUser -> (userDisplayName, userSurname))) initRes nudge csrf = do
(tickRes, tickView) <- if (tickRes, tickView) <- if
| fmap entityKey cUser == Just uid | fmap entityKey cUser == Just uid
-> mforced checkBoxField ("" & addName (nudge "tick")) True -> mforced checkBoxField ("" & addName (nudge "tick")) True
@ -239,27 +236,26 @@ commR CommunicationRoute{..} = do
recipientsListMsg <- messageI Info MsgCommRecipientsList recipientsListMsg <- messageI Info MsgCommRecipientsList
$logWarnS "COMM" "Communication handler some definitions done" $logWarnS "COMM" "Communication handler some definitions done"
-- attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize
-- let attachmentField = genericFileField $ return FileField let attachmentField = genericFileField $ return FileField
-- { fieldIdent = Nothing { fieldIdent = Nothing
-- , fieldUnpackZips = FileFieldUserOption True False , fieldUnpackZips = FileFieldUserOption True False
-- , fieldMultiple = True , fieldMultiple = True
-- , fieldRestrictExtensions = Nothing , fieldRestrictExtensions = Nothing
-- , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty
-- , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize
-- , fieldAllEmptyOk = True , fieldAllEmptyOk = True
-- } }
$logWarnS "COMM" "Communication handler some parameters done" -- SEEN $logWarnS "COMM" "Communication handler some parameters done" -- SEEN
((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication ((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication
<$> recipientAForm <$> recipientAForm
<* aformMessage recipientsListMsg <* aformMessage recipientsListMsg
<*> (pure (CommunicationContent (Just "subject") (text2Html "body") Set.empty) :: AForm Handler CommunicationContent) <*> ( CommunicationContent
-- <*> ( CommunicationContent <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing
-- <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing)
-- <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing) <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField)
-- <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField) (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing)
-- (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing) )
-- )
$logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN ANYMORE $logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN ANYMORE
formResult commRes $ \case formResult commRes $ \case
(comm, BtnCommunicationSend) -> do (comm, BtnCommunicationSend) -> do