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
@@ -328,7 +329,7 @@ mkExactFilterLastWith :: (PersistField b)
                       -> Last a                        -- ^ needle
                       -> E.SqlExpr (E.Value Bool)
 mkExactFilterLastWith cast lenslike row criterias
-  | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)  
+  | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)
   | otherwise = true
 
 -- | like `mkExactFilterLast` but deals with Nothing being a filter criterion as well
@@ -409,7 +410,7 @@ mkContainsFilterWithCommaPlus cast lenslike row (foldMap commaSeparatedText -> c
   | Set.null compulsories = cond_optional
   | Set.null alternatives = cond_compulsory
   | otherwise             = cond_compulsory E.&&. cond_optional
-  where    
+  where
     (Set.mapMonotonic (Text.stripStart . Text.drop 1) -> compulsories, alternatives) = Set.partition (Text.isPrefixOf "+") criterias
     cond_compulsory = all (hasInfix (lenslike row) . E.val . cast) compulsories
     cond_optional   = any (hasInfix (lenslike row) . E.val . cast) alternatives
@@ -516,7 +517,7 @@ selectExists query = do
     _other      -> error "SELECT EXISTS ... returned zero or more than one rows"
 selectNotExists = fmap not . selectExists
 
-filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono)) 
+filterExists :: (MonadIO m, PersistEntity val, MonoFoldable mono, PersistField (Element mono))
              => EntityField val (Element mono) -> mono -> E.SqlReadT m [Element mono]
 filterExists prj vs = fmap (fmap Ex.unValue) <$> Ex.select $ do
   ent <- Ex.from Ex.table
@@ -655,7 +656,7 @@ infixl 8 ->.
 
 infixl 8 ->>.
 
-(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text) 
+(->>.) :: E.SqlExpr (E.Value a) -> Text -> E.SqlExpr (E.Value Text)
 (->>.) expr t = E.unsafeSqlBinOp "->>" expr $ E.val t
 
 infixl 8 ->>>.
@@ -682,7 +683,7 @@ unKey = E.veryUnsafeCoerceSqlExprValue
 -- | distinct version of `Database.Esqueleto.subSelectCount`
 subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a)
 subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query)
-  
+
 -- PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
 -- countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)
 
@@ -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"
@@ -726,9 +731,9 @@ dayMaybe :: E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value (Maybe Day
 dayMaybe = E.unsafeSqlCastAs "date"
 
 interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=.  requires both types to be the same, so we use Day
--- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example 
+-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
 interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show
-  where 
+  where
     singleQuote     = Text.Builder.singleton '\''
     wrapSqlString b = singleQuote <> b <> singleQuote
 
@@ -775,12 +780,12 @@ instance (PersistField a1, PersistField a2, PersistField b, Finite a1, Finite a2
 
 
 -- Suspected to cause trouble. Needs more testing!
--- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) 
+-- truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record)
 --               => record -> ReaderT backend m ()
 -- truncateTable tbl = E.rawExecute ("TRUNCATE TABLE " <> P.tableName tbl <> "  RESTART IDENTITY") []
 
 truncateTable :: (MonadIO m, BackendCompatible SqlBackend backend, PersistEntity record) -- TODO: test this code
                   => proxy record -> ReaderT backend m ()
-truncateTable tbl = 
+truncateTable tbl =
   let tblName :: Text = P.unEntityNameDB $ P.entityDB $ P.entityDef tbl
   in  E.rawExecute ("TRUNCATE TABLE " <> tblName <> " RESTART IDENTITY") []

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
+getMailHtmlR  :: CryptoUUIDSentMail -> Handler Html
-getMailShowR _ = error "TODO: STUB"
+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
 
@@ -140,9 +140,9 @@ import Web.HttpApiData (ToHttpApiData(toHeader))
 
 newtype AddressEqIgnoreName = AddressEqIgnoreName { getAddress :: Address }
   deriving (Show, Generic)
-instance Eq AddressEqIgnoreName where 
+instance Eq AddressEqIgnoreName where
   (==)    = (==)    `on` (addressEmail . getAddress)
-instance Ord AddressEqIgnoreName where 
+instance Ord AddressEqIgnoreName where
   compare = compare `on` (addressEmail . getAddress)
 
 
@@ -159,16 +159,19 @@ _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'
 
-_mailReplyTo' :: Lens' Mail Text 
+_mailHeader' :: CI ByteString -> Traversal' Headers Text
+_mailHeader' hdrName = traverse . filtered (views _1 $ (== hdrName) . CI.mk) . _2
+
+_mailReplyTo' :: Lens' Mail Text
 _mailReplyTo' = _mailHeaders . _headerReplyTo'
 
-_headerReplyTo' :: Lens' Headers Text 
+_headerReplyTo' :: Lens' Headers Text
 --  Functor f => (Text -> f Text) -> [(ByteString, Text)] -> f [(ByteString, Text)]
 _headerReplyTo' f hdrs = (\x -> insertAssoc replyto x hdrs) <$> f (maybeMonoid $ lookup replyto hdrs)
-  where 
+  where
-    replyto = "Reply-To"        
+    replyto = "Reply-To"
 
 _mailReplyTo :: Lens' Mail Address
 _mailReplyTo = _mailHeaders . _headerReplyTo
@@ -176,8 +179,8 @@ _mailReplyTo = _mailHeaders . _headerReplyTo
 _headerReplyTo :: Lens' Headers Address
 --  Functor f => (Address -> f Address) -> [(ByteString, Text)] -> f [(ByteString, Text)]
 _headerReplyTo f hdrs = (\x -> insertAssoc replyto (renderAddress x) hdrs) <$> f (fromString $ unpack $ maybeMonoid $ lookup replyto hdrs)
-  where 
+  where
-    replyto = "Reply-To"        
+    replyto = "Reply-To"
     -- _addressEmail :: Lens' Address Text might help to simplify this code?
 
 newtype MailT m a = MailT { _unMailT :: RWST MailContext MailSmtpData Mail m a }
@@ -270,7 +273,7 @@ instance Exception MailException
 class Yesod site => YesodMail site where
   defaultFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Address
   defaultFromAddress = Address Nothing . ("yesod@" <>) . pack <$> liftIO getHostName
-  
+
   envelopeFromAddress :: (MonadHandler m, HandlerSite m ~ site) => m Text
   envelopeFromAddress = addressEmail <$> defaultFromAddress
 
@@ -336,12 +339,12 @@ defMailT :: ( MonadHandler m
               -> MailT m a
               -> m a
 defMailT ls (MailT mailC) = do
-  fromAddress <- defaultFromAddress  
+  fromAddress <- defaultFromAddress
-  (ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress)  
+  (ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress)
   mail1 <- maybeT (return mail0) $ do
     guardM useReplyToInstead -- if sender must be fixed within ObjectIdDomain, use replyTo instead
     domain <- mailObjectIdDomain
-    let sender = mail0 ^. _mailFrom 
+    let sender = mail0 ^. _mailFrom
         isdomainaddress = (Text.isInfixOf `on` Text.toCaseFold) domain (sender ^. _addressEmail) -- not sure how to use CI.mk and isInfixOf here
     $logDebugS "Mail" $ "Use ReplyTo instead of Sender: " <> tshow isdomainaddress <> " From was: " <> renderAddress sender <> " From is: " <> renderAddress fromAddress
     guard isdomainaddress -- allowing foreign senders might be Fraport specific; maybe remove this guard
@@ -378,7 +381,7 @@ instance Semigroup (PrioritisedAlternatives m) where
   (<>) = mappenddefault
 
 instance Monoid (PrioritisedAlternatives m) where
-  mempty = memptydefault  
+  mempty = memptydefault
 
 class YesodMail site => ToMailPart site a where
   type MailPartReturn site a :: Type
@@ -452,14 +455,14 @@ instance YesodMail site => ToMailPart site YamlValue where
     _partContent .= PartContent (fromStrict $ Yaml.encode val)
 
 
-data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a } 
+data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a }
 
 instance ToMailPart site a => ToMailPart site (NamedMailPart a) where
   type MailPartReturn site (NamedMailPart a) = MailPartReturn site a
-  toMailPart nmp = do 
+  toMailPart nmp = do
-    r <- toMailPart $ namedPart nmp 
+    r <- toMailPart $ namedPart nmp
     _partDisposition .= disposition nmp
-    return r    
+    return r
 
 
 addAlternatives :: (MonadMail m)
@@ -546,7 +549,7 @@ lookupMailHeader :: MonadHeader m => MailHeader -> m (Maybe Text)
 lookupMailHeader = fmap listToMaybe . getMailHeaders
 
 mapMailHeader ::  MonadHeader m => MailHeader -> (Text -> Text) -> m ()
-mapMailHeader header f = modifyHeaders $ adjustAssoc f header 
+mapMailHeader header f = modifyHeaders $ adjustAssoc f header
 
 replaceMailHeaderI :: ( RenderMessage site msg
                       , MonadMail m
@@ -642,5 +645,5 @@ getMailSmtpData = execWriterT $ do
 
   tell $ mempty
     { smtpRecipients = recps
-    , smtpEnvelopeFrom = Last $ Just from 
+    , smtpEnvelopeFrom = Last $ Just from
     }

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 {toHeaders:: Headers}
-newtype MailHeaders = MailHeaders Headers
   deriving (Eq, Ord, Read, Show, Generic)
   deriving anyclass (NFData)
 
@@ -79,7 +78,7 @@ deriving anyclass instance NFData PartContent
 deriving anyclass instance NFData Part
 deriving anyclass instance NFData Address
 deriving anyclass instance NFData Mail
-  
+
 deriveJSON defaultOptions
   { constructorTagModifier = camelToPathPiece
   } ''Encoding

src/Utils/Lens.hs

@@ -186,8 +186,8 @@ class HasEntity c record where
   hasEntity :: Lens' c (Entity record)
 
 --Trivial instance, usefull for lifting to maybes
-instance HasEntity (Entity r) r where 
+instance HasEntity (Entity r) r where
-  hasEntity = id 
+  hasEntity = id
 
 -- Typed convenience to avoid type signatures, due to the missing FunctionalDepenency that we do not want.
 hasEntityUser :: (HasEntity a User) => Lens' a (Entity User)
@@ -299,6 +299,9 @@ makeLenses_ ''FallbackPersonalisedSheetFilesKey
 makeWrapped ''Textarea
 makeLenses_ ''SentMail
 
+_mailHeaders' :: Iso' MailHeaders Headers
+_mailHeaders' = coerced
+
 makePrisms ''RoomReference
 makeLenses_ ''RoomReference