370 lines
15 KiB
Haskell
370 lines
15 KiB
Haskell
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
|
--
|
|
-- 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|
|
|
<section>
|
|
<dl .deflist>
|
|
<dt .deflist__dt>
|
|
_{MsgPrintJobCreated}
|
|
<dd .deflist__dd>
|
|
^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)}
|
|
$maybe usr <- sm ^. _sentMailRecipient
|
|
<dt .deflist__dt>
|
|
_{MsgPrintRecipient}
|
|
<dd .deflist__dd>
|
|
^{userIdWidget usr}
|
|
$maybe r <- getHeader "To"
|
|
<dt .deflist__dt>
|
|
To
|
|
<dd .deflist__dd>
|
|
#{decodeEncodedWord r}
|
|
$maybe r <- getHeader "Cc"
|
|
<dt .deflist__dt>
|
|
Cc
|
|
<dd .deflist__dd>
|
|
#{decodeEncodedWord r}
|
|
$maybe r <- getHeader "From"
|
|
<dt .deflist__dt>
|
|
From
|
|
<dd .deflist__dd>
|
|
#{decodeEncodedWord r}
|
|
$maybe r <- getHeader "Subject"
|
|
<dt .deflist__dt>
|
|
_{MsgCommSubject}
|
|
<dd .deflist__dd>
|
|
#{decodeEncodedWord r}
|
|
|
|
<section>
|
|
$forall pt <- mparts
|
|
^{part2widget cusm pt}
|
|
|]
|
|
-- Include for Debugging:
|
|
-- <section>
|
|
-- <h2>Debugging
|
|
-- <p>
|
|
-- ^{jsonWidget (sm ^. _sentMailHeaders)}
|
|
-- <p>
|
|
-- ^{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|<h3>_{MsgMailFileAttachment}|]
|
|
disposition2widget (InlineDisposition n) = [whamlet|<h3>_{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|
|
|
<section>
|
|
^{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|<a href=@{MailAttachmentR cusm t}>#{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|<h2>Not found: #{sdn}|]
|
|
Just Entity{entityVal = u@User{userPinPassword=mbpw}} ->
|
|
[whamlet|
|
|
<section>
|
|
$maybe pw <- mbpw
|
|
<details>
|
|
<summary>
|
|
_{MsgAdminUserPinPassword}
|
|
<p>
|
|
<dl .deflist>
|
|
<dt .deflist__dt>
|
|
^{userWidget u}
|
|
<dd .deflist__dd>
|
|
<b>
|
|
#{pw}
|
|
<p>
|
|
_{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
|