Vervis/src/Web/ActivityPub.hs

1105 lines
39 KiB
Haskell
Raw Normal View History

{- This file is part of Vervis.
-
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- 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
- <http://creativecommons.org/publicdomain/zero/1.0/>.
-}
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 (..)
, CollectionType (..)
, Collection (..)
, CollectionPageType (..)
, CollectionPage (..)
, Recipient (..)
-- * Activity
, Note (..)
, Accept (..)
, Create (..)
, Follow (..)
, 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 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 (lookup)
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
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
, 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")
<*> 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 pkeys)
= "id" .= l2f host id_
<> "type" .= typ
<> "preferredUsername" .=? musername
<> "name" .=? mname
<> "summary" .=? msummary
<> "inbox" .= l2f host inbox
<> "publicKey" `pair` encodePublicKeySet host pkeys
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
, 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"
(h, attrib) <- f2l <$> o .: "attributedTo"
fmap (h,) $
Note
<$> withHostMaybe h (fmap f2l <$> o .:? "id")
<*> pure attrib
<*> parseAudience o
<*> o .:? "inReplyTo"
<*> o .:? "context"
<*> o .:? "published"
<*> o .: "content"
toSeries host (Note mid attrib aud mreply mcontext mpublished content)
= "type" .= ("Note" :: Text)
<> "id" .=? (l2f host <$> mid)
<> "attributedTo" .= l2f host attrib
<> encodeAudience aud
<> "inReplyTo" .=? mreply
<> "context" .=? mcontext
<> "published" .=? mpublished
<> "content" .= content
{-
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
-}
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 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
| 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
"Reject" -> RejectActivity <$> parseReject o
_ ->
fail $
"Unrecognized activity type: " ++ T.unpack typ
where
withHost h a = do
(h', v) <- a
if h == h'
then return v
else fail "URI host mismatch"
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 (RejectActivity _) = "Reject"
encodeSpecific _ _ (AcceptActivity a) = encodeAccept a
encodeSpecific h u (CreateActivity a) = encodeCreate h u a
encodeSpecific _ _ (FollowActivity a) = encodeFollow 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.
, 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)
inbox <- actorInbox <$> ExceptT (keyListedByActor manager host luKey luActor)
return Fetched
{ fetchedPublicKey = publicKeyMaterial pkey
, fetchedKeyExpires = publicKeyExpires pkey
, fetchedActorId = luActor
, fetchedActorInbox = inbox
, 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"
2019-02-22 09:30:43 +01:00
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 ->
2019-02-22 09:30:43 +01:00
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
, 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)