refactor(comm): clean CommCenterR and MailCenterR handlers and unify these

2024-08-08 13:56:10 +02:00 · 2024-08-08 13:56:10 +02:00 · 1e6547e903
commit 1e6547e903
parent e4abf915ee
6 changed files with 78 additions and 75 deletions
--- a/messages/uniworx/utils/utils/de-de-formal.msg
+++ b/messages/uniworx/utils/utils/de-de-formal.msg
@ -25,6 +25,7 @@ RGTutorialParticipants tutn@TutorialName: Kursteilnehmer:innen (#{tutn})
 RGExamRegistered examn@ExamName: Angemeldet zur Prüfung „#{examn}“
 RGSheetSubmittor shn@SheetName: Abgebende für das Übungsblatt „#{shn}“
 CommSubject: Betreff
+CommContent: Inhalt
 CommAttachments: Anhänge
 CommAttachmentsTip: Im Allgemeinen ist es vorzuziehen Dateien, die Sie mit den Empfängern teilen möchten, als Material hochzuladen (und ggf. in der Nachricht zu verlinken). So ist die Datei für die Empfänger dauerhaft abrufbar und auch Personen, die sich z.B. erst später zur Kursart anmelden, haben Zugriff auf die Datei.
 CommSuccess n@Int: Nachricht wurde an #{n} Empfänger versandt
--- a/messages/uniworx/utils/utils/en-eu.msg
+++ b/messages/uniworx/utils/utils/en-eu.msg
@ -25,6 +25,7 @@ RGTutorialParticipants tutn: Course participants (#{tutn})
 RGExamRegistered examn: Registered for exam “#{examn}”
 RGSheetSubmittor shn: Submitted for exercise sheet “#{shn}”
 CommSubject: Subject
+CommContent: Content
 CommAttachments: Attachments
 CommAttachmentsTip: In general it is preferable to upload files as course type material instead of sending them as attachments. You can then link to the material from the message. The file is then permanently accessable to the recipients and to persons that, for example, register for the Course type at a later date.
 CommSuccess n: Message was sent to #{n} #{pluralEN n "recipient" "recipients"}
--- a/src/Foundation/Navigation.hs
+++ b/src/Foundation/Navigation.hs
@ -2493,18 +2493,38 @@ pageActions CommCenterR = return
    }
  ]

-pageActions (MailHtmlR smid) = return
-  [ NavPageActionPrimary
-    { navLink = defNavLink MsgMenuMailPlain $ MailPlainR smid
-    , navChildren = []
-    }
-  ]
-pageActions (MailPlainR smid) = return
-  [ NavPageActionPrimary
-    { navLink = defNavLink MsgMenuMailHtml $ MailHtmlR smid
-    , navChildren = []
-    }
-  ]
+pageActions (MailHtmlR smid) = do
+  sid <- decrypt smid
+  usrNotiSettings <- useRunDB $ runMaybeT $ do
+    sm <- MaybeT $ get sid
+    uid <- hoistMaybe $ sentMailRecipient sm
+    User{userDisplayName} <- MaybeT $ get uid
+    uuid <- liftHandler $ encrypt uid
+    return NavPageActionPrimary
+        { navLink = defNavLink (MsgNotificationSettingsHeading userDisplayName) $ UserNotificationR uuid
+        , navChildren = []
+        }
+  let linkPlain = NavPageActionPrimary
+        { navLink = defNavLink MsgMenuMailPlain $ MailPlainR smid
+        , navChildren = []
+        }
+  return $ msnoc [linkPlain] usrNotiSettings
+pageActions (MailPlainR smid) = do
+  sid <- decrypt smid
+  usrNotiSettings <- useRunDB $ runMaybeT $ do
+    sm <- MaybeT $ get sid
+    uid <- hoistMaybe $ sentMailRecipient sm
+    User{userDisplayName} <- MaybeT $ get uid
+    uuid <- liftHandler $ encrypt uid
+    return NavPageActionPrimary
+        { navLink = defNavLink (MsgNotificationSettingsHeading userDisplayName) $ UserNotificationR uuid
+        , navChildren = []
+        }
+  let linkHtml = NavPageActionPrimary
+        { navLink = defNavLink MsgMenuMailHtml $ MailHtmlR smid
+        , navChildren = []
+        }
+  return $ msnoc [linkHtml] usrNotiSettings

 pageActions AdminCrontabR = return
  [ NavPageActionPrimary
--- a/src/Handler/CommCenter.hs
+++ b/src/Handler/CommCenter.hs
@ -2,9 +2,6 @@
 --
 -- 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
@ -12,41 +9,21 @@ module Handler.CommCenter
  ) where

 import Import
+import Handler.Utils

-import qualified Data.Set as Set
+-- 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 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

-- 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
@ -107,7 +84,7 @@ mkCCTable = do
      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
+      -- 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)
@ -143,14 +120,17 @@ mkCCTable = do
          ]
      ]
    dbtFilter = mconcat
-      [ single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just
+      [ single ("sent"      , 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
+      , 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 "date"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgPrintJobCreated)
+      , 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}
@ -166,7 +146,7 @@ mkCCTable = do
 getCommCenterR :: Handler Html
 getCommCenterR = do
  (_, ccTable) <- runDB mkCCTable
-  siteLayoutMsg MsgMenuMailCenter $ do
-    setTitleI MsgMenuMailCenter
+  siteLayoutMsg MsgMenuCommCenter $ do
+    setTitleI MsgMenuCommCenter
    $(widgetFile "comm-center")

--- a/src/Handler/MailCenter.hs
+++ b/src/Handler/MailCenter.hs
@ -2,9 +2,6 @@
 --
 -- 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.MailCenter
@ -40,20 +37,18 @@ 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 qualified Data.Text as T
 -- import qualified Data.Text.Lazy as LT
 -- import qualified Data.Text.Lazy.Encoding as LT
 import qualified Data.ByteString.Lazy as LB

-import Data.Char as C
+-- import Data.Char as C

-import qualified Data.Text as T
 -- import qualified Data.Text.Encoding as TE
 -- import qualified Data.ByteString.Char8 as BS

-import Data.Bits
+-- import Data.Bits
 -- import Data.Word

 -- avoids repetition of local definitions
@ -112,15 +107,15 @@ mkMCTable = do
          let subject = v ^? _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject"
              linkWgt = maybe (msg2widget MsgUtilEMail) text2widget subject
          in anchorCellM (MailHtmlR <$> encrypt k) linkWgt
-      , sortable Nothing (i18nCell MsgMenuMailHtml)   $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html")
-      , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h
+      -- , sortable Nothing (i18nCell MsgCommContent)    $ \(view $ resultMail . _entityKey -> k) -> anchorCellM (MailHtmlR <$> encrypt k) (text2widget "html")
+      -- , sortable Nothing (i18nCell MsgCommSubject) $ \(preview $ resultMail . _entityVal . _sentMailHeaders . _mailHeaders' . _mailHeader' "Subject" -> h) -> cellMaybe textCell h
      ]
    dbtSorting = mconcat
      [ single ("sent"      , SortColumn $ queryMail >>> (E.^. SentMailSentAt))
      , single ("recipient" , sortUserNameBareM queryRecipient)
      ]
    dbtFilter = mconcat
-      [ single ("sent"      , FilterColumn . E.mkDayFilter                          $ views (to queryMail)        (E.^. SentMailSentAt))
+      [ single ("sent"      , FilterColumn . E.mkDayFilterTo                        $ views (to queryMail)        (E.^. SentMailSentAt))
      , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just   $ views (to queryRecipient)   (E.?. UserDisplayName))
      , single ("subject"   , FilterColumn . E.mkContainsFilter                     $ views (to queryMail)        (E.str2text . (E.^. SentMailHeaders)))
      ]
@ -177,20 +172,20 @@ postMailCenterR = do


 getMailHtmlR  :: CryptoUUIDSentMail -> Handler Html
-getMailHtmlR  = handleMailShow [typeHtml,typePlain]
+getMailHtmlR  = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailHtml])  [typeHtml,typePlain]

 getMailPlainR :: CryptoUUIDSentMail -> Handler Html
-getMailPlainR = handleMailShow [typePlain,typeHtml]
+getMailPlainR = handleMailShow (SomeMessages [SomeMessage MsgUtilEMail, SomeMessage MsgMenuMailPlain]) [typePlain,typeHtml]

-handleMailShow :: [ContentType] -> CryptoUUIDSentMail -> Handler Html
-handleMailShow prefTypes cusm = do
+handleMailShow :: _ -> [ContentType] -> CryptoUUIDSentMail -> Handler Html
+handleMailShow hdr prefTypes cusm = do
  smid <- decrypt cusm
-  (sm,cn) <- runDB $ do
+  (sm,cn) <- runDBRead $ do
    sm <- get404 smid
    cn <- get404 $ sm ^. _sentMailContentRef
    return (sm,cn)
-  siteLayoutMsg MsgMenuMailCenter $ do
-    setTitleI MsgMenuMailCenter
+  siteLayout' Nothing $ do
+    setTitleI hdr
    let mcontent = getMailContent (sentMailContentContent cn)
        getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
    [whamlet|
@ -200,16 +195,21 @@ handleMailShow prefTypes cusm = do
            _{MsgPrintJobCreated}
          <dd .deflist__dd>
            ^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)}
-          $maybe r <- getHeader "From"
+          $maybe usr <- sm ^. _sentMailRecipient
            <dt .deflist__dt>
-              _{MsgPrintSender}
+              _{MsgPrintRecipient}
            <dd .deflist__dd>
-              #{decodeMime r}
+              ^{userIdWidget usr}
          $maybe r <- getHeader "To"
            <dt .deflist__dt>
              _{MsgPrintRecipient}
            <dd .deflist__dd>
              #{decodeMime r}
+          $maybe r <- getHeader "From"
+            <dt .deflist__dt>
+              _{MsgPrintSender}
+            <dd .deflist__dd>
+              #{decodeMime r}
          $maybe r <- getHeader "Subject"
            <dt .deflist__dt>
              _{MsgCommSubject}
@ -246,16 +246,14 @@ part2widget Part{partContent=NestedParts ps} =
  [whamlet|
    <section>
      $forall p <- ps
-        ^{part2widget p}
-        <hr>
-    <hr>
+        <p>
+          ^{part2widget p}
  |]
 part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
    [whamlet|
      <section>
        ^{disposition2widget dispo}
        ^{showBody}
-      <hr>
    |]
  where
    showBody
@ -269,9 +267,8 @@ part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partD

 -- | decode the MIME encoded-word format, which is used in email headers to encode non-ASCII text. This format is specified in RFC 2047.
 decodeMime :: Text -> Text
-decodeMime t = t
-- decodeMime t
--   | Just r <- T.stripPrefix "=?utf-8?Q?" t
--     = T.replace "_" " " $ T.replace "?=" "" r  -- TODO: this only works in plain cases without special characters; e.g. umlauts are not handled correctly
--   | otherwise
--     = t
+decodeMime t
+ | Just r <- T.stripPrefix "=?utf-8?Q?" t
+   = T.replace "_" " " $ T.replace "?=" "" r  -- TODO: this only works in plain cases without special characters; e.g. umlauts are not handled correctly
+ | otherwise
+   = t
--- a/src/Utils.hs
+++ b/src/Utils.hs
@ -1008,6 +1008,10 @@ mcons :: Maybe a -> [a] -> [a]
 mcons Nothing  xs = xs
 mcons (Just x) xs = x:xs

+msnoc :: [a] -> Maybe a -> [a]
+msnoc xs Nothing  = xs
+msnoc xs (Just x) = xs ++ [x]
+
 mconss :: [Maybe a] -> [a] -> [a]
 mconss    []  tl = tl
 mconss (m:xs) tl