From b53a7b4f48e7bc8d3b9e18e82dc40cbb8ab45aff Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Fri, 22 Feb 2019 08:30:43 +0000
Subject: [PATCH] Refactor actor key fetching code a bit

---
 src/Web/ActivityPub.hs | 86 ++++++++++++++++++++++--------------------
 1 file changed, 46 insertions(+), 40 deletions(-)

diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index 7a258c5..5c5dce2 100644
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@@ -581,48 +581,54 @@ fetchKey manager sigAlgo host mluActor luKey = runExceptT $ do
                     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
-                                    )
+                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 -> do
+                        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
-        case malgo of
-            Nothing ->
+        verifyAlgo sigAlgo malgo
+        mkFetched <$> parseKey pem
+    where
+    matchKeyObj luKey (PublicKeySet k1 mk2) =
+        let match' = match luKey
+        in  case match' k1 <|> (match' =<< mk2) of
+                Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID"
+                Just pk -> return pk
+        where
+        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 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"
+                    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 $ mkFetched k
+            CryptoPassed k -> Right k
             CryptoFailed _ -> Left "Parsing Ed25519 public key failed"