270 lines
10 KiB
Haskell
270 lines
10 KiB
Haskell
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
|
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
|
|
-- TODO: remove these above
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
|
|
module Handler.MailCenter
|
|
( getMailCenterR, postMailCenterR
|
|
, getMailHtmlR
|
|
, getMailPlainR
|
|
) 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 Utils.Print
|
|
|
|
import Handler.Utils
|
|
-- import Handler.Utils.Csv
|
|
-- import qualified Data.Csv as Csv
|
|
-- import qualified Data.CaseInsensitive as CI
|
|
|
|
-- import Jobs.Queue
|
|
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 Data.Text (Text)
|
|
|
|
|
|
-- import qualified Data.Text.Lazy as LT
|
|
-- import qualified Data.Text.Lazy.Encoding as LT
|
|
import qualified Data.ByteString.Lazy as LB
|
|
|
|
import Data.Char as C
|
|
|
|
import qualified Data.Text as T
|
|
-- import qualified Data.Text.Encoding as TE
|
|
-- import qualified Data.ByteString.Char8 as BS
|
|
|
|
import Data.Bits
|
|
-- import Data.Word
|
|
|
|
-- avoids repetition of local definitions
|
|
single :: (k,a) -> Map k a
|
|
single = uncurry Map.singleton
|
|
|
|
|
|
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 MsgMenuMailHtml) $ \(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 = mconcat
|
|
[ single ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
|
|
, single ("recipient" , sortUserNameBareM queryRecipient)
|
|
]
|
|
dbtFilter = mconcat
|
|
[ single ("sent" , FilterColumn . E.mkDayFilter $ views (to queryMail) (E.^. SentMailSentAt))
|
|
, single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName))
|
|
, single ("subject" , FilterColumn . E.mkContainsFilter $ 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)
|
|
]
|
|
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 = 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")
|
|
|
|
|
|
getMailHtmlR :: CryptoUUIDSentMail -> Handler Html
|
|
getMailHtmlR = handleMailShow [typeHtml,typePlain]
|
|
|
|
getMailPlainR :: CryptoUUIDSentMail -> Handler Html
|
|
getMailPlainR = handleMailShow [typePlain,typeHtml]
|
|
|
|
handleMailShow :: [ContentType] -> CryptoUUIDSentMail -> Handler Html
|
|
handleMailShow prefTypes cusm = do
|
|
smid <- decrypt cusm
|
|
(sm,cn) <- runDB $ do
|
|
sm <- get404 smid
|
|
cn <- get404 $ sm ^. _sentMailContentRef
|
|
return (sm,cn)
|
|
siteLayoutMsg MsgMenuMailCenter $ do
|
|
setTitleI MsgMenuMailCenter
|
|
let mcontent = getMailContent (sentMailContentContent cn)
|
|
getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
|
|
[whamlet|
|
|
<section>
|
|
<dl .deflist>
|
|
<dt .deflist__dt>
|
|
_{MsgPrintJobCreated}
|
|
<dd .deflist__dd>
|
|
^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)}
|
|
$maybe r <- getHeader "From"
|
|
<dt .deflist__dt>
|
|
_{MsgPrintSender}
|
|
<dd .deflist__dd>
|
|
#{decodeMime r}
|
|
$maybe r <- getHeader "To"
|
|
<dt .deflist__dt>
|
|
_{MsgPrintRecipient}
|
|
<dd .deflist__dd>
|
|
#{decodeMime r}
|
|
$maybe r <- getHeader "Subject"
|
|
<dt .deflist__dt>
|
|
_{MsgCommSubject}
|
|
<dd .deflist__dd>
|
|
#{decodeMime r}
|
|
|
|
<section>
|
|
$forall mc <- mcontent
|
|
$maybe pt <- selectAlternative prefTypes mc
|
|
<p>
|
|
^{part2widget pt}
|
|
|]
|
|
-- ^{jsonWidget (sm ^. _sentMailHeaders)}
|
|
-- ^{jsonWidget (sentMailContentContent cn)}
|
|
|
|
|
|
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
|
|
|
|
disposition2widget :: Disposition -> Widget
|
|
disposition2widget (AttachmentDisposition n) = [whamlet|<h3>Attachment #{n}|]
|
|
disposition2widget (InlineDisposition n) = [whamlet|<h3>#{n}|]
|
|
disposition2widget DefaultDisposition = mempty
|
|
|
|
part2widget :: Part -> Widget
|
|
part2widget Part{partContent=NestedParts ps} =
|
|
[whamlet|
|
|
<section>
|
|
$forall p <- ps
|
|
^{part2widget p}
|
|
<hr>
|
|
<hr>
|
|
|]
|
|
part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
|
|
[whamlet|
|
|
<section>
|
|
^{disposition2widget dispo}
|
|
^{showBody}
|
|
<hr>
|
|
|]
|
|
where
|
|
showBody
|
|
| pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plaintextToHtml $ decodeUtf8 pc
|
|
| pt == decodeUtf8 typeHtml = toWidget $ preEscapedToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
|
|
| pt == decodeUtf8 typeJson =
|
|
let jw :: Aeson.Value -> Widget = jsonWidget
|
|
in either str2widget jw $ Aeson.eitherDecodeStrict' pc
|
|
| otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|]
|
|
|
|
|
|
-- | decode the MIME encoded-word format, which is used in email headers to encode non-ASCII text. This format is specified in RFC 2047.
|
|
decodeMime :: Text -> Text
|
|
decodeMime = id -- TODO |