forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Switch OutboxItem's Activity from plain BL to an upgraded PersistJSONObject

Browse source
This commit is contained in:
fr33domlover 2019-06-29 03:19:00 +00:00
parent e10b4d452a
commit 6d72d676e7
16 changed files with 122 additions and 71 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 OutboxItem
outbox OutboxId outbox OutboxId
activity PersistJSONBL activity PersistJSONObject
published UTCTime published UTCTime
Inbox Inbox

2
migrations/2019_03_19.model
View file

@ -1,5 +1,5 @@
RemoteRawObject RemoteRawObject
content PersistJSONValue content PersistJSONObject
received UTCTime received UTCTime
RemoteDiscussion RemoteDiscussion

2
migrations/2019_03_30.model
View file

@ -1,6 +1,6 @@
OutboxItem OutboxItem
person PersonId person PersonId
activity PersistJSONValue activity PersistJSONObject
published UTCTime published UTCTime
FollowerSet FollowerSet

2
migrations/2019_04_22.model
View file

@ -1,7 +1,7 @@
RemoteActivity RemoteActivity
instance InstanceId instance InstanceId
ident Text ident Text
content PersistJSONValue content PersistJSONObject
received UTCTime received UTCTime
UniqueRemoteActivity instance ident UniqueRemoteActivity instance ident

2
migrations/2019_05_24.model
View file

@ -23,7 +23,7 @@ Person
OutboxItem OutboxItem
person PersonId person PersonId
activity PersistActivity activity PersistJSONObject
published UTCTime published UTCTime
Discussion Discussion

2
migrations/2019_06_12.model
View file

@ -25,7 +25,7 @@ Person
OutboxItem OutboxItem
person PersonId person PersonId
activity PersistActivity activity PersistJSONObject
published UTCTime published UTCTime
Inbox Inbox

2
migrations/2019_06_24.model
View file

@ -29,7 +29,7 @@ Outbox
OutboxItem OutboxItem
outbox OutboxId outbox OutboxId
activity PersistActivity activity PersistJSONObject
published UTCTime published UTCTime
Inbox Inbox

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

@ -22,32 +22,37 @@
-- means all encoding has to go through 'Value' and we can't benefit from -- means all encoding has to go through 'Value' and we can't benefit from
-- 'toEncoding'. -- 'toEncoding'.
module Database.Persist.JSON module Database.Persist.JSON
( PersistJSON (..) ( PersistJSON ()
, PersistJSONBL (..) , persistJSONDoc
, PersistJSONValue , persistJSONObject
, persistJSONBytes
, PersistJSONObject , PersistJSONObject
, persistJSONFromDoc
, persistJSONFromObject
, persistJSONFromB
, persistJSONFromBL
, persistJSONObjectFromDoc
) )
where where
import Data.Aeson import Data.Aeson
import Data.Aeson.Text import Data.Aeson.Text
import Data.Text.Lazy.Encoding import Data.ByteString (ByteString)
import Data.Text.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.ByteString.Lazy as BL
import qualified Data.Text as T import qualified Data.Text as T
newtype PersistJSON a = PersistJSON import Data.Aeson.Local
{ persistJSONValue :: a
}
newtype PersistJSONBL = PersistJSONBL data PersistJSON a = PersistJSON
{ persistJSONBL :: BL.ByteString { persistJSONDoc :: a
, persistJSONObject :: Object
, persistJSONBytes :: ByteString
} }
type PersistJSONValue = PersistJSON Value
type PersistJSONObject = PersistJSON Object type PersistJSONObject = PersistJSON Object
-- persistent-postgresql turns jsonb values into PersistByteString, but it -- persistent-postgresql turns jsonb values into PersistByteString, but it
@ -56,23 +61,14 @@ type PersistJSONObject = PersistJSON Object
-- (because that's what persistent-postgresql sends, which is convenient -- (because that's what persistent-postgresql sends, which is convenient
-- because we can directly decode the ByteString using aeson). -- because we can directly decode the ByteString using aeson).
instance (FromJSON a, ToJSON a) => PersistField (PersistJSON a) where instance (FromJSON a, ToJSON a) => PersistField (PersistJSON a) where
toPersistValue = toPersistValue . encodeToLazyText . persistJSONValue toPersistValue = toPersistValue . decodeUtf8 . persistJSONBytes
fromPersistValue (PersistByteString b) = fromPersistValue (PersistByteString b) =
case eitherDecodeStrict b of case eitherDecodeStrict b of
Left s -> Left $ T.concat Left s -> Left $ T.concat
[ "Decoding jsonb value ", T.pack (show b), " failed: " [ "Decoding jsonb value ", T.pack (show b), " failed: "
, T.pack s , T.pack s
] ]
Right x -> Right $ PersistJSON x Right (WithValue o d) -> Right $ PersistJSON d o b
fromPersistValue v =
Left $
"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 = fromPersistValue v =
Left $ Left $
"Expected jsonb field to be decoded by persistent-postgresql as \ "Expected jsonb field to be decoded by persistent-postgresql as \
@ -81,5 +77,43 @@ instance PersistField PersistJSONBL where
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 persistJSONFromDoc :: ToJSON a => a -> PersistJSON a
sqlType _ = SqlOther "jsonb" persistJSONFromDoc d =
let bl = encode d
in PersistJSON d (fromEnc $ decode bl) (BL.toStrict bl)
where
fromEnc Nothing = error "persistJSONFromDoc: decode failed"
fromEnc (Just o) = o
persistJSONFromObject :: FromJSON a => Object -> PersistJSON a
persistJSONFromObject o =
let doc =
case fromJSON $ Object o of
Error _ -> error "persistJSONFromObject: parseJSON failed"
Success d -> d
in PersistJSON doc o (BL.toStrict $ encode o)
persistJSONFromB :: FromJSON a => ByteString -> PersistJSON a
persistJSONFromB b =
let WithValue obj doc =
case decodeStrict b of
Nothing -> error "persistJSONFromB: decode failed"
Just x -> x
in PersistJSON doc obj b
persistJSONFromBL :: FromJSON a => BL.ByteString -> PersistJSON a
persistJSONFromBL bl =
let WithValue obj doc =
case decode bl of
Nothing -> error "persistJSONFromBL: decode failed"
Just x -> x
in PersistJSON doc obj (BL.toStrict bl)
persistJSONObjectFromDoc :: ToJSON a => a -> PersistJSON Object
persistJSONObjectFromDoc doc =
let bl = encode doc
obj =
case decode bl of
Nothing -> error "persistJSONObjectFromDoc: decode failed"
Just o -> o
in PersistJSON obj obj (BL.toStrict bl)

13
src/Vervis/API.hs
View file

@ -361,7 +361,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
obiid <- insert OutboxItem obiid <- insert OutboxItem
{ outboxItemOutbox = obid { outboxItemOutbox = obid
, outboxItemActivity = , outboxItemActivity =
PersistJSONBL $ encode $ activity tempUri tempUri persistJSONObjectFromDoc $ activity tempUri tempUri
, outboxItemPublished = now , outboxItemPublished = now
} }
lmid <- insert LocalMessage lmid <- insert LocalMessage
@ -379,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 =. PersistJSONBL (encode doc)] update obiid [OutboxItemActivity =. persistJSONObjectFromDoc 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.
@ -529,14 +529,15 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
} }
obiid <- insert OutboxItem obiid <- insert OutboxItem
{ outboxItemOutbox = obid { outboxItemOutbox = obid
, outboxItemActivity = PersistJSONBL $ encode $ activity Nothing , outboxItemActivity =
persistJSONObjectFromDoc $ 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 =. PersistJSONBL (encode doc)] update obiid [OutboxItemActivity =. persistJSONObjectFromDoc 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
@ -640,7 +641,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
obiid <- insert OutboxItem obiid <- insert OutboxItem
{ outboxItemOutbox = obid { outboxItemOutbox = obid
, outboxItemActivity = , outboxItemActivity =
PersistJSONBL $ encode $ accept Nothing persistJSONObjectFromDoc $ accept Nothing
, outboxItemPublished = now , outboxItemPublished = now
} }
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -649,7 +650,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
doc = accept $ Just luAct doc = accept $ Just luAct
update update
obiid obiid
[OutboxItemActivity =. PersistJSONBL (encode doc)] [OutboxItemActivity =. persistJSONObjectFromDoc 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

4
src/Vervis/Federation.hs
View file

@ -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, persistJSONBL act)) , ((uraid, luRecip), (udlid, fwd, obid, BL.fromStrict $ persistJSONBytes 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, persistJSONBL act)) , ((raid, (ident, inbox)), (dlid, fwd, BL.fromStrict $ persistJSONBytes act))
) )
, since , since
) )

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

@ -174,7 +174,7 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
throwE "Remote parent belongs to a different discussion" throwE "Remote parent belongs to a different discussion"
insertToInbox luCreate ibidRecip = do insertToInbox luCreate ibidRecip = do
let iidAuthor = remoteAuthorInstance author let iidAuthor = remoteAuthorInstance author
jsonObj = PersistJSON $ actbObject body jsonObj = persistJSONFromBL $ actbBL body
ract = RemoteActivity iidAuthor luCreate jsonObj now ract = RemoteActivity iidAuthor luCreate jsonObj now
ractid <- either entityKey id <$> insertBy' ract ractid <- either entityKey id <$> insertBy' ract
ibiid <- insert $ InboxItem True ibiid <- insert $ InboxItem True
@ -288,7 +288,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
ractid <- either entityKey id <$> insertBy' RemoteActivity ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityInstance = iidAuthor { remoteActivityInstance = iidAuthor
, remoteActivityIdent = luCreate , remoteActivityIdent = luCreate
, remoteActivityContent = PersistJSON $ actbObject body , remoteActivityContent = persistJSONFromBL $ actbBL body
, remoteActivityReceived = now , remoteActivityReceived = now
} }
mid <- insert Message mid <- insert Message

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

@ -117,7 +117,7 @@ sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
throwE "Local dep: No such ticket number in DB" throwE "Local dep: No such ticket number in DB"
insertToInbox luOffer ibidRecip = do insertToInbox luOffer ibidRecip = do
let iidAuthor = remoteAuthorInstance author let iidAuthor = remoteAuthorInstance author
jsonObj = PersistJSON $ actbObject body jsonObj = persistJSONFromBL $ actbBL body
ract = RemoteActivity iidAuthor luOffer jsonObj now ract = RemoteActivity iidAuthor luOffer jsonObj now
ractid <- either entityKey id <$> insertBy' ract ractid <- either entityKey id <$> insertBy' ract
ibiid <- insert $ InboxItem True ibiid <- insert $ InboxItem True
@ -148,7 +148,7 @@ sharerAcceptOfferTicketF now shrRecip author body (Accept _uOffer _luTicket) = d
where where
insertToInbox luAccept ibidRecip = do insertToInbox luAccept ibidRecip = do
let iidAuthor = remoteAuthorInstance author let iidAuthor = remoteAuthorInstance author
jsonObj = PersistJSON $ actbObject body jsonObj = persistJSONFromBL $ actbBL body
ract = RemoteActivity iidAuthor luAccept jsonObj now ract = RemoteActivity iidAuthor luAccept jsonObj now
ractid <- either entityKey id <$> insertBy' ract ractid <- either entityKey id <$> insertBy' ract
ibiid <- insert $ InboxItem True ibiid <- insert $ InboxItem True
@ -179,7 +179,7 @@ sharerRejectOfferTicketF now shrRecip author body (Reject _uOffer) = do
where where
insertToInbox luReject ibidRecip = do insertToInbox luReject ibidRecip = do
let iidAuthor = remoteAuthorInstance author let iidAuthor = remoteAuthorInstance author
jsonObj = PersistJSON $ actbObject body jsonObj = persistJSONFromBL $ actbBL body
ract = RemoteActivity iidAuthor luReject jsonObj now ract = RemoteActivity iidAuthor luReject jsonObj now
ractid <- either entityKey id <$> insertBy' ract ractid <- either entityKey id <$> insertBy' ract
ibiid <- insert $ InboxItem True ibiid <- insert $ InboxItem True
@ -283,7 +283,7 @@ projectOfferTicketF
ractid <- either entityKey id <$> insertBy' RemoteActivity ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityInstance = iidAuthor { remoteActivityInstance = iidAuthor
, remoteActivityIdent = luOffer , remoteActivityIdent = luOffer
, remoteActivityContent = PersistJSON $ actbObject body , remoteActivityContent = persistJSONFromBL $ actbBL body
, remoteActivityReceived = now , remoteActivityReceived = now
} }
ibiid <- insert $ InboxItem False ibiid <- insert $ InboxItem False
@ -396,14 +396,14 @@ projectOfferTicketF
} }
obiid <- insert OutboxItem obiid <- insert OutboxItem
{ outboxItemOutbox = obid { outboxItemOutbox = obid
, outboxItemActivity = PersistJSONBL $ encode $ accept Nothing , outboxItemActivity = persistJSONObjectFromDoc $ 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 =. PersistJSONBL (encode doc)] update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (obiid, doc) return (obiid, doc)
publishAccept luOffer num obiid doc = do publishAccept luOffer num obiid doc = do

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

@ -234,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) -> fromJust $ decode $ persistJSONBL act (Just act, Nothing) -> persistJSONObject act
(Nothing, Just obj) -> persistJSONValue obj (Nothing, Just obj) -> persistJSONObject obj
getSharerInboxR :: ShrIdent -> Handler TypedContent getSharerInboxR :: ShrIdent -> Handler TypedContent
getSharerInboxR shr = getInbox here getInboxId getSharerInboxR shr = getInbox here getInboxId
@ -434,8 +434,6 @@ 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
@ -453,7 +451,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 (fromJust . decodeToObj . persistJSONBL . outboxItemActivity . entityVal) items , collectionPageItems = map (persistJSONObject . outboxItemActivity . entityVal) items
} }
provideRep $ do provideRep $ do
let pageNav = navWidget navModel let pageNav = navWidget navModel
@ -476,7 +474,7 @@ getOutboxItem here getObid obikhid = do
obid <- getObid obid <- getObid
obi <- get404 obiid obi <- get404 obiid
unless (outboxItemOutbox obi == obid) notFound unless (outboxItemOutbox obi == obid) notFound
return $ persistJSONBL $ outboxItemActivity obi return $ BL.fromStrict $ persistJSONBytes $ outboxItemActivity obi
provideHtmlAndAP'' body $ redirect (here, [("prettyjson", "true")]) provideHtmlAndAP'' body $ redirect (here, [("prettyjson", "true")])
getSharerOutboxR :: ShrIdent -> Handler TypedContent getSharerOutboxR :: ShrIdent -> Handler TypedContent
@ -706,8 +704,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, fromJust $ decode $ persistJSONBL act) (Just act, Nothing) -> (ibid, persistJSONObject act)
(Nothing, Just obj) -> (ibid, persistJSONValue obj) (Nothing, Just obj) -> (ibid, persistJSONObject obj)
postNotificationsR :: ShrIdent -> Handler Html postNotificationsR :: ShrIdent -> Handler Html
postNotificationsR shr = do postNotificationsR shr = do

44
src/Vervis/Migration.hs
View file

@ -20,11 +20,12 @@ where
import Control.Applicative import Control.Applicative
import Control.Exception import Control.Exception
import Control.Monad (unless) import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Data.Aeson
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Default.Class import Data.Default.Class
import Data.Default.Instances.ByteString () import Data.Default.Instances.ByteString ()
@ -52,6 +53,7 @@ import Text.Hamlet
import Web.Hashids import Web.Hashids
import Web.PathPieces (toPathPiece) import Web.PathPieces (toPathPiece)
import qualified Data.HashMap.Strict as M
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy as TL
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
@ -323,15 +325,31 @@ changes hLocal ctx =
, activityAudience = Audience [] [] [] [] [] [] , activityAudience = Audience [] [] [] [] [] []
, activitySpecific = RejectActivity $ Reject fedUri , activitySpecific = RejectActivity $ Reject fedUri
} }
insertEntity $ OutboxItem201905 pid (PersistJSON doc) defaultTime insertEntity $ OutboxItem201905 pid (persistJSONObjectFromDoc doc) defaultTime
) )
(Just $ \ (Entity obid ob) -> do (Just $ \ (Entity obid ob) -> do
let actNoteId (Activity _ _ _ _ (CreateActivity (Create note))) = noteId note let actNoteId a = do
actNoteId _ = Nothing String atyp <- M.lookup "type" a
guard $ atyp == "Create"
Object o <- M.lookup "object" a
String otyp <- M.lookup "type" o
guard $ otyp == "Note"
Just $
let t = case M.lookup "id" o of
Nothing -> error "Mig77: Note 'id' not found"
Just (String s) -> s
_ -> error "Mig77: Note 'id' not a string"
fu = case parseFedURI t of
Left _ -> error "Mig77: Note 'id' invalid FedURI"
Right u -> u
(h, lu) = f2l fu
in if h == hLocal
then lu
else error "Mig77: Note 'id' on foreign host"
obNoteId (Entity i o) = obNoteId (Entity i o) =
if i == obid if i == obid
then Nothing then Nothing
else (,i) <$> actNoteId (docValue $ persistJSONValue $ outboxItem201905Activity o) else (,i) <$> actNoteId (persistJSONObject $ outboxItem201905Activity o)
obs <- obs <-
mapMaybe obNoteId <$> mapMaybe obNoteId <$>
selectList ([] :: [Filter OutboxItem201905]) [] selectList ([] :: [Filter OutboxItem201905]) []
@ -459,7 +477,7 @@ changes hLocal ctx =
tempUri = LocalURI "" "" tempUri = LocalURI "" ""
newObid <- insert OutboxItem201905 newObid <- insert OutboxItem201905
{ outboxItem201905Person = pid { outboxItem201905Person = pid
, outboxItem201905Activity = PersistJSON $ activity tempUri tempUri , outboxItem201905Activity = persistJSONObjectFromDoc $ activity tempUri tempUri
, outboxItem201905Published = message201905Created m , outboxItem201905Published = message201905Created m
} }
let notePath = T.concat let notePath = T.concat
@ -473,7 +491,7 @@ changes hLocal ctx =
luAct = LocalURI obPath "" luAct = LocalURI obPath ""
luNote = LocalURI notePath "" luNote = LocalURI notePath ""
doc = activity luAct luNote doc = activity luAct luNote
update newObid [OutboxItem201905Activity =. PersistJSON doc] update newObid [OutboxItem201905Activity =. persistJSONObjectFromDoc doc]
return newObid return newObid
update lmid [LocalMessage201905Create =. obidNew] update lmid [LocalMessage201905Create =. obidNew]
@ -690,7 +708,7 @@ changes hLocal ctx =
, activityAudience = Audience [] [] [] [] [] [] , activityAudience = Audience [] [] [] [] [] []
, activitySpecific = RejectActivity $ Reject fedUri , activitySpecific = RejectActivity $ Reject fedUri
} }
insertEntity $ OutboxItem20190612 pid (PersistJSON doc) defaultTime insertEntity $ OutboxItem20190612 pid (persistJSONObjectFromDoc doc) defaultTime
) )
(Just $ \ (Entity obidTemp obTemp) -> do (Just $ \ (Entity obidTemp obTemp) -> do
ts <- selectList ([] :: [Filter Ticket20190612]) [] ts <- selectList ([] :: [Filter Ticket20190612]) []
@ -763,7 +781,7 @@ changes hLocal ctx =
tempUri = LocalURI "" "" tempUri = LocalURI "" ""
obidNew <- insert OutboxItem20190612 obidNew <- insert OutboxItem20190612
{ outboxItem20190612Person = pidAuthor { outboxItem20190612Person = pidAuthor
, outboxItem20190612Activity = PersistJSON $ doc tempUri , outboxItem20190612Activity = persistJSONObjectFromDoc $ doc tempUri
, outboxItem20190612Published = , outboxItem20190612Published =
ticket20190612Created ticket ticket20190612Created ticket
} }
@ -773,7 +791,7 @@ changes hLocal ctx =
encodeRouteLocal $ encodeRouteLocal $
SharerOutboxItemR shrAuthor obkhidNew SharerOutboxItemR shrAuthor obkhidNew
act = doc luAct act = doc luAct
update obidNew [OutboxItem20190612Activity =. PersistJSON act] update obidNew [OutboxItem20190612Activity =. persistJSONObjectFromDoc act]
update talid [TicketAuthorLocal20190612Offer =. obidNew] update talid [TicketAuthorLocal20190612Offer =. obidNew]
ibiid <- insert $ InboxItem20190612 False ibiid <- insert $ InboxItem20190612 False
insert_ $ InboxItemLocal20190612 ibidProject obidNew ibiid insert_ $ InboxItemLocal20190612 ibidProject obidNew ibiid
@ -855,7 +873,7 @@ changes hLocal ctx =
, activityAudience = Audience [] [] [] [] [] [] , activityAudience = Audience [] [] [] [] [] []
, activitySpecific = RejectActivity $ Reject fedUri , activitySpecific = RejectActivity $ Reject fedUri
} }
insertEntity $ OutboxItem20190624 obid (PersistJSON doc) defaultTime insertEntity $ OutboxItem20190624 obid (persistJSONObjectFromDoc doc) defaultTime
) )
(Just $ \ (Entity obiidTemp obiTemp) -> do (Just $ \ (Entity obiidTemp obiTemp) -> do
ts <- selectList ([] :: [Filter Ticket20190624]) [] ts <- selectList ([] :: [Filter Ticket20190624]) []
@ -918,7 +936,7 @@ changes hLocal ctx =
} }
obiidNew <- insert OutboxItem20190624 obiidNew <- insert OutboxItem20190624
{ outboxItem20190624Outbox = obidProject { outboxItem20190624Outbox = obidProject
, outboxItem20190624Activity = PersistJSON $ doc Nothing , outboxItem20190624Activity = persistJSONObjectFromDoc $ doc Nothing
, outboxItem20190624Published = , outboxItem20190624Published =
ticket20190624Created ticket ticket20190624Created ticket
} }
@ -928,7 +946,7 @@ changes hLocal ctx =
encodeRouteLocal $ encodeRouteLocal $
ProjectOutboxItemR shrProject prj obikhidNew ProjectOutboxItemR shrProject prj obikhidNew
act = doc $ Just luAct act = doc $ Just luAct
update obiidNew [OutboxItem20190624Activity =. PersistJSON act] update obiidNew [OutboxItem20190624Activity =. persistJSONObjectFromDoc act]
update tid [Ticket20190624Accept =. obiidNew] update tid [Ticket20190624Accept =. obiidNew]
ibiid <- insert $ InboxItem20190624 True ibiid <- insert $ InboxItem20190624 True
insert_ $ InboxItemLocal20190624 ibidAuthor obiidNew ibiid insert_ $ InboxItemLocal20190624 ibidAuthor obiidNew ibiid

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

@ -117,7 +117,7 @@ import Data.ByteString (ByteString)
import Data.Text (Text) import Data.Text (Text)
import Data.Time (UTCTime) import Data.Time (UTCTime)
import Database.Persist.Class (EntityField, Unique) import Database.Persist.Class (EntityField, Unique)
import Database.Persist.JSON (PersistJSONValue) --import Database.Persist.JSON (PersistJSONValue)
import Database.Persist.Schema.Types (Entity) import Database.Persist.Schema.Types (Entity)
import Database.Persist.Schema.SQL () import Database.Persist.Schema.SQL ()
import Database.Persist.Sql (SqlBackend) import Database.Persist.Sql (SqlBackend)

4
templates/person/outbox.hamlet
View file

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