8ac559d064
Using a dedicated type allows to record in the type the guarantees that we provide, such as scheme being HTTPS and authority being present. Allows to replace ugly `fromJust` and such with direct field access.
473 lines
18 KiB
Haskell
473 lines
18 KiB
Haskell
{- 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
|
|
( -- * Actor
|
|
--
|
|
-- ActivityPub actor document including a public key, with a 'FromJSON'
|
|
-- instance for fetching and a 'ToJSON' instance for publishing.
|
|
ActorType (..)
|
|
, Algorithm (..)
|
|
, PublicKey (..)
|
|
, PublicKeySet (..)
|
|
, Actor (..)
|
|
|
|
-- * Activity
|
|
--
|
|
-- Very basic activity document which is just general JSON with some
|
|
-- basic checks. 'FromJSON' instance for receiving POSTs, and 'ToJSON'
|
|
-- instance for delivering to other servers.
|
|
, Activity (..)
|
|
|
|
-- * Utilities
|
|
, hActivityPubActor
|
|
, provideAP
|
|
, APGetError (..)
|
|
, httpGetAP
|
|
, httpPostAP
|
|
, Fetched (..)
|
|
, fetchKey
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
import Control.Applicative ((<|>), optional)
|
|
import Control.Exception (Exception, displayException, try)
|
|
import Control.Monad ((<=<))
|
|
import Control.Monad.IO.Class
|
|
import Control.Monad.Trans.Except
|
|
import Control.Monad.Trans.Writer (Writer)
|
|
import Crypto.Error (CryptoFailable (..))
|
|
import Data.Aeson
|
|
import Data.Aeson.Types (Parser)
|
|
import Data.Bifunctor (bimap, first)
|
|
import Data.Bitraversable (bitraverse)
|
|
import Data.ByteString (ByteString)
|
|
import Data.List.NonEmpty (NonEmpty)
|
|
import Data.PEM
|
|
import Data.Semigroup (Endo)
|
|
import Data.Text (Text)
|
|
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
|
import Data.Time.Clock (UTCTime)
|
|
import Network.HTTP.Client
|
|
import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
|
|
import Network.HTTP.Client.Signature (signRequest)
|
|
import Network.HTTP.Signature (KeyId, Signature)
|
|
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 qualified Crypto.PubKey.Ed25519 as E (PublicKey, publicKey)
|
|
import qualified Data.HashMap.Strict as M (lookup)
|
|
import qualified Data.Text as T (pack, unpack)
|
|
import qualified Data.Vector as V (fromList, toList)
|
|
|
|
import Network.FedURI
|
|
|
|
import Data.Aeson.Local
|
|
|
|
as2context :: Text
|
|
as2context = "https://www.w3.org/ns/activitystreams"
|
|
|
|
actorContext :: Value
|
|
actorContext = Array $ V.fromList
|
|
[ String as2context
|
|
, String "https://w3id.org/security/v1"
|
|
]
|
|
|
|
data ActorType = ActorTypePerson | ActorTypeOther Text
|
|
|
|
instance FromJSON ActorType where
|
|
parseJSON = withText "ActorType" $ \ t ->
|
|
pure $ case t of
|
|
"Person" -> ActorTypePerson
|
|
_ -> ActorTypeOther t
|
|
|
|
instance ToJSON ActorType where
|
|
toJSON = error "toJSON ActorType"
|
|
toEncoding at =
|
|
toEncoding $ case at of
|
|
ActorTypePerson -> "Person"
|
|
ActorTypeOther t -> t
|
|
|
|
data Algorithm = AlgorithmEd25519 | AlgorithmOther Text
|
|
|
|
instance FromJSON Algorithm where
|
|
parseJSON = withText "Algorithm" $ \ t ->
|
|
pure $ if t == frg <> "ed25519"
|
|
then AlgorithmEd25519
|
|
else AlgorithmOther t
|
|
|
|
instance ToJSON Algorithm where
|
|
toJSON = error "toJSON Algorithm"
|
|
toEncoding algo =
|
|
toEncoding $ case algo of
|
|
AlgorithmEd25519 -> frg <> "ed25519"
|
|
AlgorithmOther t -> t
|
|
|
|
data PublicKey = PublicKey
|
|
{ publicKeyId :: FedURI
|
|
, publicKeyExpires :: Maybe UTCTime
|
|
, publicKeyOwner :: FedURI
|
|
, publicKeyPem :: PEM
|
|
, publicKeyAlgo :: Maybe Algorithm
|
|
, publicKeyShared :: Bool
|
|
}
|
|
|
|
instance FromJSON PublicKey where
|
|
parseJSON = withObject "PublicKey" $ \ o -> do
|
|
mtyp <- optional $ o .: "@type" <|> o .: "type"
|
|
case mtyp of
|
|
Nothing -> return ()
|
|
Just t ->
|
|
if t == ("Key" :: Text)
|
|
then return ()
|
|
else fail "PublicKey @type isn't Key"
|
|
PublicKey
|
|
<$> o .: "id"
|
|
<*> o .:? "expires"
|
|
<*> o .: "owner"
|
|
<*> (parsePEM =<< o .: "publicKeyPem")
|
|
<*> o .:? (frg <> "algorithm")
|
|
<*> o .:? (frg <> "shared") .!= False
|
|
where
|
|
parsePEM t =
|
|
case pemParseBS $ encodeUtf8 t of
|
|
Left e -> fail $ "PEM parsing failed: " ++ e
|
|
Right xs ->
|
|
case xs of
|
|
[] -> fail "Empty PEM"
|
|
[x] -> pure x
|
|
_ -> fail "Multiple PEM sections"
|
|
|
|
instance ToJSON PublicKey where
|
|
toJSON = error "toJSON PublicKey"
|
|
toEncoding (PublicKey id_ mexpires owner pem malgo shared) =
|
|
pairs
|
|
$ "id" .= id_
|
|
<> "expires" .=? mexpires
|
|
<> "owner" .= owner
|
|
<> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem)
|
|
<> (frg <> "algorithm") .=? malgo
|
|
<> (frg <> "shared") .= shared
|
|
|
|
data PublicKeySet = PublicKeySet
|
|
{ publicKey1 :: Either FedURI PublicKey
|
|
, publicKey2 :: Maybe (Either FedURI PublicKey)
|
|
}
|
|
|
|
instance FromJSON PublicKeySet where
|
|
parseJSON v =
|
|
case v of
|
|
Array a ->
|
|
case V.toList a of
|
|
[] -> fail "No public keys"
|
|
[k1] -> PublicKeySet <$> parseKey k1 <*> pure Nothing
|
|
[k1, k2] -> PublicKeySet <$> parseKey k1 <*> (Just <$> parseKey k2)
|
|
_ -> fail "More than 2 public keys isn't supported"
|
|
_ -> PublicKeySet <$> parseKey v <*> pure Nothing
|
|
where
|
|
parseKey = fmap toEither . parseJSON
|
|
|
|
instance ToJSON PublicKeySet where
|
|
toJSON = error "toJSON PublicKeySet"
|
|
toEncoding (PublicKeySet k1 mk2) =
|
|
case mk2 of
|
|
Nothing -> toEncoding $ renderKey k1
|
|
Just k2 -> toEncodingList [renderKey k1, renderKey k2]
|
|
where
|
|
renderKey = fromEither
|
|
|
|
data Actor = Actor
|
|
{ actorId :: FedURI
|
|
, actorType :: ActorType
|
|
, actorUsername :: Text
|
|
, actorInbox :: FedURI
|
|
, actorPublicKeys :: PublicKeySet
|
|
}
|
|
|
|
instance FromJSON Actor where
|
|
parseJSON = withObject "Actor" $ \ o ->
|
|
Actor
|
|
<$> o .: "id"
|
|
<*> o .: "type"
|
|
<*> o .: "preferredUsername"
|
|
<*> o .: "inbox"
|
|
<*> o .: "publicKey"
|
|
|
|
instance ToJSON Actor where
|
|
toJSON = error "toJSON Actor"
|
|
toEncoding (Actor id_ typ username inbox pkeys) =
|
|
pairs
|
|
$ "@context" .= actorContext
|
|
<> "id" .= id_
|
|
<> "type" .= typ
|
|
<> "preferredUsername" .= username
|
|
<> "inbox" .= inbox
|
|
<> "publicKey" .= pkeys
|
|
|
|
-- | This may seem trivial, but it exists for a good reason: In the 'FromJSON'
|
|
-- instance we perform sanity checks. We just don't need to remember the fields
|
|
-- after checking, so we don't unnecessarily add them as fields. We just keep
|
|
-- the _to_ field, which tells us who the target actor is (we currently support
|
|
-- only the _to_ field, and it has to be a single URI, and that URI has to be
|
|
-- an actor, not a collection). The 'Object' we keep is simply for encoding
|
|
-- back to JSON. I suppose that's actually silly, we could just keep the actual
|
|
-- ByteString, but I guess it's okay for now, and it happens to guarantee the
|
|
-- JSON we POST has no extra whitespace.
|
|
data Activity = Activity
|
|
{ activityTo :: FedURI
|
|
, activityJSON :: Object
|
|
}
|
|
|
|
instance FromJSON Activity where
|
|
parseJSON = withObject "Activity" $ \ o -> do
|
|
c <- o .: "@context"
|
|
if c == as2context
|
|
then return ()
|
|
else fail "@context isn't the AS2 context URI"
|
|
case M.lookup "id" o of
|
|
Nothing -> return ()
|
|
Just _ -> fail "id is provided; let the server set it"
|
|
case M.lookup "type" o of
|
|
Nothing -> fail "Activity type missing"
|
|
Just (String _) -> return ()
|
|
Just _ -> fail "Activity type isn't a string"
|
|
case M.lookup "actor" o of
|
|
Nothing -> return ()
|
|
Just _ -> fail "actor is provided; let the server set it"
|
|
mto <- case M.lookup "object" o of
|
|
Nothing -> return Nothing
|
|
Just v -> case v of
|
|
String _ -> return Nothing
|
|
Object obj -> do
|
|
case M.lookup "id" obj of
|
|
Nothing -> return ()
|
|
Just _ -> fail "object's id is provided; let the server set it"
|
|
case M.lookup "type" obj of
|
|
Nothing -> fail "Activity object type missing"
|
|
Just (String _) -> return ()
|
|
Just _ -> fail "Activity object type isn't a string"
|
|
case M.lookup "actor" o <|> M.lookup "attributedTo" o of
|
|
Nothing -> return ()
|
|
Just _ -> fail "attribution is provided; let the server set it"
|
|
obj .:? "to"
|
|
_ -> fail "Activity object isn't JSON string or object"
|
|
mto2 <- o .:? "to"
|
|
to <- case mto <|> mto2 of
|
|
Nothing -> fail "to not provided"
|
|
Just u -> return u
|
|
return $ Activity to o
|
|
|
|
instance ToJSON Activity where
|
|
toJSON = error "toJSON Activity"
|
|
toEncoding = toEncoding . activityJSON
|
|
|
|
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) => a -> Writer (Endo [ProvidedRep m]) ()
|
|
provideAP v = do
|
|
let enc = toEncoding v
|
|
-- provideRepType typeActivityStreams2 $ return enc
|
|
provideRepType typeActivityStreams2LD $ return enc
|
|
|
|
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"
|
|
|
|
-- | 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
|
|
-- * 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
|
|
-> (ByteString -> (KeyId, Signature))
|
|
-> Text
|
|
-> a
|
|
-> m (Either HttpException (Response ()))
|
|
httpPostAP manager uri headers sign uActor value =
|
|
liftIO $ try $ do
|
|
req <- requestFromURI $ toURI uri
|
|
let req' =
|
|
setRequestCheckStatus $
|
|
consHeader hContentType typeActivityStreams2LD $
|
|
consHeader hActivityPubActor (encodeUtf8 uActor) $
|
|
req { method = "POST"
|
|
, requestBody = RequestBodyLBS $ encode value
|
|
}
|
|
sign' b =
|
|
let (k, s) = sign b
|
|
in (Nothing, k, s)
|
|
req'' <- signRequest headers sign' Nothing req'
|
|
httpNoBody req'' manager
|
|
where
|
|
consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
|
|
|
|
-- | Result of GETing the keyId URI and processing the JSON document.
|
|
data Fetched = Fetched
|
|
{ fetchedPublicKey :: E.PublicKey
|
|
-- ^ The Ed25519 public key corresponding to the URI we requested.
|
|
, fetchedKeyExpires :: Maybe UTCTime
|
|
-- ^ Optional expiration time declared for the key we received.
|
|
, fetchedActorId :: FedURI
|
|
-- ^ The @id URI of the actor for whom the key's signature applies.
|
|
, fetchedHost :: Text
|
|
-- ^ The domain name of the instance from which we got the key.
|
|
, 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.
|
|
}
|
|
|
|
fetchKey
|
|
:: MonadIO m
|
|
=> Manager
|
|
-> Bool
|
|
-> Maybe FedURI
|
|
-> FedURI
|
|
-> m (Either String Fetched)
|
|
fetchKey manager sigAlgo muActor uKey = runExceptT $ do
|
|
let fetch :: (MonadIO m, FromJSON a) => FedURI -> ExceptT String m a
|
|
fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
|
|
obj <- fetch uKey
|
|
let inztance = uKey { furiPath = "", furiFragment = "" }
|
|
(actor, pkey, shared) <-
|
|
case obj of
|
|
Left' pkey -> do
|
|
if publicKeyId pkey == uKey
|
|
then return ()
|
|
else throwE "Public key's ID doesn't match the keyid URI"
|
|
if furiHost (publicKeyOwner pkey) == furiHost uKey
|
|
then return ()
|
|
else throwE "Actor and key on different domains, we reject"
|
|
uActor <-
|
|
if publicKeyShared pkey
|
|
then case muActor of
|
|
Nothing -> throwE "Key is shared but actor header not specified!"
|
|
Just u -> return u
|
|
else return $ publicKeyOwner pkey
|
|
actor <- fetch uActor
|
|
let PublicKeySet k1 mk2 = actorPublicKeys actor
|
|
match (Left uri) = uri == uKey
|
|
match (Right _) = False
|
|
if match k1 || maybe False match mk2
|
|
then return (actor, pkey, publicKeyShared pkey)
|
|
else throwE "Actor publicKey has no URI matching pkey @id"
|
|
Right' actor -> do
|
|
if actorId actor == uKey { furiFragment = "" }
|
|
then return ()
|
|
else throwE "Actor ID doesn't match the keyid URI we fetched"
|
|
case muActor of
|
|
Nothing -> return ()
|
|
Just u ->
|
|
if actorId actor == u
|
|
then return ()
|
|
else throwE "Key's owner doesn't match actor header"
|
|
let PublicKeySet k1 mk2 = actorPublicKeys actor
|
|
match (Left _) = Nothing
|
|
match (Right pk) =
|
|
if publicKeyId pk == uKey
|
|
then Just pk
|
|
else Nothing
|
|
case match k1 <|> (match =<< mk2) of
|
|
Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID"
|
|
Just pk ->
|
|
if publicKeyShared pk
|
|
then throwE "Actor's publicKey is shared, but embedded in actor document! We allow shared keys only if they're in a separate document"
|
|
else return (actor, pk, False)
|
|
ExceptT . pure $ do
|
|
if shared
|
|
then if publicKeyOwner pkey == inztance
|
|
then Right ()
|
|
else Left "Key is shared but its owner isn't the top-level instance URI"
|
|
else if publicKeyOwner pkey == actorId actor
|
|
then Right ()
|
|
else Left "Actor's publicKey's owner doesn't match the actor's ID"
|
|
case publicKeyAlgo pkey of
|
|
Nothing ->
|
|
Left $
|
|
if sigAlgo
|
|
then "Algo mismatch, Ed25519 in Sig but none in actor"
|
|
else "Algo not given in Sig nor actor"
|
|
Just algo ->
|
|
case algo of
|
|
AlgorithmEd25519 -> Right ()
|
|
AlgorithmOther _ ->
|
|
Left $
|
|
if sigAlgo
|
|
then "Algo mismatch, Ed25519 in Sig but unsupported algo in actor"
|
|
else "No algo in Sig, unsupported algo in actor"
|
|
case E.publicKey $ pemContent $ publicKeyPem pkey of
|
|
CryptoPassed k -> Right Fetched
|
|
{ fetchedPublicKey = k
|
|
, fetchedKeyExpires = publicKeyExpires pkey
|
|
, fetchedActorId = actorId actor
|
|
, fetchedHost = furiHost uKey
|
|
, fetchedKeyShared = shared
|
|
}
|
|
CryptoFailed _ -> Left "Parsing Ed25519 public key failed"
|