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

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

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"}

src/Foundation/Navigation.hs

@@ -2493,18 +2493,38 @@ pageActions CommCenterR = return
     }
   ]
 
-pageActions (MailHtmlR smid) = return
+pageActions (MailHtmlR smid) = do
-  [ NavPageActionPrimary
+  sid <- decrypt smid
-    { navLink = defNavLink MsgMenuMailPlain $ MailPlainR smid
+  usrNotiSettings <- useRunDB $ runMaybeT $ do
-    , navChildren = []
+    sm <- MaybeT $ get sid
-    }
+    uid <- hoistMaybe $ sentMailRecipient sm
-  ]
+    User{userDisplayName} <- MaybeT $ get uid
-pageActions (MailPlainR smid) = return
+    uuid <- liftHandler $ encrypt uid
-  [ NavPageActionPrimary
+    return NavPageActionPrimary
-    { navLink = defNavLink MsgMenuMailHtml $ MailHtmlR smid
+        { navLink = defNavLink (MsgNotificationSettingsHeading userDisplayName) $ UserNotificationR uuid
-    , navChildren = []
+        , 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

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
+  siteLayoutMsg MsgMenuCommCenter $ do
-    setTitleI MsgMenuMailCenter
+    setTitleI MsgMenuCommCenter
     $(widgetFile "comm-center")
 

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 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
+      -- , 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 :: _ -> [ContentType] -> CryptoUUIDSentMail -> Handler Html
-handleMailShow prefTypes cusm = do
+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
+  siteLayout' Nothing $ do
-    setTitleI MsgMenuMailCenter
+    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}
+        <p>
-        <hr>
+          ^{part2widget p}
-    <hr>
   |]
 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
--- decodeMime t
+ | Just r <- T.stripPrefix "=?utf-8?Q?" 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
---     = T.replace "_" " " $ T.replace "?=" "" r  -- TODO: this only works in plain cases without special characters; e.g. umlauts are not handled correctly
+ | otherwise
---   | otherwise
+   = t
---     = t

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