From e10b4d452aee06536d6fcd3f845da5fb83d404f9 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Fri, 28 Jun 2019 23:15:08 +0000 Subject: [PATCH] Treat outbox items in DB as bytestrings to avoid depending on JSON parsing --- config/models | 2 +- src/Database/Persist/JSON.hs | 18 ++++++ src/Vervis/API.hs | 16 +++-- src/Vervis/ActivityPub.hs | 11 ++++ src/Vervis/Federation.hs | 6 +- src/Vervis/Federation/Ticket.hs | 4 +- src/Vervis/Handler/Discussion.hs | 12 ++-- src/Vervis/Handler/Inbox.hs | 21 ++++--- src/Web/ActivityPub.hs | 4 ++ src/Yesod/ActivityPub.hs | 87 +++++++++++++++++++++++++-- src/Yesod/RenderSource.hs | 9 ++- templates/person/inbox.hamlet | 8 +-- templates/person/notifications.hamlet | 6 +- templates/person/outbox.hamlet | 4 +- 14 files changed, 160 insertions(+), 48 deletions(-) diff --git a/config/models b/config/models index f5b711f..27642aa 100644 --- a/config/models +++ b/config/models @@ -47,7 +47,7 @@ Outbox OutboxItem outbox OutboxId - activity PersistActivity + activity PersistJSONBL published UTCTime Inbox diff --git a/src/Database/Persist/JSON.hs b/src/Database/Persist/JSON.hs index b547dc4..a183e8f 100644 --- a/src/Database/Persist/JSON.hs +++ b/src/Database/Persist/JSON.hs @@ -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" diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 8333b4c..2e3b469 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -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 diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index 74970b5..a923bec 100644 --- a/src/Vervis/ActivityPub.hs +++ b/src/Vervis/ActivityPub.hs @@ -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 diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 245cdfd..17b4414 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -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 ) diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index d5f0095..6394a4d 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -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 diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index b3ca6cc..3760444 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/src/Vervis/Handler/Discussion.hs @@ -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 diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index ffe5b88..648c9a0 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 3d5afb7..3aac68f 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -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 diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs index bdb80f9..dac8d08 100644 --- a/src/Yesod/ActivityPub.hs +++ b/src/Yesod/ActivityPub.hs @@ -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 [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| +
+ + [See JSON] + |] diff --git a/src/Yesod/RenderSource.hs b/src/Yesod/RenderSource.hs index 09ee30d..5e9f91e 100644 --- a/src/Yesod/RenderSource.hs +++ b/src/Yesod/RenderSource.hs @@ -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 diff --git a/templates/person/inbox.hamlet b/templates/person/inbox.hamlet index b0b4f31..6723406 100644 --- a/templates/person/inbox.hamlet +++ b/templates/person/inbox.hamlet @@ -20,12 +20,8 @@ $# . ^{pageNav}
- $forall item <- items + $forall obj <- items 
-      $case item
-        $of Left doc
-          #{AEP.encodePrettyToLazyText doc}
-        $of Right obj
-          #{TLB.toLazyText $ encodePrettyToTextBuilder obj}
+      #{TLB.toLazyText $ encodePrettyToTextBuilder obj}
 
 ^{pageNav}
diff --git a/templates/person/notifications.hamlet b/templates/person/notifications.hamlet
index aa8f9d2..e6e83e0 100644
--- a/templates/person/notifications.hamlet
+++ b/templates/person/notifications.hamlet
@@ -19,11 +19,7 @@ $# .
 

   $forall (activity, widget, enctype) <- notifications
     
-      $case activity
-        $of Left doc
-          #{AEP.encodePrettyToLazyText doc}
-        $of Right obj
-          #{TLB.toLazyText $ encodePrettyToTextBuilder obj}
+      #{TLB.toLazyText $ encodePrettyToTextBuilder activity}
     

       ^{widget}
       
diff --git a/templates/person/outbox.hamlet b/templates/person/outbox.hamlet
index 8818a6a..41d6e97 100644
--- a/templates/person/outbox.hamlet
+++ b/templates/person/outbox.hamlet
@@ -20,8 +20,8 @@ $# .
 ^{pageNav}
 
 

-  $forall Entity _ (OutboxItem _ (PersistJSON doc) published) <- items
+  $forall Entity _ (OutboxItem _ (PersistJSONBL body) published) <- items
     
#{showTime published}
-    
^{renderPrettyJSON doc}
+    
^{renderPrettyJSON' body}
 
 ^{pageNav}