Some cleanup and term updates in Web.ActivityPub to match the spec and plans
* 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
parent
b29e197670
commit
5df8965488
2 changed files with 81 additions and 157 deletions
|
|
@ -17,7 +17,8 @@ module Data.Aeson.Local
|
|||
( Either' (..)
|
||||
, toEither
|
||||
, fromEither
|
||||
, frg
|
||||
, (.:|)
|
||||
, (.:|?)
|
||||
, (.=?)
|
||||
, (.=%)
|
||||
, WithValue (..)
|
||||
|
|
@ -26,7 +27,7 @@ where
|
|||
|
||||
import Prelude
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Control.Applicative
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types (Parser)
|
||||
import Data.Text (Text)
|
||||
|
|
@ -52,9 +53,14 @@ fromEither :: Either a b -> Either' a b
|
|||
fromEither (Left x) = Left' x
|
||||
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#"
|
||||
|
||||
(.:|?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
|
||||
o .:|? t = optional $ o .:| t
|
||||
|
||||
infixr 8 .=?
|
||||
(.=?) :: ToJSON v => Text -> Maybe v -> Series
|
||||
_ .=? Nothing = mempty
|
||||
|
|
|
|||
|
|
@ -132,11 +132,17 @@ import Data.Aeson.Local
|
|||
proxy :: a -> Proxy a
|
||||
proxy _ = Proxy
|
||||
|
||||
as2context :: Text
|
||||
as2context = "https://www.w3.org/ns/activitystreams"
|
||||
as2Context :: FedURI
|
||||
as2Context = FedURI "www.w3.org" "/ns/activitystreams" ""
|
||||
|
||||
secContext :: Text
|
||||
secContext = "https://w3id.org/security/v1"
|
||||
secContext :: FedURI
|
||||
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 "www.w3.org" "/ns/activitystreams" "#Public"
|
||||
|
|
@ -144,27 +150,8 @@ publicURI = FedURI "www.w3.org" "/ns/activitystreams" "#Public"
|
|||
publicT :: Text
|
||||
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
|
||||
jsonldContext :: Proxy a -> Context
|
||||
jsonldContext :: Proxy a -> [FedURI]
|
||||
parseObject :: Object -> Parser (Text, a)
|
||||
toSeries :: Text -> a -> Series
|
||||
|
||||
|
|
@ -174,19 +161,18 @@ data Doc a = Doc
|
|||
}
|
||||
|
||||
instance ActivityPub a => FromJSON (Doc a) where
|
||||
parseJSON = withObject "Doc" $ \ o -> do
|
||||
(h, v) <- parseObject o
|
||||
ctx <- o .: "@context"
|
||||
if ctx == jsonldContext (proxy v)
|
||||
then return $ Doc h v
|
||||
else fail "@context doesn't match"
|
||||
parseJSON = withObject "Doc" $ \ o -> uncurry Doc <$> parseObject o
|
||||
|
||||
instance ActivityPub a => ToJSON (Doc a) where
|
||||
toJSON = error "toJSON Doc"
|
||||
toEncoding (Doc h v) =
|
||||
pairs
|
||||
$ "@context" .= jsonldContext (proxy v)
|
||||
$ context (jsonldContext $ proxy v)
|
||||
<> toSeries h v
|
||||
where
|
||||
context [] = mempty
|
||||
context [t] = "@context" .= t
|
||||
context ts = "@context" .= ts
|
||||
|
||||
data ActorType = ActorTypePerson | ActorTypeProject | ActorTypeOther Text
|
||||
deriving Eq
|
||||
|
|
@ -196,7 +182,7 @@ instance FromJSON ActorType where
|
|||
where
|
||||
parse t
|
||||
| t == "Person" = ActorTypePerson
|
||||
| t == frg <> "Project" = ActorTypeProject
|
||||
| t == "Project" = ActorTypeProject
|
||||
| otherwise = ActorTypeOther t
|
||||
|
||||
instance ToJSON ActorType where
|
||||
|
|
@ -204,27 +190,9 @@ instance ToJSON ActorType where
|
|||
toEncoding at =
|
||||
toEncoding $ case at of
|
||||
ActorTypePerson -> "Person"
|
||||
ActorTypeProject -> frg <> "Project"
|
||||
ActorTypeProject -> "Project"
|
||||
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
|
||||
|
||||
ownerShared :: Owner -> Bool
|
||||
|
|
@ -236,18 +204,17 @@ data PublicKey = PublicKey
|
|||
, publicKeyExpires :: Maybe UTCTime
|
||||
, publicKeyOwner :: Owner
|
||||
, publicKeyMaterial :: PublicVerifKey
|
||||
--, publicKeyAlgo :: Maybe Algorithm
|
||||
}
|
||||
|
||||
instance ActivityPub PublicKey where
|
||||
jsonldContext _ = ContextPKey
|
||||
jsonldContext _ = [secContext, extContext]
|
||||
parseObject o = do
|
||||
mtyp <- optional $ o .: "@type" <|> o .: "type"
|
||||
for_ mtyp $ \ t ->
|
||||
when (t /= ("Key" :: Text)) $
|
||||
fail "PublicKey @type isn't Key"
|
||||
(host, id_) <- f2l <$> (o .: "@id" <|> o .: "id")
|
||||
shared <- o .:? (frg <> "isShared") .!= False
|
||||
shared <- o .:|? "isShared" .!= False
|
||||
fmap (host,) $
|
||||
PublicKey id_
|
||||
<$> o .:? "expires"
|
||||
|
|
@ -255,7 +222,6 @@ instance ActivityPub PublicKey where
|
|||
<*> (either fail return . decodePublicVerifKeyPEM =<<
|
||||
o .: "publicKeyPem"
|
||||
)
|
||||
-- <*> o .:? (frg <> "algorithm")
|
||||
where
|
||||
withHost h o t = do
|
||||
(h', lu) <- f2l <$> o .: t
|
||||
|
|
@ -270,8 +236,7 @@ instance ActivityPub PublicKey where
|
|||
<> "expires" .=? mexpires
|
||||
<> "owner" .= mkOwner host owner
|
||||
<> "publicKeyPem" .= encodePublicVerifKeyPEM mat
|
||||
-- <> (frg <> "algorithm") .=? malgo
|
||||
<> (frg <> "isShared") .= ownerShared owner
|
||||
<> "isShared" .= ownerShared owner
|
||||
where
|
||||
mkOwner h OwnerInstance = FedURI h "" ""
|
||||
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 (Object o) = second Right <$> parseObject o
|
||||
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 host es =
|
||||
|
|
@ -319,7 +279,7 @@ data Actor = Actor
|
|||
}
|
||||
|
||||
instance ActivityPub Actor where
|
||||
jsonldContext _ = ContextActor
|
||||
jsonldContext _ = [as2Context, secContext, extContext]
|
||||
parseObject o = do
|
||||
(host, id_) <- f2l <$> o .: "id"
|
||||
fmap (host,) $
|
||||
|
|
@ -332,12 +292,6 @@ instance ActivityPub Actor where
|
|||
<*> withHostMaybe host (fmap f2l <$> o .:? "outbox")
|
||||
<*> withHostMaybe host (fmap f2l <$> o .:? "followers")
|
||||
<*> 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
|
||||
(Actor id_ typ musername mname msummary inbox outbox followers pkeys)
|
||||
= "id" .= l2f host id_
|
||||
|
|
@ -356,17 +310,17 @@ data Project = Project
|
|||
}
|
||||
|
||||
instance ActivityPub Project where
|
||||
jsonldContext _ = ContextActor
|
||||
jsonldContext _ = [as2Context, secContext, forgeContext, extContext]
|
||||
parseObject o = do
|
||||
(h, a) <- parseObject o
|
||||
unless (actorType a == ActorTypeProject) $
|
||||
fail "Actor type isn't Project"
|
||||
fmap (h,) $
|
||||
Project a
|
||||
<$> withHost h (f2l <$> o .: (frg <> "team"))
|
||||
<$> withHost h (f2l <$> o .:| "team")
|
||||
toSeries host (Project actor team)
|
||||
= toSeries host actor
|
||||
<> (frg <> "team") .= l2f host team
|
||||
<> "team" .= l2f host team
|
||||
|
||||
data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered
|
||||
|
||||
|
|
@ -395,7 +349,7 @@ data Collection a = Collection
|
|||
}
|
||||
|
||||
instance (FromJSON a, ToJSON a) => ActivityPub (Collection a) where
|
||||
jsonldContext _ = ContextAS2
|
||||
jsonldContext _ = [as2Context, forgeContext, extContext]
|
||||
parseObject o = do
|
||||
(host, id_) <- f2l <$> o .: "id"
|
||||
fmap (host,) $
|
||||
|
|
@ -448,7 +402,7 @@ data CollectionPage a = CollectionPage
|
|||
}
|
||||
|
||||
instance (FromJSON a, ToJSON a) => ActivityPub (CollectionPage a) where
|
||||
jsonldContext _ = ContextAS2
|
||||
jsonldContext _ = [as2Context, forgeContext, extContext]
|
||||
parseObject o = do
|
||||
(host, id_) <- fp2lp <$> o .: "id"
|
||||
fmap (host,) $
|
||||
|
|
@ -479,7 +433,7 @@ instance (FromJSON a, ToJSON a) => ActivityPub (CollectionPage a) where
|
|||
data Recipient = RecipientActor Actor | RecipientCollection (Collection FedURI)
|
||||
|
||||
instance ActivityPub Recipient where
|
||||
jsonldContext _ = ContextAS2
|
||||
jsonldContext _ = [as2Context, secContext, forgeContext, extContext]
|
||||
parseObject o =
|
||||
second RecipientActor <$> parseObject o <|>
|
||||
second RecipientCollection <$> parseObject o
|
||||
|
|
@ -517,11 +471,14 @@ parseAudience o =
|
|||
<*> o .:& "cc"
|
||||
<*> o .:& "bcc"
|
||||
<*> o .:& "audience"
|
||||
<*> o .:& (frg <> "nonActors")
|
||||
<*> o .:|& "nonActors"
|
||||
where
|
||||
obj .:& key = do
|
||||
l <- obj .:? key .!= []
|
||||
return $ map unAdapt l
|
||||
obj .:|& key = do
|
||||
l <- obj .:|? key .!= []
|
||||
return $ map unAdapt l
|
||||
|
||||
encodeAudience :: Audience -> Series
|
||||
encodeAudience (Audience to bto cc bcc aud nons)
|
||||
|
|
@ -530,7 +487,7 @@ encodeAudience (Audience to bto cc bcc aud nons)
|
|||
<> "cc" .=% cc
|
||||
<> "bcc" .=% bcc
|
||||
<> "audience" .=% aud
|
||||
<> (frg <> "nonActors") .=% nons
|
||||
<> "nonActors" .=% nons
|
||||
|
||||
data Note = Note
|
||||
{ noteId :: Maybe LocalURI
|
||||
|
|
@ -557,7 +514,7 @@ withHostMaybe h a = do
|
|||
else fail "URI host mismatch"
|
||||
|
||||
instance ActivityPub Note where
|
||||
jsonldContext _ = ContextAS2
|
||||
jsonldContext _ = [as2Context, extContext]
|
||||
parseObject o = do
|
||||
typ <- o .: "type"
|
||||
unless (typ == ("Note" :: Text)) $
|
||||
|
|
@ -598,39 +555,6 @@ instance ActivityPub Note where
|
|||
<> "content" .= content
|
||||
<> "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
|
||||
{ unTextHtml :: Text
|
||||
}
|
||||
|
|
@ -657,9 +581,9 @@ parseTicketLocal o = do
|
|||
Nothing -> do
|
||||
verifyNothing "context"
|
||||
verifyNothing "replies"
|
||||
verifyNothing $ frg <> "participants"
|
||||
verifyNothing $ frg <> "team"
|
||||
verifyNothing $ frg <> "events"
|
||||
verifyNothing "participants"
|
||||
verifyNothing "team"
|
||||
verifyNothing "history"
|
||||
return Nothing
|
||||
Just (h, id_) ->
|
||||
fmap (Just . (h,)) $
|
||||
|
|
@ -667,9 +591,9 @@ parseTicketLocal o = do
|
|||
<$> pure id_
|
||||
<*> withHost h (f2l <$> o .: "context")
|
||||
<*> withHost h (f2l <$> o .: "replies")
|
||||
<*> withHost h (f2l <$> o .: (frg <> "participants"))
|
||||
<*> withHost h (f2l <$> o .: (frg <> "team"))
|
||||
<*> withHost h (f2l <$> o .: (frg <> "events"))
|
||||
<*> withHost h (f2l <$> o .: "participants")
|
||||
<*> withHost h (f2l <$> o .: "team")
|
||||
<*> withHost h (f2l <$> o .: "history")
|
||||
where
|
||||
verifyNothing t =
|
||||
if t `M.member` o
|
||||
|
|
@ -681,9 +605,9 @@ encodeTicketLocal h (TicketLocal id_ context replies participants team events)
|
|||
= "id" .= l2f h id_
|
||||
<> "context" .= l2f h context
|
||||
<> "replies" .= l2f h replies
|
||||
<> (frg <> "participants") .= l2f h participants
|
||||
<> (frg <> "team") .= l2f h team
|
||||
<> (frg <> "events") .= l2f h events
|
||||
<> "participants" .= l2f h participants
|
||||
<> "team" .= l2f h team
|
||||
<> "history" .= l2f h events
|
||||
|
||||
data Ticket = Ticket
|
||||
{ ticketLocal :: Maybe (Text, TicketLocal)
|
||||
|
|
@ -701,7 +625,7 @@ data Ticket = Ticket
|
|||
}
|
||||
|
||||
instance ActivityPub Ticket where
|
||||
jsonldContext _ = ContextAS2
|
||||
jsonldContext _ = [as2Context, forgeContext, extContext]
|
||||
parseObject o = do
|
||||
typ <- o .: "type"
|
||||
unless (typ == ("Ticket" :: Text)) $
|
||||
|
|
@ -728,10 +652,10 @@ instance ActivityPub Ticket where
|
|||
<*> (TextHtml . sanitizeBalance <$> o .: "summary")
|
||||
<*> (TextHtml . sanitizeBalance <$> o .: "content")
|
||||
<*> source .: "content"
|
||||
<*> o .:? (frg <> "assignedTo")
|
||||
<*> o .: (frg <> "isResolved")
|
||||
<*> o .:? (frg <> "dependsOn") .!= []
|
||||
<*> o .:? (frg <> "dependedBy") .!= []
|
||||
<*> o .:? "assignedTo"
|
||||
<*> o .: "isResolved"
|
||||
<*> o .:? "dependsOn" .!= []
|
||||
<*> o .:? "dependedBy" .!= []
|
||||
|
||||
toSeries host
|
||||
(Ticket local attributedTo published updated name summary content
|
||||
|
|
@ -750,10 +674,10 @@ instance ActivityPub Ticket where
|
|||
[ "content" .= source
|
||||
, "mediaType" .= ("text/markdown; variant=Pandoc" :: Text)
|
||||
]
|
||||
<> (frg <> "assignedTo") .=? assignedTo
|
||||
<> (frg <> "isResolved") .= isResolved
|
||||
<> (frg <> "dependsOn") .=% dependsOn
|
||||
<> (frg <> "dependedBy") .=% dependedBy
|
||||
<> "assignedTo" .=? assignedTo
|
||||
<> "isResolved" .= isResolved
|
||||
<> "dependsOn" .=% dependsOn
|
||||
<> "dependedBy" .=% dependedBy
|
||||
|
||||
data Accept = Accept
|
||||
{ acceptObject :: FedURI
|
||||
|
|
@ -774,12 +698,6 @@ parseCreate o h luActor = do
|
|||
note <- withHost h $ parseObject =<< o .: "object"
|
||||
unless (luActor == noteAttrib note) $ fail "Create actor != Note attrib"
|
||||
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 host actor (Create obj) =
|
||||
|
|
@ -794,12 +712,12 @@ parseFollow :: Object -> Parser Follow
|
|||
parseFollow o =
|
||||
Follow
|
||||
<$> o .: "object"
|
||||
<*> o .: (frg <> "hide")
|
||||
<*> o .: "hide"
|
||||
|
||||
encodeFollow :: Follow -> Series
|
||||
encodeFollow (Follow obj hide)
|
||||
= "object" .= obj
|
||||
<> (frg <> "hide") .= hide
|
||||
<> "hide" .= hide
|
||||
|
||||
data Offer = Offer
|
||||
{ offerObject :: Ticket
|
||||
|
|
@ -850,7 +768,7 @@ data Activity = Activity
|
|||
}
|
||||
|
||||
instance ActivityPub Activity where
|
||||
jsonldContext _ = ContextAS2
|
||||
jsonldContext _ = [as2Context, forgeContext, extContext]
|
||||
parseObject o = do
|
||||
(h, id_) <- f2l <$> o .: "id"
|
||||
actor <- withHost h $ f2l <$> o .: "actor"
|
||||
|
|
|
|||
Loading…
Reference in a new issue