naskya/vervis
1
0
Fork 0
mirror of https://code.naskya.net/repos/ndqEd synced 2025-03-20 15:14:54 +09:00
Code Activity

S2S & C2S: Switch from single-patch MR version to multi-patch bundle support

Browse source
This commit is contained in:
fr33domlover 2020-08-13 10:26:20 +00:00
parent da01fcf451
commit b16c9505af
19 changed files with 901 additions and 593 deletions

107
src/Web/ActivityPub.hs
View file

@ -49,6 +49,8 @@ module Web.ActivityPub
, PatchType (..)
, PatchLocal (..)
, Patch (..)
, BundleLocal (..)
, Bundle (..)
, TicketLocal (..)
, MergeRequest (..)
, Ticket (..)
@ -826,7 +828,7 @@ newtype TextPandocMarkdown = TextPandocMarkdown
}
deriving (FromJSON, ToJSON)
data PatchType = PatchTypeDarcs
data PatchType = PatchTypeDarcs deriving Eq
instance FromJSON PatchType where
parseJSON = withText "PatchType" parse
@ -841,10 +843,8 @@ instance ToJSON PatchType where
render PatchTypeDarcs = "application/x-darcs-patch" :: Text
data PatchLocal = PatchLocal
{ patchId :: LocalURI
, patchContext :: LocalURI
, patchPrevVersions :: [LocalURI]
, patchCurrentVersion :: Maybe LocalURI
{ patchId :: LocalURI
, patchContext :: LocalURI
}
parsePatchLocal
@ -854,16 +854,12 @@ parsePatchLocal o = do
case mid of
Nothing -> do
verifyNothing "context"
verifyNothing "previousVersions"
verifyNothing "currentVersion"
return Nothing
Just (ObjURI a id_) ->
fmap (Just . (a,)) $
PatchLocal
<$> pure id_
<*> withAuthorityO a (o .: "context")
<*> (traverse (withAuthorityO a . return) =<< o .:? "previousVersions" .!= [])
<*> withAuthorityMaybeO a (o .:? "currentVersion")
where
verifyNothing t =
if t `M.member` o
@ -871,11 +867,9 @@ parsePatchLocal o = do
else return ()
encodePatchLocal :: UriMode u => Authority u -> PatchLocal -> Series
encodePatchLocal a (PatchLocal id_ context versions mcurrent)
encodePatchLocal a (PatchLocal id_ context)
= "id" .= ObjURI a id_
<> "context" .= ObjURI a context
<> "previousVersions" .= map (ObjURI a) versions
<> "currentVersion" .=? (ObjURI a <$> mcurrent)
data Patch u = Patch
{ patchLocal :: Maybe (Authority u, PatchLocal)
@ -911,6 +905,89 @@ instance ActivityPub Patch where
<> "mediaType" .= typ
<> "content" .= content
data BundleLocal = BundleLocal
{ bundleId :: LocalURI
, bundleContext :: LocalURI
, bundlePrevVersions :: [LocalURI]
, bundleCurrentVersion :: Maybe LocalURI
}
parseBundleLocal
:: UriMode u => Object -> Parser (Maybe (Authority u, BundleLocal))
parseBundleLocal o = do
mid <- o .:? "id"
case mid of
Nothing -> do
verifyNothing "context"
verifyNothing "previousVersions"
verifyNothing "currentVersion"
return Nothing
Just (ObjURI a id_) ->
fmap (Just . (a,)) $
BundleLocal
<$> pure id_
<*> withAuthorityO a (o .: "context")
<*> (traverse (withAuthorityO a . return) =<< o .:? "previousVersions" .!= [])
<*> withAuthorityMaybeO a (o .:? "currentVersion")
where
verifyNothing t =
if t `M.member` o
then fail $ T.unpack t ++ " field found, expected none"
else return ()
encodeBundleLocal :: UriMode u => Authority u -> BundleLocal -> Series
encodeBundleLocal a (BundleLocal id_ context versions mcurrent)
= "id" .= ObjURI a id_
<> "context" .= ObjURI a context
<> "previousVersions" .= map (ObjURI a) versions
<> "currentVersion" .=? (ObjURI a <$> mcurrent)
data Bundle u
= BundleHosted (Maybe BundleLocal) (NonEmpty LocalURI)
| BundleOffer (Maybe (Authority u, BundleLocal)) (NonEmpty (Patch u))
instance ActivityPub Bundle where
jsonldContext _ = [as2Context, forgeContext]
parseObject o = do
typ <- o .: "type"
unless (typ == ("OrderedCollection" :: Text)) $
fail "type isn't OrderedCollection"
mlocal <- parseBundleLocal o
mtotal <- o .:? "totalItems"
items <- toEither <$> o .: "orderedItems" <|> o .: "items"
case items of
Left (ObjURI h lu :| us) -> do
for_ mlocal $ \ (h', _) ->
unless (h == h') $
fail "Patches in bundle not on the same host as bundle"
unless (all (== h) $ map objUriAuthority us) $
fail "Patches in bundle on different hosts"
for_ mtotal $ \ total ->
unless (length us + 1 == total) $
fail "Incorrect totalItems"
return (h, BundleHosted (snd <$> mlocal) $ lu :| map objUriLocal us)
Right (Doc h p :| ps) -> do
unless (all (== h) $ map docAuthority ps) $
fail "Patches in bundle have different authors"
for_ mtotal $ \ total ->
unless (length ps + 1 == total) $
fail "Incorrect totalItems"
return (h, BundleOffer mlocal $ p :| map docValue ps)
toSeries hBundle (BundleHosted mlocal lus)
= maybe mempty (encodeBundleLocal hBundle) mlocal
<> "type" .= ("OrderedCollection" :: Text)
<> "totalItems" .= length lus
<> "orderedItems" .= NE.map (ObjURI hBundle) lus
toSeries hAttrib (BundleOffer mlocal patches)
= maybe mempty (uncurry encodeBundleLocal) mlocal
<> "type" .= ("OrderedCollection" :: Text)
<> "totalItems" .= length patches
<> "orderedItems" .= NE.map (Doc hAttrib) patches
data TicketLocal = TicketLocal
{ ticketId :: LocalURI
, ticketReplies :: LocalURI
@ -964,7 +1041,7 @@ encodeTicketLocal
data MergeRequest u = MergeRequest
{ mrOrigin :: Maybe (ObjURI u)
, mrTarget :: LocalURI
, mrPatch :: Either (ObjURI u) (Authority u, Patch u)
, mrBundle :: Either (ObjURI u) (Authority u, Bundle u)
}
instance ActivityPub MergeRequest where
@ -985,11 +1062,11 @@ instance ActivityPub MergeRequest where
where
fromDoc (Doc h v) = (h, v)
toSeries h (MergeRequest morigin target patch)
toSeries h (MergeRequest morigin target bundle)
= "type" .= ("Offer" :: Text)
<> "origin" .=? morigin
<> "target" .= ObjURI h target
<> "object" .= fromEither (second (uncurry Doc) patch)
<> "object" .= fromEither (second (uncurry Doc) bundle)
data Ticket u = Ticket
{ ticketLocal :: Maybe (Authority u, TicketLocal)