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

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

View file

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

View file

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

View file

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

View file

@ -30,6 +30,7 @@ module Vervis.ActivityPub
, isInstanceErrorP , isInstanceErrorP
, isInstanceErrorG , isInstanceErrorG
, deliverHttp , deliverHttp
, deliverHttpBL
, deliverRemoteDB , deliverRemoteDB
, deliverRemoteHTTP , deliverRemoteHTTP
, checkForward , checkForward
@ -278,6 +279,16 @@ deliverHttp
deliverHttp doc mfwd h luInbox = deliverHttp doc mfwd h luInbox =
deliverActivity (l2f h luInbox) (l2f h <$> mfwd) doc 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 deliverRemoteDB
:: BL.ByteString :: BL.ByteString
-> RemoteActivityId -> RemoteActivityId

View file

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

View file

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

View file

@ -150,8 +150,8 @@ getDiscussionMessage shr lmid = do
rs <- getJust $ remoteMessageAuthor rmParent rs <- getJust $ remoteMessageAuthor rmParent
i <- getJust $ remoteActorInstance rs i <- getJust $ remoteActorInstance rs
return $ l2f (instanceHost i) (remoteActorIdent 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 host <- getsYesod $ appInstanceHost . appSettings
route2local <- getEncodeRouteLocal route2local <- getEncodeRouteLocal
@ -159,10 +159,10 @@ getDiscussionMessage shr lmid = do
return $ Doc host Note return $ Doc host Note
{ noteId = Just $ route2local $ MessageR shr lmhid { noteId = Just $ route2local $ MessageR shr lmhid
, noteAttrib = route2local $ SharerR shr , 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 , noteReplyTo = Just $ fromMaybe uContext muParent
, noteContext = Just uContext , noteContext = Just uContext
, notePublished = Just $ messageCreated m , notePublished = Just $ messageCreated m

View file

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

View file

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

View file

@ -16,14 +16,18 @@
module Yesod.ActivityPub module Yesod.ActivityPub
( YesodActivityPub (..) ( YesodActivityPub (..)
, deliverActivity , deliverActivity
, deliverActivityBL
, deliverActivityBL'
, forwardActivity , forwardActivity
, provideHtmlAndAP , provideHtmlAndAP
, provideHtmlAndAP' , provideHtmlAndAP'
, provideHtmlAndAP''
) )
where where
import Control.Exception import Control.Exception
import Control.Monad.Logger.CallStack import Control.Monad.Logger.CallStack
import Data.Aeson
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Foldable import Data.Foldable
import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty (NonEmpty)
@ -33,6 +37,7 @@ import Network.HTTP.Types.Header
import Yesod.Core hiding (logError, logDebug) import Yesod.Core hiding (logError, logDebug)
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as M
import qualified Data.Text as T import qualified Data.Text as T
import Network.HTTP.Signature import Network.HTTP.Signature
@ -53,7 +58,7 @@ class Yesod site => YesodActivityPub site where
siteSigVerSeconds :: site -> Int siteSigVerSeconds :: site -> Int
-} -}
deliverActivity deliverActivity'
:: ( MonadSite m :: ( MonadSite m
, SiteEnv m ~ site , SiteEnv m ~ site
, HasHttpManager site , HasHttpManager site
@ -61,15 +66,16 @@ deliverActivity
) )
=> FedURI => FedURI
-> Maybe FedURI -> Maybe FedURI
-> Doc Activity -> Text
-> BL.ByteString
-> m (Either APPostError (Response ())) -> m (Either APPostError (Response ()))
deliverActivity inbox mfwd doc@(Doc hAct activity) = do deliverActivity' inbox mfwd sender body = do
manager <- asksSite getHttpManager manager <- asksSite getHttpManager
headers <- asksSite sitePostSignedHeaders headers <- asksSite sitePostSignedHeaders
(keyid, sign) <- siteGetHttpSign (keyid, sign) <- siteGetHttpSign
let sender = renderFedURI $ l2f hAct (activityActor activity)
result <- result <-
httpPostAP manager inbox headers keyid sign sender (Left <$> mfwd) doc httpPostAPBytes
manager inbox headers keyid sign sender (Left <$> mfwd) body
case result of case result of
Left err -> Left err ->
logError $ T.concat logError $ T.concat
@ -83,6 +89,55 @@ deliverActivity inbox mfwd doc@(Doc hAct activity) = do
] ]
return result 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 forwardActivity
:: ( MonadSite m :: ( MonadSite m
, SiteEnv m ~ site , SiteEnv m ~ site
@ -144,3 +199,25 @@ provideHtmlAndAP' host object widget = selectRep $ do
<a href=@?{(route, pj : params)}> <a href=@?{(route, pj : params)}>
[See JSON] [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]
|]

View file

@ -41,6 +41,7 @@ module Yesod.RenderSource
, renderSourceBL , renderSourceBL
, renderPandocMarkdown , renderPandocMarkdown
, renderPrettyJSON , renderPrettyJSON
, renderPrettyJSON'
) )
where where
@ -256,8 +257,10 @@ renderPandocMarkdown input =
. writeHtml5 writerOptions . writeHtml5 writerOptions
renderPrettyJSON :: ToJSON a => a -> WidgetFor site () 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 prettyTL = TLE.decodeUtf8 prettyBL
in renderCode L.JS.lexer prettyTL prettyB in renderCode L.JS.lexer prettyTL prettyB

View file

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

View file

@ -19,11 +19,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<div> <div>
$forall (activity, widget, enctype) <- notifications $forall (activity, widget, enctype) <- notifications
<div><pre> <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}> <form method=POST action=@{NotificationsR shr} enctype=#{enctype}>
^{widget} ^{widget}
<input type=submit value="Mark as read"> <input type=submit value="Mark as read">

View file

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