chore(mail): mail display towards #171

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -150,7 +150,8 @@ MenuPrintLog: LPR Schnittstelle
 MenuPrintAck: Druckbestätigung
 
 MenuMailCenter: E‑Mails
-MenuMailShow: Anzeige
+MenuMailHtml !ident-ok: Html
+MenuMailPlain !ident-ok: Text
 
 MenuApiDocs: API-Dokumentation (Englisch)
 MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -150,7 +150,8 @@ MenuPrintLog: LPR Interface
 MenuPrintAck: Acknowledge Printing
 
 MenuMailCenter: Email
-MenuMailShow: Display
+MenuMailHtml: Html
+MenuMailPlain: Text
 
 MenuApiDocs: API documentation
 MenuSwagger: OpenAPI 2.0 (Swagger)

routes

@@ -85,7 +85,8 @@
 /print/log                            PrintLogR       GET       !system-printer
 
 /mail                                 MailCenterR     GET POST
-/mail/show/#CryptoUUIDSentMail        MailShowR       GET
+/mail/html/#CryptoUUIDSentMail        MailHtmlR       GET
+/mail/plain/#CryptoUUIDSentMail       MailPlainR      GET
 
 /health                       HealthR           GET             !free
 /health/interface/+Texts      HealthInterfaceR  GET             !free

src/Database/Esqueleto/Utils.hs

@@ -48,6 +48,7 @@ module Database.Esqueleto.Utils
   , subSelectCountDistinct
   , selectCountRows, selectCountDistinct
   , selectMaybe
+  , str2text
   , num2text --, text2num
   , day, day', dayMaybe, interval, diffDays, diffTimes
   , exprLift
@@ -707,6 +708,10 @@ selectCountDistinct q = do
 selectMaybe :: (E.SqlSelect a r, MonadIO m) => E.SqlQuery a -> E.SqlReadT m (Maybe r)
 selectMaybe = fmap listToMaybe . E.select . (<* E.limit 1)
 
+-- | convert something that is like a text to text
+str2text :: E.SqlString a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Text)
+str2text = E.unsafeSqlCastAs "text"
+
 -- | cast numeric type to text, which is safe and allows for an inefficient but safe comparison of numbers stored as text and numbers
 num2text :: Num n => E.SqlExpr (E.Value n) -> E.SqlExpr (E.Value Text)
 num2text = E.unsafeSqlCastAs "text"

src/Foundation/Navigation.hs

@@ -137,7 +137,8 @@ breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck       $ Just PrintCenter
 breadcrumb PrintLogR        = i18nCrumb MsgMenuPrintLog       $ Just PrintCenterR
 
 breadcrumb MailCenterR      = i18nCrumb MsgMenuMailCenter       Nothing
-breadcrumb MailShowR{}      = i18nCrumb MsgMenuMailShow       $ Just MailCenterR
+breadcrumb MailHtmlR{}      = i18nCrumb MsgMenuMailHtml       $ Just MailCenterR
+breadcrumb MailPlainR{}     = i18nCrumb MsgMenuMailPlain      $ Just MailCenterR
 
 breadcrumb SchoolListR      = i18nCrumb MsgMenuSchoolList       $ Just AdminR
 breadcrumb (SchoolR ssh sRoute) = case sRoute of
@@ -2477,8 +2478,25 @@ pageActions PrintCenterR = do
                       , navForceActive = False
                       }
                     }
+      emailCenter = NavPageActionPrimary
+                    { navLink = defNavLink MsgMenuMailCenter $ MailCenterR
+                    , navChildren = []
+                    }
   dayLinks <- mapM toDayAck $ Map.toAscList dayMap
-  return $ manualSend : printLog : printAck : take 9 dayLinks
+  return $ emailCenter : manualSend : printLog : printAck : take 9 dayLinks
+
+pageActions (MailHtmlR smid) = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgMenuMailPlain $ MailPlainR smid
+    , navChildren = []
+    }
+  ]
+pageActions (MailPlainR smid) = return
+  [ NavPageActionPrimary
+    { navLink = defNavLink MsgMenuMailHtml $ MailHtmlR smid
+    , navChildren = []
+    }
+  ]
 
 pageActions AdminCrontabR = return
   [ NavPageActionPrimary

src/Handler/MailCenter.hs

@@ -6,7 +6,8 @@
 
 module Handler.MailCenter
   ( getMailCenterR, postMailCenterR
-  , getMailShowR
+  , getMailHtmlR
+  , getMailPlainR
   ) where
 
 import Import
@@ -31,6 +32,18 @@ import Handler.Utils
 -- 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 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
@@ -58,20 +71,19 @@ type MCTableExpr =
 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
@@ -85,15 +97,27 @@ mkMCTable = do
     dbtColonnade = mconcat
       [ dbSelect (applying _2) id (return . view (resultMail . _entityKey))
       , sortable (Just "sent")      (i18nCell MsgPrintJobCreated)       $ \(   view $ resultMail . _entityVal . _sentMailSentAt -> t) ->      dateTimeCell t -- TODO: msg
+      , sortable (Just "recipient") (i18nCell MsgPrintRecipient)        $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
+      , sortable Nothing (i18nCell MsgCommSubject) $ \(view resultMail -> Entity k v) ->
+          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
       ]
     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.mkDayFilter                          $ 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)))
       ]
     dbtFilterUI mPrev = mconcat
       [ prismAForm (singletonFilter "sent"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)  (fslI MsgPrintJobCreated) -- TODO: msg
+      , 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}
     dbtIdent :: Text
@@ -140,5 +164,104 @@ postMailCenterR = do
     $(widgetFile "mail-center")
 
 
-getMailShowR :: CryptoUUIDSentMail -> Handler Html
-getMailShowR _ = error "TODO: STUB"
+getMailHtmlR  :: CryptoUUIDSentMail -> Handler Html
+getMailHtmlR  = handleMailShow [typeHtml,typePlain]
+
+getMailPlainR :: CryptoUUIDSentMail -> Handler Html
+getMailPlainR = handleMailShow [typePlain,typeHtml]
+
+handleMailShow :: [ContentType] -> CryptoUUIDSentMail -> Handler Html
+handleMailShow prefTypes cusm = do
+  smid <- decrypt cusm
+  (sm,cn) <- runDB $ do
+    sm <- get404 smid
+    cn <- get404 $ sm ^. _sentMailContentRef
+    return (sm,cn)
+  siteLayoutMsg MsgMenuMailCenter $ do
+    setTitleI MsgMenuMailCenter
+    let mcontent = getMailContent (sentMailContentContent cn)
+        getHeader h = preview (_mailHeader' h) (sm ^. _sentMailHeaders . _mailHeaders')
+    [whamlet|
+      <section>
+        <dl .deflist>
+          <dt .deflist__dt>
+            _{MsgPrintJobCreated}
+          <dd .deflist__dd>
+            ^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)}
+          $maybe r <- getHeader "From"
+            <dt .deflist__dt>
+              _{MsgPrintSender}
+            <dd .deflist__dd>
+              #{r}
+          $maybe r <- getHeader "To"
+            <dt .deflist__dt>
+              _{MsgPrintRecipient}
+            <dd .deflist__dd>
+              #{r}
+          $maybe r <- getHeader "Subject"
+            <dt .deflist__dt>
+              _{MsgCommSubject}
+            <dd .deflist__dd>
+              #{r}
+
+      <section>
+        $forall mc <- mcontent
+          $maybe pt <- selectAlternative prefTypes mc
+            <p>
+              ^{part2widget pt}
+    |]
+    -- ^{jsonWidget (sm ^. _sentMailHeaders)}
+    -- ^{jsonWidget (sentMailContentContent cn)}
+
+
+{-
+alternative2widget :: Alternatives -> Widget
+alternative2widget alt = -- show all parts for now TODO: select only best representation for each
+  [whamlet|
+    <section>
+      $forall p <- alt
+        ^{part2widget p}
+        <hr>
+  |]
+-}
+
+selectAlternative :: [ContentType] -> Alternatives -> Maybe Part
+selectAlternative (fmap decodeUtf8 -> prefTypes) allAlts = aux prefTypes allAlts
+  where
+    aux ts@(ct:_) (pt:ps)
+      | ct == partType pt = Just pt
+      | otherwise         = aux ts ps
+    aux (_:ts) []         = aux ts allAlts
+    aux []     (pt:_)     = Just pt
+    aux _      []         = Nothing
+
+disposition2widget :: Disposition -> Widget
+disposition2widget (AttachmentDisposition n) = [whamlet|<h3>Attachment #{n}|]
+disposition2widget (InlineDisposition     n) = [whamlet|<h3>#{n}|]
+disposition2widget  DefaultDisposition       = mempty
+
+
+part2widget :: Part -> Widget
+part2widget Part{partContent=NestedParts ps} =
+  [whamlet|
+    <section>
+      $forall p <- ps
+        ^{part2widget p}
+        <hr>
+    <hr>
+  |]
+part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} =
+    [whamlet|
+      <section>
+        ^{disposition2widget dispo}
+        ^{showBody}
+      <hr>
+    |]
+  where
+    showBody
+      | pt == decodeUtf8 typePlain = toWidget $ preEscapedToHtml $ plaintextToHtml $ decodeUtf8 pc
+      | pt == decodeUtf8 typeHtml  = toWidget $ preEscapedToHtml $ decodeUtf8 pc -- preEscapedToHtml :: ToMarkup a => a -> Html
+      | pt == decodeUtf8 typeJson  =
+          let jw :: Aeson.Value -> Widget = jsonWidget
+          in  either str2widget jw $ Aeson.eitherDecodeStrict' pc
+      | otherwise = [whamlet|part2widget cannot decode parts of type #{pt} yet.|]

src/Mail.hs

@@ -38,7 +38,7 @@ module Mail
   , setDate, setDateCurrent
   , getMailSmtpData
   , _addressName, _addressEmail
-  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailParts
+  , _mailFrom, _mailTo, _mailCc, _mailBcc, _mailReplyTo, _mailReplyTo', _mailHeaders, _mailHeader, _mailHeader', _mailParts
   , _partType, _partEncoding, _partDisposition, _partFilename, _partHeaders, _partContent
   ) where
 
@@ -159,7 +159,10 @@ _partFilename = _partDisposition . dispositionFilename
     dispositionFilename _  DefaultDisposition       = pure DefaultDisposition
 
 _mailHeader :: CI ByteString -> Traversal' Mail Text
-_mailHeader hdrName = _mailHeaders . traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
+_mailHeader = (_mailHeaders .) . _mailHeader'
+
+_mailHeader' :: CI ByteString -> Traversal' Headers Text
+_mailHeader' hdrName = traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
 
 _mailReplyTo' :: Lens' Mail Text
 _mailReplyTo' = _mailHeaders . _headerReplyTo'

src/Model/Types/Mail.hs

@@ -34,6 +34,7 @@ import Data.ByteString.Base32
 
 import qualified Data.CaseInsensitive as CI
 
+import qualified Database.Esqueleto.Experimental as E
 
 -- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@
 --
@@ -121,7 +122,7 @@ instance PathPiece BounceSecret where
   toPathPiece = CI.foldCase . encodeBase32Unpadded . BA.convert
   fromPathPiece = fmap BounceSecret . digestFromByteString <=< either (const Nothing) Just . decodeBase32Unpadded . encodeUtf8
 
-newtype MailContent = MailContent [Alternatives]
+newtype MailContent = MailContent {getMailContent :: [Alternatives]}
   deriving (Eq, Show, Generic)
   deriving newtype (ToJSON, FromJSON)
   deriving anyclass (Binary, NFData)
@@ -140,3 +141,5 @@ instance PersistFieldSql MailContentReference where
   sqlType _ = sqlType $ Proxy @(Digest SHA3_512)
 
 derivePersistFieldJSON ''MailHeaders
+
+instance E.SqlString MailHeaders

src/Network/Mail/Mime/Instances.hs

@@ -56,8 +56,7 @@ instance Csv.ToNamedRecord Address where
 instance Csv.DefaultOrdered Address where
   headerOrder _ = Csv.header [ "name", "email" ]
 
-  
-newtype MailHeaders = MailHeaders Headers
+newtype MailHeaders = MailHeaders {toHeaders:: Headers}
   deriving (Eq, Ord, Read, Show, Generic)
   deriving anyclass (NFData)
 

src/Utils/Lens.hs

@@ -299,6 +299,9 @@ makeLenses_ ''FallbackPersonalisedSheetFilesKey
 makeWrapped ''Textarea
 makeLenses_ ''SentMail
 
+_mailHeaders' :: Iso' MailHeaders Headers
+_mailHeaders' = coerced
+
 makePrisms ''RoomReference
 makeLenses_ ''RoomReference