378 lines
14 KiB
Haskell
378 lines
14 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 (..)
|
|
, 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
|
|
, provideAP
|
|
, APGetError (..)
|
|
, httpGetAP
|
|
, httpPostAP
|
|
, fetchKey
|
|
)
|
|
where
|
|
|
|
import Prelude
|
|
|
|
import Control.Applicative ((<|>), optional)
|
|
import Control.Exception (Exception, displayException, try)
|
|
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)
|
|
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 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 (unpack)
|
|
import qualified Data.Vector as V (fromList)
|
|
|
|
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 :: URI
|
|
, publicKeyOwner :: URI
|
|
, 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
|
|
<$> (parseHttpsURI =<< o .: "id")
|
|
<*> (parseHttpsURI =<< 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_ owner pem malgo shared) =
|
|
pairs
|
|
$ "id" .= renderURI id_
|
|
<> "owner" .= renderURI owner
|
|
<> "publicKeyPem" .= decodeUtf8 (pemWriteBS pem)
|
|
<> (frg <> "algorithm") .=? malgo
|
|
<> (frg <> "shared") .= shared
|
|
|
|
data Actor = Actor
|
|
{ actorId :: URI
|
|
, actorType :: ActorType
|
|
, actorUsername :: Text
|
|
, actorInbox :: URI
|
|
, actorPublicKey :: PublicKey
|
|
}
|
|
|
|
instance FromJSON Actor where
|
|
parseJSON = withObject "Actor" $ \ o ->
|
|
Actor
|
|
<$> (parseHttpsURI =<< o .: "id")
|
|
<*> o .: "type"
|
|
<*> o .: "preferredUsername"
|
|
<*> (parseHttpsURI =<< o .: "inbox")
|
|
<*> o .: "publicKey"
|
|
|
|
instance ToJSON Actor where
|
|
toJSON = error "toJSON Actor"
|
|
toEncoding (Actor id_ typ username inbox pkey) =
|
|
pairs
|
|
$ "@context" .= actorContext
|
|
<> "id" .= renderURI id_
|
|
<> "type" .= typ
|
|
<> "preferredUsername" .= username
|
|
<> "inbox" .= renderURI inbox
|
|
<> "publicKey" .= pkey
|
|
|
|
-- | 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 :: URI
|
|
, 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 t -> parseHttpsURI t
|
|
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\""
|
|
|
|
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
|
|
-> URI
|
|
-> m (Either APGetError (Response a))
|
|
httpGetAP manager uri =
|
|
if uriScheme uri /= "https:"
|
|
then return $ Left $ APGetErrorHTTP $ InvalidUrlException (show uri) "Scheme isn't https"
|
|
else liftIO $ mkResult <$> try (httpAPEither manager =<< requestFromURI 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"
|
|
|
|
-- Set method to POST, Set Content-Type, make HTTP signature, set response to throw on non-2xx
|
|
-- status
|
|
|
|
-- | 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
|
|
-- * Compute HTTP signature and add _Signature_ request header
|
|
-- * Perform the POST request
|
|
-- * Verify the response status is 2xx
|
|
httpPostAP
|
|
:: (MonadIO m, ToJSON a)
|
|
=> Manager
|
|
-> URI
|
|
-> NonEmpty HeaderName
|
|
-> (ByteString -> (KeyId, Signature))
|
|
-> a
|
|
-> m (Either HttpException (Response ()))
|
|
httpPostAP manager uri headers sign value =
|
|
if uriScheme uri /= "https:"
|
|
then return $ Left $ InvalidUrlException (show uri) "Scheme isn't https"
|
|
else liftIO $ try $ do
|
|
req <- requestFromURI uri
|
|
let req' =
|
|
setRequestCheckStatus $
|
|
consHeader hContentType typeActivityStreams2LD $
|
|
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 }
|
|
|
|
fetchKey
|
|
:: MonadIO m
|
|
=> Manager
|
|
-> Bool
|
|
-> URI
|
|
-> m (Either String (E.PublicKey, URI))
|
|
fetchKey manager sigAlgo u = runExceptT $ do
|
|
let fetch :: (MonadIO m, FromJSON a) => URI -> ExceptT String m a
|
|
fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
|
|
obj <- fetch u
|
|
(actor, pkey) <-
|
|
case obj of
|
|
Left' pkey ->
|
|
if uriAuthority (publicKeyOwner pkey) == uriAuthority u
|
|
then do
|
|
actor <- fetch $ publicKeyOwner pkey
|
|
return (actor, pkey)
|
|
else throwE "Actor and key on different domains, we reject"
|
|
Right' actor ->
|
|
if actorId actor == u { uriFragment = "" }
|
|
then return (actor, actorPublicKey actor)
|
|
else throwE "Actor ID doesn't match the keyid URI we fetched"
|
|
ExceptT . pure $ do
|
|
if publicKeyShared pkey
|
|
then Left "Actor's publicKey is shared, we're rejecting it!"
|
|
else Right ()
|
|
if publicKeyId pkey == u
|
|
then Right ()
|
|
else Left "Actor's publicKey's ID doesn't match the keyid URI"
|
|
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 (k, actorId actor)
|
|
CryptoFailed e -> Left "Parsing Ed25519 public key failed"
|