forge/Vervis
1
0
Fork 0
Code Pull requests Activity

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

Browse source
This commit is contained in:
fr33domlover 2019-06-02 14:41:51 +00:00
parent facf4d7f3e
commit c7dccbb7fe
11 changed files with 116 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
config/models
View file

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

8
migrations/2019_06_02.model Normal file
View file

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

17
src/Vervis/Federation.hs
View file

@ -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

16
src/Vervis/Handler/Discussion.hs
View file

@ -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

8
src/Vervis/Handler/Inbox.hs
View file

@ -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

25
src/Vervis/Migration.hs
View file

@ -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))

5
src/Vervis/Migration/Model.hs
View file

@ -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")

24
src/Vervis/Render.hs
View file

@ -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

5
src/Vervis/Widget/Discussion.hs
View file

@ -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

25
src/Web/ActivityPub.hs
View file

@ -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))

2
templates/discussion/widget/message.hamlet
View file

@ -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