From aefb2aaee7d982ba2e48fcc0cfc448f2c47e5405 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Wed, 20 Feb 2019 07:40:25 +0000
Subject: [PATCH] Add InstanceURI datatype

---
 src/Network/FedURI.hs  | 15 +++++++++++++++
 src/Web/ActivityPub.hs |  4 ++--
 2 files changed, 17 insertions(+), 2 deletions(-)

diff --git a/src/Network/FedURI.hs b/src/Network/FedURI.hs
index 53e4189..5c5a381 100644
--- a/src/Network/FedURI.hs
+++ b/src/Network/FedURI.hs
@@ -18,6 +18,10 @@ module Network.FedURI
     , parseFedURI
     , toURI
     , renderFedURI
+
+    , InstanceURI (..)
+    , i2f
+    , f2i
     )
 where
 
@@ -99,3 +103,14 @@ toURI (FedURI h p f) = URI
 
 renderFedURI :: FedURI -> Text
 renderFedURI = T.pack . flip (uriToString id) "" . toURI
+
+newtype InstanceURI = InstanceURI
+    { iuriHost :: Text
+    }
+    deriving Eq
+
+i2f :: InstanceURI -> FedURI
+i2f (InstanceURI h) = FedURI h "" ""
+
+f2i :: FedURI -> InstanceURI
+f2i = InstanceURI . furiHost
diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index 5d00a3c..1b0df66 100644
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@@ -435,7 +435,7 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do
     let fetch :: (MonadIO m, FromJSON a) => FedURI -> ExceptT String m a
         fetch u = ExceptT $ bimap displayException responseBody <$> httpGetAP manager u
     obj <- fetch uKey
-    let inztance = uKey { furiPath = "", furiFragment = "" }
+    let inztance = f2i uKey
     (actor, pkey) <-
         case obj of
             Left' pkey -> do
@@ -481,7 +481,7 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do
                             else return (actor, pk)
     ExceptT . pure $ do
         if publicKeyShared pkey
-            then if publicKeyOwner pkey == inztance
+            then if publicKeyOwner pkey == i2f inztance
                     then Right ()
                     else Left "Key is shared but its owner isn't the top-level instance URI"
             else if publicKeyOwner pkey == actorId actor