sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 16:24:52 +09:00
Code Issues Activity

Treat outbox items in DB as bytestrings to avoid depending on JSON parsing

Browse source
This commit is contained in:
fr33domlover 2019-06-28 23:15:08 +00:00
parent e5f9b34ad2
commit e10b4d452a
14 changed files with 160 additions and 48 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
config/models
View file

@ -47,7 +47,7 @@ Outbox
OutboxItem
outbox OutboxId
activity PersistActivity
activity PersistJSONBL
published UTCTime
Inbox

18
src/Database/Persist/JSON.hs
View file

@ -23,6 +23,7 @@
-- 'toEncoding'.
module Database.Persist.JSON
( PersistJSON (..)
, PersistJSONBL (..)
, PersistJSONValue
, PersistJSONObject
)
@ -34,12 +35,17 @@ import Data.Text.Lazy.Encoding
import Database.Persist
import Database.Persist.Sql
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
newtype PersistJSON a = PersistJSON
{ persistJSONValue :: a
}
newtype PersistJSONBL = PersistJSONBL
{ persistJSONBL :: BL.ByteString
}
type PersistJSONValue = PersistJSON Value
type PersistJSONObject = PersistJSON Object
@ -63,5 +69,17 @@ instance (FromJSON a, ToJSON a) => PersistField (PersistJSON a) where
"Expected jsonb field to be decoded by persistent-postgresql as \
\a PersistByteString, instead got " <> T.pack (show v)
instance PersistField PersistJSONBL where
toPersistValue = toPersistValue . decodeUtf8 . persistJSONBL
fromPersistValue (PersistByteString b) =
Right $ PersistJSONBL $ BL.fromStrict b
fromPersistValue v =
Left $
"Expected jsonb field to be decoded by persistent-postgresql as \
\a PersistByteString, instead got " <> T.pack (show v)
instance (FromJSON a, ToJSON a) => PersistFieldSql (PersistJSON a) where
sqlType _ = SqlOther "jsonb"
instance PersistFieldSql PersistJSONBL where
sqlType _ = SqlOther "jsonb"

16
src/Vervis/API.hs
View file

@ -360,7 +360,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
tempUri = LocalURI "" ""
obiid <- insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity = PersistJSON $ activity tempUri tempUri
, outboxItemActivity =
PersistJSONBL $ encode $ activity tempUri tempUri
, outboxItemPublished = now
}
lmid <- insert LocalMessage
@ -378,7 +379,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
let luAct = route2local $ SharerOutboxItemR shrUser obihid
luNote = route2local $ MessageR shrUser lmhid
doc = activity luAct luNote
update obiid [OutboxItemActivity =. PersistJSON doc]
update obiid [OutboxItemActivity =. PersistJSONBL (encode doc)]
return (lmid, obiid, doc)
-- Deliver to local recipients. For local users, find in DB and deliver.
@ -528,14 +529,14 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
}
obiid <- insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity = PersistJSON $ activity Nothing
, outboxItemActivity = PersistJSONBL $ encode $ activity Nothing
, outboxItemPublished = now
}
encodeRouteLocal <- getEncodeRouteLocal
obikhid <- encodeKeyHashid obiid
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
doc = activity $ Just luAct
update obiid [OutboxItemActivity =. PersistJSON doc]
update obiid [OutboxItemActivity =. PersistJSONBL (encode doc)]
return (obiid, doc, luAct)
deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer recips = do
(pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer projects) -> do
@ -638,14 +639,17 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
}
obiid <- insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity = PersistJSON $ accept Nothing
, outboxItemActivity =
PersistJSONBL $ encode $ accept Nothing
, outboxItemPublished = now
}
encodeRouteLocal <- getEncodeRouteLocal
obikhid <- encodeKeyHashid obiid
let luAct = encodeRouteLocal $ ProjectOutboxItemR shrProject prjProject obikhid
doc = accept $ Just luAct
update obiid [OutboxItemActivity =. PersistJSON doc]
update
obiid
[OutboxItemActivity =. PersistJSONBL (encode doc)]
return (obiid, doc)
insertTicket jid tidsDeps next obiidAccept = do
did <- insert Discussion

11
src/Vervis/ActivityPub.hs
View file

@ -30,6 +30,7 @@ module Vervis.ActivityPub
, isInstanceErrorP
, isInstanceErrorG
, deliverHttp
, deliverHttpBL
, deliverRemoteDB
, deliverRemoteHTTP
, checkForward
@ -278,6 +279,16 @@ deliverHttp
deliverHttp doc mfwd h luInbox =
deliverActivity (l2f h luInbox) (l2f h <$> mfwd) doc
deliverHttpBL
:: (MonadSite m, SiteEnv m ~ App)
=> BL.ByteString
-> Maybe LocalURI
-> Text
-> LocalURI
-> m (Either APPostError (Response ()))
deliverHttpBL body mfwd h luInbox =
deliverActivityBL' (l2f h luInbox) (l2f h <$> mfwd) body
deliverRemoteDB
:: BL.ByteString
-> RemoteActivityId

6
src/Vervis/Federation.hs
View file

@ -363,7 +363,7 @@ retryOutboxDelivery = do
let (forwardingOld, forwardingNew) = partitionEithers $ map (decideBySinceFW dropAfter now . adaptForwarding) forwarding
deleteWhere [ForwardingId <-. forwardingOld]
return (groupUnlinked lonelyNew, groupLinked linkedNew, groupForwarding forwardingNew)
let deliver = deliverHttp
let deliver = deliverHttpBL
logInfo "Periodic delivery prepared DB, starting async HTTP POSTs"
logDebug $
@ -411,7 +411,7 @@ retryOutboxDelivery = do
(E.Value iid, E.Value h, E.Value uraid, E.Value luRecip, E.Value since, E.Value udlid, E.Value obid, E.Value fwd, E.Value act, E.Value mraid, E.Value mrcid) =
( Left <$> mraid <|> Right <$> mrcid
, ( ( (iid, h)
, ((uraid, luRecip), (udlid, fwd, obid, persistJSONValue act))
, ((uraid, luRecip), (udlid, fwd, obid, persistJSONBL act))
)
, since
)
@ -433,7 +433,7 @@ retryOutboxDelivery = do
adaptLinked
(E.Value iid, E.Value h, E.Value raid, E.Value ident, E.Value inbox, E.Value since, E.Value dlid, E.Value fwd, E.Value act) =
( ( (iid, h)
, ((raid, (ident, inbox)), (dlid, fwd, persistJSONValue act))
, ((raid, (ident, inbox)), (dlid, fwd, persistJSONBL act))
)
, since
)

4
src/Vervis/Federation/Ticket.hs
View file

@ -396,14 +396,14 @@ projectOfferTicketF
}
obiid <- insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity = PersistJSON $ accept Nothing
, outboxItemActivity = PersistJSONBL $ encode $ accept Nothing
, outboxItemPublished = now
}
encodeRouteLocal <- getEncodeRouteLocal
obikhid <- encodeKeyHashid obiid
let luAct = encodeRouteLocal $ ProjectOutboxItemR shrRecip prjRecip obikhid
doc = accept $ Just luAct
update obiid [OutboxItemActivity =. PersistJSON doc]
update obiid [OutboxItemActivity =. PersistJSONBL (encode doc)]
return (obiid, doc)
publishAccept luOffer num obiid doc = do

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

@ -150,8 +150,8 @@ getDiscussionMessage shr lmid = do
rs <- getJust $ remoteMessageAuthor rmParent
i <- getJust $ remoteActorInstance rs
return $ l2f (instanceHost i) (remoteActorIdent rs)
ob <- getJust $ localMessageCreate lm
let activity = docValue $ persistJSONValue $ outboxItemActivity ob
--ob <- getJust $ localMessageCreate lm
--let activity = docValue $ persistJSONValue $ outboxItemActivity ob
host <- getsYesod $ appInstanceHost . appSettings
route2local <- getEncodeRouteLocal
@ -159,10 +159,10 @@ getDiscussionMessage shr lmid = do
return $ Doc host Note
{ noteId = Just $ route2local $ MessageR shr lmhid
, noteAttrib = route2local $ SharerR shr
, noteAudience =
case activitySpecific activity of
CreateActivity (Create note) -> noteAudience note
_ -> error $ "lmid#" ++ show (fromSqlKey lmid) ++ "'s create isn't a Create activity!"
, noteAudience = Audience [] [] [] [] [] []
--case activitySpecific activity of
-- CreateActivity (Create note) -> noteAudience note
-- _ -> error $ "lmid#" ++ show (fromSqlKey lmid) ++ "'s create isn't a Create activity!"
, noteReplyTo = Just $ fromMaybe uContext muParent
, noteContext = Just uContext
, notePublished = Just $ messageCreated m

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

@ -80,6 +80,7 @@ import Yesod.Form.Types
import Yesod.Persist.Core
import qualified Data.ByteString.Char8 as BC (unpack)
import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI (mk)
import qualified Data.HashMap.Strict as M (lookup, insert, adjust, fromList)
import qualified Data.Text as T
@ -194,7 +195,7 @@ getInbox here getInboxId = do
then Just $ pageUrl $ current + 1
else Nothing
, collectionPageStartIndex = Nothing
, collectionPageItems = map fromEither items
, collectionPageItems = items
}
provideRep $
let pageNav = navWidget navModel
@ -233,8 +234,8 @@ getInbox here getInboxId = do
"InboxItem #" ++ show ibid ++ " neither local nor remote"
(Just _, Just _) ->
error $ "InboxItem #" ++ show ibid ++ " both local and remote"
(Just act, Nothing) -> Left $ persistJSONValue act
(Nothing, Just obj) -> Right $ persistJSONValue obj
(Just act, Nothing) -> fromJust $ decode $ persistJSONBL act
(Nothing, Just obj) -> persistJSONValue obj
getSharerInboxR :: ShrIdent -> Handler TypedContent
getSharerInboxR shr = getInbox here getInboxId
@ -433,6 +434,8 @@ getOutbox here getObid = do
provideRep (redirectFirstPage here :: Handler Html)
Just (items, navModel) -> do
let current = nmCurrent navModel
decodeToObj :: BL.ByteString -> Maybe Object
decodeToObj = decode
provideAP $ pure $ Doc host $ CollectionPage
{ collectionPageId = pageUrl current
, collectionPageType = CollectionPageTypeOrdered
@ -450,7 +453,7 @@ getOutbox here getObid = do
then Just $ pageUrl $ current + 1
else Nothing
, collectionPageStartIndex = Nothing
, collectionPageItems = map (persistJSONValue . outboxItemActivity . entityVal) items
, collectionPageItems = map (fromJust . decodeToObj . persistJSONBL . outboxItemActivity . entityVal) items
}
provideRep $ do
let pageNav = navWidget navModel
@ -469,12 +472,12 @@ getOutboxItem
-> Handler TypedContent
getOutboxItem here getObid obikhid = do
obiid <- decodeKeyHashid404 obikhid
Doc h act <- runDB $ do
body <- runDB $ do
obid <- getObid
obi <- get404 obiid
unless (outboxItemOutbox obi == obid) notFound
return $ persistJSONValue $ outboxItemActivity obi
provideHtmlAndAP' h act $ redirect (here, [("prettyjson", "true")])
return $ persistJSONBL $ outboxItemActivity obi
provideHtmlAndAP'' body $ redirect (here, [("prettyjson", "true")])
getSharerOutboxR :: ShrIdent -> Handler TypedContent
getSharerOutboxR shr = getOutbox here getObid
@ -703,8 +706,8 @@ getNotificationsR shr = do
"InboxItem #" ++ show ibid ++ " neither local nor remote"
(Just _, Just _) ->
error $ "InboxItem #" ++ show ibid ++ " both local and remote"
(Just act, Nothing) -> (ibid, Left $ persistJSONValue act)
(Nothing, Just obj) -> (ibid, Right $ persistJSONValue obj)
(Just act, Nothing) -> (ibid, fromJust $ decode $ persistJSONBL act)
(Nothing, Just obj) -> (ibid, persistJSONValue obj)
postNotificationsR :: ShrIdent -> Handler Html
postNotificationsR shr = do

4
src/Web/ActivityPub.hs
View file

@ -59,6 +59,7 @@ module Web.ActivityPub
, publicURI
, hActivityPubActor
, provideAP
, provideAP'
, APGetError (..)
, httpGetAP
, APPostError (..)
@ -829,6 +830,9 @@ provideAP mk =
-- provideRepType typeActivityStreams2 $ return enc
provideRepType typeActivityStreams2LD $ toEncoding <$> mk
provideAP' :: Monad m => m BL.ByteString -> Writer (Endo [ProvidedRep m]) ()
provideAP' = provideRepType typeActivityStreams2LD
data APGetError
= APGetErrorHTTP HttpException
| APGetErrorJSON JSONException

87
src/Yesod/ActivityPub.hs
View file

@ -16,14 +16,18 @@
module Yesod.ActivityPub
( YesodActivityPub (..)
, deliverActivity
, deliverActivityBL
, deliverActivityBL'
, forwardActivity
, provideHtmlAndAP
, provideHtmlAndAP'
, provideHtmlAndAP''
)
where
import Control.Exception
import Control.Monad.Logger.CallStack
import Data.Aeson
import Data.ByteString (ByteString)
import Data.Foldable
import Data.List.NonEmpty (NonEmpty)
@ -33,6 +37,7 @@ import Network.HTTP.Types.Header
import Yesod.Core hiding (logError, logDebug)
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as M
import qualified Data.Text as T
import Network.HTTP.Signature
@ -53,7 +58,7 @@ class Yesod site => YesodActivityPub site where
siteSigVerSeconds :: site -> Int
-}
deliverActivity
deliverActivity'
:: ( MonadSite m
, SiteEnv m ~ site
, HasHttpManager site
@ -61,15 +66,16 @@ deliverActivity
)
=> FedURI
-> Maybe FedURI
-> Doc Activity
-> Text
-> BL.ByteString
-> m (Either APPostError (Response ()))
deliverActivity inbox mfwd doc@(Doc hAct activity) = do
deliverActivity' inbox mfwd sender body = do
manager <- asksSite getHttpManager
headers <- asksSite sitePostSignedHeaders
(keyid, sign) <- siteGetHttpSign
let sender = renderFedURI $ l2f hAct (activityActor activity)
result <-
httpPostAP manager inbox headers keyid sign sender (Left <$> mfwd) doc
httpPostAPBytes
manager inbox headers keyid sign sender (Left <$> mfwd) body
case result of
Left err ->
logError $ T.concat
@ -83,6 +89,55 @@ deliverActivity inbox mfwd doc@(Doc hAct activity) = do
]
return result
deliverActivity
:: ( MonadSite m
, SiteEnv m ~ site
, HasHttpManager site
, YesodActivityPub site
)
=> FedURI
-> Maybe FedURI
-> Doc Activity
-> m (Either APPostError (Response ()))
deliverActivity inbox mfwd doc@(Doc hAct activity) =
let sender = renderFedURI $ l2f hAct (activityActor activity)
body = encode doc
in deliverActivity' inbox mfwd sender body
deliverActivityBL
:: ( MonadSite m
, SiteEnv m ~ site
, HasHttpManager site
, YesodActivityPub site
)
=> FedURI
-> Maybe FedURI
-> Route site
-> BL.ByteString
-> m (Either APPostError (Response ()))
deliverActivityBL inbox mfwd senderR body = do
renderUrl <- askUrlRender
let sender = renderUrl senderR
deliverActivity' inbox mfwd sender body
deliverActivityBL'
:: ( MonadSite m
, SiteEnv m ~ site
, HasHttpManager site
, YesodActivityPub site
)
=> FedURI
-> Maybe FedURI
-> BL.ByteString
-> m (Either APPostError (Response ()))
deliverActivityBL' inbox mfwd body = do
sender <-
case M.lookup ("actor" :: Text) =<< decode body of
Just (String t) -> return t
_ ->
liftIO $ throwIO $ userError "Couldn't extract actor from body"
deliverActivity' inbox mfwd sender body
forwardActivity
:: ( MonadSite m
, SiteEnv m ~ site
@ -144,3 +199,25 @@ provideHtmlAndAP' host object widget = selectRep $ do
<a href=@?{(route, pj : params)}>
[See JSON]
|]
provideHtmlAndAP''
:: YesodActivityPub site
=> BL.ByteString -> WidgetFor site () -> HandlerFor site TypedContent
provideHtmlAndAP'' body widget = selectRep $ do
provideAP' $ pure body
provideRep $ do
mval <- lookupGetParam "prettyjson"
defaultLayout $
case mval of
Just "true" -> renderPrettyJSON' body
_ -> do
widget
mroute <- getCurrentRoute
for_ mroute $ \ route -> do
params <- reqGetParams <$> getRequest
let pj = ("prettyjson", "true")
[whamlet|
<div>
<a href=@?{(route, pj : params)}>
[See JSON]
|]

9
src/Yesod/RenderSource.hs
View file

@ -41,6 +41,7 @@ module Yesod.RenderSource
, renderSourceBL
, renderPandocMarkdown
, renderPrettyJSON
, renderPrettyJSON'
)
where
@ -256,8 +257,10 @@ renderPandocMarkdown input =
. writeHtml5 writerOptions
renderPrettyJSON :: ToJSON a => a -> WidgetFor site ()
renderPrettyJSON a =
let prettyBL = encodePretty a
prettyB = BL.toStrict prettyBL
renderPrettyJSON = renderPrettyJSON' . encode
renderPrettyJSON' :: BL.ByteString -> WidgetFor site ()
renderPrettyJSON' prettyBL =
let prettyB = BL.toStrict prettyBL
prettyTL = TLE.decodeUtf8 prettyBL
in renderCode L.JS.lexer prettyTL prettyB

8
templates/person/inbox.hamlet
View file

@ -20,12 +20,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
^{pageNav}
<div>
$forall item <- items
$forall obj <- items
<div><pre>
$case item
$of Left doc
#{AEP.encodePrettyToLazyText doc}
$of Right obj
#{TLB.toLazyText $ encodePrettyToTextBuilder obj}
#{TLB.toLazyText $ encodePrettyToTextBuilder obj}
^{pageNav}

6
templates/person/notifications.hamlet
View file

@ -19,11 +19,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div>
$forall (activity, widget, enctype) <- notifications
<div><pre>
$case activity
$of Left doc
#{AEP.encodePrettyToLazyText doc}
$of Right obj
#{TLB.toLazyText $ encodePrettyToTextBuilder obj}
#{TLB.toLazyText $ encodePrettyToTextBuilder activity}
<form method=POST action=@{NotificationsR shr} enctype=#{enctype}>
^{widget}
<input type=submit value="Mark as read">

4
templates/person/outbox.hamlet
View file

@ -20,8 +20,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
^{pageNav}
<div>
$forall Entity _ (OutboxItem _ (PersistJSON doc) published) <- items
$forall Entity _ (OutboxItem _ (PersistJSONBL body) published) <- items
<div>#{showTime published}
<div>^{renderPrettyJSON doc}
<div>^{renderPrettyJSON' body}
^{pageNav}