From 4df8bd2fa5e2c785aefbed105eadf01cd920a814 Mon Sep 17 00:00:00 2001 From: Steffen Date: Fri, 2 Aug 2024 18:28:16 +0200 Subject: [PATCH] chore(mail): stub towards #171 new routes /mail and /mail/show/UUID to eventually display all sent emails by the system --- .../uniworx/categories/print/de-de-formal.msg | 4 +- messages/uniworx/categories/print/en-eu.msg | 4 +- .../utils/navigation/menu/de-de-formal.msg | 3 + .../uniworx/utils/navigation/menu/en-eu.msg | 3 + routes | 3 + src/Application.hs | 13 +- src/CryptoID.hs | 1 + src/Foundation/Navigation.hs | 7 +- src/Handler/Course/Edit.hs | 2 +- src/Handler/LMS.hs | 2 +- src/Handler/MailCenter.hs | 144 ++++++++++++++++++ src/Handler/PrintCenter.hs | 10 +- templates/mail-center.hamlet | 9 ++ 13 files changed, 188 insertions(+), 17 deletions(-) create mode 100644 src/Handler/MailCenter.hs create mode 100644 templates/mail-center.hamlet diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index d2c275335..3cc18f0ee 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -26,4 +26,6 @@ PrintPDF !ident-ok: PDF PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden PrintLmsUser: E‑Learning Id PrintJobs: Druckaufräge -PrintLetterType: Brieftypkürzel \ No newline at end of file +PrintLetterType: Brieftypkürzel + +MCActDummy: Platzhalter \ No newline at end of file diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg index dbe776ebe..2b491983e 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -26,4 +26,6 @@ PrintPDF: PDF PrintManualRenewal: Manual sending of an apron driver's licence renewal letter PrintLmsUser: E‑learning id PrintJobs: Print jobs -PrintLetterType: Letter type shorthand \ No newline at end of file +PrintLetterType: Letter type shorthand + +MCActDummy: Placeholder \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index eab4f204e..8979eacc5 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -149,6 +149,9 @@ MenuPrintDownload: Brief herunterladen MenuPrintLog: LPR Schnittstelle MenuPrintAck: Druckbestätigung +MenuMailCenter: E‑Mails +MenuMailShow: Anzeige + MenuApiDocs: API-Dokumentation (Englisch) MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 526c6d871..09399e8bf 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -149,6 +149,9 @@ MenuPrintDownload: Download Letter MenuPrintLog: LPR Interface MenuPrintAck: Acknowledge Printing +MenuMailCenter: Email +MenuMailShow: Display + MenuApiDocs: API documentation MenuSwagger: OpenAPI 2.0 (Swagger) diff --git a/routes b/routes index c484282ac..762594efd 100644 --- a/routes +++ b/routes @@ -84,6 +84,9 @@ /print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer /print/log PrintLogR GET !system-printer +/mail MailCenterR GET POST +/mail/show/#CryptoUUIDSentMail MailShowR GET + /health HealthR GET !free /health/interface/+Texts HealthInterfaceR GET !free /instance InstanceR GET !free diff --git a/src/Application.hs b/src/Application.hs index e7dc88b68..30f6d9469 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -158,6 +158,7 @@ import Handler.Qualification import Handler.LMS import Handler.SAP import Handler.PrintCenter +import Handler.MailCenter import Handler.ApiDocs import Handler.Swagger import Handler.Firm @@ -352,15 +353,15 @@ makeFoundation appSettings''@AppSettings{..} = do handleIf isBucketExists (const $ return ()) $ Minio.makeBucket appUploadTmpBucket Nothing return conn - appAvsQuery <- case appAvsConf of + appAvsQuery <- case appAvsConf of Nothing -> do $logErrorS "avsPrepare" "appAvsConfig is empty, i.e. invalid AVS configuration settings." return Nothing - -- error "AvsConfig is empty, i.e. invalid AVS configuration settings." - - Just avsConf -> do + -- error "AvsConfig is empty, i.e. invalid AVS configuration settings." + + Just avsConf -> do manager <- newManagerSettings $ mkManagerSettings (def { settingDisableCertificateValidation = True }) Nothing - let avsServer = BaseUrl + let avsServer = BaseUrl { baseUrlScheme = Https , baseUrlHost = avsHost avsConf , baseUrlPort = avsPort avsConf @@ -657,7 +658,7 @@ appMain = runResourceT $ do notifyWatchdog = forever' Nothing $ \pResults -> do let delay = floor $ wInterval % 4 d <- liftIO $ newDelay delay - + $logDebugS "Notify" $ "Waiting up to " <> tshow delay <> "µs..." mResults <- atomically $ asum [ pResults <$ waitDelay d diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 9d724bbee..9c4fdfaa1 100644 --- a/src/CryptoID.hs +++ b/src/CryptoID.hs @@ -59,6 +59,7 @@ decCryptoIDs [ ''SubmissionId , ''MaterialFileId , ''PrintJobId , ''QualificationId + , ''SentMailId ] decCryptoIDKeySize diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index b485a7018..af634108c 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -136,6 +136,9 @@ breadcrumb PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenter breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck $ Just PrintCenterR breadcrumb PrintLogR = i18nCrumb MsgMenuPrintLog $ Just PrintCenterR +breadcrumb MailCenterR = i18nCrumb MsgMenuMailCenter Nothing +breadcrumb MailShowR{} = i18nCrumb MsgMenuMailShow $ Just MailCenterR + breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR breadcrumb (SchoolR ssh sRoute) = case sRoute of SchoolEditR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool $ Just SchoolListR) $ do @@ -1225,7 +1228,7 @@ pageActions (AdminUserR cID) = return , NavPageActionPrimary { navLink = defNavLink MsgMenuUserEdit $ ForProfileR cID , navChildren = [] - } + } , NavPageActionPrimary { navLink = defNavLinkModal MsgUserHijack $ AdminHijackUserR cID , navChildren = [] @@ -1461,7 +1464,7 @@ pageActions (ForProfileDataR cID) = return [ NavPageActionPrimary { navLink = defNavLink MsgAdminUserHeading $ AdminUserR cID , navChildren = [] - } + } ] pageActions TermShowR = do participantsSecondary <- pageQuickActions NavQuickViewPageActionSecondary ParticipantsListR diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 6c0c7e851..c1df2fd59 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index b4e8f0b83..27fd41991 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs new file mode 100644 index 000000000..ce4b2b06e --- /dev/null +++ b/src/Handler/MailCenter.hs @@ -0,0 +1,144 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.MailCenter + ( getMailCenterR, postMailCenterR + , getMailShowR + ) 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 + + +-- 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 -- TODO: msg + ] + dbtSorting = mconcat + [ single ("sent" , SortColumn $ queryMail >>> (E.^. SentMailSentAt)) + ] + dbtFilter = mconcat + [ single ("sent" , FilterColumn . E.mkDayFilter $ views (to queryMail) (E.^. SentMailSentAt)) + ] + dbtFilterUI mPrev = mconcat + [ prismAForm (singletonFilter "sent" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift dayField) (fslI MsgPrintJobCreated) -- TODO: msg + ] + 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") + + +getMailShowR :: CryptoUUIDSentMail -> Handler Html +getMailShowR _ = error "TODO: STUB" diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 99e2433b4..559fb6188 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -20,9 +20,9 @@ import qualified Data.Set as Set import qualified Data.Map as Map import Database.Persist.Sql (updateWhereCount) -import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma -import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E +import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma +import qualified Database.Esqueleto.Legacy as E -- needed for dbTable using Esqueleto.Legacy +import qualified Database.Esqueleto.Utils as E import Database.Esqueleto.Utils.TH import Utils.Print @@ -133,10 +133,10 @@ instance Finite PJTableAction nullaryPathPiece ''PJTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''PJTableAction id --- Not yet needed, since there is no additional data for now: data PJTableActionData = PJActAcknowledgeData | PJActReprintData { ignoreReroute :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) + type PJTableExpr = ( E.SqlExpr (Entity PrintJob) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) diff --git a/templates/mail-center.hamlet b/templates/mail-center.hamlet new file mode 100644 index 000000000..de17a2a38 --- /dev/null +++ b/templates/mail-center.hamlet @@ -0,0 +1,9 @@ +$newline never + +$# SPDX-FileCopyrightText: 2024 Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
+

+ ^{mcTable}