Render in advance and store comment content as HTML alongside Markdown source

config/models

@@ -322,6 +322,7 @@ RemoteDiscussion
 Message
     created UTCTime
     source  Text               -- Pandoc Markdown
+    content Text               -- HTML
     parent  MessageId    Maybe
     root    DiscussionId
 

migrations/2019_06_02.model

@@ -0,0 +1,8 @@
+Discussion
+
+Message
+    created UTCTime
+    source  Text               -- Pandoc Markdown
+    content Text               -- HTML
+    parent  MessageId    Maybe
+    root    DiscussionId

src/Vervis/Federation.hs

@@ -608,7 +608,7 @@ handleSharerInbox now shrRecip (Right iidSender) raw activity =
         CreateActivity (Create note) -> handleNote note
         _ -> return "Unsupported activity type"
     where
-    handleNote (Note mluNote _ _ muParent muContext mpublished content) = do
+    handleNote (Note mluNote _ _ muParent muContext mpublished _ _) = do
         _luNote <- fromMaybeE mluNote "Note without note id"
         _published <- fromMaybeE mpublished "Note without 'published' field"
         uContext <- fromMaybeE muContext "Note without context"
@@ -702,7 +702,7 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a
             handleNote (activityAudience activity) note
         _ -> return "Unsupported activity type"
     where
-    handleNote audience (Note mluNote _ _ muParent muCtx mpub content) = do
+    handleNote audience (Note mluNote _ _ muParent muCtx mpub src content) = do
         luNote <- fromMaybeE mluNote "Note without note id"
         published <- fromMaybeE mpub "Note without 'published' field"
         uContext <- fromMaybeE muCtx "Note without context"
@@ -812,7 +812,8 @@ handleProjectInbox now shrRecip prjRecip iidSender hSender raidSender body raw a
                 }
             mid <- insert Message
                 { messageCreated = published
-                , messageSource  = content
+                , messageSource  = src
+                , messageContent = content
                 , messageParent  =
                     case meparent of
                         Just (Left midParent) -> Just midParent
@@ -1060,7 +1061,7 @@ data Recip
 -- a comment on a local ticket, or a comment on some remote context. Return an
 -- error message if the Note is rejected, otherwise the new 'LocalMessageId'.
 handleOutboxNote :: Text -> Note -> Handler (Either Text LocalMessageId)
-handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished content) = runExceptT $ do
+handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished source content) = runExceptT $ do
     verifyHostLocal host "Attributed to non-local actor"
     verifyNothing mluNote "Note specifies an id"
     verifyNothing mpublished "Note specifies published"
@@ -1131,7 +1132,7 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
                                         throwE "Remote parent belongs to a different discussion"
                                     return mid
                 return (did, meparent, Nothing)
-        (lmid, obid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent content
+        (lmid, obid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent source content
         moreRemotes <- deliverLocal pid obid localRecips mcollections
         unless (federation || null moreRemotes) $
             throwE "Federation disabled but remote collection members found"
@@ -1322,12 +1323,14 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
         -> Maybe FedURI
         -> Maybe (Either MessageId FedURI)
         -> Text
+        -> Text
         -> AppDB (LocalMessageId, OutboxItemId, Doc Activity)
-    insertMessage luAttrib shrUser pid uContext did muParent meparent content = do
+    insertMessage luAttrib shrUser pid uContext did muParent meparent source content = do
         now <- liftIO getCurrentTime
         mid <- insert Message
             { messageCreated = now
-            , messageSource  = content
+            , messageSource  = source
+            , messageContent = content
             , messageParent  =
                 case meparent of
                     Just (Left midParent) -> Just midParent

src/Vervis/Handler/Discussion.hs

@@ -42,6 +42,8 @@ import Yesod.Form.Functions (runFormPost)
 import Yesod.Form.Types (FormResult (..))
 import Yesod.Persist.Core (runDB, get404, getBy404)
 
+import qualified Data.Text as T
+
 import Data.Aeson.Encode.Pretty.ToEncoding
 import Database.Persist.JSON
 import Network.FedURI
@@ -59,6 +61,7 @@ import Vervis.Federation
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
+import Vervis.Render
 import Vervis.Settings
 import Vervis.Widget.Discussion
 
@@ -164,7 +167,8 @@ getDiscussionMessage shr lmid = do
             , noteReplyTo   = Just $ fromMaybe uContext muParent
             , noteContext   = Just uContext
             , notePublished = Just $ messageCreated m
-            , noteContent   = messageSource m
+            , noteSource    = messageSource m
+            , noteContent   = messageContent m
             }
     selectRep $ do
         provideAP $ pure doc
@@ -200,6 +204,8 @@ postTopReply hDest recipsA recipsC context replyP after = do
         shrAuthor <- do
             Entity _ p <- requireVerifiedAuth
             lift $ runDB $ sharerIdent <$> get404 (personIdent p)
+        let msg' = T.filter (/= '\r') msg
+        contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
         let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
             uContext = encodeRecipRoute context
             recips = recipsA ++ recipsC
@@ -217,7 +223,8 @@ postTopReply hDest recipsA recipsC context replyP after = do
                 , noteReplyTo   = Just uContext
                 , noteContext   = Just uContext
                 , notePublished = Nothing
-                , noteContent   = msg
+                , noteSource    = msg'
+                , noteContent   = contentHtml
                 }
         ExceptT $ handleOutboxNote hLocal note
     case elmid of
@@ -280,6 +287,8 @@ postReply hDest recipsA recipsC context replyG replyP after getdid midParent = d
                         i <- getJust $ remoteMessageInstance rm
                         return $ l2f (instanceHost i) (remoteMessageIdent rm)
                 return (shr, parent)
+        let msg' = T.filter (/= '\r') msg
+        contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
         let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
             uContext = encodeRecipRoute context
             recips = recipsA ++ recipsC
@@ -297,7 +306,8 @@ postReply hDest recipsA recipsC context replyG replyP after getdid midParent = d
                 , noteReplyTo   = Just uParent
                 , noteContext   = Just uContext
                 , notePublished = Nothing
-                , noteContent   = msg
+                , noteSource    = msg'
+                , noteContent   = contentHtml
                 }
         ExceptT $ handleOutboxNote hLocal note
     case elmid of

src/Vervis/Handler/Inbox.hs

@@ -79,7 +79,7 @@ import Yesod.Persist.Core
 import qualified Data.ByteString.Char8 as BC (unpack)
 import qualified Data.CaseInsensitive as CI (mk)
 import qualified Data.HashMap.Strict as M (lookup, insert, adjust, fromList)
-import qualified Data.Text as T (pack, unpack, concat)
+import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL (toStrict)
 import qualified Data.Text.Lazy.Builder as TLB
 import qualified Data.Vector as V
@@ -115,6 +115,7 @@ import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Paginate
 import Vervis.RemoteActorStore
+import Vervis.Render
 import Vervis.Settings
 
 getInboxR :: Handler Html
@@ -438,6 +439,8 @@ postOutboxR shrAuthor = do
                 FormSuccess r -> return r
         encodeRouteFed <- getEncodeRouteHome
         encodeRouteLocal <- getEncodeRouteLocal
+        let msg' = T.filter (/= '\r') msg
+        contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
         let encodeRecipRoute = l2f hTicket . encodeRouteLocal
             uTicket = encodeRecipRoute $ TicketR shrTicket prj num
             (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
@@ -460,7 +463,8 @@ postOutboxR shrAuthor = do
                 , noteReplyTo   = Just $ fromMaybe uTicket muParent
                 , noteContext   = Just uTicket
                 , notePublished = Nothing
-                , noteContent   = msg
+                , noteSource    = msg'
+                , noteContent   = contentHtml
                 }
         ExceptT $ handleOutboxNote hLocal note
     case elmid of

src/Vervis/Migration.hs

@@ -21,6 +21,7 @@ where
 import Prelude
 
 import Control.Applicative
+import Control.Exception
 import Control.Monad (unless)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class (lift)
@@ -65,6 +66,7 @@ import Database.Persist.Local
 import Vervis.Model.Ident
 import Vervis.Foundation (Route (..))
 import Vervis.Migration.Model
+import Vervis.Render
 
 instance PersistDefault ByteString where
     pdef = def
@@ -424,6 +426,12 @@ changes hLocal ctx =
                                                     l2f (instance201905Host i)
                                                         (remoteMessage201905Ident rmP)
 
+                            let msg = T.filter (/= '\r') $ message201905Content m
+                            contentHtml <-
+                                case renderPandocMarkdown msg of
+                                    Left e -> error $ T.unpack e
+                                    Right t -> return t
+
                             let aud = Audience recips [] [] [] [] []
 
                                 luAttrib = LocalURI ("/s/" <> shr2text shr) ""
@@ -439,7 +447,8 @@ changes hLocal ctx =
                                             , noteReplyTo   = Just $ fromMaybe uContext muParent
                                             , noteContext   = Just uContext
                                             , notePublished = Just $ message201905Created m
-                                            , noteContent   = message201905Content m
+                                            , noteSource    = msg
+                                            , noteContent   = contentHtml
                                             }
                                         }
                                     }
@@ -488,6 +497,20 @@ changes hLocal ctx =
     , renameUnique "RoleAccess" "UniqueProjectAccess" "UniqueRoleAccess"
       -- 85
     , renameField "Message" "content" "source"
+      -- 86
+    , addFieldPrimRequired "Message" ("" :: Text) "content"
+      -- 87
+    , unchecked $ lift $ do
+        msgs <- selectList ([] :: [Filter Message201906]) []
+        for_ msgs $ \ (Entity mid m) ->
+            let source = T.filter (/= '\r') $ message201906Source m
+            in  case renderPandocMarkdown $ message201906Source m of
+                    Left err -> liftIO $ throwIO $ userError $ T.unpack err
+                    Right content ->
+                        update mid
+                            [ Message201906Source  =. source
+                            , Message201906Content =. content
+                            ]
     ]
 
 migrateDB :: MonadIO m => Text -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))

src/Vervis/Migration/Model.hs

@@ -53,6 +53,8 @@ module Vervis.Migration.Model
     , Instance201905Generic (..)
     , RemoteDiscussion201905Generic (..)
     , RemoteMessage201905Generic (..)
+    , Message201906Generic (..)
+    , Message201906
     )
 where
 
@@ -136,3 +138,6 @@ model_2019_05_17 = $(schema "2019_05_17")
 
 makeEntitiesMigration "201905"
     $(modelFile "migrations/2019_05_24.model")
+
+makeEntitiesMigration "201906"
+    $(modelFile "migrations/2019_06_02.model")

src/Vervis/Render.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -39,11 +39,13 @@
 module Vervis.Render
     ( renderSourceT
     , renderSourceBL
+    , renderPandocMarkdown
     )
 where
 
 import Prelude
 
+import Control.Exception
 import Control.Monad.Catch (throwM)
 import Control.Monad.Logger (logDebug, logWarn)
 import Data.Foldable (for_)
@@ -230,3 +232,23 @@ renderSource mt contentB contentTL contentT =
             Haskell   -> code L.Haskell.lexer
             -- * Misc
             _         -> plain
+
+renderPandocMarkdown :: Text -> Either Text Text
+renderPandocMarkdown input =
+    case parse input of
+        Left err ->
+            Left $
+                "Failed to parse Markdown: " <> T.pack (displayException err)
+        Right doc ->
+            case render doc of
+                Left err ->
+                    Left $
+                        "Failed to render Markdown: " <>
+                        T.pack (displayException err)
+                Right output -> Right output
+    where
+    parse = runPure . readMarkdown readerOptions
+    render
+        = fmap (sanitizeBalance . TL.toStrict . renderHtml)
+        . runPure
+        . writeHtml5 writerOptions

src/Vervis/Widget/Discussion.hs

@@ -26,7 +26,7 @@ import Data.Text (Text)
 import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
 import Data.Tree (Tree (..))
 import Database.Persist.Types (Entity (..))
-import Yesod.Core (Route)
+import Yesod.Core
 import Yesod.Core.Handler (newIdent)
 import Yesod.Core.Widget
 
@@ -61,7 +61,8 @@ messageW now (MessageTreeNode msgid msg author) reply = do
             intervalToEventTime .
             FriendlyConvert .
             diffUTCTime now
-        showContent = renderSourceT Markdown . T.filter (/= '\r')
+        showContent :: Text -> Widget
+        showContent = toWidget . preEscapedToMarkup
     $(widgetFile "discussion/widget/message")
 
 messageTreeW

src/Web/ActivityPub.hs

@@ -100,6 +100,7 @@ import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
 import Network.HTTP.Simple (JSONException)
 import Network.HTTP.Types.Header (HeaderName, hContentType)
 import Network.URI
+import Text.HTML.SanitizeXSS
 import Yesod.Core.Content (ContentType)
 import Yesod.Core.Handler (ProvidedRep, provideRepType)
 
@@ -507,6 +508,7 @@ data Note = Note
     , noteReplyTo   :: Maybe FedURI
     , noteContext   :: Maybe FedURI
     , notePublished :: Maybe UTCTime
+    , noteSource    :: Text
     , noteContent   :: Text
     }
 
@@ -527,7 +529,18 @@ instance ActivityPub Note where
     jsonldContext _ = ContextAS2
     parseObject o = do
         typ <- o .: "type"
-        unless (typ == ("Note" :: Text)) $ fail "type isn't Note"
+        unless (typ == ("Note" :: Text)) $
+            fail "type isn't Note"
+
+        mediaType <- o .: "mediaType"
+        unless (mediaType == ("text/html" :: Text)) $
+            fail "mediaType isn't HTML"
+
+        source <- o .: "source"
+        sourceType <- source .: "mediaType"
+        unless (sourceType == ("text/markdown; variant=Pandoc" :: Text)) $
+            fail "source mediaType isn't Pandoc Markdown"
+
         (h, attrib) <- f2l <$> o .: "attributedTo"
         fmap (h,) $
             Note
@@ -537,8 +550,9 @@ instance ActivityPub Note where
                 <*> o .:? "inReplyTo"
                 <*> o .:? "context"
                 <*> o .:? "published"
-                <*> o .:  "content"
+                <*> source .: "content"
-    toSeries host (Note mid attrib aud mreply mcontext mpublished content)
+                <*> (sanitizeBalance <$> o .: "content")
+    toSeries host (Note mid attrib aud mreply mcontext mpublished src content)
         =  "type"         .=  ("Note" :: Text)
         <> "id"           .=? (l2f host <$> mid)
         <> "attributedTo" .=  l2f host attrib
@@ -546,7 +560,12 @@ instance ActivityPub Note where
         <> "inReplyTo"    .=? mreply
         <> "context"      .=? mcontext
         <> "published"    .=? mpublished
+        <> "source"       .=  object
+                [ "content"   .= src
+                , "mediaType" .= ("text/markdown; variant=Pandoc" :: Text)
+                ]
         <> "content"      .=  content
+        <> "mediaType"    .=  ("text/html" :: Text)
 
 {-
 parseNote :: Value -> Parser (Text, (Note, LocalURI))

templates/discussion/widget/message.hamlet

@@ -22,6 +22,6 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
       <a href="#{renderFedURI $ l2f h luMsg}"}>
         #{showTime $ messageCreated msg}
 <div>
-  ^{showContent $ messageSource msg}
+  ^{showContent $ messageContent msg}
 <div>
   <a href=@{reply msgid}>reply