New datatype FedURI for @id URIs

Using a dedicated type allows to record in the type the guarantees that we
provide, such as scheme being HTTPS and authority being present. Allows to
replace ugly `fromJust` and such with direct field access.

config/models

@@ -40,7 +40,7 @@ Person
     UniquePersonEmail email
 
 VerifKey
-    ident    URI
+    ident    FedURI
     instance InstanceId
     expires  UTCTime Maybe
     public   PublicKey
@@ -49,7 +49,7 @@ VerifKey
     UniqueVerifKey ident
 
 RemoteSharer
-    ident    URI
+    ident    FedURI
     instance InstanceId
 
     UniqueRemoteSharer ident

migrations/2019_02_03_verifkey.model

@@ -1,5 +1,5 @@
 VerifKey
-    ident    String
+    ident    Text
     instance InstanceId
     expires  UTCTime Maybe
     public   ByteString
@@ -8,7 +8,7 @@ VerifKey
     UniqueVerifKey ident
 
 RemoteSharer
-    ident    String
+    ident    Text
     instance InstanceId
 
     UniqueRemoteSharer ident

src/Data/Aeson/Local.hs

@@ -18,9 +18,6 @@ module Data.Aeson.Local
     , toEither
     , fromEither
     , frg
-    , parseHttpsURI'
-    , parseHttpsURI
-    , renderURI
     , (.=?)
     )
 where
@@ -56,26 +53,6 @@ fromEither (Right y) = Right' y
 frg :: Text
 frg = "https://forgefed.angeley.es/ns#"
 
-parseHttpsURI' :: Text -> Either String URI
-parseHttpsURI' t =
-    case parseURI $ T.unpack t of
-        Nothing -> Left "Invalid absolute URI"
-        Just u ->
-            if uriScheme u == "https:"
-                then case uriAuthority u of
-                        Just a ->
-                            if uriUserInfo a == "" && uriPort a == ""
-                                then Right u
-                                else Left "URI has userinfo or port"
-                        Nothing -> Left "URI has empty authority"
-                else Left "URI scheme isn't https"
-
-parseHttpsURI :: Text -> Parser URI
-parseHttpsURI = either fail return . parseHttpsURI'
-
-renderURI :: URI -> String
-renderURI u = uriToString id u ""
-
 infixr 8 .=?
 (.=?) :: ToJSON v => Text -> Maybe v -> Series
 _ .=? Nothing  = mempty

src/Database/Persist/Class/Local.hs

@@ -34,24 +34,10 @@ import Network.URI (URI, uriScheme, parseURI)
 import qualified Data.CaseInsensitive as CI
 import qualified Data.Text as T (pack)
 
-import Data.Aeson.Local (renderURI)
-
 instance (PersistField s, CI.FoldCase s) => PersistField (CI s) where
     toPersistValue = toPersistValue . CI.original
     fromPersistValue = fmap CI.mk . fromPersistValue
 
-instance PersistField URI where
-    toPersistValue = toPersistValue . renderURI
-    fromPersistValue = parseHttpsURI <=< fromPersistValue
-        where
-        parseHttpsURI s =
-            case parseURI s of
-                Nothing -> Left "Invalid absolute URI"
-                Just u ->
-                    if uriScheme u == "https:"
-                        then Right u
-                        else Left "URI scheme isn't https"
-
 instance PersistField PublicKey where
     toPersistValue = toPersistValue . convert'
         where

src/Database/Persist/Sql/Local.hs

@@ -25,19 +25,14 @@ import Data.ByteArray (convert)
 import Data.ByteString (ByteString)
 import Data.CaseInsensitive (CI)
 import Database.Persist.Sql
-import Network.URI (URI)
 
 import qualified Data.CaseInsensitive as CI
 
-import Data.Aeson.Local (renderURI)
 import Database.Persist.Class.Local ()
 
 instance (PersistFieldSql s, CI.FoldCase s) => PersistFieldSql (CI s) where
     sqlType = sqlType . fmap CI.original
 
-instance PersistFieldSql URI where
-    sqlType = sqlType . fmap renderURI
-
 instance PersistFieldSql PublicKey where
     sqlType = sqlType . fmap convert'
         where

src/Network/FedURI.hs

@@ -0,0 +1,101 @@
+{- This file is part of Vervis.
+ -
+ - Written 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 Network.FedURI
+    ( FedURI (..)
+    , parseFedURI
+    , toURI
+    , renderFedURI
+    )
+where
+
+import Prelude
+
+import Control.Monad ((<=<))
+import Data.Aeson
+import Data.Bifunctor (first)
+import Data.Text (Text)
+import Database.Persist.Class (PersistField (..))
+import Database.Persist.Sql (PersistFieldSql (..))
+import Network.URI
+
+import qualified Data.Text as T (pack, unpack)
+
+-- | An absolute URI with the following properties:
+--
+-- * The scheme is HTTPS
+-- * The authority part is present
+-- * The authority part doesn't have userinfo
+-- * The authority part doesn't have a port number
+-- * There is no query part
+-- * A fragment part may be present
+data FedURI = FedURI
+    { furiHost     :: Text
+    , furiPath     :: Text
+    , furiFragment :: Text
+    }
+    deriving Eq
+
+instance FromJSON FedURI where
+    parseJSON = withText "FedURI" $ either fail return . parseFedURI
+
+instance ToJSON FedURI where
+    toJSON = error "toJSON FedURI"
+    toEncoding = toEncoding . renderFedURI
+
+instance PersistField FedURI where
+    toPersistValue = toPersistValue . renderFedURI
+    fromPersistValue = first T.pack . parseFedURI <=< fromPersistValue
+
+instance PersistFieldSql FedURI where
+    sqlType = sqlType . fmap renderFedURI
+
+parseFedURI :: Text -> Either String FedURI
+parseFedURI t = do
+    uri <- case parseURI $ T.unpack t of
+        Nothing -> Left "Invalid absolute URI"
+        Just u -> Right u
+    if uriScheme uri == "https:"
+        then Right ()
+        else Left "URI scheme isn't https"
+    URIAuth ui h p <- case uriAuthority uri of
+        Nothing -> Left "URI has empty authority"
+        Just a -> Right a
+    if ui == ""
+        then Right ()
+        else Left "URI has non-empty userinfo"
+    if p == ""
+        then Right ()
+        else Left "URI has non-empty port"
+    if uriQuery uri == ""
+        then Right ()
+        else Left "URI query is non-empty"
+    Right FedURI
+        { furiHost     = T.pack h
+        , furiPath     = T.pack p
+        , furiFragment = T.pack $ uriFragment uri
+        }
+
+toURI :: FedURI -> URI
+toURI (FedURI h p f) = URI
+    { uriScheme    = "https:"
+    , uriAuthority = Just $ URIAuth "" (T.unpack h) ""
+    , uriPath      = T.unpack p
+    , uriQuery     = ""
+    , uriFragment  = T.unpack f
+    }
+
+renderFedURI :: FedURI -> Text
+renderFedURI = T.pack . flip (uriToString id) "" . toURI

src/Vervis/Foundation.hs

@@ -57,9 +57,9 @@ import Yesod.Mail.Send
 
 import qualified Network.HTTP.Signature as S (Algorithm (..))
 
+import Network.FedURI
 import Web.ActivityPub
 
-import Data.Aeson.Local (parseHttpsURI')
 import Text.Email.Local
 import Text.Jasmine.Local (discardm)
 
@@ -562,8 +562,8 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
 -- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
 
 instance YesodHttpSig App where
-    data HttpSigVerResult App = HttpSigVerResult (Either String URI)
+    data HttpSigVerResult App = HttpSigVerResult (Either String FedURI)
-    httpSigVerHeaders = const [hRequestTarget, hHost, "ActivityPub-Actor"]
+    httpSigVerHeaders = const [hRequestTarget, hHost, hActivityPubActor]
     httpSigVerSeconds =
         fromIntegral . toSeconds . appHttpSigTimeLimit . appSettings
         where
@@ -576,20 +576,20 @@ instance YesodHttpSig App where
                 case algo of
                     S.AlgorithmEd25519 -> Right ()
                     S.AlgorithmOther _ -> Left "Unsupported algo in Sig header"
-        u <- ExceptT . pure $ case parseURI $ BC.unpack keyid of
+        u <- ExceptT . pure $ case parseFedURI =<< (first displayException . decodeUtf8') keyid of
-            Nothing  -> Left "keyId in Sig header isn't a valid absolute URI"
+            Left e -> Left $ "keyId in Sig header isn't a valid FedURI: " ++ e
-            Just uri -> Right uri
+            Right uri -> Right uri
         signature <- ExceptT . pure $ do
             case signature sig of
                 CryptoPassed s -> Right s
                 CryptoFailed e -> Left "Parsing Ed25519 signature failed"
         muActorHeader <- do
-            bs <- lookupHeaders "ActivityPub-Actor"
+            bs <- lookupHeaders hActivityPubActor
             case bs of
                 [] -> return Nothing
                 [b] -> fmap Just . ExceptT . pure $ do
                     t <- first displayException $ decodeUtf8' b
-                    parseHttpsURI' t
+                    parseFedURI t
                 _ -> throwE "Multiple ActivityPub-Actor headers"
         (mvkid, key, mexpires, uActor, host, shared) <- do
             ments <- lift $ runDB $ do
@@ -612,7 +612,7 @@ instance YesodHttpSig App where
                         , verifKeyPublic vk
                         , verifKeyExpires vk
                         , ua
-                        , T.pack $ uriRegName $ fromJust $ uriAuthority uKey
+                        , furiHost uKey
                         , s
                         )
                 Nothing -> do

src/Vervis/Handler/Inbox.hs

@@ -49,7 +49,6 @@ import Database.Persist (Entity (..))
 import Network.HTTP.Client (Manager, HttpException, requestFromURI)
 import Network.HTTP.Simple (httpJSONEither, getResponseBody, setRequestManager, addRequestHeader)
 import Network.HTTP.Types.Header (hDate, hHost)
-import Network.URI
 import Text.Blaze.Html (Html)
 import UnliftIO.Exception (try)
 import Yesod.Auth (requireAuth)
@@ -75,8 +74,7 @@ import Yesod.HttpSignature (verifyRequestSignature)
 
 import qualified Network.HTTP.Signature as S (Algorithm (..))
 
-import Data.Aeson.Local (parseHttpsURI')
+import Network.FedURI
-
 import Web.ActivityPub
 
 import Vervis.ActorKey
@@ -167,9 +165,9 @@ postInboxR = do
             case M.lookup "actor" o of
                 Nothing -> Left "Activity has no actor member"
                 Just v -> case v of
-                    String t -> case parseURI $ T.unpack t of
+                    String t -> case parseFedURI t of
-                        Nothing -> Left "Activity actor URI parsing failed"
+                        Left e -> Left $ "Activity actor URI parsing failed: " ++ e
-                        Just uri -> Right uri
+                        Right uri -> Right uri
                     _ -> Left "Activity actor isn't a JSON string"
         liftE $ if activityActor == uActor
             then Right ()
@@ -180,9 +178,9 @@ postInboxR = do
                 Object obj -> case M.lookup "actor" obj <|> M.lookup "attributedTo" obj of
                     Nothing -> Right ()
                     Just v' -> case v' of
-                        String t -> case parseURI $ T.unpack t of
+                        String t -> case parseFedURI t of
-                            Nothing -> Left "Activity actor URI parsing failed"
+                            Left e -> Left $ "Activity actor URI parsing failed: " ++ e
-                            Just uri ->
+                            Right uri ->
                                 if uri == uActor
                                     then Right ()
                                     else Left "Activity object's actor doesn't match activity's actor"
@@ -200,12 +198,7 @@ activityForm :: Form Activity
 activityForm = renderDivs $ areq jsonField "" $ Just defval
     where
     defval = Activity
-        { activityTo =
+        { activityTo = FedURI "forge.angeley.es" "/p/aviva" ""
-            URI "https:"
-                (Just $ URIAuth "" "forge.angeley.es" "")
-                "/p/aviva"
-                ""
-                ""
         , activityJSON = M.fromList
             [ "@context" .= ("https://www.w3.org/ns/activitystreams" :: Text)
             , "type"     .= ("Create" :: Text)
@@ -292,7 +285,7 @@ postOutboxR = do
                                         else (keyID2, akey2)
                                 sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
                             eres' <- httpPostAP manager (actorInbox actor) (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID (updateAct act)
-                            case eres of
+                            case eres' of
                                 Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e)
                                 Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result."
     defaultLayout $ activityWidget widget enctype
@@ -304,7 +297,7 @@ getActorKey choose route = do
         getsYesod appActorKeys
     renderUrl <- getUrlRender
     let route2uri r =
-            case parseHttpsURI' $ renderUrl r of
+            case parseFedURI $ renderUrl r of
                 Left e -> error e
                 Right u -> u
     selectRep $

src/Vervis/Handler/Person.hs

@@ -28,7 +28,6 @@ import Vervis.Import hiding ((==.))
 --import Prelude
 
 import Database.Esqueleto hiding (isNothing, count)
-import Network.URI (uriFragment, parseAbsoluteURI)
 import Vervis.Form.Person
 --import Model
 import Text.Blaze.Html (toHtml)
@@ -41,6 +40,7 @@ import Yesod.Auth.Unverified (requireUnverifiedAuth)
 
 import Text.Email.Local
 
+import Network.FedURI
 import Web.ActivityPub
 
 --import Vervis.ActivityStreams
@@ -137,9 +137,9 @@ getPersonR shr = do
         return p
     renderUrl <- getUrlRender
     let route2uri route =
-            case parseAbsoluteURI $ T.unpack $ renderUrl route of
+            case parseFedURI $ renderUrl route of
-                Nothing -> error "getRenderUrl produced invalid URI!!!"
+                Left e -> error $ "getRenderUrl produced invalid FedURI!!! " ++ e
-                Just u  -> u
+                Right u -> u
         me = route2uri $ PersonR shr
     selectRep $ do
         provideRep $ do

src/Vervis/Model.hs

@@ -23,12 +23,12 @@ import Yesod hiding (Header, parseTime)
 import Crypto.PubKey.Ed25519 (PublicKey)
 import Database.Persist.Quasi
 import Database.Persist.Sql (fromSqlKey)
-import Network.URI (URI)
 import Text.Email.Validate (EmailAddress)
 import Yesod.Auth.Account (PersistUserCredentials (..))
 
 import Database.Persist.EmailAddress
 import Database.Persist.Graph.Class
+import Network.FedURI (FedURI)
 
 import Vervis.Model.Group
 import Vervis.Model.Ident

src/Web/ActivityPub.hs

@@ -77,6 +77,8 @@ 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
 
 as2context :: Text
@@ -119,9 +121,9 @@ instance ToJSON Algorithm where
             AlgorithmOther t -> t
 
 data PublicKey = PublicKey
-    { publicKeyId      :: URI
+    { publicKeyId      :: FedURI
     , publicKeyExpires :: Maybe UTCTime
-    , publicKeyOwner   :: URI
+    , publicKeyOwner   :: FedURI
     , publicKeyPem     :: PEM
     , publicKeyAlgo    :: Maybe Algorithm
     , publicKeyShared  :: Bool
@@ -137,9 +139,9 @@ instance FromJSON PublicKey where
                     then return ()
                     else fail "PublicKey @type isn't Key"
         PublicKey
-            <$> (parseHttpsURI =<< o .: "id")
+            <$> o .: "id"
             <*> o .:? "expires"
-            <*> (parseHttpsURI =<< o .: "owner")
+            <*> o .: "owner"
             <*> (parsePEM =<< o .: "publicKeyPem")
             <*> o .:? (frg <> "algorithm")
             <*> o .:? (frg <> "shared") .!= False
@@ -157,16 +159,16 @@ instance ToJSON PublicKey where
     toJSON = error "toJSON PublicKey"
     toEncoding (PublicKey id_ mexpires owner pem malgo shared) =
         pairs
-            $  "id"                 .=  renderURI id_
+            $  "id"                 .=  id_
             <> "expires"            .=? mexpires
-            <> "owner"              .=  renderURI owner
+            <> "owner"              .=  owner
             <> "publicKeyPem"       .=  decodeUtf8 (pemWriteBS pem)
             <> (frg <> "algorithm") .=? malgo
             <> (frg <> "shared")    .=  shared
 
 data PublicKeySet = PublicKeySet
-    { publicKey1 :: Either URI PublicKey
+    { publicKey1 :: Either FedURI PublicKey
-    , publicKey2 :: Maybe (Either URI PublicKey)
+    , publicKey2 :: Maybe (Either FedURI PublicKey)
     }
 
 instance FromJSON PublicKeySet where
@@ -180,7 +182,7 @@ instance FromJSON PublicKeySet where
                     _ -> fail "More than 2 public keys isn't supported"
             _ -> PublicKeySet <$> parseKey v <*> pure Nothing
         where
-        parseKey = bitraverse parseHttpsURI pure . toEither <=< parseJSON
+        parseKey = fmap toEither . parseJSON
 
 instance ToJSON PublicKeySet where
     toJSON = error "toJSON PublicKeySet"
@@ -189,23 +191,23 @@ instance ToJSON PublicKeySet where
             Nothing -> toEncoding $ renderKey k1
             Just k2 -> toEncodingList [renderKey k1, renderKey k2]
         where
-        renderKey = fromEither . first renderURI
+        renderKey = fromEither
 
 data Actor = Actor
-    { actorId         :: URI
+    { actorId         :: FedURI
     , actorType       :: ActorType
     , actorUsername   :: Text
-    , actorInbox      :: URI
+    , actorInbox      :: FedURI
     , actorPublicKeys :: PublicKeySet
     }
 
 instance FromJSON Actor where
     parseJSON = withObject "Actor" $ \ o ->
         Actor
-            <$> (parseHttpsURI =<< o .: "id")
+            <$> o .: "id"
             <*> o .: "type"
             <*> o .: "preferredUsername"
-            <*> (parseHttpsURI =<< o .: "inbox")
+            <*> o .: "inbox"
             <*> o .: "publicKey"
 
 instance ToJSON Actor where
@@ -213,10 +215,10 @@ instance ToJSON Actor where
     toEncoding (Actor id_ typ username inbox pkeys) =
         pairs
             $  "@context"          .= actorContext
-            <> "id"                .= renderURI id_
+            <> "id"                .= id_
             <> "type"              .= typ
             <> "preferredUsername" .= username
-            <> "inbox"             .= renderURI inbox
+            <> "inbox"             .= inbox
             <> "publicKey"         .= pkeys
 
 -- | This may seem trivial, but it exists for a good reason: In the 'FromJSON'
@@ -229,7 +231,7 @@ instance ToJSON Actor where
 -- ByteString, but I guess it's okay for now, and it happens to guarantee the
 -- JSON we POST has no extra whitespace.
 data Activity = Activity
-    { activityTo   :: URI
+    { activityTo   :: FedURI
     , activityJSON :: Object
     }
 
@@ -269,7 +271,7 @@ instance FromJSON Activity where
         mto2 <- o .:? "to"
         to <- case mto <|> mto2 of
             Nothing -> fail "to not provided"
-            Just t  -> parseHttpsURI t
+            Just u  -> return u
         return $ Activity to o
 
 instance ToJSON Activity where
@@ -310,12 +312,11 @@ instance Exception APGetError
 httpGetAP
     :: (MonadIO m, FromJSON a)
     => Manager
-    -> URI
+    -> FedURI
     -> m (Either APGetError (Response a))
 httpGetAP manager uri =
-    if uriScheme uri /= "https:"
+    liftIO $
-        then return $ Left $ APGetErrorHTTP $ InvalidUrlException (show uri) "Scheme isn't https"
+        mkResult <$> try (httpAPEither manager =<< requestFromURI (toURI uri))
-        else liftIO $ mkResult <$> try (httpAPEither manager =<< requestFromURI uri)
     where
     lookup' x = map snd . filter ((== x) . fst)
     mkResult (Left e)  = Left $ APGetErrorHTTP e
@@ -340,29 +341,27 @@ httpGetAP manager uri =
 httpPostAP
     :: (MonadIO m, ToJSON a)
     => Manager
-    -> URI
+    -> FedURI
     -> NonEmpty HeaderName
     -> (ByteString -> (KeyId, Signature))
     -> Text
     -> a
     -> m (Either HttpException (Response ()))
 httpPostAP manager uri headers sign uActor value =
-    if uriScheme uri /= "https:"
+    liftIO $ try $ do
-        then return $ Left $ InvalidUrlException (show uri) "Scheme isn't https"
+        req <- requestFromURI $ toURI uri
-        else liftIO $ try $ do
+        let req' =
-            req <- requestFromURI uri
+                setRequestCheckStatus $
-            let req' =
+                consHeader hContentType typeActivityStreams2LD $
-                    setRequestCheckStatus $
+                consHeader hActivityPubActor (encodeUtf8 uActor) $
-                    consHeader hContentType typeActivityStreams2LD $
+                req { method      = "POST"
-                    consHeader hActivityPubActor (encodeUtf8 uActor) $
+                    , requestBody = RequestBodyLBS $ encode value
-                    req { method      = "POST"
+                    }
-                        , requestBody = RequestBodyLBS $ encode value
+            sign' b =
-                        }
+                let (k, s) = sign b
-                sign' b =
+                in  (Nothing, k, s)
-                    let (k, s) = sign b
+        req'' <- signRequest headers sign' Nothing req'
-                    in  (Nothing, k, s)
+        httpNoBody req'' manager
-            req'' <- signRequest headers sign' Nothing req'
-            httpNoBody req'' manager
     where
     consHeader n b r = r { requestHeaders = (n, b) : requestHeaders r }
 
@@ -372,7 +371,7 @@ data Fetched = Fetched
       -- ^ The Ed25519 public key corresponding to the URI we requested.
     , fetchedKeyExpires :: Maybe UTCTime
       -- ^ Optional expiration time declared for the key we received.
-    , fetchedActorId    :: URI
+    , fetchedActorId    :: FedURI
       -- ^ The @id URI of the actor for whom the key's signature applies.
     , fetchedHost       :: Text
       -- ^ The domain name of the instance from which we got the key.
@@ -389,25 +388,21 @@ fetchKey
     :: MonadIO m
     => Manager
     -> Bool
-    -> Maybe URI
+    -> Maybe FedURI
-    -> URI
+    -> FedURI
     -> m (Either String Fetched)
 fetchKey manager sigAlgo muActor uKey = runExceptT $ do
-    let fetch :: (MonadIO m, FromJSON a) => URI -> ExceptT String m a
+    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 { uriPath = "", uriQuery = "", uriFragment = "" }
+    let inztance = uKey { furiPath = "", furiFragment = "" }
-        authority =
-            case uriAuthority uKey of
-                Nothing -> error "BUG! We were supposed to verify URI authority is non-empty!"
-                Just a  -> a
     (actor, pkey, shared) <-
         case obj of
             Left' pkey -> do
                 if publicKeyId pkey == uKey
                     then return ()
                     else throwE "Public key's ID doesn't match the keyid URI"
-                if uriAuthority (publicKeyOwner pkey) == Just authority
+                if furiHost (publicKeyOwner pkey) == furiHost uKey
                     then return ()
                     else throwE "Actor and key on different domains, we reject"
                 uActor <-
@@ -424,7 +419,7 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do
                     then return (actor, pkey, publicKeyShared pkey)
                     else throwE "Actor publicKey has no URI matching pkey @id"
             Right' actor -> do
-                if actorId actor == uKey { uriFragment = "" }
+                if actorId actor == uKey { furiFragment = "" }
                     then return ()
                     else throwE "Actor ID doesn't match the keyid URI we fetched"
                 case muActor of
@@ -472,7 +467,7 @@ fetchKey manager sigAlgo muActor uKey = runExceptT $ do
                 { fetchedPublicKey  = k
                 , fetchedKeyExpires = publicKeyExpires pkey
                 , fetchedActorId    = actorId actor
-                , fetchedHost       = T.pack $ uriRegName authority
+                , fetchedHost       = furiHost uKey
                 , fetchedKeyShared  = shared
                 }
             CryptoFailed _ -> Left "Parsing Ed25519 public key failed"

vervis.cabal

@@ -75,6 +75,7 @@ library
                        Diagrams.IntransitiveDAG
                        Formatting.CaseInsensitive
                        Language.Haskell.TH.Quote.Local
+                       Network.FedURI
                        Network.HTTP.Client.Conduit.ActivityPub
                        Network.SSH.Local
                        Text.Blaze.Local