-- SPDX-FileCopyrightText: 2024 Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later {-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.MailCenter ( getMailCenterR, postMailCenterR , getMailHtmlR , getMailPlainR , getMailAttachmentR ) where import Import import qualified Data.Set as Set import qualified Data.Map as Map -- import qualified Data.Aeson as Aeson -- import qualified Data.Text as Text -- import Database.Persist.Sql (updateWhereCount) -- import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Legacy as EL (on) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import qualified Data.Aeson as Aeson import Text.Blaze.Html (preEscapedToHtml) -- import Text.Blaze.Html5 as H (html, body, pre, p, h1) -- import Text.Blaze.Html.Renderer.String (renderHtml) import Numeric (readHex) import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as LB import Handler.Utils data MCTableAction = MCActDummy -- just a dummy, since we don't now yet which actions we will be needing deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) instance Universe MCTableAction instance Finite MCTableAction nullaryPathPiece ''MCTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''MCTableAction id data MCTableActionData = MCActDummyData deriving (Eq, Ord, Read, Show, Generic) type MCTableExpr = ( E.SqlExpr (Entity SentMail) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) ) queryMail :: MCTableExpr -> E.SqlExpr (Entity SentMail) queryMail = $(sqlLOJproj 2 1) queryRecipient :: MCTableExpr -> E.SqlExpr (Maybe (Entity User)) queryRecipient = $(sqlLOJproj 2 2) type MCTableData = DBRow (Entity SentMail, Maybe (Entity User)) resultMail :: Lens' MCTableData (Entity SentMail) resultMail = _dbrOutput . _1 resultRecipient :: Traversal' MCTableData (Entity User) resultRecipient = _dbrOutput . _2 . _Just mkMCTable :: DB (FormResult (MCTableActionData, Set SentMailId), Widget) mkMCTable = do let dbtSQLQuery :: MCTableExpr -> E.SqlQuery (E.SqlExpr (Entity SentMail), E.SqlExpr (Maybe (Entity User))) dbtSQLQuery (mail `E.LeftOuterJoin` recipient) = do EL.on $ mail E.^. SentMailRecipient E.==. recipient E.?. UserId return (mail, recipient) dbtRowKey = queryMail >>> (E.^. SentMailId) dbtProj = dbtProjId dbtColonnade = mconcat [ -- dbSelect (applying _2) id (return . view (resultMail . _entityKey)) sortable (Just "sent") (i18nCell MsgPrintJobCreated) $ \( view $ resultMail . _entityVal . _sentMailSentAt -> t) -> dateTimeCell t , sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR , sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) -> let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject in anchorCellM (MailHtmlR <$> encrypt k) linkWgt -- , sortable Nothing (i18nCell MsgCommContent) $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html") -- , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h ] dbtSorting = Map.fromList [ ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt)) , ("recipient" , sortUserNameBareM queryRecipient) ] dbtFilter = Map.fromList [ ("sent" , FilterColumn . E.mkDayFilterTo $ views (to queryMail) (E.^. SentMailSentAt)) , ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) , ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) -- , ("regex" , FilterColumn . E.mkRegExFilterWith id $ views (to queryMail) (E.str2text . (E.^. SentMailHeaders))) ] dbtFilterUI mPrev = mconcat [ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) , prismAForm (singletonFilter "recipient" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintRecipient & setTooltip MsgTableFilterCommaPlus) , prismAForm (singletonFilter "subject" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject & setTooltip MsgTableFilterCommaPlusShort) -- , prismAForm (singletonFilter "regex" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgCommSubject ) ] dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout} dbtIdent :: Text dbtIdent = "sent-mail" dbtCsvEncode = noCsvEncode dbtCsvDecode = Nothing dbtExtraReps = [] dbtParams = DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] , dbParamsFormSubmit = FormNoSubmit , dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty) -- , dbParamsFormSubmit = FormSubmit -- , dbParamsFormAdditional -- = let acts :: Map MCTableAction (AForm Handler MCTableActionData) -- acts = mconcat -- [ singletonMap MCActDummy $ pure MCActDummyData -- ] -- in renderAForm FormStandard -- $ (, mempty) . First . Just -- <$> multiActionA acts (fslI MsgTableAction) Nothing , dbParamsFormEvaluate = liftHandler . runFormPost , dbParamsFormResult = id , dbParamsFormIdent = def } postprocess :: FormResult (First MCTableActionData, DBFormResult SentMailId Bool MCTableData) -> FormResult ( MCTableActionData, Set SentMailId) postprocess inp = do (First (Just act), jobMap) <- inp let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap return (act, jobSet) psValidator = def & defaultSorting [SortDescBy "sent"] over _1 postprocess <$> dbTable psValidator DBTable{..} getMailCenterR, postMailCenterR :: Handler Html getMailCenterR = postMailCenterR postMailCenterR = do (mcRes, mcTable) <- runDB mkMCTable formResult mcRes $ \case (MCActDummyData, Set.toList -> _smIds) -> do addMessageI Success MsgBoolIrrelevant reloadKeepGetParams MailCenterR siteLayoutMsg MsgMenuMailCenter $ do setTitleI MsgMenuMailCenter $(widgetFile "mail-center") typePDF :: ContentType typePDF = "application/pdf" getMailAttachmentR :: CryptoUUIDSentMail -> Text -> Handler TypedContent getMailAttachmentR cusm attdisp = do smid <- decrypt cusm (sm,cn) <- runDBRead $ do sm <- get404 smid cn <- get404 $ sm ^. _sentMailContentRef return (sm,cn) let mcontent = getMailContent (sentMailContentContent cn) getAttm alts = case selectAlternative [typePDF] alts of (Just Part{partContent=PartContent (LB.toStrict -> pc), partDisposition=AttachmentDisposition t}) -- partType=pt, | t == attdisp -> Just pc _ -> Nothing attm = firstJust getAttm mcontent case attm of (Just pc) -> sendByteStringAsFile (T.unpack attdisp) pc $ sm ^. _sentMailSentAt _ -> notFound getMailHtmlR :: CryptoUUIDSentMail -> Handler Html getMailHtmlR = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml]) [typeHtml,typePlain] getMailPlainR :: CryptoUUIDSentMail -> Handler Html getMailPlainR = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailPlain]) [typePlain,typeHtml] handleMailShow :: _ -> [ContentType] -> CryptoUUIDSentMail -> Handler Html handleMailShow hdr prefTypes cusm = do smid <- decrypt cusm (sm,cn) <- runDBRead $ do sm <- get404 smid cn <- get404 $ sm ^. _sentMailContentRef return (sm,cn) siteLayout' Nothing $ do setTitleI hdr let mcontent = getMailContent (sentMailContentContent cn) getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders') mparts = reorderParts $ mapMaybe (selectAlternative prefTypes) mcontent [whamlet|
_{MsgPrintJobCreated}
^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)} $maybe usr <- sm ^. _sentMailRecipient
_{MsgPrintRecipient}
^{userIdWidget usr} $maybe r <- getHeader "To"
To
#{decodeEncodedWord r} $maybe r <- getHeader "Cc"
Cc
#{decodeEncodedWord r} $maybe r <- getHeader "From"
From
#{decodeEncodedWord r} $maybe r <- getHeader "Subject"
_{MsgCommSubject}
#{decodeEncodedWord r}
$forall pt <- mparts ^{part2widget cusm pt} |] -- Include for Debugging: --
--

Debugging --

-- ^{jsonWidget (sm ^. _sentMailHeaders)} --

-- ^{jsonWidget (sentMailContentContent cn)} -- content fields needs decoding of base64 to make sense here selectAlternative :: [ContentType] -> Alternatives -> Maybe Part selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts where aux ts@(ct:_) (pt:ps) | ct == partType pt = Just pt | otherwise = aux ts ps aux (_:ts) [] = aux ts allAlts aux [] (pt:_) = Just pt aux _ [] = Nothing reorderParts :: [Part] -> [Part] reorderParts = sortBy pOrder where pOrder Part{partDisposition=d1} Part{partDisposition=d2} = dispoOrder d1 d2 dispoOrder DefaultDisposition DefaultDisposition = EQ dispoOrder DefaultDisposition _ = LT dispoOrder _ DefaultDisposition = GT dispoOrder (InlineDisposition t1) (InlineDisposition t2) = compare t1 t2 dispoOrder (InlineDisposition _) _ = LT dispoOrder _ (InlineDisposition _) = GT dispoOrder (AttachmentDisposition t1) (AttachmentDisposition t2) = compare t1 t2 disposition2widget :: Disposition -> Widget disposition2widget (AttachmentDisposition _) = [whamlet|

_{MsgMailFileAttachment}|] disposition2widget (InlineDisposition n) = [whamlet|

_{MsgMenuMailAttachment} #{n}|] disposition2widget DefaultDisposition = mempty part2widget :: CryptoUUIDSentMail -> Part -> Widget part2widget cusm Part{partContent=NestedParts ps} = [whamlet| $forall p <- ps ^{part2widget cusm p} |] part2widget cusm Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} = [whamlet|
^{disposition2widget dispo} ^{showBody} ^{showPass} |] where showBody | pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plainTextToHtml $ decodeUtf8 pc | pt == decodeUtf8 typeHtml = toWidget $ preEscapedToHtml $ plainHtmlToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html | pt == decodeUtf8 typeJson = let jw :: Aeson.Value -> Widget = jsonWidget in either str2widget jw $ Aeson.eitherDecodeStrict' pc | pt == decodeUtf8 typePDF , AttachmentDisposition t <- dispo = [whamlet|#{t}|] | otherwise = [whamlet|FRADrive cannot decode email parts of type #{pt} yet.|] showPass | pt == decodeUtf8 typePlain , let cw = T.words $ decodeUtf8 pc , Just name <- listBracket ("Inhaber","Gültig") cw -- heursitic for dirving licence renewal letters only; improve <|> listBracket ("Licensee","Valid") cw = let sdn = T.filter (/= '*') (T.unwords $ dropWhile (":"==) name) in liftHandler (runDBRead $ getByFilter [UserDisplayName ==. sdn]) >>= \case Nothing -> mempty -- DEBUG: [whamlet|

Not found: #{sdn}|] Just Entity{entityVal = u@User{userPinPassword=mbpw}} -> [whamlet|
$maybe pw <- mbpw
_{MsgAdminUserPinPassword}

^{userWidget u}
#{pw}

_{MsgAdminUserPinPassNotIncluded} $nothing _{MsgAdminUserNoPassword} |] | otherwise = mempty ------------------------------ -- Decode MIME Encoded Word -- | decode the MIME encoded-word format, which is used in email headers to encode non-ASCII text. This format is specified in RFC 2047. decodeEncodedWord :: Text -> Text decodeEncodedWord tinp | (pl, T.drop 2 -> cf) <- T.breakOn "=?" tinp , (cw, T.drop 2 -> rm) <- T.breakOn "?=" cf , notNull cw = pl <> decodeEncodedWordHeader cw <> decodeEncodedWord rm | otherwise = tinp decodeEncodedWordHeader :: Text -> Text decodeEncodedWordHeader tinp | [enc, bin, cw] <- T.splitOn "?" tinp , "utf-8" == T.toLower enc , "Q" == T.toUpper bin -- Quoted Printable Text = decEncWrdUtf8Q cw -- TODO: add more decoders for other possible encodings here, but "=?utf-8?Q?..?=" is the only one used by Network.Mail.Mime at the moment | otherwise = tinp decEncWrdUtf8Q :: Text -> Text decEncWrdUtf8Q tinp | Right ok <- TE.decodeUtf8' $ decWds tinp = ok | otherwise = tinp where decWds :: Text -> S.ByteString decWds t | (h:tl) <- T.splitOn "=" t = mconcat $ TE.encodeUtf8 h : map deco tl | otherwise = TE.encodeUtf8 t deco :: Text -> S.ByteString deco w | (c,r) <- T.splitAt 2 w , [(v,"")] <- readHex $ T.unpack c = S.cons v $ TE.encodeUtf8 r | otherwise = TE.encodeUtf8 w