forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Some cleanup and term updates in Web.ActivityPub to match the spec and plans

Browse source 
* No more full URIs, all terms are used as short non-prefixed names
* Some terms support parsing full URI form for compatibility with objects in DB
* No more @context checking when parsing
* Use the new ForgeFed context URI specified in the spec draft
* Use an extension context URI for all custom properties not specific to forges
* Rename "events" property to "history", thanks cjslep for suggesting this name
This commit is contained in:
fr33domlover 2019-06-12 00:11:24 +00:00
parent b29e197670
commit 5df8965488
2 changed files with 81 additions and 157 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
src/Data/Aeson/Local.hs
View file

@ -17,7 +17,8 @@ module Data.Aeson.Local
( Either' (..) ( Either' (..)
, toEither , toEither
, fromEither , fromEither
, frg , (.:|)
, (.:|?)
, (.=?) , (.=?)
, (.=%) , (.=%)
, WithValue (..) , WithValue (..)
@ -26,7 +27,7 @@ where
import Prelude import Prelude
import Control.Applicative ((<|>)) import Control.Applicative
import Data.Aeson import Data.Aeson
import Data.Aeson.Types (Parser) import Data.Aeson.Types (Parser)
import Data.Text (Text) import Data.Text (Text)
@ -52,9 +53,14 @@ fromEither :: Either a b -> Either' a b
fromEither (Left x) = Left' x fromEither (Left x) = Left' x
fromEither (Right y) = Right' y fromEither (Right y) = Right' y
frg :: Text (.:|) :: FromJSON a => Object -> Text -> Parser a
o .:| t = o .: t <|> o .: (frg <> t)
where
frg = "https://forgefed.angeley.es/ns#" frg = "https://forgefed.angeley.es/ns#"
(.:|?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
o .:|? t = optional $ o .:| t
infixr 8 .=? infixr 8 .=?
(.=?) :: ToJSON v => Text -> Maybe v -> Series (.=?) :: ToJSON v => Text -> Maybe v -> Series
_ .=? Nothing = mempty _ .=? Nothing = mempty

194
src/Web/ActivityPub.hs
View file

@ -132,11 +132,17 @@ import Data.Aeson.Local
proxy :: a -> Proxy a proxy :: a -> Proxy a
proxy _ = Proxy proxy _ = Proxy
as2context :: Text as2Context :: FedURI
as2context = "https://www.w3.org/ns/activitystreams" as2Context = FedURI "www.w3.org" "/ns/activitystreams" ""
secContext :: Text secContext :: FedURI
secContext = "https://w3id.org/security/v1" secContext = FedURI "w3id.org" "/security/v1" ""
forgeContext :: FedURI
forgeContext = FedURI "forgefed.peers.community" "/ns" ""
extContext :: FedURI
extContext = FedURI "angeley.es" "/as2-ext" ""
publicURI :: FedURI publicURI :: FedURI
publicURI = FedURI "www.w3.org" "/ns/activitystreams" "#Public" publicURI = FedURI "www.w3.org" "/ns/activitystreams" "#Public"
@ -144,27 +150,8 @@ publicURI = FedURI "www.w3.org" "/ns/activitystreams" "#Public"
publicT :: Text publicT :: Text
publicT = renderFedURI publicURI publicT = renderFedURI publicURI
actorContext :: [Text]
actorContext = [as2context, secContext]
data Context = ContextAS2 | ContextPKey | ContextActor deriving Eq
instance FromJSON Context where
parseJSON (String t)
| t == as2context = return ContextAS2
| t == secContext = return ContextPKey
parseJSON (Array v)
| V.toList v == map String actorContext = return ContextActor
parseJSON _ = fail "Unrecognized @context"
instance ToJSON Context where
toJSON = error "toJSON Context"
toEncoding ContextAS2 = toEncoding as2context
toEncoding ContextPKey = toEncoding secContext
toEncoding ContextActor = toEncoding actorContext
class ActivityPub a where class ActivityPub a where
jsonldContext :: Proxy a -> Context jsonldContext :: Proxy a -> [FedURI]
parseObject :: Object -> Parser (Text, a) parseObject :: Object -> Parser (Text, a)
toSeries :: Text -> a -> Series toSeries :: Text -> a -> Series
@ -174,19 +161,18 @@ data Doc a = Doc
} }
instance ActivityPub a => FromJSON (Doc a) where instance ActivityPub a => FromJSON (Doc a) where
parseJSON = withObject "Doc" $ \ o -> do parseJSON = withObject "Doc" $ \ o -> uncurry Doc <$> parseObject o
(h, v) <- parseObject o
ctx <- o .: "@context"
if ctx == jsonldContext (proxy v)
then return $ Doc h v
else fail "@context doesn't match"
instance ActivityPub a => ToJSON (Doc a) where instance ActivityPub a => ToJSON (Doc a) where
toJSON = error "toJSON Doc" toJSON = error "toJSON Doc"
toEncoding (Doc h v) = toEncoding (Doc h v) =
pairs pairs
$ "@context" .= jsonldContext (proxy v) $ context (jsonldContext $ proxy v)
<> toSeries h v <> toSeries h v
where
context [] = mempty
context [t] = "@context" .= t
context ts = "@context" .= ts
data ActorType = ActorTypePerson | ActorTypeProject | ActorTypeOther Text data ActorType = ActorTypePerson | ActorTypeProject | ActorTypeOther Text
deriving Eq deriving Eq
@ -196,7 +182,7 @@ instance FromJSON ActorType where
where where
parse t parse t
| t == "Person" = ActorTypePerson | t == "Person" = ActorTypePerson
| t == frg <> "Project" = ActorTypeProject | t == "Project" = ActorTypeProject
| otherwise = ActorTypeOther t | otherwise = ActorTypeOther t
instance ToJSON ActorType where instance ToJSON ActorType where
@ -204,27 +190,9 @@ instance ToJSON ActorType where
toEncoding at = toEncoding at =
toEncoding $ case at of toEncoding $ case at of
ActorTypePerson -> "Person" ActorTypePerson -> "Person"
ActorTypeProject -> frg <> "Project" ActorTypeProject -> "Project"
ActorTypeOther t -> t ActorTypeOther t -> t
{-
data Algorithm = AlgorithmEd25519 | AlgorithmRsaSha256 | AlgorithmOther Text
instance FromJSON Algorithm where
parseJSON = withText "Algorithm" $ \ t -> pure
| t == frg <> "ed25519" = AlgorithmEd25519
| t == frg <> "rsa-sha256" = AlgorithmRsaSha256
| otherwise = AlgorithmOther t
instance ToJSON Algorithm where
toJSON = error "toJSON Algorithm"
toEncoding algo =
toEncoding $ case algo of
AlgorithmEd25519 -> frg <> "ed25519"
AlgorithmRsaSha256 -> frg <> "rsa-sha256"
AlgorithmOther t -> t
-}
data Owner = OwnerInstance | OwnerActor LocalURI data Owner = OwnerInstance | OwnerActor LocalURI
ownerShared :: Owner -> Bool ownerShared :: Owner -> Bool
@ -236,18 +204,17 @@ data PublicKey = PublicKey
, publicKeyExpires :: Maybe UTCTime , publicKeyExpires :: Maybe UTCTime
, publicKeyOwner :: Owner , publicKeyOwner :: Owner
, publicKeyMaterial :: PublicVerifKey , publicKeyMaterial :: PublicVerifKey
--, publicKeyAlgo :: Maybe Algorithm
} }
instance ActivityPub PublicKey where instance ActivityPub PublicKey where
jsonldContext _ = ContextPKey jsonldContext _ = [secContext, extContext]
parseObject o = do parseObject o = do
mtyp <- optional $ o .: "@type" <|> o .: "type" mtyp <- optional $ o .: "@type" <|> o .: "type"
for_ mtyp $ \ t -> for_ mtyp $ \ t ->
when (t /= ("Key" :: Text)) $ when (t /= ("Key" :: Text)) $
fail "PublicKey @type isn't Key" fail "PublicKey @type isn't Key"
(host, id_) <- f2l <$> (o .: "@id" <|> o .: "id") (host, id_) <- f2l <$> (o .: "@id" <|> o .: "id")
shared <- o .:? (frg <> "isShared") .!= False shared <- o .:|? "isShared" .!= False
fmap (host,) $ fmap (host,) $
PublicKey id_ PublicKey id_
<$> o .:? "expires" <$> o .:? "expires"
@ -255,7 +222,6 @@ instance ActivityPub PublicKey where
<*> (either fail return . decodePublicVerifKeyPEM =<< <*> (either fail return . decodePublicVerifKeyPEM =<<
o .: "publicKeyPem" o .: "publicKeyPem"
) )
-- <*> o .:? (frg <> "algorithm")
where where
withHost h o t = do withHost h o t = do
(h', lu) <- f2l <$> o .: t (h', lu) <- f2l <$> o .: t
@ -270,8 +236,7 @@ instance ActivityPub PublicKey where
<> "expires" .=? mexpires <> "expires" .=? mexpires
<> "owner" .= mkOwner host owner <> "owner" .= mkOwner host owner
<> "publicKeyPem" .= encodePublicVerifKeyPEM mat <> "publicKeyPem" .= encodePublicVerifKeyPEM mat
-- <> (frg <> "algorithm") .=? malgo <> "isShared" .= ownerShared owner
<> (frg <> "isShared") .= ownerShared owner
where where
mkOwner h OwnerInstance = FedURI h "" "" mkOwner h OwnerInstance = FedURI h "" ""
mkOwner h (OwnerActor lu) = l2f h lu mkOwner h (OwnerActor lu) = l2f h lu
@ -291,11 +256,6 @@ parsePublicKeySet v =
parseKey (String t) = second Left . f2l <$> either fail return (parseFedURI t) parseKey (String t) = second Left . f2l <$> either fail return (parseFedURI t)
parseKey (Object o) = second Right <$> parseObject o parseKey (Object o) = second Right <$> parseObject o
parseKey v = typeMismatch "PublicKeySet Item" v parseKey v = typeMismatch "PublicKeySet Item" v
withHost h a = do
(h', v) <- a
if h == h'
then return v
else fail "URI host mismatch"
encodePublicKeySet :: Text -> [Either LocalURI PublicKey] -> Encoding encodePublicKeySet :: Text -> [Either LocalURI PublicKey] -> Encoding
encodePublicKeySet host es = encodePublicKeySet host es =
@ -319,7 +279,7 @@ data Actor = Actor
} }
instance ActivityPub Actor where instance ActivityPub Actor where
jsonldContext _ = ContextActor jsonldContext _ = [as2Context, secContext, extContext]
parseObject o = do parseObject o = do
(host, id_) <- f2l <$> o .: "id" (host, id_) <- f2l <$> o .: "id"
fmap (host,) $ fmap (host,) $
@ -332,12 +292,6 @@ instance ActivityPub Actor where
<*> withHostMaybe host (fmap f2l <$> o .:? "outbox") <*> withHostMaybe host (fmap f2l <$> o .:? "outbox")
<*> withHostMaybe host (fmap f2l <$> o .:? "followers") <*> withHostMaybe host (fmap f2l <$> o .:? "followers")
<*> withHost host (parsePublicKeySet =<< o .: "publicKey") <*> withHost host (parsePublicKeySet =<< o .: "publicKey")
where
withHost h a = do
(h', v) <- a
if h == h'
then return v
else fail "URI host mismatch"
toSeries host toSeries host
(Actor id_ typ musername mname msummary inbox outbox followers pkeys) (Actor id_ typ musername mname msummary inbox outbox followers pkeys)
= "id" .= l2f host id_ = "id" .= l2f host id_
@ -356,17 +310,17 @@ data Project = Project
} }
instance ActivityPub Project where instance ActivityPub Project where
jsonldContext _ = ContextActor jsonldContext _ = [as2Context, secContext, forgeContext, extContext]
parseObject o = do parseObject o = do
(h, a) <- parseObject o (h, a) <- parseObject o
unless (actorType a == ActorTypeProject) $ unless (actorType a == ActorTypeProject) $
fail "Actor type isn't Project" fail "Actor type isn't Project"
fmap (h,) $ fmap (h,) $
Project a Project a
<$> withHost h (f2l <$> o .: (frg <> "team")) <$> withHost h (f2l <$> o .:| "team")
toSeries host (Project actor team) toSeries host (Project actor team)
= toSeries host actor = toSeries host actor
<> (frg <> "team") .= l2f host team <> "team" .= l2f host team
data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered
@ -395,7 +349,7 @@ data Collection a = Collection
} }
instance (FromJSON a, ToJSON a) => ActivityPub (Collection a) where instance (FromJSON a, ToJSON a) => ActivityPub (Collection a) where
jsonldContext _ = ContextAS2 jsonldContext _ = [as2Context, forgeContext, extContext]
parseObject o = do parseObject o = do
(host, id_) <- f2l <$> o .: "id" (host, id_) <- f2l <$> o .: "id"
fmap (host,) $ fmap (host,) $
@ -448,7 +402,7 @@ data CollectionPage a = CollectionPage
} }
instance (FromJSON a, ToJSON a) => ActivityPub (CollectionPage a) where instance (FromJSON a, ToJSON a) => ActivityPub (CollectionPage a) where
jsonldContext _ = ContextAS2 jsonldContext _ = [as2Context, forgeContext, extContext]
parseObject o = do parseObject o = do
(host, id_) <- fp2lp <$> o .: "id" (host, id_) <- fp2lp <$> o .: "id"
fmap (host,) $ fmap (host,) $
@ -479,7 +433,7 @@ instance (FromJSON a, ToJSON a) => ActivityPub (CollectionPage a) where
data Recipient = RecipientActor Actor | RecipientCollection (Collection FedURI) data Recipient = RecipientActor Actor | RecipientCollection (Collection FedURI)
instance ActivityPub Recipient where instance ActivityPub Recipient where
jsonldContext _ = ContextAS2 jsonldContext _ = [as2Context, secContext, forgeContext, extContext]
parseObject o = parseObject o =
second RecipientActor <$> parseObject o <|> second RecipientActor <$> parseObject o <|>
second RecipientCollection <$> parseObject o second RecipientCollection <$> parseObject o
@ -517,11 +471,14 @@ parseAudience o =
<*> o .:& "cc" <*> o .:& "cc"
<*> o .:& "bcc" <*> o .:& "bcc"
<*> o .:& "audience" <*> o .:& "audience"
<*> o .:& (frg <> "nonActors") <*> o .:|& "nonActors"
where where
obj .:& key = do obj .:& key = do
l <- obj .:? key .!= [] l <- obj .:? key .!= []
return $ map unAdapt l return $ map unAdapt l
obj .:|& key = do
l <- obj .:|? key .!= []
return $ map unAdapt l
encodeAudience :: Audience -> Series encodeAudience :: Audience -> Series
encodeAudience (Audience to bto cc bcc aud nons) encodeAudience (Audience to bto cc bcc aud nons)
@ -530,7 +487,7 @@ encodeAudience (Audience to bto cc bcc aud nons)
<> "cc" .=% cc <> "cc" .=% cc
<> "bcc" .=% bcc <> "bcc" .=% bcc
<> "audience" .=% aud <> "audience" .=% aud
<> (frg <> "nonActors") .=% nons <> "nonActors" .=% nons
data Note = Note data Note = Note
{ noteId :: Maybe LocalURI { noteId :: Maybe LocalURI
@ -557,7 +514,7 @@ withHostMaybe h a = do
else fail "URI host mismatch" else fail "URI host mismatch"
instance ActivityPub Note where instance ActivityPub Note where
jsonldContext _ = ContextAS2 jsonldContext _ = [as2Context, extContext]
parseObject o = do parseObject o = do
typ <- o .: "type" typ <- o .: "type"
unless (typ == ("Note" :: Text)) $ unless (typ == ("Note" :: Text)) $
@ -598,39 +555,6 @@ instance ActivityPub Note where
<> "content" .= content <> "content" .= content
<> "mediaType" .= ("text/html" :: Text) <> "mediaType" .= ("text/html" :: Text)
{-
parseNote :: Value -> Parser (Text, (Note, LocalURI))
parseNote = withObject "Note" $ \ o -> do
typ <- o .: "type"
unless (typ == ("Note" :: Text)) $ fail "type isn't Note"
(h, id_) <- f2l <$> o .: "id"
fmap (h,) $
(,) <$> (Note id_
<$> o .:? "inReplyTo"
<*> o .:? "context"
<*> o .:? "published"
<*> o .: "content"
)
<*> withHost h (f2l <$> o .: "attributedTo")
where
withHost h a = do
(h', v) <- a
if h == h'
then return v
else fail "URI host mismatch"
encodeNote :: Text -> Note -> LocalURI -> Encoding
encodeNote host (Note id_ mreply mcontext mpublished content) attrib =
pairs
$ "type" .= ("Note" :: Text)
<> "id" .= l2f host id_
<> "attributedTo" .= l2f host attrib
<> "inReplyTo" .=? mreply
<> "context" .=? mcontext
<> "published" .=? mpublished
<> "content" .= content
-}
newtype TextHtml = TextHtml newtype TextHtml = TextHtml
{ unTextHtml :: Text { unTextHtml :: Text
} }
@ -657,9 +581,9 @@ parseTicketLocal o = do
Nothing -> do Nothing -> do
verifyNothing "context" verifyNothing "context"
verifyNothing "replies" verifyNothing "replies"
verifyNothing $ frg <> "participants" verifyNothing "participants"
verifyNothing $ frg <> "team" verifyNothing "team"
verifyNothing $ frg <> "events" verifyNothing "history"
return Nothing return Nothing
Just (h, id_) -> Just (h, id_) ->
fmap (Just . (h,)) $ fmap (Just . (h,)) $
@ -667,9 +591,9 @@ parseTicketLocal o = do
<$> pure id_ <$> pure id_
<*> withHost h (f2l <$> o .: "context") <*> withHost h (f2l <$> o .: "context")
<*> withHost h (f2l <$> o .: "replies") <*> withHost h (f2l <$> o .: "replies")
<*> withHost h (f2l <$> o .: (frg <> "participants")) <*> withHost h (f2l <$> o .: "participants")
<*> withHost h (f2l <$> o .: (frg <> "team")) <*> withHost h (f2l <$> o .: "team")
<*> withHost h (f2l <$> o .: (frg <> "events")) <*> withHost h (f2l <$> o .: "history")
where where
verifyNothing t = verifyNothing t =
if t `M.member` o if t `M.member` o
@ -681,9 +605,9 @@ encodeTicketLocal h (TicketLocal id_ context replies participants team events)
= "id" .= l2f h id_ = "id" .= l2f h id_
<> "context" .= l2f h context <> "context" .= l2f h context
<> "replies" .= l2f h replies <> "replies" .= l2f h replies
<> (frg <> "participants") .= l2f h participants <> "participants" .= l2f h participants
<> (frg <> "team") .= l2f h team <> "team" .= l2f h team
<> (frg <> "events") .= l2f h events <> "history" .= l2f h events
data Ticket = Ticket data Ticket = Ticket
{ ticketLocal :: Maybe (Text, TicketLocal) { ticketLocal :: Maybe (Text, TicketLocal)
@ -701,7 +625,7 @@ data Ticket = Ticket
} }
instance ActivityPub Ticket where instance ActivityPub Ticket where
jsonldContext _ = ContextAS2 jsonldContext _ = [as2Context, forgeContext, extContext]
parseObject o = do parseObject o = do
typ <- o .: "type" typ <- o .: "type"
unless (typ == ("Ticket" :: Text)) $ unless (typ == ("Ticket" :: Text)) $
@ -728,10 +652,10 @@ instance ActivityPub Ticket where
<*> (TextHtml . sanitizeBalance <$> o .: "summary") <*> (TextHtml . sanitizeBalance <$> o .: "summary")
<*> (TextHtml . sanitizeBalance <$> o .: "content") <*> (TextHtml . sanitizeBalance <$> o .: "content")
<*> source .: "content" <*> source .: "content"
<*> o .:? (frg <> "assignedTo") <*> o .:? "assignedTo"
<*> o .: (frg <> "isResolved") <*> o .: "isResolved"
<*> o .:? (frg <> "dependsOn") .!= [] <*> o .:? "dependsOn" .!= []
<*> o .:? (frg <> "dependedBy") .!= [] <*> o .:? "dependedBy" .!= []
toSeries host toSeries host
(Ticket local attributedTo published updated name summary content (Ticket local attributedTo published updated name summary content
@ -750,10 +674,10 @@ instance ActivityPub Ticket where
[ "content" .= source [ "content" .= source
, "mediaType" .= ("text/markdown; variant=Pandoc" :: Text) , "mediaType" .= ("text/markdown; variant=Pandoc" :: Text)
] ]
<> (frg <> "assignedTo") .=? assignedTo <> "assignedTo" .=? assignedTo
<> (frg <> "isResolved") .= isResolved <> "isResolved" .= isResolved
<> (frg <> "dependsOn") .=% dependsOn <> "dependsOn" .=% dependsOn
<> (frg <> "dependedBy") .=% dependedBy <> "dependedBy" .=% dependedBy
data Accept = Accept data Accept = Accept
{ acceptObject :: FedURI { acceptObject :: FedURI
@ -774,12 +698,6 @@ parseCreate o h luActor = do
note <- withHost h $ parseObject =<< o .: "object" note <- withHost h $ parseObject =<< o .: "object"
unless (luActor == noteAttrib note) $ fail "Create actor != Note attrib" unless (luActor == noteAttrib note) $ fail "Create actor != Note attrib"
return $ Create note return $ Create note
where
withHost h a = do
(h', v) <- a
if h == h'
then return v
else fail "URI host mismatch"
encodeCreate :: Text -> LocalURI -> Create -> Series encodeCreate :: Text -> LocalURI -> Create -> Series
encodeCreate host actor (Create obj) = encodeCreate host actor (Create obj) =
@ -794,12 +712,12 @@ parseFollow :: Object -> Parser Follow
parseFollow o = parseFollow o =
Follow Follow
<$> o .: "object" <$> o .: "object"
<*> o .: (frg <> "hide") <*> o .: "hide"
encodeFollow :: Follow -> Series encodeFollow :: Follow -> Series
encodeFollow (Follow obj hide) encodeFollow (Follow obj hide)
= "object" .= obj = "object" .= obj
<> (frg <> "hide") .= hide <> "hide" .= hide
data Offer = Offer data Offer = Offer
{ offerObject :: Ticket { offerObject :: Ticket
@ -850,7 +768,7 @@ data Activity = Activity
} }
instance ActivityPub Activity where instance ActivityPub Activity where
jsonldContext _ = ContextAS2 jsonldContext _ = [as2Context, forgeContext, extContext]
parseObject o = do parseObject o = do
(h, id_) <- f2l <$> o .: "id" (h, id_) <- f2l <$> o .: "id"
actor <- withHost h $ f2l <$> o .: "actor" actor <- withHost h $ f2l <$> o .: "actor"