{- This file is part of Vervis. - - Written in 2019 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - - The author(s) have dedicated all copyright and related and neighboring - rights to this software to the public domain worldwide. This software is - distributed without any warranty. - - You should have received a copy of the CC0 Public Domain Dedication along - with this software. If not, see - . -} module Web.ActivityPub ( -- * Type-safe manipulation tools -- -- Types and functions that make handling URIs and JSON-LD contexts less -- error-prone and safer by recording safety checks in the type and -- placing the checks in a single clear place. ActivityPub (..) , Doc (..) -- * Actor -- -- ActivityPub actor document including a public key, with a 'FromJSON' -- instance for fetching and a 'ToJSON' instance for publishing. , ActorType (..) --, Algorithm (..) , Owner (..) , PublicKey (..) , Actor (..) , Project (..) , CollectionType (..) , Collection (..) , CollectionPageType (..) , CollectionPage (..) , Recipient (..) -- * Content objects , Note (..) , TextHtml (..) , TextPandocMarkdown (..) , TicketLocal (..) , Ticket (..) -- * Activity , Accept (..) , Create (..) , Follow (..) , Offer (..) , Reject (..) , Audience (..) , SpecificActivity (..) , Activity (..) -- * Utilities , publicURI , hActivityPubActor , provideAP , APGetError (..) , httpGetAP , APPostError (..) , hActivityPubForwarder , hForwardingSignature , hForwardedSignature , httpPostAP , httpPostAPBytes , Fetched (..) , fetchAPID , fetchAPID' , fetchRecipient , keyListedByActor , fetchUnknownKey , fetchKnownPersonalKey , fetchKnownSharedKey ) where import Prelude import Control.Applicative ((<|>), optional) import Control.Exception (Exception, displayException, try) import Control.Monad (when, unless, (<=<), join) import Control.Monad.IO.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Writer (Writer) import Crypto.Hash hiding (Context) import Data.Aeson import Data.Aeson.Encoding (pair) import Data.Aeson.Types (Parser, typeMismatch, listEncoding) import Data.Bifunctor import Data.Bitraversable (bitraverse) import Data.ByteString (ByteString) import Data.Foldable (for_) import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.Proxy import Data.PEM import Data.Semigroup (Endo, First (..)) import Data.Text (Text) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Time.Clock (UTCTime) import Data.Traversable import Data.Vector (Vector) import Network.HTTP.Client hiding (Proxy, proxy) import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither) import Network.HTTP.Simple (JSONException) import Network.HTTP.Types.Header (HeaderName, hContentType) import Network.URI import Text.HTML.SanitizeXSS import Yesod.Core.Content (ContentType) import Yesod.Core.Handler (ProvidedRep, provideRepType) import Network.HTTP.Client.Signature import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as BL import qualified Data.HashMap.Strict as M import qualified Data.Text as T (pack, unpack) import qualified Data.Vector as V import qualified Network.HTTP.Signature as S import Crypto.PublicVerifKey import Network.FedURI import Network.HTTP.Digest import Data.Aeson.Local proxy :: a -> Proxy a proxy _ = Proxy as2context :: Text as2context = "https://www.w3.org/ns/activitystreams" secContext :: Text secContext = "https://w3id.org/security/v1" publicURI :: FedURI 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 parseObject :: Object -> Parser (Text, a) toSeries :: Text -> a -> Series data Doc a = Doc { docHost :: Text , docValue :: a } 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" instance ActivityPub a => ToJSON (Doc a) where toJSON = error "toJSON Doc" toEncoding (Doc h v) = pairs $ "@context" .= jsonldContext (proxy v) <> toSeries h v data ActorType = ActorTypePerson | ActorTypeProject | ActorTypeOther Text deriving Eq instance FromJSON ActorType where parseJSON = withText "ActorType" $ pure . parse where parse t | t == "Person" = ActorTypePerson | t == frg <> "Project" = ActorTypeProject | otherwise = ActorTypeOther t instance ToJSON ActorType where toJSON = error "toJSON ActorType" toEncoding at = toEncoding $ case at of ActorTypePerson -> "Person" ActorTypeProject -> frg <> "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 ownerShared OwnerInstance = True ownerShared (OwnerActor _) = False data PublicKey = PublicKey { publicKeyId :: LocalURI , publicKeyExpires :: Maybe UTCTime , publicKeyOwner :: Owner , publicKeyMaterial :: PublicVerifKey --, publicKeyAlgo :: Maybe Algorithm } instance ActivityPub PublicKey where jsonldContext _ = ContextPKey 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 fmap (host,) $ PublicKey id_ <$> o .:? "expires" <*> (mkOwner shared =<< withHost host o "owner") <*> (either fail return . decodePublicVerifKeyPEM =<< o .: "publicKeyPem" ) -- <*> o .:? (frg <> "algorithm") where withHost h o t = do (h', lu) <- f2l <$> o .: t if h == h' then return lu else fail "URI host mismatch" mkOwner True (LocalURI "" "") = return OwnerInstance 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 where mkOwner h OwnerInstance = FedURI h "" "" mkOwner h (OwnerActor lu) = l2f h lu parsePublicKeySet :: Value -> Parser (Text, [Either LocalURI PublicKey]) parsePublicKeySet v = case v of Array a -> case V.toList a of [] -> fail "No public keys" k : ks -> do (h, e) <- parseKey k es <- traverse (withHost h . parseKey) ks return (h, e : es) _ -> second (: []) <$> parseKey v where 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 = case es of [e] -> renderKey e _ -> listEncoding renderKey es where renderKey (Left lu) = toEncoding $ l2f host lu renderKey (Right pk) = pairs $ toSeries host pk data Actor = Actor { actorId :: LocalURI , actorType :: ActorType , actorUsername :: Maybe Text , actorName :: Maybe Text , actorSummary :: Maybe Text , actorInbox :: LocalURI , actorOutbox :: Maybe LocalURI , actorFollowers :: Maybe LocalURI , actorPublicKeys :: [Either LocalURI PublicKey] } instance ActivityPub Actor where jsonldContext _ = ContextActor parseObject o = do (host, id_) <- f2l <$> o .: "id" fmap (host,) $ Actor id_ <$> o .: "type" <*> o .:? "preferredUsername" <*> o .:? "name" <*> o .:? "summary" <*> withHost host (f2l <$> o .: "inbox") <*> 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_ <> "type" .= typ <> "preferredUsername" .=? musername <> "name" .=? mname <> "summary" .=? msummary <> "inbox" .= l2f host inbox <> "outbox" .=? (l2f host <$> outbox) <> "followers" .=? (l2f host <$> followers) <> "publicKey" `pair` encodePublicKeySet host pkeys data Project = Project { projectActor :: Actor , projectTeam :: LocalURI } instance ActivityPub Project where jsonldContext _ = ContextActor 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")) toSeries host (Project actor team) = toSeries host actor <> (frg <> "team") .= l2f host team data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered instance FromJSON CollectionType where parseJSON = withText "CollectionType" parse where parse "Collection" = pure CollectionTypeUnordered parse "OrderedCollection" = pure CollectionTypeOrdered parse t = fail $ "Unknown collection type: " ++ T.unpack t instance ToJSON CollectionType where toJSON = error "toJSON CollectionType" toEncoding ct = toEncoding $ case ct of CollectionTypeUnordered -> "Collection" :: Text CollectionTypeOrdered -> "OrderedCollection" data Collection a = Collection { collectionId :: LocalURI , collectionType :: CollectionType , collectionTotalItems :: Maybe Int , collectionCurrent :: Maybe LocalURI , collectionFirst :: Maybe LocalPageURI , collectionLast :: Maybe LocalPageURI , collectionItems :: [a] } instance (FromJSON a, ToJSON a) => ActivityPub (Collection a) where jsonldContext _ = ContextAS2 parseObject o = do (host, id_) <- f2l <$> o .: "id" fmap (host,) $ Collection id_ <$> o .: "type" <*> o .:? "totalItems" <*> withHostMaybe host (fmap f2l <$> o .:? "current") <*> withHostMaybe host (fmap fp2lp <$> o .:? "first") <*> withHostMaybe host (fmap fp2lp <$> o .:? "last") <*> optional (o .: "items" <|> o .: "orderedItems") .!= [] toSeries host (Collection id_ typ total curr firzt last items) = "id" .= l2f host id_ <> "type" .= typ <> "totalItems" .=? total <> "current" .=? (l2f host <$> curr) <> "first" .=? (lp2fp host <$> firzt) <> "last" .=? (lp2fp host <$> last) <> "items" .=% items data CollectionPageType = CollectionPageTypeUnordered | CollectionPageTypeOrdered instance FromJSON CollectionPageType where parseJSON = withText "CollectionPageType" parse where parse "CollectionPage" = pure CollectionPageTypeUnordered parse "OrderedCollectionPage" = pure CollectionPageTypeOrdered parse t = fail $ "Unknown collection page type: " ++ T.unpack t instance ToJSON CollectionPageType where toJSON = error "toJSON CollectionPageType" toEncoding ct = toEncoding $ case ct of CollectionPageTypeUnordered -> "CollectionPage" :: Text CollectionPageTypeOrdered -> "OrderedCollectionPage" data CollectionPage a = CollectionPage { collectionPageId :: LocalPageURI , collectionPageType :: CollectionPageType , collectionPageTotalItems :: Maybe Int , collectionPageCurrent :: Maybe LocalPageURI , collectionPageFirst :: Maybe LocalPageURI , collectionPageLast :: Maybe LocalPageURI , collectionPagePartOf :: LocalURI , collectionPagePrev :: Maybe LocalPageURI , collectionPageNext :: Maybe LocalPageURI , collectionPageStartIndex :: Maybe Int , collectionPageItems :: [a] } instance (FromJSON a, ToJSON a) => ActivityPub (CollectionPage a) where jsonldContext _ = ContextAS2 parseObject o = do (host, id_) <- fp2lp <$> o .: "id" fmap (host,) $ CollectionPage id_ <$> o .: "type" <*> o .:? "totalItems" <*> withHostMaybe host (fmap fp2lp <$> o .:? "current") <*> withHostMaybe host (fmap fp2lp <$> o .:? "first") <*> withHostMaybe host (fmap fp2lp <$> o .:? "last") <*> withHost host (f2l <$> o .: "partOf") <*> withHostMaybe host (fmap fp2lp <$> o .:? "prev") <*> withHostMaybe host (fmap fp2lp <$> o .:? "next") <*> o .:? "startIndex" <*> optional (o .: "items" <|> o .: "orderedItems") .!= [] toSeries host (CollectionPage id_ typ total curr firzt last partOf prev next ind items) = "id" .= lp2fp host id_ <> "type" .= typ <> "totalItems" .=? total <> "current" .=? (lp2fp host <$> curr) <> "first" .=? (lp2fp host <$> firzt) <> "last" .=? (lp2fp host <$> last) <> "partOf" .= (l2f host partOf) <> "prev" .=? (lp2fp host <$> prev) <> "next" .=? (lp2fp host <$> next) <> "startIndex" .=? ind <> "items" .=% items data Recipient = RecipientActor Actor | RecipientCollection (Collection FedURI) instance ActivityPub Recipient where jsonldContext _ = ContextAS2 parseObject o = second RecipientActor <$> parseObject o <|> second RecipientCollection <$> parseObject o toSeries h (RecipientActor a) = toSeries h a toSeries h (RecipientCollection c) = toSeries h c data Audience = Audience { audienceTo :: [FedURI] , audienceBto :: [FedURI] , audienceCc :: [FedURI] , audienceBcc :: [FedURI] , audienceGeneral :: [FedURI] , audienceNonActors :: [FedURI] } newtype AdaptAudience = AdaptAudience { unAdapt :: FedURI } instance FromJSON AdaptAudience where parseJSON = fmap AdaptAudience . parseJSON . adapt where adapt v = case v of String t | t == "Public" -> String publicT | t == "as:Public" -> String publicT _ -> v parseAudience :: Object -> Parser Audience parseAudience o = Audience <$> o .:& "to" <*> o .:& "bto" <*> o .:& "cc" <*> o .:& "bcc" <*> o .:& "audience" <*> o .:& (frg <> "nonActors") where 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 data Note = Note { noteId :: Maybe LocalURI , noteAttrib :: LocalURI , noteAudience :: Audience , noteReplyTo :: Maybe FedURI , noteContext :: Maybe FedURI , notePublished :: Maybe UTCTime , noteSource :: Text , noteContent :: Text } withHost h a = do (h', v) <- a if h == h' then return v else fail "URI host mismatch" withHostMaybe h a = do mp <- a for mp $ \ (h', v) -> if h == h' then return v else fail "URI host mismatch" instance ActivityPub Note where jsonldContext _ = ContextAS2 parseObject o = do typ <- o .: "type" unless (typ == ("Note" :: Text)) $ fail "type isn't Note" mediaType <- o .: "mediaType" unless (mediaType == ("text/html" :: Text)) $ fail "mediaType isn't HTML" source <- o .: "source" sourceType <- source .: "mediaType" unless (sourceType == ("text/markdown; variant=Pandoc" :: Text)) $ fail "source mediaType isn't Pandoc Markdown" (h, attrib) <- f2l <$> o .: "attributedTo" fmap (h,) $ Note <$> withHostMaybe h (fmap f2l <$> o .:? "id") <*> pure attrib <*> parseAudience o <*> o .:? "inReplyTo" <*> o .:? "context" <*> o .:? "published" <*> source .: "content" <*> (sanitizeBalance <$> o .: "content") toSeries host (Note mid attrib aud mreply mcontext mpublished src content) = "type" .= ("Note" :: Text) <> "id" .=? (l2f host <$> mid) <> "attributedTo" .= l2f host attrib <> encodeAudience aud <> "inReplyTo" .=? mreply <> "context" .=? mcontext <> "published" .=? mpublished <> "source" .= object [ "content" .= src , "mediaType" .= ("text/markdown; variant=Pandoc" :: Text) ] <> "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 } deriving (FromJSON, ToJSON) newtype TextPandocMarkdown = TextPandocMarkdown { unTextPandocMarkdown :: Text } deriving (FromJSON, ToJSON) data TicketLocal = TicketLocal { ticketId :: LocalURI , ticketContext :: LocalURI , ticketReplies :: LocalURI , ticketParticipants :: LocalURI , ticketTeam :: LocalURI , ticketEvents :: LocalURI } parseTicketLocal :: Object -> Parser (Maybe (Text, TicketLocal)) parseTicketLocal o = do mid <- fmap f2l <$> o .:? "id" case mid of Nothing -> do verifyNothing "context" verifyNothing "replies" verifyNothing $ frg <> "participants" verifyNothing $ frg <> "team" verifyNothing $ frg <> "events" return Nothing Just (h, id_) -> fmap (Just . (h,)) $ TicketLocal <$> 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")) where verifyNothing t = if t `M.member` o then fail $ T.unpack t ++ " field found, expected none" else return () 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 data Ticket = Ticket { ticketLocal :: Maybe (Text, TicketLocal) , ticketAttributedTo :: LocalURI , ticketPublished :: Maybe UTCTime , ticketUpdated :: Maybe UTCTime , ticketName :: Maybe Text , ticketSummary :: TextHtml , ticketContent :: TextHtml , ticketSource :: TextPandocMarkdown , ticketAssignedTo :: Maybe FedURI , ticketIsResolved :: Bool , ticketDependsOn :: [FedURI] , ticketDependedBy :: [FedURI] } instance ActivityPub Ticket where jsonldContext _ = ContextAS2 parseObject o = do typ <- o .: "type" unless (typ == ("Ticket" :: Text)) $ fail "type isn't Ticket" mediaType <- o .: "mediaType" unless (mediaType == ("text/html" :: Text)) $ fail "mediaType isn't HTML" source <- o .: "source" sourceType <- source .: "mediaType" unless (sourceType == ("text/markdown; variant=Pandoc" :: Text)) $ fail "source mediaType isn't Pandoc Markdown" (h, attributedTo) <- f2l <$> o .: "attributedTo" fmap (h,) $ Ticket <$> parseTicketLocal o <*> pure attributedTo <*> o .:? "published" <*> o .:? "updated" <*> o .:? "name" <*> (TextHtml . sanitizeBalance <$> o .: "summary") <*> (TextHtml . sanitizeBalance <$> o .: "content") <*> source .: "content" <*> o .:? (frg <> "assignedTo") <*> o .: (frg <> "isResolved") <*> o .:? (frg <> "dependsOn") .!= [] <*> o .:? (frg <> "dependedBy") .!= [] toSeries host (Ticket local attributedTo published updated name summary content source assignedTo isResolved dependsOn dependedBy) = maybe mempty (uncurry encodeTicketLocal) local <> "type" .= ("Ticket" :: Text) <> "attributedTo" .= l2f host attributedTo <> "published" .=? published <> "updated" .=? updated <> "name" .=? name <> "summary" .= summary <> "content" .= content <> "mediaType" .= ("text/html" :: Text) <> "source" .= object [ "content" .= source , "mediaType" .= ("text/markdown; variant=Pandoc" :: Text) ] <> (frg <> "assignedTo") .=? assignedTo <> (frg <> "isResolved") .= isResolved <> (frg <> "dependsOn") .=% dependsOn <> (frg <> "dependedBy") .=% dependedBy data Accept = Accept { acceptObject :: FedURI } parseAccept :: Object -> Parser Accept parseAccept o = Accept <$> o .: "object" encodeAccept :: Accept -> Series encodeAccept (Accept obj) = "object" .= obj data Create = Create { createObject :: Note } parseCreate :: Object -> Text -> LocalURI -> Parser Create 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) = "object" `pair` pairs (toSeries host obj) data Follow = Follow { followObject :: FedURI , followHide :: Bool } parseFollow :: Object -> Parser Follow parseFollow o = Follow <$> o .: "object" <*> o .: (frg <> "hide") encodeFollow :: Follow -> Series encodeFollow (Follow obj hide) = "object" .= obj <> (frg <> "hide") .= hide data Offer = Offer { offerObject :: Ticket , offerTarget :: FedURI } parseOffer :: Object -> Text -> LocalURI -> Parser Offer parseOffer o h luActor = do ticket <- withHost h $ parseObject =<< o .: "object" unless (luActor == ticketAttributedTo ticket) $ fail "Offer actor != Ticket attrib" target <- o .: "target" for_ (ticketLocal ticket) $ \ (host, local) -> do let (hTarget, luTarget) = f2l target unless (hTarget == host) $ fail "Offer target host != Ticket local host" unless (luTarget == ticketContext local) $ fail "Offer target != Ticket context" return $ Offer ticket target encodeOffer :: Text -> LocalURI -> Offer -> Series encodeOffer host actor (Offer obj target) = "object" `pair` pairs (toSeries host obj) <> "target" .= target data Reject = Reject { rejectObject :: FedURI } parseReject :: Object -> Parser Reject parseReject o = Reject <$> o .: "object" encodeReject :: Reject -> Series encodeReject (Reject obj) = "object" .= obj data SpecificActivity = AcceptActivity Accept | CreateActivity Create | FollowActivity Follow | OfferActivity Offer | RejectActivity Reject data Activity = Activity { activityId :: LocalURI , activityActor :: LocalURI , activityAudience :: Audience , activitySpecific :: SpecificActivity } instance ActivityPub Activity where jsonldContext _ = ContextAS2 parseObject o = do (h, id_) <- f2l <$> o .: "id" actor <- withHost h $ f2l <$> o .: "actor" fmap (h,) $ Activity id_ actor <$> parseAudience o <*> do typ <- o .: "type" case typ of "Accept" -> AcceptActivity <$> parseAccept o "Create" -> CreateActivity <$> parseCreate o h actor "Follow" -> FollowActivity <$> parseFollow o "Offer" -> OfferActivity <$> parseOffer o h actor "Reject" -> RejectActivity <$> parseReject o _ -> fail $ "Unrecognized activity type: " ++ T.unpack typ toSeries host (Activity id_ actor audience specific) = "type" .= activityType specific <> "id" .= l2f host id_ <> "actor" .= l2f host actor <> encodeAudience audience <> encodeSpecific host actor specific where activityType :: SpecificActivity -> Text activityType (AcceptActivity _) = "Accept" activityType (CreateActivity _) = "Create" activityType (FollowActivity _) = "Follow" activityType (OfferActivity _) = "Offer" activityType (RejectActivity _) = "Reject" encodeSpecific _ _ (AcceptActivity a) = encodeAccept a encodeSpecific h u (CreateActivity a) = encodeCreate h u a encodeSpecific _ _ (FollowActivity a) = encodeFollow a encodeSpecific h u (OfferActivity a) = encodeOffer h u a encodeSpecific _ _ (RejectActivity a) = encodeReject a typeActivityStreams2 :: ContentType typeActivityStreams2 = "application/activity+json" typeActivityStreams2LD :: ContentType typeActivityStreams2LD = "application/ld+json; profile=\"https://www.w3.org/ns/activitystreams\"" hActivityPubActor :: HeaderName hActivityPubActor = "ActivityPub-Actor" provideAP :: (Monad m, ToJSON a) => m a -> Writer (Endo [ProvidedRep m]) () provideAP mk = -- let enc = toEncoding v -- provideRepType typeActivityStreams2 $ return enc provideRepType typeActivityStreams2LD $ toEncoding <$> mk data APGetError = APGetErrorHTTP HttpException | APGetErrorJSON JSONException | APGetErrorContentType Text deriving Show instance Exception APGetError -- | Perform an HTTP GET request to fetch an ActivityPub object. -- -- * Verify the URI scheme is _https:_ and authority part is present -- * Set _Accept_ request header -- * Perform the GET request -- * Verify the _Content-Type_ response header -- * Parse the JSON response body httpGetAP :: (MonadIO m, FromJSON a) => Manager -> FedURI -> m (Either APGetError (Response a)) httpGetAP manager uri = liftIO $ mkResult <$> try (httpAPEither manager =<< requestFromURI (toURI uri)) where lookup' x = map snd . filter ((== x) . fst) mkResult (Left e) = Left $ APGetErrorHTTP e mkResult (Right r) = case lookup' hContentType $ responseHeaders r of [] -> Left $ APGetErrorContentType "No Content-Type" [b] -> if b == typeActivityStreams2LD || b == typeActivityStreams2 then case responseBody r of Left e -> Left $ APGetErrorJSON e Right v -> Right $ v <$ r else Left $ APGetErrorContentType $ "Non-AP Content-Type: " <> decodeUtf8 b _ -> Left $ APGetErrorContentType "Multiple Content-Type" data APPostError = APPostErrorSig S.HttpSigGenError | APPostErrorHTTP HttpException deriving Show instance Exception APPostError hActivityPubForwarder :: HeaderName hActivityPubForwarder = "ActivityPub-Forwarder" hForwardingSignature :: HeaderName hForwardingSignature = "Forwarding-Signature" hForwardedSignature :: HeaderName hForwardedSignature = "Forwarded-Signature" -- | Perform an HTTP POST request to submit an ActivityPub object. -- -- * Verify the URI scheme is _https:_ and authority part is present -- * Set _Content-Type_ request header -- * Set _ActivityPub-Actor_ request header -- * Set _Digest_ request header using SHA-256 hash -- * If recipient is given, set _ActivityPub-Forwarder_ header and compute -- _Forwarding-Signature_ header -- * If forwarded signature is given, set set _ActivityPub-Forwarder_ and -- _Forwarded-Signature_ headers -- * Compute HTTP signature and add _Signature_ request header -- * Perform the POST request -- * Verify the response status is 2xx httpPostAP :: (MonadIO m, ToJSON a) => Manager -> FedURI -> NonEmpty HeaderName -> S.KeyId -> (ByteString -> S.Signature) -> Text -> Maybe (Either FedURI ByteString) -> a -> m (Either APPostError (Response ())) httpPostAP manager uri headers keyid sign uSender mfwd value = httpPostAPBytes manager uri headers keyid sign uSender mfwd $ encode value -- | Like 'httpPostAP', except it takes the object as a raw lazy -- 'BL.ByteString'. It's your responsibility to make sure it's valid JSON. httpPostAPBytes :: MonadIO m => Manager -> FedURI -> NonEmpty HeaderName -> S.KeyId -> (ByteString -> S.Signature) -> Text -> Maybe (Either FedURI ByteString) -> BL.ByteString -> m (Either APPostError (Response ())) httpPostAPBytes manager uri headers keyid sign uSender mfwd body = liftIO $ runExceptT $ do req <- requestFromURI $ toURI uri let digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body req' = setRequestCheckStatus $ consHeader hContentType typeActivityStreams2LD $ consHeader hActivityPubActor (encodeUtf8 uSender) $ consHeader hDigest digest $ req { method = "POST" , requestBody = RequestBodyLBS body } req'' <- tryExceptT APPostErrorSig $ signRequest headers Nothing keyid sign Nothing req' req''' <- case mfwd of Nothing -> return req'' Just (Left uRecip) -> tryExceptT APPostErrorSig $ signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign Nothing $ consHeader hActivityPubForwarder (encodeUtf8 $ renderFedURI uRecip) req'' Just (Right sig) -> return $ consHeader hForwardedSignature sig $ consHeader hActivityPubForwarder (encodeUtf8 uSender) req'' tryExceptT APPostErrorHTTP $ httpNoBody req''' manager where consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r } tryExceptT adapt action = ExceptT $ first adapt <$> try action -- | Result of GETing the keyId URI and processing the JSON document. data Fetched = Fetched { fetchedPublicKey :: PublicVerifKey -- ^ The Ed25519 or RSA public key corresponding to the URI we requested. , fetchedKeyExpires :: Maybe UTCTime -- ^ Optional expiration time declared for the key we received. , fetchedActorId :: LocalURI -- ^ The @id URI of the actor for whom the key's signature applies. , fetchedActorName :: Maybe Text -- ^ Name of the actor for whom the key's signature applies. , fetchedActorInbox :: LocalURI -- ^ The inbox URI of the actor for whom the key's signature applies. , fetchedKeyShared :: Bool -- ^ Whether the key we received is shared. A shared key can sign -- requests for any actor on the same instance, while a personal key is -- only for one actor. Knowing whether the key is shared will allow us -- when receiving more requests, whether to accept signatures made on -- different actors, or allow only a single permanent actor for the key -- we received. } fetchAP' :: (MonadIO m, FromJSON a) => Manager -> FedURI -> ExceptT APGetError m a fetchAP' m u = ExceptT $ second responseBody <$> httpGetAP m u fetchAP :: (MonadIO m, FromJSON a) => Manager -> FedURI -> ExceptT String m a fetchAP m u = withExceptT displayException $ fetchAP' m u {- fetchAPH :: (MonadIO m, ActivityPub a) => Manager -> Text -> LocalURI -> ExceptT String m a fetchAPH m h lu = do Doc h' v <- fetchAP m $ l2f h lu if h == h' then return v else throwE "Object @id URI's host doesn't match the URI we fetched" -} fetchAPID' :: (MonadIO m, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either (Maybe APGetError) a) fetchAPID' m getId h lu = runExceptT $ do Doc h' v <- withExceptT Just $ fetchAP' m $ l2f h lu if h == h' && getId v == lu then return v else throwE Nothing fetchRecipient :: MonadIO m => Manager -> Text -> LocalURI -> m (Either (Maybe APGetError) Recipient) fetchRecipient m = fetchAPID' m getId where getId (RecipientActor a) = actorId a getId (RecipientCollection c) = collectionId c fetchAPID :: (MonadIO m, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either String a) fetchAPID m getId h lu = first showError <$> fetchAPID' m getId h lu where showError Nothing = "Object @id doesn't match the URI we fetched" showError (Just e) = displayException e data FetchAPError = FetchAPErrorGet APGetError -- Object @id doesn't match the URI we fetched | FetchAPErrorIdMismatch -- Object @id URI's host doesn't match the URI we fetched | FetchAPErrorHostMismatch deriving Show fetchAPIDOrH' :: (MonadIO m, ActivityPub a, ActivityPub b) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> ExceptT FetchAPError m (Either a b) fetchAPIDOrH' m getId h lu = do e <- withExceptT FetchAPErrorGet $ fetchAP' m $ l2f h lu case e of Left' (Doc h' x) -> if h == h' && getId x == lu then return $ Left x else throwE FetchAPErrorIdMismatch Right' (Doc h' y) -> if h == h' then return $ Right y else throwE FetchAPErrorHostMismatch fetchAPIDOrH :: (MonadIO m, ActivityPub a, ActivityPub b) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> ExceptT String m (Either a b) fetchAPIDOrH m getId h lu = withExceptT show $ fetchAPIDOrH' m getId h lu -- | Fetches the given actor and checks whether it lists the given key (as a -- URI, not as an embedded object). If it does, returns 'Right' the fetched -- actor. Otherwise, or if an error occurs during fetching, returns 'Left' an -- error message. keyListedByActor :: MonadIO m => Manager -> Text -> LocalURI -> LocalURI -> m (Either String Actor) keyListedByActor manager host luKey luActor = runExceptT $ do actor <- ExceptT $ fetchAPID manager actorId host luActor if keyUriListed luKey actor then return actor else throwE "Actor publicKey has no URI matching pkey @id" where keyUriListed uk a = let match (Left uri) = uri == uk match (Right _) = False in any match $ actorPublicKeys a matchKeyObj :: (Foldable f, Monad m) => LocalURI -> f (Either LocalURI PublicKey) -> ExceptT String m PublicKey matchKeyObj luKey es = case find' (match luKey) es of Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID" Just pk -> return pk where find' :: Foldable f => (a -> Maybe b) -> f a -> Maybe b find' p = join . fmap getFirst . foldMap (Just . First . p) match _ (Left _) = Nothing match luk (Right pk) = if publicKeyId pk == luk then Just pk else Nothing verifyAlgo :: Maybe S.Algorithm -> PublicVerifKey -> Either String () verifyAlgo Nothing _ = Right () verifyAlgo (Just a) k = case a of S.AlgorithmEd25519 -> case k of PublicVerifKeyEd25519 _ -> Right () PublicVerifKeyRSA _ -> Left "Algo mismatch, algo is Ed25519 but actual key is RSA" S.AlgorithmRsaSha256 -> case k of PublicVerifKeyEd25519 _ -> Left "Algo mismatch, algo is RSA-SHA256 but actual key is \ \Ed25519" PublicVerifKeyRSA _ -> Right () S.AlgorithmOther b -> Left $ concat [ "Unrecognized algo " , BC.unpack b , ", actual key is " , case k of PublicVerifKeyEd25519 _ -> "Ed25519" PublicVerifKeyRSA _ -> "RSA" ] -- | Fetch a key we don't have cached locally. fetchUnknownKey :: MonadIO m => Manager -- ^ Manager for making HTTP requests -> Maybe S.Algorithm -- ^ Signature algorithm possibly specified in the HTTP signature header -> Text -- ^ Instance host -> Maybe LocalURI -- ^ Actor URI possibly provided in the HTTP request's actor header -> LocalURI -- ^ Key URI provided in HTTP signature header -> ExceptT String m Fetched fetchUnknownKey manager malgo host mluActor luKey = do obj <- fetchAPIDOrH manager publicKeyId host luKey fetched <- case obj of Left pkey -> do (oi, luActor) <- case publicKeyOwner pkey of OwnerInstance -> case mluActor of Nothing -> throwE "Key is shared but actor header not specified!" Just u -> return (True, u) OwnerActor owner -> do for_ mluActor $ \ lu -> if owner == lu then return () else throwE "Key's owner doesn't match actor header" return (False, owner) actor <- ExceptT $ keyListedByActor manager host luKey luActor return Fetched { fetchedPublicKey = publicKeyMaterial pkey , fetchedKeyExpires = publicKeyExpires pkey , fetchedActorId = luActor , fetchedActorName = actorName actor <|> actorUsername actor , fetchedActorInbox = actorInbox actor , fetchedKeyShared = oi } Right actor -> do if actorId actor == luKey { luriFragment = "" } then return () else throwE "Actor ID doesn't match the keyid URI we fetched" for_ mluActor $ \ lu -> if actorId actor == lu then return () else throwE "Key's owner doesn't match actor header" pk <- matchKeyObj luKey $ actorPublicKeys actor owner <- case publicKeyOwner pk of OwnerInstance -> throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document" OwnerActor owner -> if owner == actorId actor then return owner else throwE "Actor's publicKey's owner doesn't match the actor's ID" return Fetched { fetchedPublicKey = publicKeyMaterial pk , fetchedKeyExpires = publicKeyExpires pk , fetchedActorId = owner , fetchedActorName = actorName actor <|> actorUsername actor , fetchedActorInbox = actorInbox actor , fetchedKeyShared = False } ExceptT . pure $ verifyAlgo malgo $ fetchedPublicKey fetched return fetched keyDetail pk = (publicKeyMaterial pk, publicKeyExpires pk) -- | Fetch a personal key we already have cached locally, but we'd like to -- refresh the local copy by fetching the key again from the server. fetchKnownPersonalKey :: MonadIO m => Manager -- ^ Manager for making HTTP requests -> Maybe S.Algorithm -- ^ Signature algorithm possibly specified in the HTTP signature header -> Text -- ^ Instance host -> LocalURI -- ^ Key owner actor ID URI -> LocalURI -- ^ Key URI -> ExceptT String m (PublicVerifKey, Maybe UTCTime) fetchKnownPersonalKey manager malgo host luOwner luKey = do obj <- fetchAPIDOrH manager publicKeyId host luKey (material, mexpires) <- case obj of Left pkey -> do case publicKeyOwner pkey of OwnerInstance -> throwE "Personal key became shared" OwnerActor owner -> when (luOwner /= owner) $ throwE "Key owner changed" return $ keyDetail pkey Right actor -> do when (actorId actor /= luKey { luriFragment = "" }) $ throwE "Actor ID doesn't match the keyid URI we fetched" when (actorId actor /= luOwner) $ throwE "Key owner changed" pk <- matchKeyObj luKey $ actorPublicKeys actor case publicKeyOwner pk of OwnerInstance -> throwE "Personal key became shared" OwnerActor owner -> when (owner /= luOwner) $ throwE "Actor's publicKey's owner doesn't match the actor's ID" return $ keyDetail pk ExceptT . pure $ verifyAlgo malgo material return (material, mexpires) -- | Fetch a shared key we already have cached locally, but we'd like to -- refresh the local copy by fetching the key again from the server. fetchKnownSharedKey :: MonadIO m => Manager -- ^ Manager for making HTTP requests -> Maybe S.Algorithm -- ^ Signature algorithm possibly specified in the HTTP signature header -> Text -- ^ Instance host -> LocalURI -- ^ Actor ID from HTTP actor header -> LocalURI -- ^ Key URI -> ExceptT String m (PublicVerifKey, Maybe UTCTime) fetchKnownSharedKey manager malgo host luActor luKey = do obj <- fetchAPIDOrH manager publicKeyId host luKey pkey <- case obj :: Either PublicKey Actor of Left pk -> return pk Right _actor -> throwE "Expected stand-alone key, got embedded key" case publicKeyOwner pkey of OwnerInstance -> return () OwnerActor _owner -> throwE "Shared key became personal" let (material, mexpires) = keyDetail pkey ExceptT . pure $ verifyAlgo malgo material return (material, mexpires)