sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-27 17:54:53 +09:00
Code Issues Activity

Web.ActivityPub: Add PatchLocal type similar to TicketLocal

Browse source
This commit is contained in:
fr33domlover 2020-07-14 09:56:13 +00:00
parent fa3348513a
commit 216aaa72ee
2 changed files with 73 additions and 29 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

45
src/Vervis/Handler/Patch.hs
View file

@ -265,19 +265,26 @@ getSharerPatchVersionR shr talkhid ptkhid = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
encodePatchId <- getEncodeKeyHashid
hLocal <- getsYesod siteInstanceHost
let versionUrl = SharerPatchVersionR shr talkhid . encodePatchId
versionAP = AP.Patch
{ AP.patchId = encodeRouteLocal here
, AP.patchAttributedTo = encodeRouteHome $ SharerR shr
{ AP.patchLocal = Just
( hLocal
, AP.PatchLocal
{ AP.patchId = encodeRouteLocal here
, AP.patchContext =
encodeRouteLocal $ SharerPatchR shr talkhid
, AP.patchPrevVersions =
map (encodeRouteLocal . versionUrl) versions
}
)
, AP.patchAttributedTo = encodeRouteLocal $ SharerR shr
, AP.patchPublished = patchCreated patch
, AP.patchContext = encodeRouteLocal $ SharerPatchR shr talkhid
, AP.patchType =
case vcs of
VCSDarcs -> PatchTypeDarcs
VCSGit -> error "TODO add PatchType for git patches"
, AP.patchContent = patchContent patch
, AP.patchPrevVersions =
map (encodeRouteLocal . versionUrl) versions
}
provideHtmlAndAP versionAP $ redirectToPrettyJSON here
where
@ -541,27 +548,35 @@ getRepoPatchVersionR shr rp ltkhid ptkhid = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
encodePatchId <- getEncodeKeyHashid
hLocal <- getsYesod siteInstanceHost
let versionUrl = RepoPatchVersionR shr rp ltkhid . encodePatchId
host =
case author of
Left _ -> hLocal
Right (i, _) -> instanceHost i
versionAP = AP.Patch
{ AP.patchId = encodeRouteLocal here
{ AP.patchLocal = Just
( hLocal
, AP.PatchLocal
{ AP.patchId = encodeRouteLocal here
, AP.patchContext =
encodeRouteLocal $ RepoPatchR shr rp ltkhid
, AP.patchPrevVersions =
map (encodeRouteLocal . versionUrl) versions
}
)
, AP.patchAttributedTo =
case author of
Left sharer ->
encodeRouteHome $ SharerR $ sharerIdent sharer
Right (inztance, object) ->
ObjURI
(instanceHost inztance)
(remoteObjectIdent object)
encodeRouteLocal $ SharerR $ sharerIdent sharer
Right (_, object) -> remoteObjectIdent object
, AP.patchPublished = patchCreated patch
, AP.patchContext = encodeRouteLocal $ RepoPatchR shr rp ltkhid
, AP.patchType =
case vcs of
VCSDarcs -> PatchTypeDarcs
VCSGit -> error "TODO add PatchType for git patches"
, AP.patchContent = patchContent patch
, AP.patchPrevVersions =
map (encodeRouteLocal . versionUrl) versions
}
provideHtmlAndAP versionAP $ redirectToPrettyJSON here
provideHtmlAndAP' host versionAP $ redirectToPrettyJSON here
where
here = RepoPatchVersionR shr rp ltkhid ptkhid

57
src/Web/ActivityPub.hs
View file

@ -47,6 +47,7 @@ module Web.ActivityPub
, TextHtml (..)
, TextPandocMarkdown (..)
, PatchType (..)
, PatchLocal (..)
, Patch (..)
, TicketLocal (..)
, MergeRequest (..)
@ -838,14 +839,45 @@ instance ToJSON PatchType where
where
render PatchTypeDarcs = "application/x-darcs-patch" :: Text
data Patch u = Patch
data PatchLocal = PatchLocal
{ patchId :: LocalURI
, patchAttributedTo :: ObjURI u
, patchPublished :: UTCTime
, patchContext :: LocalURI
, patchPrevVersions :: [LocalURI]
}
parsePatchLocal
:: UriMode u => Object -> Parser (Maybe (Authority u, PatchLocal))
parsePatchLocal o = do
mid <- o .:? "id"
case mid of
Nothing -> do
verifyNothing "context"
verifyNothing "previousVersions"
return Nothing
Just (ObjURI a id_) ->
fmap (Just . (a,)) $
PatchLocal
<$> pure id_
<*> withAuthorityO a (o .: "context")
<*> (traverse (withAuthorityO a . return) =<< o .:? "previousVersions" .!= [])
where
verifyNothing t =
if t `M.member` o
then fail $ T.unpack t ++ " field found, expected none"
else return ()
encodePatchLocal :: UriMode u => Authority u -> PatchLocal -> Series
encodePatchLocal a (PatchLocal id_ context versions)
= "id" .= ObjURI a id_
<> "context" .= ObjURI a context
<> "previousVersions" .= map (ObjURI a) versions
data Patch u = Patch
{ patchLocal :: Maybe (Authority u, PatchLocal)
, patchAttributedTo :: LocalURI
, patchPublished :: UTCTime
, patchType :: PatchType
, patchContent :: Text
, patchPrevVersions :: [LocalURI]
}
instance ActivityPub Patch where
@ -856,26 +888,23 @@ instance ActivityPub Patch where
unless (typ == ("Patch" :: Text)) $
fail "type isn't Patch"
ObjURI a id_ <- o .: "id"
ObjURI a attrib <- o .: "attributedTo"
fmap (a,) $
Patch id_
<$> o .: "attributedTo"
Patch
<$> parsePatchLocal o
<*> pure attrib
<*> o .: "published"
<*> withAuthorityO a (o .: "context")
<*> o .: "mediaType"
<*> o .: "content"
<*> (traverse (withAuthorityO a . return) =<< o .:? "previousVersions" .!= [])
toSeries a (Patch id_ attrib published context typ content vers)
= "id" .= ObjURI a id_
toSeries a (Patch local attrib published typ content)
= maybe mempty (uncurry encodePatchLocal) local
<> "type" .= ("Patch" :: Text)
<> "attributedTo" .= attrib
<> "context" .= ObjURI a context
<> "attributedTo" .= ObjURI a attrib
<> "published" .= published
<> "mediaType" .= typ
<> "content" .= content
<> "previousVersions" .= map (ObjURI a) vers
data TicketLocal = TicketLocal
{ ticketId :: LocalURI