Add InstanceURI datatype

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

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