diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 69ef443a5..84478dbb9 100644 --- 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 diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index 48b4a5e25..5a30b858b 100644 --- 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"} diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 5c3fe16c5..6eebe6da3 100644 --- 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 diff --git a/src/Handler/CommCenter.hs b/src/Handler/CommCenter.hs index 6cfb16eb0..00c688647 100644 --- 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") diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index 82abaf504..b9182fd7c 100644 --- 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}
^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)} - $maybe r <- getHeader "From" + $maybe usr <- sm ^. _sentMailRecipient
- _{MsgPrintSender} + _{MsgPrintRecipient}
- #{decodeMime r} + ^{userIdWidget usr} $maybe r <- getHeader "To"
_{MsgPrintRecipient}
#{decodeMime r} + $maybe r <- getHeader "From" +
+ _{MsgPrintSender} +
+ #{decodeMime r} $maybe r <- getHeader "Subject"
_{MsgCommSubject} @@ -246,16 +246,14 @@ part2widget Part{partContent=NestedParts ps} = [whamlet|
$forall p <- ps - ^{part2widget p} -
-
+

+ ^{part2widget p} |] part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} = [whamlet|

^{disposition2widget dispo} ^{showBody} -
|] 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 diff --git a/src/Utils.hs b/src/Utils.hs index ac3027992..ceac5a618 100644 --- 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