Vervis/src/Web/ActivityPub.hs

{- 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"