151 lines
8.1 KiB
Haskell
151 lines
8.1 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.CommCenter
|
|
( getCommCenterR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
|
|
-- import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
-- import qualified Data.Text as Text
|
|
import Data.Text.Lens (packed)
|
|
|
|
-- 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 qualified Database.Esqueleto.PostgreSQL as E
|
|
import Database.Esqueleto.Utils.TH
|
|
|
|
|
|
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 for full outer join
|
|
-- 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 = Map.fromList
|
|
[ ("sentTo" , FilterColumn . E.mkDayFilterTo
|
|
$ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used
|
|
, ("sentFrom" , FilterColumn . E.mkDayFilterFrom
|
|
$ \row -> E.coalesceDefault [queryPrint row E.?. PrintJobCreated, queryMail row E.?. SentMailSentAt] E.now_) -- either one is guaranteed to be non-null, default never used
|
|
, ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
|
|
$ \row -> E.coalesce [queryRecipientPrint row E.?. UserDisplayName, queryRecipientMail row E.?. UserDisplayName])
|
|
, ("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 "sentTo" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableFilterSentBefore)
|
|
, prismAForm (singletonFilter "sentFrom" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgTableFilterSentAfter)
|
|
, 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 MsgMenuCommCenter $ do
|
|
setTitleI MsgMenuCommCenter
|
|
$(widgetFile "comm-center")
|
|
|