fraport/fradrive
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{..} = do
$logWarnS "COMM" "Communication handleer started"
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))
let decrypt' :: CryptoUUIDUser -> DB (Maybe (Entity User))
decrypt' cID = do
uid <- decrypt cID
whenIsJust crRecipientAuth $ guardAuthResult <=< ($ uid)
getEntity uid
chosen' <- fmap (maybe id cons cUser . catMaybes) $ mapM decrypt' =<< lookupGlobalGetParams GetRecipient
return (suggested, chosen')
cUser <- maybeAuth
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) <> ")")
let
lookupUser :: UserId -> User
lookupUser lId
= entityVal . headDef (error $ "this is it" <> show lId) . filter ((== lId) . entityKey) $ concatMap (view _2) suggestedRecipients ++ chosenRecipients
lookupUser :: UserId -> (UserDisplayName,UserSurname)
lookupUser =
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 $
[ ( (BoundedPosition $ RecipientGroup g, pos)
@ -187,7 +184,7 @@ commR CommunicationRoute{..} = do
miCell _ (Left (CI.original -> email)) initRes nudge csrf = do
(tickRes, tickView) <- mpreq checkBoxField ("" & addName (nudge "tick")) $ initRes <|> Just True
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
| fmap entityKey cUser == Just uid
-> mforced checkBoxField ("" & addName (nudge "tick")) True
@ -239,27 +236,26 @@ commR CommunicationRoute{..} = do
recipientsListMsg <- messageI Info MsgCommRecipientsList
$logWarnS "COMM" "Communication handler some definitions done"
-- attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize
-- let attachmentField = genericFileField $ return FileField
-- { fieldIdent = Nothing
-- , fieldUnpackZips = FileFieldUserOption True False
-- , fieldMultiple = True
-- , fieldRestrictExtensions = Nothing
-- , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty
-- , fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize
-- , fieldAllEmptyOk = True
-- }
attachmentsMaxSize <- getsYesod $ view _appCommunicationAttachmentsMaxSize
let attachmentField = genericFileField $ return FileField
{ fieldIdent = Nothing
, fieldUnpackZips = FileFieldUserOption True False
, fieldMultiple = True
, fieldRestrictExtensions = Nothing
, fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty
, fieldMaxFileSize = Nothing, fieldMaxCumulativeSize = attachmentsMaxSize
, fieldAllEmptyOk = True
}
$logWarnS "COMM" "Communication handler some parameters done" -- SEEN
((commRes,commWdgt),commEncoding) <- runFormPost . identifyForm FIDCommunication . withButtonForm' universeF . renderAForm FormStandard $ Communication
<$> recipientAForm
<* aformMessage recipientsListMsg
<*> (pure (CommunicationContent (Just "subject") (text2Html "body") Set.empty) :: AForm Handler CommunicationContent)
-- <*> ( CommunicationContent
-- <$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing
-- <*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing)
-- <*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField)
-- (fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing)
-- )
<*> ( CommunicationContent
<$> aopt textField (fslI MsgCommSubject & addAttr "uw-enter-as-tab" "") Nothing
<*> (markupOutput <$> areq htmlField (fslI MsgCommBody) Nothing)
<*> fmap fold (aopt (convertFieldM (runConduit . (.| C.foldMap Set.singleton)) yieldMany attachmentField)
(fslI MsgCommAttachments & setTooltip MsgCommAttachmentsTip) Nothing)
)
$logWarnS "COMM" "Communication handler run form post done" -- NOT SEEN ANYMORE
formResult commRes $ \case
(comm, BtnCommunicationSend) -> do