From c7dccbb7fe95fbaeef24e996c2280ea88eea641e Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sun, 2 Jun 2019 14:41:51 +0000 Subject: [PATCH] Render in advance and store comment content as HTML alongside Markdown source --- config/models | 1 + migrations/2019_06_02.model | 8 +++++++ src/Vervis/Federation.hs | 17 +++++++++------ src/Vervis/Handler/Discussion.hs | 16 +++++++++++--- src/Vervis/Handler/Inbox.hs | 8 +++++-- src/Vervis/Migration.hs | 25 +++++++++++++++++++++- src/Vervis/Migration/Model.hs | 5 +++++ src/Vervis/Render.hs | 24 ++++++++++++++++++++- src/Vervis/Widget/Discussion.hs | 5 +++-- src/Web/ActivityPub.hs | 25 +++++++++++++++++++--- templates/discussion/widget/message.hamlet | 2 +- 11 files changed, 116 insertions(+), 20 deletions(-) create mode 100644 migrations/2019_06_02.model diff --git a/config/models b/config/models index 2cb5f30..b81060d 100644 --- a/config/models +++ b/config/models @@ -322,6 +322,7 @@ RemoteDiscussion Message created UTCTime source Text -- Pandoc Markdown + content Text -- HTML parent MessageId Maybe root DiscussionId diff --git a/migrations/2019_06_02.model b/migrations/2019_06_02.model new file mode 100644 index 0000000..c0b5b11 --- /dev/null +++ b/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 diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 231b37c..1e604b4 100644 --- a/src/Vervis/Federation.hs +++ b/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 diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index c634e5d..e38b842 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/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 diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 89f49a7..365a576 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/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 diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index cbc4595..2bee29e 100644 --- a/src/Vervis/Migration.hs +++ b/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)) diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index 7acda20..289d091 100644 --- a/src/Vervis/Migration/Model.hs +++ b/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") diff --git a/src/Vervis/Render.hs b/src/Vervis/Render.hs index f5a544e..a56b5e3 100644 --- a/src/Vervis/Render.hs +++ b/src/Vervis/Render.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018 by fr33domlover . + - Written in 2016, 2018, 2019 by fr33domlover . - - ♡ 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 diff --git a/src/Vervis/Widget/Discussion.hs b/src/Vervis/Widget/Discussion.hs index 14dfdb7..f051b9c 100644 --- a/src/Vervis/Widget/Discussion.hs +++ b/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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 34d49e7..51d7fc2 100644 --- a/src/Web/ActivityPub.hs +++ b/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" - toSeries host (Note mid attrib aud mreply mcontext mpublished content) + <*> source .: "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)) diff --git a/templates/discussion/widget/message.hamlet b/templates/discussion/widget/message.hamlet index bd8359c..e9824fb 100644 --- a/templates/discussion/widget/message.hamlet +++ b/templates/discussion/widget/message.hamlet @@ -22,6 +22,6 @@ $# . #{showTime $ messageCreated msg}
- ^{showContent $ messageSource msg} + ^{showContent $ messageContent msg}