diff --git a/src/Data/Aeson/Local.hs b/src/Data/Aeson/Local.hs index afab31d..7f2bbb1 100644 --- a/src/Data/Aeson/Local.hs +++ b/src/Data/Aeson/Local.hs @@ -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,8 +53,13 @@ fromEither :: Either a b -> Either' a b fromEither (Left x) = Left' x fromEither (Right y) = Right' y -frg :: Text -frg = "https://forgefed.angeley.es/ns#" +(.:|) :: 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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index f99e0c1..0f90cf5 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -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 @@ -195,36 +181,18 @@ instance FromJSON ActorType where parseJSON = withText "ActorType" $ pure . parse where parse t - | t == "Person" = ActorTypePerson - | t == frg <> "Project" = ActorTypeProject - | otherwise = ActorTypeOther t + | t == "Person" = ActorTypePerson + | t == "Project" = ActorTypeProject + | otherwise = ActorTypeOther t instance ToJSON ActorType where toJSON = error "toJSON ActorType" 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 @@ -266,12 +232,11 @@ instance ActivityPub PublicKey where mkOwner True _ = fail "Shared key but owner isn't instance URI" mkOwner False lu = return $ OwnerActor lu toSeries host (PublicKey id_ mexpires owner mat) - = "@id" .= l2f host id_ - <> "expires" .=? mexpires - <> "owner" .= mkOwner host owner - <> "publicKeyPem" .= encodePublicVerifKeyPEM mat - -- <> (frg <> "algorithm") .=? malgo - <> (frg <> "isShared") .= ownerShared owner + = "@id" .= l2f host id_ + <> "expires" .=? mexpires + <> "owner" .= mkOwner host owner + <> "publicKeyPem" .= encodePublicVerifKeyPEM mat + <> "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,20 +471,23 @@ 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) - = "to" .=% to - <> "bto" .=% bto - <> "cc" .=% cc - <> "bcc" .=% bcc - <> "audience" .=% aud - <> (frg <> "nonActors") .=% nons + = "to" .=% to + <> "bto" .=% bto + <> "cc" .=% cc + <> "bcc" .=% bcc + <> "audience" .=% aud + <> "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 @@ -678,12 +602,12 @@ parseTicketLocal o = do encodeTicketLocal :: Text -> TicketLocal -> Series 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 + = "id" .= l2f h id_ + <> "context" .= l2f h context + <> "replies" .= l2f h replies + <> "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 + = "object" .= obj + <> "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"