diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 8979eacc5..9eae9e201 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/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) diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 09399e8bf..79438c351 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/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) diff --git a/routes b/routes index 762594efd..10627db43 100644 --- a/routes +++ b/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 diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 9dfd9eec9..1ce50b833 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/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") [] \ No newline at end of file diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index af634108c..773b2c165 100644 --- a/src/Foundation/Navigation.hs +++ b/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 diff --git a/src/Handler/MailCenter.hs b/src/Handler/MailCenter.hs index ce4b2b06e..f638341f0 100644 --- a/src/Handler/MailCenter.hs +++ b/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| +
+
+
+ _{MsgPrintJobCreated} +
+ ^{formatTimeW SelFormatDateTime (sm ^. _sentMailSentAt)} + $maybe r <- getHeader "From" +
+ _{MsgPrintSender} +
+ #{r} + $maybe r <- getHeader "To" +
+ _{MsgPrintRecipient} +
+ #{r} + $maybe r <- getHeader "Subject" +
+ _{MsgCommSubject} +
+ #{r} + +
+ $forall mc <- mcontent + $maybe pt <- selectAlternative prefTypes mc +

+ ^{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| +

+ $forall p <- alt + ^{part2widget p} +
+ |] +-} + +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|

Attachment #{n}|] +disposition2widget (InlineDisposition n) = [whamlet|

#{n}|] +disposition2widget DefaultDisposition = mempty + + +part2widget :: Part -> Widget +part2widget Part{partContent=NestedParts ps} = + [whamlet| +
+ $forall p <- ps + ^{part2widget p} +
+
+ |] +part2widget Part{partContent=PartContent (LB.toStrict -> pc), partType=pt, partDisposition=dispo} = + [whamlet| +
+ ^{disposition2widget dispo} + ^{showBody} +
+ |] + 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.|] diff --git a/src/Mail.hs b/src/Mail.hs index 4f9ab00d6..cb44ce38e 100644 --- a/src/Mail.hs +++ b/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 - replyto = "Reply-To" + where + 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 - replyto = "Reply-To" + where + 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 - (ret, mail0, smtpData0) <- runRWST mailC ls (emptyMail fromAddress) + fromAddress <- defaultFromAddress + (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 - r <- toMailPart $ namedPart nmp + toMailPart nmp = do + 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 } diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index 1b6223e10..577e4ebe0 100644 --- a/src/Model/Types/Mail.hs +++ b/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 \ No newline at end of file diff --git a/src/Network/Mail/Mime/Instances.hs b/src/Network/Mail/Mime/Instances.hs index fe195fd37..6f3242574 100644 --- a/src/Network/Mail/Mime/Instances.hs +++ b/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) @@ -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 diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 55228823d..fbf697fec 100644 --- a/src/Utils/Lens.hs +++ b/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 - hasEntity = id +instance HasEntity (Entity r) r where + 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