fraport/fradrive-old
fraport/fradrive-old
Archived
3
1
Fork 0
Code Issues 65 Pull Requests 5 Actions Packages Projects Releases 197 Wiki Activity

chore(mail): stub towards #171

Browse Source 
new routes /mail and /mail/show/UUID to eventually display all sent emails by the system
This commit is contained in:
Steffen Jost 2024-08-02 18:28:16 +02:00
parent d1fa01fcc5
commit 4df8bd2fa5
13 changed files with 188 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
messages/uniworx/categories/print/de-de-formal.msg
View File

@ -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
PrintLetterType: Brieftypkürzel
MCActDummy: Platzhalter

4
messages/uniworx/categories/print/en-eu.msg
View File

@ -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
PrintLetterType: Letter type shorthand
MCActDummy: Placeholder

3
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -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)

3
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -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)

3
routes
View File

@ -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

13
src/Application.hs
View File

@ -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

1
src/CryptoID.hs
View File

@ -59,6 +59,7 @@ decCryptoIDs [ ''SubmissionId
, ''MaterialFileId
, ''PrintJobId
, ''QualificationId
, ''SentMailId
]
decCryptoIDKeySize

7
src/Foundation/Navigation.hs
View File

@ -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

2
src/Handler/Course/Edit.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

2
src/Handler/LMS.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

144
src/Handler/MailCenter.hs Normal file
View File

@ -0,0 +1,144 @@
-- 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
, 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"

10
src/Handler/PrintCenter.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-24 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- 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))

9
templates/mail-center.hamlet Normal file
View File

@ -0,0 +1,9 @@
$newline never
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<p>
^{mcTable}