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

config/models

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

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"

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

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

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
             )

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

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
+        --ob <- getJust $ localMessageCreate lm
-        let activity = docValue $ persistJSONValue $ outboxItemActivity ob
+        --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  =
+            , noteAudience  = Audience [] [] [] [] [] []
-                case activitySpecific activity of
+                --case activitySpecific activity of
-                    CreateActivity (Create note) -> noteAudience note
+                --    CreateActivity (Create note) -> noteAudience note
-                    _ -> error $ "lmid#" ++ show (fromSqlKey lmid) ++ "'s create isn't a Create activity!"
+                --    _ -> error $ "lmid#" ++ show (fromSqlKey lmid) ++ "'s create isn't a Create activity!"
             , noteReplyTo   = Just $ fromMaybe uContext muParent
             , noteContext   = Just uContext
             , notePublished = Just $ messageCreated m

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
+            (Just act, Nothing) -> fromJust $ decode $ persistJSONBL act
-            (Nothing, Just obj) -> Right $ persistJSONValue obj
+            (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
+        return $ persistJSONBL $ outboxItemActivity obi
-    provideHtmlAndAP' h act $ redirect (here, [("prettyjson", "true")])
+    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)
+            (Just act, Nothing) -> (ibid, fromJust $ decode $ persistJSONBL act)
-            (Nothing, Just obj) -> (ibid, Right $ persistJSONValue obj)
+            (Nothing, Just obj) -> (ibid, persistJSONValue obj)
 
 postNotificationsR :: ShrIdent -> Handler Html
 postNotificationsR shr = do

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

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
                               <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]
+                        |]

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 =
+renderPrettyJSON = renderPrettyJSON' . encode
-    let prettyBL = encodePretty a
+
-        prettyB = BL.toStrict prettyBL
+renderPrettyJSON' :: BL.ByteString -> WidgetFor site ()
+renderPrettyJSON' prettyBL =
+    let prettyB = BL.toStrict prettyBL
         prettyTL = TLE.decodeUtf8 prettyBL
     in  renderCode L.JS.lexer prettyTL prettyB

templates/person/inbox.hamlet

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

templates/person/notifications.hamlet

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

templates/person/outbox.hamlet

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