173 lines
8.0 KiB
Haskell
173 lines
8.0 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.CommCenter
|
|
( getCommCenterR
|
|
) 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 Data.Text.Lens (packed)
|
|
-- import qualified Data.Text.Lazy as LT
|
|
-- import qualified Data.Text.Lazy.Encoding as LT
|
|
import qualified Data.ByteString.Lazy as LB
|
|
|
|
|
|
|
|
-- avoids repetition of local definitions
|
|
single :: (k,a) -> Map k a
|
|
single = uncurry Map.singleton
|
|
|
|
|
|
data CCTableAction = CCActDummy -- 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 CCTableAction
|
|
instance Finite CCTableAction
|
|
nullaryPathPiece ''CCTableAction $ camelToPathPiece' 2
|
|
embedRenderMessage ''UniWorX ''CCTableAction id
|
|
|
|
data CCTableActionData = CCActDummyData
|
|
deriving (Eq, Ord, Read, Show, Generic)
|
|
|
|
|
|
-- SJ: I don't know how to use E.unionAll_ with dbTable, so we simulate it by a FullOuterJoin with constant False ON-clause instead
|
|
type CCTableExpr =
|
|
( (E.SqlExpr (Maybe (Entity User)) `E.InnerJoin` E.SqlExpr (Maybe (Entity SentMail)))
|
|
`E.FullOuterJoin` (E.SqlExpr (Maybe (Entity User)) `E.InnerJoin` E.SqlExpr (Maybe (Entity PrintJob)))
|
|
)
|
|
|
|
queryRecipientMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity User))
|
|
queryRecipientMail = $(sqlIJproj 2 1) . $(sqlFOJproj 2 1)
|
|
|
|
queryMail :: CCTableExpr -> E.SqlExpr (Maybe (Entity SentMail))
|
|
queryMail = $(sqlIJproj 2 2) . $(sqlFOJproj 2 1)
|
|
|
|
queryRecipientPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity User))
|
|
queryRecipientPrint = $(sqlIJproj 2 1) . $(sqlFOJproj 2 2)
|
|
|
|
queryPrint :: CCTableExpr -> E.SqlExpr (Maybe (Entity PrintJob))
|
|
queryPrint = $(sqlIJproj 2 2) . $(sqlFOJproj 2 2)
|
|
|
|
type CCTableData = DBRow (Maybe (Entity User), Maybe (Entity SentMail), Maybe (Entity User), Maybe (Entity PrintJob))
|
|
|
|
resultRecipientMail :: Traversal' CCTableData (Entity User)
|
|
resultRecipientMail = _dbrOutput . _1 . _Just
|
|
|
|
resultMail :: Traversal' CCTableData (Entity SentMail)
|
|
resultMail = _dbrOutput . _2 . _Just
|
|
|
|
resultRecipientPrint :: Traversal' CCTableData (Entity User)
|
|
resultRecipientPrint = _dbrOutput . _3 . _Just
|
|
|
|
resultPrint :: Traversal' CCTableData (Entity PrintJob)
|
|
resultPrint = _dbrOutput . _4 . _Just
|
|
|
|
|
|
mkCCTable :: DB (Any, Widget)
|
|
mkCCTable = do
|
|
let
|
|
dbtSQLQuery :: CCTableExpr -> E.SqlQuery (E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity SentMail)), E.SqlExpr (Maybe (Entity User)), E.SqlExpr (Maybe (Entity PrintJob)))
|
|
dbtSQLQuery ((recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (recipientPrint `E.InnerJoin` printJob)) = do
|
|
EL.on $ recipientMail E.?. UserId E.==. E.joinV (mail E.?. SentMailRecipient)
|
|
EL.on $ recipientPrint E.?. UserId E.==. E.joinV (printJob E.?. PrintJobRecipient)
|
|
-- EL.on $ recipientMail E.?. UserId E.==. recipientPrint E.?. UserId E.&&. E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_
|
|
EL.on E.false -- simulating E.unionAll_ by a constant false full outer join, since it is unclear how dbTable could handle E.unionAll_
|
|
-- E.where_ $ E.isJust (recipientMail E.?. UserId) E.||. E.isJust (recipientPrint E.?. UserId) -- not needed
|
|
-- return (E.coalesce[recipientMail, recipientPrint], mail, print) -- coalesce only works on values, not entities
|
|
return (recipientMail, mail, recipientPrint, printJob)
|
|
-- dbtRowKey = (,) <$> views (to queryMail) (E.?. SentMailId) <*> views (to queryPrint) (E.?. PrintJobId)
|
|
dbtRowKey ((_recipientMail `E.InnerJoin` mail) `E.FullOuterJoin` (_recipientPrint `E.InnerJoin` printJob)) = (mail E.?. SentMailId, printJob E.?. PrintJobId)
|
|
|
|
dbtProj = dbtProjId
|
|
dbtColonnade = dbColonnade $ mconcat -- prefer print over email in the impossible case that both are Just
|
|
[ sortable (Just "date") (i18nCell MsgPrintJobCreated) $ \row ->
|
|
let tprint = row ^? resultPrint . _entityVal . _printJobCreated
|
|
tmail = row ^? resultMail . _entityVal . _sentMailSentAt
|
|
in maybeCell (tprint <|> tmail) dateTimeCell
|
|
, sortable (Just "recipient") (i18nCell MsgPrintRecipient) $ \row ->
|
|
let uprint = row ^? resultRecipientPrint
|
|
umail = row ^? resultRecipientMail
|
|
in maybeCell (uprint <|> umail) $ cellHasUserLink AdminUserR
|
|
, sortable Nothing (i18nCell MsgCommBody) $ \row -> if
|
|
| (Just k) <- row ^? resultPrint . _entityKey
|
|
-> anchorCellM (PrintDownloadR <$> encrypt k) $ toWgt (iconLetterOrEmail True ) <> text2widget "-link"
|
|
| (Just k) <- row ^? resultMail . _entityKey
|
|
-> anchorCellM (MailHtmlR <$> encrypt k) $ toWgt (iconLetterOrEmail False) <> text2widget "-link"
|
|
| otherwise
|
|
-> mempty
|
|
, sortable Nothing (i18nCell MsgCommSubject) $ \row ->
|
|
let tsubject = row ^? resultPrint . _entityVal . _printJobFilename . packed
|
|
msubject = row ^? resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
|
|
in maybeCell (tsubject <|> msubject) textCell
|
|
]
|
|
dbtSorting = mconcat
|
|
[ singletonMap "date" $ SortColumn $ \row -> E.coalesce [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt]
|
|
, singletonMap "recipient" $ SortColumns $ \row ->
|
|
[ SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserSurname , queryRecipientMail row E.?. UserSurname ]
|
|
, SomeExprValue $ E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName]
|
|
]
|
|
]
|
|
dbtFilter = mconcat
|
|
[ single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
|
|
$ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName])
|
|
, single ("subject" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
|
|
$ \row -> E.coalesce [E.str2text' $ queryPrint row E.?. PrintJobFilename
|
|
,E.str2text' $ queryMail row E.?. SentMailHeaders ])
|
|
]
|
|
dbtFilterUI mPrev = mconcat
|
|
[ 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 = "comms"
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
dbtExtraReps = []
|
|
dbtParams = def
|
|
psValidator = def & defaultSorting [SortDescBy "date"]
|
|
dbTable psValidator DBTable{..}
|
|
|
|
getCommCenterR :: Handler Html
|
|
getCommCenterR = do
|
|
(_, ccTable) <- runDB mkCCTable
|
|
siteLayoutMsg MsgMenuMailCenter $ do
|
|
setTitleI MsgMenuMailCenter
|
|
$(widgetFile "comm-center")
|
|
|