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
    ( -- * 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 (..)
    , PublicKeySet (..)
    , Actor (..)

      -- * Activity
    , Note (..)
    , Create (..)
    , Activity (..)

      -- * Utilities
    , hActivityPubActor
    , provideAP
    , APGetError (..)
    , httpGetAP
    , httpPostAP
    , Fetched (..)
    , fetchAPID
    , keyListedByActor
    , fetchKey
    )
where

import Prelude

import Control.Applicative ((<|>), optional)
import Control.Exception (Exception, displayException, try)
import Control.Monad (when, unless, (<=<))
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.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)
import Data.Proxy
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 hiding (Proxy, proxy)
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

proxy :: a -> Proxy a
proxy _ = Proxy

as2context :: Text
as2context = "https://www.w3.org/ns/activitystreams"

secContext :: Text
secContext = "https://w3id.org/security/v1"

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 | 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 Owner = OwnerInstance | OwnerActor LocalURI

ownerShared :: Owner -> Bool
ownerShared OwnerInstance  = True
ownerShared (OwnerActor _) = False

data PublicKey = PublicKey
    { publicKeyId      :: LocalURI
    , publicKeyExpires :: Maybe UTCTime
    , publicKeyOwner   :: Owner
    , publicKeyPem     :: PEM
    , 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")
                <*> (parsePEM =<< 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
        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"
    toSeries host (PublicKey id_ mexpires owner pem malgo)
        =  "@id"                .=  l2f host id_
        <> "expires"            .=? mexpires
        <> "owner"              .=  mkOwner host owner
        <> "publicKeyPem"       .=  decodeUtf8 (pemWriteBS pem)
        <> (frg <> "algorithm") .=? malgo
        <> (frg <> "isShared")  .=  ownerShared owner
        where
        mkOwner h OwnerInstance   = FedURI h "" ""
        mkOwner h (OwnerActor lu) = l2f h lu

data PublicKeySet = PublicKeySet
    { publicKey1 :: Either LocalURI PublicKey
    , publicKey2 :: Maybe (Either LocalURI PublicKey)
    }

parsePublicKeySet :: Value -> Parser (Text, PublicKeySet)
parsePublicKeySet v =
    case v of
        Array a ->
            case V.toList a of
                [] -> fail "No public keys"
                [k1] -> second (flip PublicKeySet Nothing) <$> parseKey k1
                [k1, k2] -> do
                    (h, e1) <- parseKey k1
                    e2 <- withHost h $ parseKey k2
                    return (h, PublicKeySet e1 $ Just e2)
                _ -> fail "More than 2 public keys isn't supported"
        _ -> second (flip PublicKeySet Nothing) <$> 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 -> PublicKeySet -> Encoding
encodePublicKeySet host (PublicKeySet k1 mk2) =
    case mk2 of
        Nothing -> renderKey k1
        Just k2 -> listEncoding renderKey [k1, k2]
    where
    renderKey (Left lu)  = toEncoding $ l2f host lu
    renderKey (Right pk) = pairs $ toSeries host pk

data Actor = Actor
    { actorId         :: LocalURI
    , actorType       :: ActorType
    , actorUsername   :: Text
    , actorInbox      :: LocalURI
    , actorPublicKeys :: PublicKeySet
    }

instance ActivityPub Actor where
    jsonldContext _ = ContextActor
    parseObject o = do
        (host, id_) <- f2l <$> o .: "id"
        fmap (host,) $
            Actor id_
                <$> o .: "type"
                <*> o .: "preferredUsername"
                <*> 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 username inbox pkeys)
        =  "id"                .=     l2f host id_
        <> "type"              .=     typ
        <> "preferredUsername" .=     username
        <> "inbox"             .=     l2f host inbox
        <> "publicKey"         `pair` encodePublicKeySet host pkeys
data Note = Note
    { noteId      :: FedURI
    , noteAttrib  :: FedURI
    , noteTo      :: FedURI
    , noteReplyTo :: Maybe FedURI
    , noteContent :: Text
    }

instance FromJSON Note where
    parseJSON = withObject "Note" $ \ o -> do
        typ <- o .: "type"
        unless (typ == ("Note" :: Text)) $ fail "type isn't Note"
        Note
            <$> o .:  "id"
            <*> o .:  "attributedTo"
            <*> o .:  "to"
            <*> o .:? "inReplyTo"
            <*> o .:  "content"

instance ToJSON Note where
    toJSON = error "toJSON Note"
    toEncoding (Note id_ attrib to mreply content) =
        pairs
            $  "type"         .=  ("Note" :: Text)
            <> "id"           .=  id_
            <> "attributedTo" .=  attrib
            <> "to"           .=  to
            <> "inReplyTo"    .=? mreply
            <> "content"      .=  content

data Create = Create
    { createId     :: FedURI
    , createTo     :: FedURI
    , createActor  :: FedURI
    , createObject :: Note
    }

instance FromJSON Create where
    parseJSON = withObject "Create" $ \ o -> do
        typ <- o .: "type"
        unless (typ == ("Create" :: Text)) $ fail "type isn't Create"
        Create
            <$> o .: "id"
            <*> o .: "to"
            <*> o .: "actor"
            <*> o .: "object"

instance ToJSON Create where
    toJSON = error "toJSON Create"
    toEncoding (Create id_ to actor obj) =
        pairs
            $  "@context" .= as2context
            <> "type"     .= ("Create" :: Text)
            <> "id"       .= id_
            <> "to"       .= to
            <> "actor"    .= actor
            <> "object"   .= obj

data Activity = CreateActivity Create

instance FromJSON Activity where
    parseJSON = withObject "Activity" $ \ o -> do
        ctx <- o .: "@context"
        if ctx == as2context
            then return ()
            else fail "@context isn't the AS2 context URI"
        typ <- o .: "type"
        let v = Object o
        case typ of
            "Create" -> CreateActivity <$> parseJSON v
            _        -> fail $ "Unrecognized activity type: " ++ T.unpack typ

instance ToJSON Activity where
    toJSON = error "toJSON Activity"
    toEncoding (CreateActivity c) = toEncoding c

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    :: 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 String m a
fetchAP m u = ExceptT $ bimap displayException responseBody <$> httpGetAP 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 String a)
fetchAPID m getId h lu = runExceptT $ do
    Doc h' v <- fetchAP m $ l2f h lu
    if h == h' && getId v == lu
        then return v
        else throwE "Object @id doesn't match the URI we fetched"

fetchAPIDOrH
    :: (MonadIO m, ActivityPub a, ActivityPub b)
    => Manager
    -> (a -> LocalURI)
    -> Text
    -> LocalURI
    -> ExceptT String m (Either a b)
fetchAPIDOrH m getId h lu = do
    e <- fetchAP m $ l2f h lu
    case e of
        Left' (Doc h' x) ->
            if h == h' && getId x == lu
                then return $ Left x
                else throwE "Object @id doesn't match the URI we fetched"
        Right' (Doc h' y) ->
            if h == h'
                then return $ Right y
                else throwE "Object @id URI's host doesn't match the URI we fetched"

-- | 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 PublicKeySet k1 mk2 = actorPublicKeys a
            match (Left uri) = uri == uk
            match (Right _)  = False
        in  match k1 || maybe False match mk2

fetchKey
    :: MonadIO m
    => Manager
    -> Bool
    -> Text
    -> Maybe LocalURI
    -> LocalURI
    -> m (Either String Fetched)
fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do
    obj <- fetchAPIDOrH manager publicKeyId host luKey
    (pem, mkFetched, malgo) <-
        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
                    ( publicKeyPem pkey
                    , \ k ->
                        Fetched
                            { fetchedPublicKey  = k
                            , fetchedKeyExpires = publicKeyExpires pkey
                            , fetchedActorId    = luActor
                            , fetchedActorInbox = inbox
                            , fetchedKeyShared  = oi
                            }
                    , publicKeyAlgo pkey
                    )
            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"
                let PublicKeySet k1 mk2 = actorPublicKeys actor
                    match (Left _)   = Nothing
                    match (Right pk) =
                        if publicKeyId pk == luKey
                            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 ->
                        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 -> do
                                if owner == actorId actor
                                    then return ()
                                    else throwE "Actor's publicKey's owner doesn't match the actor's ID"
                                return
                                    ( publicKeyPem pk
                                    , \ k ->
                                        Fetched
                                            { fetchedPublicKey  = k
                                            , fetchedKeyExpires = publicKeyExpires pk
                                            , fetchedActorId    = owner
                                            , fetchedActorInbox = actorInbox actor
                                            , fetchedKeyShared  = False
                                            }
                                    , publicKeyAlgo pk
                                    )
    ExceptT . pure $ do
        case malgo 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 pem of
            CryptoPassed k -> Right $ mkFetched k
            CryptoFailed _ -> Left "Parsing Ed25519 public key failed"