-- SPDX-FileCopyrightText: 2024 Steffen Jost -- -- 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")