{- This file is part of Vervis. - - Written in 2019 by fr33domlover . - - ♡ 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 - . -} 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 , 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 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.Vector (Vector) import Network.HTTP.Client hiding (Proxy, proxy) import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither) import Network.HTTP.Client.Signature (signRequest) 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 Data.ByteString.Char8 as BC 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 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 Note = Note { noteId :: LocalURI --, noteAttrib :: LocalURI --, noteTo :: FedURI , noteReplyTo :: Maybe FedURI , noteContent :: Text } 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 .: "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 content) attrib = pairs $ "type" .= ("Note" :: Text) <> "id" .= l2f host id_ <> "attributedTo" .= l2f host attrib <> "inReplyTo" .=? mreply <> "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, luAttrib) <- withHost h $ parseNote =<< o .: "object" unless (luActor == luAttrib) $ 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` encodeNote host obj actor 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 Audience = Audience { audienceTo :: Vector FedURI , audienceBto :: Vector FedURI , audienceCc :: Vector FedURI , audienceBcc :: Vector FedURI , audienceGeneral :: Vector FedURI } newtype AdaptAudience = AdaptAudience { unAdapt :: FedURI } instance FromJSON AdaptAudience where parseJSON = 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" .!= V.empty <*> o .:? "bto" .!= V.empty <*> o .:? "cc" .!= V.empty <*> o .:? "bcc" .!= V.empty <*> o .:? "audience" .!= V.empty where obj .:& key = do vec <- obj .:? key .!= V.empty return $ unAdapt <$> vec encodeAudience :: Audience -> Series encodeAudience (Audience to bto cc bcc aud) = "to" .=% to <> "bto" .=% bto <> "cc" .=% cc <> "bcc" .=% bcc <> "audience" .=% aud where t .=% v = if V.null v then mempty else t .= v 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 -- | 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 -> (S.KeyId, S.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 :: 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 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 :: 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 -> ExceptT String m () -- ^ Action which checks whether the actor from HTTP actor header lists the -- key, potentually updating our local cache if needed. -> 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 listed 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" listed let (material, mexpires) = keyDetail pkey ExceptT . pure $ verifyAlgo malgo material return (material, mexpires)