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

      -- * Activity
    , Note (..)
    , Accept (..)
    , Create (..)
    , Follow (..)
    , Reject (..)
    , Audience (..)
    , SpecificActivity (..)
    , Activity (..)

      -- * Utilities
    , publicURI
    , deliverTo
    , hActivityPubActor
    , provideAP
    , APGetError (..)
    , httpGetAP
    , APPostError (..)
    , hActivityPubForwarder
    , hForwardingSignature
    , hForwardedSignature
    , httpPostAP
    , httpPostAPBytes
    , Fetched (..)
    , fetchAPID
    , fetchAPID'
    , 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 Audience = Audience
    { audienceTo      :: [FedURI]
    , audienceBto     :: [FedURI]
    , audienceCc      :: [FedURI]
    , audienceBcc     :: [FedURI]
    , audienceGeneral :: [FedURI]
    }

deliverTo :: FedURI -> Audience
deliverTo to = Audience
    { audienceTo      = [to]
    , audienceBto     = []
    , audienceCc      = []
    , audienceBcc     = []
    , audienceGeneral = []
    }

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"
    where
    obj .:& key = do
        l <- obj .:? key .!= []
        return $ map unAdapt l

encodeAudience :: Audience -> Series
encodeAudience (Audience to bto cc bcc aud)
    =  "to"       .=% to
    <> "bto"      .=% bto
    <> "cc"       .=% cc
    <> "bcc"      .=% bcc
    <> "audience" .=% aud
    where
    t .=% v =
        if null v
            then mempty
            else t .= v

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"

withHostM 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
                <$> withHostM 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

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