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

      -- * Utilities
    , hActivityPubActor
    , provideAP
    , APGetError (..)
    , httpGetAP
    , APPostError (..)
    , httpPostAP
    , Fetched (..)
    , 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.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 (..), 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 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, HttpSigGenError)
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

parsePublicKeySet :: Value -> Parser (Text, NonEmpty (Either LocalURI PublicKey))
parsePublicKeySet v =
    case v of
        Array a ->
            case nonEmpty $ V.toList a of
                Nothing -> fail "No public keys"
                Just (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 -> NonEmpty (Either LocalURI PublicKey) -> Encoding
encodePublicKeySet host (e :| es) =
    if null es
        then renderKey e
        else listEncoding renderKey $ e : es
    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 :: NonEmpty (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"
                <*> 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      :: LocalURI
    --, noteAttrib  :: LocalURI
    --, noteTo      :: FedURI
    , noteReplyTo :: Maybe FedURI
    , noteContent :: Text
    }

parseNote :: Value -> Parser (Text, (Note, LocalURI, FedURI))
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 .:  "content"
                 )
             <*> withHost h (f2l <$> o .:  "attributedTo")
             <*> o .: "to"
    where
    withHost h a = do
        (h', v) <- a
        if h == h'
            then return v
            else fail "URI host mismatch"

encodeNote :: Text -> Note -> LocalURI -> FedURI -> Encoding
encodeNote host (Note id_ mreply content) attrib to =
    pairs
        $  "type"         .=  ("Note" :: Text)
        <> "id"           .=  l2f host id_
        <> "attributedTo" .=  l2f host attrib
        <> "to"           .=  to
        <> "inReplyTo"    .=? mreply
        <> "content"      .=  content

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

parseCreate :: Object -> Parser (Text, Create)
parseCreate o = do
    typ <- o .: "type"
    unless (typ == ("Create" :: Text)) $ fail "type isn't Create"
    (h, id_) <- f2l <$> o .: "id"
    luActor <- withHost h $ f2l <$> o .: "actor"
    (note, luAttrib, uTo) <- withHost h $ parseNote =<< o .: "object"
    unless (luActor == luAttrib) $ fail "Create actor != Note attrib"
    uTo' <- o .: "to"
    unless (uTo == uTo') $ fail "Create to != Note to"
    return (h, Create id_ uTo luActor note)
    where
    withHost h a = do
        (h', v) <- a
        if h == h'
            then return v
            else fail "URI host mismatch"

encodeCreate :: Text -> Create -> Series
encodeCreate host (Create id_ to actor obj)
    =  "type"     .=     ("Create" :: Text)
    <> "id"       .=     l2f host id_
    <> "to"       .=     to
    <> "actor"    .=     l2f host actor
    <> "object"   `pair` encodeNote host obj actor to

data Activity = CreateActivity Create

instance ActivityPub Activity where
    jsonldContext _ = ContextAS2
    parseObject o = do
        typ <- o .: "type"
        case typ of
            "Create" -> second CreateActivity <$> parseCreate o
            _        -> fail $ "Unrecognized activity type: " ++ T.unpack typ
    toSeries host (CreateActivity c) = encodeCreate host 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"

data APPostError
    = APPostErrorSig HttpSigGenError
    | APPostErrorHTTP HttpException
    deriving Show

instance Exception APPostError

-- | 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 APPostError (Response ()))
httpPostAP manager uri headers sign uActor value = liftIO $ 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)
    ereq <- try $ signRequest headers sign' Nothing req'
    case ereq of
        Left sigErr -> return $ Left $ APPostErrorSig sigErr
        Right req'' -> first APPostErrorHTTP <$> try (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 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 sigAlgo Nothing =
    Left $
    if sigAlgo
        then "Algo mismatch, Ed25519 in Sig but none in actor"
        else "Algo not given in Sig nor actor"
verifyAlgo sigAlgo (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"

parseKey pem =
    case E.publicKey $ pemContent pem of
        CryptoPassed k -> Right k
        CryptoFailed _ -> Left "Parsing Ed25519 public key failed"

-- | Fetch a key we don't have cached locally.
fetchUnknownKey
    :: MonadIO m
    => Manager
    -- ^ Manager for making HTTP requests
    -> Bool
    -- ^ Whether the Ed25519 algorithm is specified explicitly 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 sigAlgo host mluActor luKey = 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"
                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
                    ( publicKeyPem pk
                    , \ k ->
                        Fetched
                            { fetchedPublicKey  = k
                            , fetchedKeyExpires = publicKeyExpires pk
                            , fetchedActorId    = owner
                            , fetchedActorInbox = actorInbox actor
                            , fetchedKeyShared  = False
                            }
                    , publicKeyAlgo pk
                    )
    ExceptT . pure $ do
        verifyAlgo sigAlgo malgo
        mkFetched <$> parseKey pem

keyDetail pk = (publicKeyPem pk, publicKeyExpires pk, publicKeyAlgo 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
    -> Bool
    -- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP
    -- signature header
    -> Text
    -- ^ Instance host
    -> LocalURI
    -- ^ Key owner actor ID URI
    -> LocalURI
    -- ^ Key URI
    -> ExceptT String m (E.PublicKey, Maybe UTCTime)
fetchKnownPersonalKey manager sigAlgo host luOwner luKey = do
    obj <- fetchAPIDOrH manager publicKeyId host luKey
    (pem, mexpires, malgo) <-
        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 $ do
        verifyAlgo sigAlgo malgo
        (, mexpires) <$> parseKey pem

-- | 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
    -> ExceptT String m ()
    -- ^ Action which checks whether the actor from HTTP actor header lists the
    -- key, potentually updating our local cache if needed.
    -> Bool
    -- ^ Whether the Ed25519 algorithm is specified explicitly in the HTTP
    -- signature header
    -> Text
    -- ^ Instance host
    -> LocalURI
    -- ^ Actor ID from HTTP actor header
    -> LocalURI
    -- ^ Key URI
    -> ExceptT String m (E.PublicKey, Maybe UTCTime)
fetchKnownSharedKey manager listed sigAlgo 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"
    listed
    let (pem, mexpires, malgo) = keyDetail pkey
    ExceptT . pure $ do
        verifyAlgo sigAlgo malgo
        (, mexpires) <$> parseKey pem