New Network.FedURI with separate URI modes for dev and for fediverse

FedURIs, until now, have been requiring HTTPS, and no port number, and DNS internet domain names. This works just fine on the forge fediverse, but it makes local dev builds much less useful. This patch introduces URI types that have a type tag specifying one of 2 modes: - `Dev`: Works with URIs like `http://localhost:3000/s/fr33` - `Fed`: Works with URIs like `https://dev.community/s/fr33` This should allow even to run multiple federating instances for development, without needing TLS or reverse proxies or editing the hosts files or anything like that.
2019-07-23 13:59:48 +00:00 · 2019-07-23 13:59:48 +00:00 · 8fc5c80dd6
commit 8fc5c80dd6
parent 84765e2b94
30 changed files with 1240 additions and 750 deletions
--- a/config/models
+++ b/config/models
@ -106,7 +106,7 @@ Forwarding
    UniqueForwarding recipient activity

 VerifKey
-    ident    LocalURI
+    ident    LocalRefURI
    instance InstanceId
    expires  UTCTime Maybe
    public   PublicVerifKey
@ -137,7 +137,7 @@ RemoteActor
    UniqueRemoteActor instance ident

 Instance
-    host Text
+    host Host

    UniqueInstance host

--- a/migrations/2019_05_24.model
+++ b/migrations/2019_05_24.model
@ -43,7 +43,7 @@ LocalMessage
    UniqueLocalMessage rest

 Instance
-    host Text
+    host Host

    UniqueInstance host

--- a/src/Data/Aeson/Local.hs
+++ b/src/Data/Aeson/Local.hs
@ -20,6 +20,7 @@ module Data.Aeson.Local
    , (.:|)
    , (.:|?)
    , (.:+)
+    , (.:+?)
    , (.=?)
    , (.=%)
    , (.=+)
@ -64,6 +65,11 @@ o .:|? t = optional $ o .:| t
 (.:+) :: (FromJSON a, FromJSON b) => Object -> Text -> Parser (Either a b)
 o .:+ t = Left <$> o .: t <|> Right <$> o .: t

+(.:+?)
+    :: (FromJSON a, FromJSON b)
+    => Object -> Text -> Parser (Maybe (Either a b))
+o .:+? t = optional $ o .:+ t
+
 infixr 8 .=?
 (.=?) :: ToJSON v => Text -> Maybe v -> Series
 _ .=? Nothing  = mempty
--- a/src/Network/FedURI.hs
+++ b/src/Network/FedURI.hs
@ -16,165 +16,325 @@
 {-# LANGUAGE DeriveGeneric #-}

 module Network.FedURI
-    ( FedURI (..)
-    , parseFedURI
-    , toURI
-    , renderFedURI
-
-    {-
-    , InstanceURI (..)
-    , i2f
-    , f2i
-    -}
-
+    ( Authority (..)
+    , renderAuthority
    , LocalURI (..)
-    , l2f
-    , f2l
-
-    , FedPageURI (..)
+    , topLocalURI
+    , LocalSubURI (..)
    , LocalPageURI (..)
-    , lp2fp
-    , fp2lp
+    , LocalRefURI (..)
+    , UriMode ()
+    , Fed ()
+    , Dev ()
+    , ObjURI (..)
+    , parseObjURI
+    , uriFromObjURI
+    , renderObjURI
+    , SubURI (..)
+    , uriFromSubURI
+    , PageURI (..)
+    , RefURI (..)
+    , parseRefURI
    )
 where

-import Control.Monad ((<=<))
+import Control.Monad
 import Data.Aeson
-import Data.Bifunctor (bimap, first)
+import Data.Bifunctor
 import Data.Char
 import Data.Hashable
-import Data.Maybe (fromJust)
+import Data.Maybe
 import Data.Text (Text)
 import Data.Text.Encoding
-import Database.Persist.Class (PersistField (..))
-import Database.Persist.Sql (PersistFieldSql (..))
+import Data.Word
+import Database.Persist.Class
+import Database.Persist.Sql
 import GHC.Generics (Generic)
-import Network.HTTP.Types.URI
-import Network.URI
 import Text.Read
+import Network.HTTP.Types.URI
+import Network.URI hiding (scheme, path, query, fragment)

 import qualified Data.Text as T

-- | 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 host needs to match certain rules
-- * 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
+data Scheme = Plain | Secure deriving Eq
+
+data Full
+
+data Authority t = Authority
+    { authorityHost :: Text
+    , authorityPort :: Maybe Word16
    }
-    deriving (Eq, Generic)
+    deriving (Eq, Ord, Generic)

-instance Hashable FedURI
+instance UriMode t => Hashable (Authority t)

-instance FromJSON FedURI where
-    parseJSON = withText "FedURI" $ either fail return . parseFedURI
+parseAuthority :: UriMode t => Text -> Either String (Authority t)
+parseAuthority t = do
+    FullObjURI s a l <- toFullObjURI =<< parseFullURI ("https://" <> t)
+    unless (s == Secure && l == topLocalURI) $
+        Left "parseAuthority: Unexpected FullObjURI"
+    let s' = case authorityPort a of
+                Nothing -> Secure
+                Just _ -> Plain
+    checkAuthority s' a

-instance ToJSON FedURI where
-    toJSON = error "toJSON FedURI"
-    toEncoding = toEncoding . renderFedURI
+renderAuthority :: Authority t -> Text
+renderAuthority (Authority h Nothing)  = h
+renderAuthority (Authority h (Just p)) = T.concat [h, ":", T.pack $ show p]

-instance PersistField FedURI where
-    toPersistValue = toPersistValue . renderFedURI
-    fromPersistValue = first T.pack . parseFedURI <=< fromPersistValue
+instance UriMode t => FromJSON (Authority t) where
+    parseJSON = withText "Authority" $ either fail return . parseAuthority

-instance PersistFieldSql FedURI where
-    sqlType = sqlType . fmap renderFedURI
+instance UriMode t => ToJSON (Authority t) where
+    toJSON = toJSON . renderAuthority
+    toEncoding = toEncoding . renderAuthority

-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 any (== '.') h
-        then Right ()
-        else Left "Host doesn't contain periods"
-    if any isAsciiLetter h
-        then Right ()
-        else Left "Host doesn't contain ASCII letters"
-    if uriQuery uri == ""
-        then Right ()
-        else Left "URI query is non-empty"
-    Right FedURI
-        { furiHost     = T.pack h
-        , furiPath     = T.pack $ uriPath uri
-        , furiFragment = T.pack $ uriFragment uri
+instance UriMode t => PersistField (Authority t) where
+    toPersistValue = toPersistValue . renderAuthority
+    fromPersistValue = first T.pack . parseAuthority <=< fromPersistValue
+
+instance UriMode t => PersistFieldSql (Authority t) where
+    sqlType = sqlType . fmap renderAuthority
+
+data FullURI = FullURI
+    { fullUriScheme    :: Scheme
+    , fullUriAuthority :: Authority Full
+    , fullUriPath      :: Text
+    , fullUriQuery     :: Text
+    , fullUriFragment  :: Text
+    }
+
+parseFullURI :: Text -> Either String FullURI
+parseFullURI t = do
+    uri <-
+        case parseURI $ T.unpack t of
+            Nothing -> Left "Invalid absolute URI"
+            Just u -> Right u
+    scheme <-
+        case uriScheme uri of
+            "http:" -> Right Plain
+            "https:" -> Right Secure
+            _ -> Left "URI scheme isn't http/s"
+    URIAuth userInfo host port <-
+        case uriAuthority uri of
+            Nothing -> Left "URI has empty authority"
+            Just a -> Right a
+    unless (userInfo == "") $
+        Left "URI has non-empty userinfo"
+    portNumber <-
+        case port of
+            [] -> Right Nothing
+            c:p ->
+                case (c, readMaybe p) of
+                    (':', Just n) ->
+                        if n == 80 || n == 443
+                            then Left "Unexpected port number"
+                            else Right $ Just n
+                    _ -> Left "Unexpected port number format"
+    when (any (== ':') host) $
+        Left "Host contains a colon"
+    unless (any isAsciiLetter host) $
+        Left "Host doesn't contain ASCII letters"
+    Right FullURI
+        { fullUriScheme    = scheme
+        , fullUriAuthority = Authority
+            { authorityHost = T.pack host
+            , authorityPort = portNumber
+            }
+        , fullUriPath      = T.pack $ uriPath uri
+        , fullUriQuery     = T.pack $ uriQuery uri
+        , fullUriFragment  = T.pack $ uriFragment uri
        }
    where
    isAsciiLetter c = isAsciiLower c || isAsciiUpper c

-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
+fromFullURI :: FullURI -> URI
+fromFullURI (FullURI scheme (Authority host mport) path query fragment) = URI
+    { uriScheme    =
+        case scheme of
+            Plain -> "http:"
+            Secure -> "https:"
+    , uriAuthority = Just URIAuth
+        { uriUserInfo = ""
+        , uriRegName  = T.unpack host
+        , uriPort     = maybe "" ((':' :) . show) mport
+        }
+    , uriPath      = T.unpack path
+    , uriQuery     = T.unpack query
+    , uriFragment  = T.unpack fragment
    }

-renderFedURI :: FedURI -> Text
-renderFedURI = T.pack . flip (uriToString id) "" . toURI
+renderFullURI :: FullURI -> Text
+renderFullURI = T.pack . flip (uriToString id) "" . fromFullURI

-- | A 'FedURI' with a page number specified as a query parameter
-data FedPageURI = FedPageURI
-    { fpuriResource :: FedURI
-    , fpuriParam    :: Text
-    , fpuriPage     :: Int
+instance FromJSON FullURI where
+    parseJSON = withText "FullURI" $ either fail return . parseFullURI
+
+instance ToJSON FullURI where
+    toJSON = error "toJSON FullURI"
+    toEncoding = toEncoding . renderFullURI
+
+instance PersistField FullURI where
+    toPersistValue = toPersistValue . renderFullURI
+    fromPersistValue = first T.pack . parseFullURI <=< fromPersistValue
+
+instance PersistFieldSql FullURI where
+    sqlType = sqlType . fmap renderFullURI
+
+data LocalURI = LocalURI
+    { localUriPath :: Text
    }
    deriving (Eq, Generic)

-instance Hashable FedPageURI
+instance Hashable LocalURI

-instance FromJSON FedPageURI where
-    parseJSON = withText "FedPageURI" $ either fail return . parseFedPageURI
+dummyAuthority :: Authority Fed
+dummyAuthority = Authority "h.h" Nothing

-instance ToJSON FedPageURI where
-    toJSON = error "toJSON FedPageURI"
-    toEncoding = toEncoding . renderFedPageURI
+dummyPrefix :: Text
+dummyPrefix = renderObjURI $ ObjURI dummyAuthority topLocalURI

-parseFedPageURI :: Text -> Either String FedPageURI
-parseFedPageURI 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 any (== '.') h
-        then Right ()
-        else Left "Host doesn't contain periods"
-    if any isAsciiLetter h
-        then Right ()
-        else Left "Host doesn't contain ASCII letters"
+instance PersistField LocalURI where
+    toPersistValue = toPersistValue . renderLocalURI
+        where
+        renderLocalURI
+            = fromJust
+            . T.stripPrefix dummyPrefix
+            . renderObjURI
+            . ObjURI dummyAuthority
+    fromPersistValue
+        =   bimap T.pack objUriLocal . parseObjURI' . (dummyPrefix <>)
+        <=< fromPersistValue
+        where
+        parseObjURI' :: Text -> Either String (ObjURI Fed)
+        parseObjURI' = parseObjURI
+
+instance PersistFieldSql LocalURI where
+    sqlType = sqlType . fmap localUriPath
+
+topLocalURI :: LocalURI
+topLocalURI = LocalURI ""
+
+data FullObjURI = FullObjURI
+    { _fullObjUriScheme    :: Scheme
+    , _fullObjUriAuthority :: Authority Full
+    , _fullObjUriLocal     :: LocalURI
+    }
+
+toFullObjURI :: FullURI -> Either String FullObjURI
+toFullObjURI (FullURI s a p q f) = do
+    unless (q == "") $
+        Left "URI query is non-empty"
+    unless (f == "") $
+        Left "URI fragment is non-empty"
+    Right $ FullObjURI s a $ LocalURI p
+
+fromFullObjURI :: FullObjURI -> FullURI
+fromFullObjURI (FullObjURI s a (LocalURI p)) = FullURI s a p "" ""
+
+instance FromJSON FullObjURI where
+    parseJSON = either fail return . toFullObjURI <=< parseJSON
+
+instance ToJSON FullObjURI where
+    toJSON = toJSON . fromFullObjURI
+    toEncoding = toEncoding . fromFullObjURI
+
+instance PersistField FullObjURI where
+    toPersistValue = toPersistValue . fromFullObjURI
+    fromPersistValue = first T.pack . toFullObjURI <=< fromPersistValue
+
+instance PersistFieldSql FullObjURI where
+    sqlType = sqlType . fmap fromFullObjURI
+
+data LocalSubURI = LocalSubURI
+    { localSubUriResource :: LocalURI
+    , localSubUriFragment :: Text
+    }
+    deriving (Eq, Generic)
+
+instance Hashable LocalSubURI
+
+instance PersistField LocalSubURI where
+    toPersistValue = toPersistValue . renderLocalSubURI
+        where
+        renderLocalSubURI
+            = fromJust
+            . T.stripPrefix dummyPrefix
+            . renderSubURI
+            . SubURI dummyAuthority
+            where
+            renderSubURI :: UriMode t => SubURI t -> Text
+            renderSubURI = renderFullURI . fromFullSubURI . fromSubURI
+    fromPersistValue
+        =   bimap T.pack subUriLocal . parseSubURI' . (dummyPrefix <>)
+        <=< fromPersistValue
+        where
+        parseSubURI' :: Text -> Either String (SubURI Fed)
+        parseSubURI' = parseSubURI
+            where
+            parseSubURI :: UriMode t => Text -> Either String (SubURI t)
+            parseSubURI = toSubURI <=< toFullSubURI <=< parseFullURI
+
+instance PersistFieldSql LocalSubURI where
+    sqlType = sqlType . fmap localSubUriResource
+
+data FullSubURI = FullSubURI
+    { _fullSubUriScheme    :: Scheme
+    , _fullSubUriAuthority :: Authority Full
+    , _fullSubUriLocal     :: LocalSubURI
+    }
+
+toFullSubURI :: FullURI -> Either String FullSubURI
+toFullSubURI (FullURI s a p q f) = do
+    unless (T.null q) $
+        Left "URI query is non-empty"
+    case T.uncons f of
+        Nothing -> Left "No URI fragment"
+        Just ('#', f') ->
+            when (T.null f') $
+                Left "URI fragment is empty"
+        _ -> Left "URI fragment unexpectedly doesn't start with a '#'"
+    when (T.null f) $
+        Left "URI fragment is empty"
+    Right $ FullSubURI s a $ LocalSubURI (LocalURI p) f
+
+fromFullSubURI :: FullSubURI -> FullURI
+fromFullSubURI (FullSubURI s a (LocalSubURI (LocalURI p) f)) =
+    FullURI s a p "" f
+
+instance FromJSON FullSubURI where
+    parseJSON = either fail return . toFullSubURI <=< parseJSON
+
+instance ToJSON FullSubURI where
+    toJSON = toJSON . fromFullSubURI
+    toEncoding = toEncoding . fromFullSubURI
+
+instance PersistField FullSubURI where
+    toPersistValue = toPersistValue . fromFullSubURI
+    fromPersistValue = first T.pack . toFullSubURI <=< fromPersistValue
+
+instance PersistFieldSql FullSubURI where
+    sqlType = sqlType . fmap fromFullSubURI
+
+data LocalPageURI = LocalPageURI
+    { localPageUriResource :: LocalURI
+    , localPageUriParam    :: Text
+    , localPageUriPage     :: Int
+    }
+    deriving (Eq, Generic)
+
+instance Hashable LocalPageURI
+
+data FullPageURI = FullPageURI
+    { _fullPageUriScheme    :: Scheme
+    , _fullPageUriAuthority :: Authority Full
+    , _fullPageUriLocal     :: LocalPageURI
+    }
+
+toFullPageURI :: FullURI -> Either String FullPageURI
+toFullPageURI (FullURI s a p q f) = do
    (param, mval) <-
-        case parseQueryText $ encodeUtf8 $ T.pack $ uriQuery uri of
+        case parseQueryText $ encodeUtf8 q of
            [] -> Left "URI query is empty"
            [qp] -> Right qp
            _ -> Left "URI has multiple query parameters"
@ -186,85 +346,240 @@ parseFedPageURI t = do
        case readMaybe $ T.unpack val of
            Nothing -> Left "URI query param value isn't an integer"
            Just n -> Right n
-    if page >= 1
-        then Right ()
-        else Left "URI page number isn't positive"
-    Right FedPageURI
-        { fpuriResource = FedURI
-            { furiHost     = T.pack h
-            , furiPath     = T.pack $ uriPath uri
-            , furiFragment = T.pack $ uriFragment uri
-            }
-        , fpuriParam = param
-        , fpuriPage  = page
-        }
+    unless (page >= 1) $
+        Left "URI page number isn't positive"
+    unless (f == "") $
+        Left "URI fragment is non-empty"
+    Right $ FullPageURI s a $ LocalPageURI (LocalURI p) param page
+
+fromFullPageURI :: FullPageURI -> FullURI
+fromFullPageURI (FullPageURI s a (LocalPageURI (LocalURI p) param page)) =
+    FullURI s a p q ""
    where
-    isAsciiLetter c = isAsciiLower c || isAsciiUpper c
+    q = T.concat ["?", param, "=", T.pack $ show page]

-toPageURI :: FedPageURI -> URI
-toPageURI (FedPageURI (FedURI h p f) qp qv) = URI
-    { uriScheme    = "https:"
-    , uriAuthority = Just $ URIAuth "" (T.unpack h) ""
-    , uriPath      = T.unpack p
-    , uriQuery     = "?" ++ T.unpack qp ++ "=" ++ show qv
-    , uriFragment  = T.unpack f
+instance FromJSON FullPageURI where
+    parseJSON = either fail return . toFullPageURI <=< parseJSON
+
+instance ToJSON FullPageURI where
+    toJSON = toJSON . fromFullPageURI
+    toEncoding = toEncoding . fromFullPageURI
+
+instance PersistField FullPageURI where
+    toPersistValue = toPersistValue . fromFullPageURI
+    fromPersistValue = first T.pack . toFullPageURI <=< fromPersistValue
+
+instance PersistFieldSql FullPageURI where
+    sqlType = sqlType . fmap fromFullPageURI
+
+newtype LocalRefURI = LocalRefURI (Either LocalURI LocalSubURI)
+    deriving (Eq, Generic)
+
+instance Hashable LocalRefURI
+
+instance PersistField LocalRefURI where
+    toPersistValue (LocalRefURI u) = either toPersistValue toPersistValue u
+    fromPersistValue v =
+        LocalRefURI <$>
+            aor (Left <$> fromPersistValue v) (Right <$> fromPersistValue v)
+        where
+        aor :: Either a b -> Either a b -> Either a b
+        aor (Left _)    y = y
+        aor a@(Right _) _ = a
+
+instance PersistFieldSql LocalRefURI where
+    sqlType = sqlType . fmap f
+        where
+        f (LocalRefURI u) = either id localSubUriResource u
+
+data FullRefURI = FullRefURI
+    { _fullRefUriScheme    :: Scheme
+    , _fullRefUriAuthority :: Authority Full
+    , _fullRefUriLocal     :: LocalRefURI
    }

-renderFedPageURI :: FedPageURI -> Text
-renderFedPageURI = T.pack . flip (uriToString id) "" . toPageURI
+toFullRefURI :: FullURI -> Either String FullRefURI
+toFullRefURI fu =
+    case toFullObjURI fu of
+        Left _ -> sub2ref <$> toFullSubURI fu
+        Right ou -> Right $ obj2ref ou
+    where
+    obj2ref (FullObjURI s a l) = FullRefURI s a $ LocalRefURI $ Left l
+    sub2ref (FullSubURI s a l) = FullRefURI s a $ LocalRefURI $ Right l

-{-
-newtype InstanceURI = InstanceURI
-    { iuriHost :: Text
+fromFullRefURI :: FullRefURI -> FullURI
+fromFullRefURI (FullRefURI s a (LocalRefURI e)) =
+    case e of
+        Left l -> fromFullObjURI $ FullObjURI s a l
+        Right l -> fromFullSubURI $ FullSubURI s a l
+
+instance FromJSON FullRefURI where
+    parseJSON = either fail return . toFullRefURI <=< parseJSON
+
+instance ToJSON FullRefURI where
+    toJSON = toJSON . fromFullRefURI
+    toEncoding = toEncoding . fromFullRefURI
+
+instance PersistField FullRefURI where
+    toPersistValue = toPersistValue . fromFullRefURI
+    fromPersistValue = first T.pack . toFullRefURI <=< fromPersistValue
+
+instance PersistFieldSql FullRefURI where
+    sqlType = sqlType . fmap fromFullRefURI
+
+class UriMode a where
+    checkAuthority  :: Scheme -> Authority Full -> Either String (Authority a)
+    authorityScheme :: Authority a -> Scheme
+
+toFull :: UriMode a => Authority a -> Authority Full
+toFull (Authority h mp) = Authority h mp
+
+data Fed
+
+instance UriMode Fed where
+    checkAuthority s (Authority h mp)
+        | s /= Secure      = Left "Scheme isn't HTTPS"
+        | isJust mp        = Left "Port number present"
+        | T.all (/= '.') h = Left "Host doesn't contain periods"
+        | otherwise        = Right $ Authority h mp
+    authorityScheme _ = Secure
+
+data Dev
+
+instance UriMode Dev where
+    checkAuthority s (Authority h mp)
+        | s /= Plain       = Left "Scheme isn't HTTP"
+        | isNothing mp     = Left "Port number missing"
+        | T.any (== '.') h = Left "Host contains periods"
+        | otherwise        = Right $ Authority h mp
+    authorityScheme _ = Plain
+
+data ObjURI t = ObjURI
+    { objUriAuthority :: Authority t
+    , objUriLocal     :: LocalURI
    }
-    deriving Eq
+    deriving (Eq, Generic)

-i2f :: InstanceURI -> FedURI
-i2f (InstanceURI h) = FedURI h "" ""
+instance UriMode t => Hashable (ObjURI t)

-f2i :: FedURI -> InstanceURI
-f2i = InstanceURI . furiHost
-}
+toObjURI :: UriMode t => FullObjURI -> Either String (ObjURI t)
+toObjURI (FullObjURI s a l) = flip ObjURI l <$> checkAuthority s a

-data LocalURI = LocalURI
-    { luriPath     :: Text
-    , luriFragment :: Text
+fromObjURI :: UriMode t => ObjURI t -> FullObjURI
+fromObjURI (ObjURI a l) = FullObjURI (authorityScheme a) (toFull a) l
+
+parseObjURI :: UriMode t => Text -> Either String (ObjURI t)
+parseObjURI = toObjURI <=< toFullObjURI <=< parseFullURI
+
+uriFromObjURI :: UriMode t => ObjURI t -> URI
+uriFromObjURI = fromFullURI . fromFullObjURI . fromObjURI
+
+renderObjURI :: UriMode t => ObjURI t -> Text
+renderObjURI = renderFullURI . fromFullObjURI . fromObjURI
+
+instance UriMode t => FromJSON (ObjURI t) where
+    parseJSON = either fail return . toObjURI <=< parseJSON
+
+instance UriMode t => ToJSON (ObjURI t) where
+    toJSON = toJSON . fromObjURI
+    toEncoding = toEncoding . fromObjURI
+
+instance UriMode t => PersistField (ObjURI t) where
+    toPersistValue = toPersistValue . fromObjURI
+    fromPersistValue = first T.pack . toObjURI <=< fromPersistValue
+
+instance UriMode t => PersistFieldSql (ObjURI t) where
+    sqlType = sqlType . fmap fromObjURI
+
+data SubURI t = SubURI
+    { subUriAuthority :: Authority t
+    , subUriLocal     :: LocalSubURI
    }
-    deriving Eq
+    deriving (Eq, Generic)

-dummyHost :: Text
-dummyHost = "h.h"
+instance UriMode t => Hashable (SubURI t)

-dummyPrefix :: Text
-dummyPrefix = "https://" <> dummyHost
+toSubURI :: UriMode t => FullSubURI -> Either String (SubURI t)
+toSubURI (FullSubURI s a l) = flip SubURI l <$> checkAuthority s a

-renderLocalURI :: LocalURI -> Text
-renderLocalURI = fromJust . T.stripPrefix dummyPrefix . renderFedURI . l2f dummyHost
+fromSubURI :: UriMode t => SubURI t -> FullSubURI
+fromSubURI (SubURI a l) = FullSubURI (authorityScheme a) (toFull a) l

-instance PersistField LocalURI where
-    toPersistValue = toPersistValue . renderLocalURI
-    fromPersistValue = bimap T.pack (snd . f2l) . parseFedURI . (dummyPrefix <>) <=< fromPersistValue
+uriFromSubURI :: UriMode t => SubURI t -> URI
+uriFromSubURI = fromFullURI . fromFullSubURI . fromSubURI

-instance PersistFieldSql LocalURI where
-    sqlType = sqlType . fmap renderLocalURI
+instance UriMode t => FromJSON (SubURI t) where
+    parseJSON = either fail return . toSubURI <=< parseJSON

-l2f :: Text -> LocalURI -> FedURI
-l2f h (LocalURI p f) = FedURI h p f
+instance UriMode t => ToJSON (SubURI t) where
+    toJSON = toJSON . fromSubURI
+    toEncoding = toEncoding . fromSubURI

-f2l :: FedURI -> (Text, LocalURI)
-f2l (FedURI h p f) = (h, LocalURI p f)
+instance UriMode t => PersistField (SubURI t) where
+    toPersistValue = toPersistValue . fromSubURI
+    fromPersistValue = first T.pack . toSubURI <=< fromPersistValue

-data LocalPageURI = LocalPageURI
-    { lpuriResource :: LocalURI
-    , lpuriParam    :: Text
-    , lpuriPage     :: Int
+instance UriMode t => PersistFieldSql (SubURI t) where
+    sqlType = sqlType . fmap fromSubURI
+
+data PageURI t = PageURI
+    { pageUriAuthority :: Authority t
+    , pageUriLocal     :: LocalPageURI
    }
-    deriving Eq
+    deriving (Eq, Generic)

-lp2fp :: Text -> LocalPageURI -> FedPageURI
-lp2fp h (LocalPageURI lu p n) = FedPageURI (l2f h lu) p n
+instance UriMode t => Hashable (PageURI t)

-fp2lp :: FedPageURI -> (Text, LocalPageURI)
-fp2lp (FedPageURI fu p n) =
-    let (h, lu) = f2l fu
-    in  (h, LocalPageURI lu p n)
+toPageURI :: UriMode t => FullPageURI -> Either String (PageURI t)
+toPageURI (FullPageURI s a l) = flip PageURI l <$> checkAuthority s a
+
+fromPageURI :: UriMode t => PageURI t -> FullPageURI
+fromPageURI (PageURI a l) = FullPageURI (authorityScheme a) (toFull a) l
+
+instance UriMode t => FromJSON (PageURI t) where
+    parseJSON = either fail return . toPageURI <=< parseJSON
+
+instance UriMode t => ToJSON (PageURI t) where
+    toJSON = toJSON . fromPageURI
+    toEncoding = toEncoding . fromPageURI
+
+instance UriMode t => PersistField (PageURI t) where
+    toPersistValue = toPersistValue . fromPageURI
+    fromPersistValue = first T.pack . toPageURI <=< fromPersistValue
+
+instance UriMode t => PersistFieldSql (PageURI t) where
+    sqlType = sqlType . fmap fromPageURI
+
+data RefURI t = RefURI
+    { refUriAuthority :: Authority t
+    , refUriLocal     :: LocalRefURI
+    }
+    deriving (Eq, Generic)
+
+instance UriMode t => Hashable (RefURI t)
+
+toRefURI :: UriMode t => FullRefURI -> Either String (RefURI t)
+toRefURI (FullRefURI s a l) = flip RefURI l <$> checkAuthority s a
+
+fromRefURI :: UriMode t => RefURI t -> FullRefURI
+fromRefURI (RefURI a l) = FullRefURI (authorityScheme a) (toFull a) l
+
+parseRefURI :: UriMode t => Text -> Either String (RefURI t)
+parseRefURI = toRefURI <=< toFullRefURI <=< parseFullURI
+
+uriFromRefURI :: UriMode t => RefURI t -> URI
+uriFromRefURI = fromFullURI . fromFullRefURI . fromRefURI
+
+instance UriMode t => FromJSON (RefURI t) where
+    parseJSON = either fail return . toRefURI <=< parseJSON
+
+instance UriMode t => ToJSON (RefURI t) where
+    toJSON = toJSON . fromRefURI
+    toEncoding = toEncoding . fromRefURI
+
+instance UriMode t => PersistField (RefURI t) where
+    toPersistValue = toPersistValue . fromRefURI
+    fromPersistValue = first T.pack . toRefURI <=< fromPersistValue
+
+instance UriMode t => PersistFieldSql (RefURI t) where
+    sqlType = sqlType . fmap fromRefURI
--- a/src/Vervis/API.hs
+++ b/src/Vervis/API.hs
@ -99,6 +99,7 @@ import Yesod.Persist.Local
 import Vervis.ActivityPub
 import Vervis.ActorKey
 import Vervis.API.Recipient
+import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
@ -145,7 +146,7 @@ parseComment luParent = do
 -- | Handle a Note submitted by a local user to their outbox. It can be either
 -- a comment on a local ticket, or a comment on some remote context. Return an
 -- error message if the Note is rejected, otherwise the new 'LocalMessageId'.
-createNoteC :: Text -> Note -> Handler (Either Text LocalMessageId)
+createNoteC :: Host -> Note URIMode -> Handler (Either Text LocalMessageId)
 createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source content) = runExceptT $ do
    verifyHostLocal host "Attributed to non-local actor"
    verifyNothingE mluNote "Note specifies an id"
@ -169,7 +170,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
                mmidParent <- for mparent $ \ parent ->
                    case parent of
                        Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
-                        Right (hParent, luParent) -> do
+                        Right (ObjURI hParent luParent) -> do
                            mrm <- lift $ runMaybeT $ do
                                iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                                MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
@ -183,7 +184,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
                return (did, Left <$> mmidParent, Just (sid, ticketFollowers t, ibidProject, fsidProject))
            Nothing -> do
                (rd, rdnew) <- lift $ do
-                    let (hContext, luContext) = f2l uContext
+                    let ObjURI hContext luContext = uContext
                    iid <- either entityKey id <$> insertBy' (Instance hContext)
                    mrd <- getValBy $ UniqueRemoteDiscussionIdent iid luContext
                    case mrd of
@ -203,12 +204,12 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
                        Left (shrParent, lmidParent) -> do
                            when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new"
                            Left <$> getLocalParentMessageId did shrParent lmidParent
-                        Right (hParent, luParent) -> do
+                        Right p@(ObjURI hParent luParent) -> do
                            mrm <- lift $ runMaybeT $ do
                                iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                                MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
                            case mrm of
-                                Nothing -> return $ Right $ l2f hParent luParent
+                                Nothing -> return $ Right p
                                Just rm -> Left <$> do
                                    let mid = remoteMessageRest rm
                                    m <- lift $ getJust mid
@ -222,15 +223,15 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
                    <p>
                      <a href=@{SharerR shrUser}>#{shr2text shrUser}
                      \ commented on a #
-                      <a href=#{renderFedURI uContext}>ticket</a>.
+                      <a href=#{renderObjURI uContext}>ticket</a>.
                |]
        (lmid, obiid, doc) <- lift $ insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary
        moreRemotes <- deliverLocal pid obiid localRecips mcollections
        unless (federation || null moreRemotes) $
            throwE "Federation disabled but remote collection members found"
-        remotesHttp <- lift $ deliverRemoteDB' (furiHost uContext) obiid remoteRecips moreRemotes
+        remotesHttp <- lift $ deliverRemoteDB' (objUriAuthority uContext) obiid remoteRecips moreRemotes
        return (lmid, obiid, doc, remotesHttp)
-    lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (furiHost uContext) obiid doc remotesHttp
+    lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (objUriAuthority uContext) obiid doc remotesHttp
    return lmid
    where
    nonEmptyE :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a)
@ -243,16 +244,16 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
        :: FedURI
        -> Maybe FedURI
        -> ExceptT Text Handler
-            ( Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))
+            ( Maybe (Either (ShrIdent, LocalMessageId) FedURI)
            , [ShrIdent]
            , Maybe (ShrIdent, PrjIdent, Int)
-            , [(Text, NonEmpty LocalURI)]
+            , [(Host, NonEmpty LocalURI)]
            )
    parseRecipsContextParent uContext muParent = do
        (localsSet, remotes) <- do
            mrecips <- parseAudience aud
            fromMaybeE mrecips "Note without recipients"
-        let (hContext, luContext) = f2l uContext
+        let ObjURI hContext luContext = uContext
        parent <- parseParent uContext muParent
        local <- hostIsLocal hContext
        if local
@ -264,17 +265,17 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
                shrs <- verifyOnlySharers localsSet
                return (parent, shrs, Nothing, remotes)
        where
-        parseParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)))
+        parseParent :: FedURI -> Maybe FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) FedURI))
        parseParent _        Nothing        = return Nothing
        parseParent uContext (Just uParent) =
            if uParent == uContext
                then return Nothing
                else Just <$> do
-                    let (hParent, luParent) = f2l uParent
+                    let ObjURI hParent luParent = uParent
                    parentLocal <- hostIsLocal hParent
                    if parentLocal
                        then Left <$> parseComment luParent
-                        else return $ Right (hParent, luParent)
+                        else return $ Right uParent

        parseContextTicket :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent, Int)
        parseContextTicket luContext = do
@ -326,7 +327,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
        -> Text
        -> Text
        -> Html
-        -> AppDB (LocalMessageId, OutboxItemId, Doc Activity)
+        -> AppDB (LocalMessageId, OutboxItemId, Doc Activity URIMode)
    insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary = do
        now <- liftIO getCurrentTime
        mid <- insert Message
@ -358,7 +359,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
                        }
                    }
                }
-            tempUri = LocalURI "" ""
+            tempUri = topLocalURI
        obiid <- insert OutboxItem
            { outboxItemOutbox    = obid
            , outboxItemActivity  =
@ -391,7 +392,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
        -> OutboxItemId
        -> [ShrIdent]
        -> Maybe (SharerId, FollowerSetId, InboxId, FollowerSetId)
-        -> ExceptT Text AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+        -> ExceptT Text AppDB [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
    deliverLocal pidAuthor obid recips mticket = do
        recipPids <- traverse getPersonId $ nub recips
        when (pidAuthor `elem` recipPids) $
@ -446,8 +447,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
 offerTicketC
    :: ShrIdent
    -> TextHtml
-    -> Audience
-    -> Offer
+    -> Audience URIMode
+    -> Offer URIMode
    -> Handler (Either Text OutboxItemId)
 offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT $ do
    (hProject, shrProject, prjProject) <- parseTarget uTarget
@ -631,7 +632,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
                            , activitySummary  = Just summary
                            , activityAudience = Audience recips [] [] [] [] []
                            , activitySpecific = AcceptActivity Accept
-                                { acceptObject = l2f hLocal luOffer
+                                { acceptObject = ObjURI hLocal luOffer
                                , acceptResult =
                                    encodeRouteLocal $ TicketR shrProject prjProject num
                                }
@ -678,11 +679,12 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
                insert_ $ Follow pidAuthor fsid False
            publishAccept pidAuthor sid jid fsid luOffer num obiid doc = do
                now <- liftIO getCurrentTime
+                let dont = Authority "dont-do.any-forwarding" Nothing
                remotesHttp <- do
                    moreRemotes <- deliverLocal now sid fsid obiid
-                    deliverRemoteDB' "dont-do.any-forwarding" obiid [] moreRemotes
+                    deliverRemoteDB' dont obiid [] moreRemotes
                site <- askSite
-                liftIO $ runWorker (deliverRemoteHttp "dont-do.any-forwarding" obiid doc remotesHttp) site
+                liftIO $ runWorker (deliverRemoteHttp dont obiid doc remotesHttp) site
                where
                deliverLocal now sid fsid obiid = do
                    (pidsTeam, remotesTeam) <- getProjectTeam sid
@ -727,6 +729,6 @@ getFollowersCollection here getFsid = do
            , collectionLast       = Nothing
            , collectionItems      =
                map (encodeRouteHome . SharerR) locals ++
-                map (uncurry l2f . bimap E.unValue E.unValue) remotes
+                map (uncurry ObjURI . bimap E.unValue E.unValue) remotes
            }
    provideHtmlAndAP followersAP $ redirect (here, [("prettyjson", "true")])
--- a/src/Vervis/API/Recipient.hs
+++ b/src/Vervis/API/Recipient.hs
@ -47,6 +47,7 @@ import Yesod.MonadSite
 import Data.List.NonEmpty.Local

 import Vervis.ActivityPub
+import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model.Ident

@ -252,7 +253,7 @@ parseRecipients recips = do
    unless (null lusInvalid) $
        throwE $
            "Local recipients are invalid routes: " <>
-            T.pack (show $ map (renderFedURI . l2f hLocal) lusInvalid)
+            T.pack (show $ map (renderObjURI . ObjURI hLocal) lusInvalid)
    unless (null routesInvalid) $ do
        renderUrl <- askUrlRender
        throwE $
@ -260,10 +261,10 @@ parseRecipients recips = do
            T.pack (show $ map renderUrl routesInvalid)
    return (localsSet, remotes)
    where
-    splitRecipients :: Text -> NonEmpty FedURI -> ([LocalURI], [FedURI])
+    splitRecipients :: Host -> NonEmpty FedURI -> ([LocalURI], [FedURI])
    splitRecipients home recips =
-        let (local, remote) = NE.partition ((== home) . furiHost) recips
-        in  (map (snd . f2l) local, remote)
+        let (local, remote) = NE.partition ((== home) . objUriAuthority) recips
+        in  (map objUriLocal local, remote)

    parseLocalRecipients
        :: [LocalURI] -> ([LocalURI], [Route App], LocalRecipientSet)
@ -287,8 +288,8 @@ parseRecipients recips = do

 parseAudience
    :: (MonadSite m, SiteEnv m ~ App)
-    => Audience
-    -> ExceptT Text m (Maybe (LocalRecipientSet, [(Text, NonEmpty LocalURI)]))
+    => Audience URIMode
+    -> ExceptT Text m (Maybe (LocalRecipientSet, [(Host, NonEmpty LocalURI)]))
 parseAudience audience = do
    let recips = concatRecipients audience
    for (nonEmpty recips) $ \ recipsNE -> do
@ -296,5 +297,5 @@ parseAudience audience = do
        return
            (localsSet, groupByHost $ remotes \\ audienceNonActors audience)
    where
-    groupByHost :: [FedURI] -> [(Text, NonEmpty LocalURI)]
-    groupByHost = groupAllExtract furiHost (snd . f2l)
+    groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)]
+    groupByHost = groupAllExtract objUriAuthority objUriLocal
--- a/src/Vervis/ActivityPub.hs
+++ b/src/Vervis/ActivityPub.hs
@ -102,18 +102,19 @@ import Data.List.NonEmpty.Local
 import Data.Tuple.Local
 import Database.Persist.Local

+import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.RemoteActorStore
 import Vervis.Settings

-hostIsLocal :: (MonadSite m, SiteEnv m ~ App) => Text -> m Bool
+hostIsLocal :: (MonadSite m, SiteEnv m ~ App) => Host -> m Bool
 hostIsLocal h = asksSite $ (== h) . appInstanceHost . appSettings

 verifyHostLocal
    :: (MonadSite m, SiteEnv m ~ App)
-    => Text -> Text -> ExceptT Text m ()
+    => Host -> Text -> ExceptT Text m ()
 verifyHostLocal h t = do
    local <- hostIsLocal h
    unless local $ throwE t
@ -121,9 +122,9 @@ verifyHostLocal h t = do
 parseContext
    :: (MonadSite m, SiteEnv m ~ App)
    => FedURI
-    -> ExceptT Text m (Either (ShrIdent, PrjIdent, Int) (Text, LocalURI))
+    -> ExceptT Text m (Either (ShrIdent, PrjIdent, Int) FedURI)
 parseContext uContext = do
-    let c@(hContext, luContext) = f2l uContext
+    let ObjURI hContext luContext = uContext
    local <- hostIsLocal hContext
    if local
        then Left <$> do
@ -133,14 +134,14 @@ parseContext uContext = do
            case route of
                TicketR shr prj num -> return (shr, prj, num)
                _ -> throwE "Local context isn't a ticket route"
-        else return $ Right c
+        else return $ Right uContext

 parseParent
    :: (MonadSite m, SiteEnv m ~ App)
    => FedURI
-    -> ExceptT Text m (Either (ShrIdent, LocalMessageId) (Text, LocalURI))
+    -> ExceptT Text m (Either (ShrIdent, LocalMessageId) FedURI)
 parseParent uParent = do
-    let p@(hParent, luParent) = f2l uParent
+    let ObjURI hParent luParent = uParent
    local <- hostIsLocal hParent
    if local
        then Left <$> do
@ -154,7 +155,7 @@ parseParent uParent = do
                            "Local parent has non-existent message \
                            \hashid"
                _ -> throwE "Local parent isn't a message route"
-        else return $ Right p
+        else return $ Right uParent

 newtype FedError = FedError Text deriving Show

@ -183,7 +184,7 @@ getLocalParentMessageId did shr lmid = do
        throwE "Local parent belongs to a different discussion"
    return mid

-concatRecipients :: Audience -> [FedURI]
+concatRecipients :: Audience u -> [ObjURI u]
 concatRecipients (Audience to bto cc bcc gen _) = concat [to, bto, cc, bcc, gen]

 getPersonOrGroupId :: SharerId -> AppDB (Either PersonId GroupId)
@ -194,7 +195,7 @@ getPersonOrGroupId sid = do
        "Found sharer that is neither person nor group"
        "Found sharer that is both person and group"

-getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
+getTicketTeam :: SharerId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
 getTicketTeam sid = do
    id_ <- getPersonOrGroupId sid
    (,[]) <$> case id_ of
@ -205,7 +206,7 @@ getTicketTeam sid = do

 getProjectTeam = getTicketTeam

-getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
+getFollowers :: FollowerSetId -> AppDB ([PersonId], [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))])
 getFollowers fsid = do
    local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson]
    remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do
@ -230,15 +231,15 @@ getFollowers fsid = do
                remote
        )
    where
-    groupRemotes :: [(InstanceId, Text, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    groupRemotes :: [(InstanceId, Host, RemoteActorId, LocalURI, LocalURI, Maybe UTCTime)] -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
    groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
        where
        toTuples (iid, h, rsid, luA, luI, ms) = ((iid, h), (rsid, luA, luI, ms))

 unionRemotes
-    :: [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-    -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-    -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    :: [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
 unionRemotes = unionGroupsOrdWith fst fst4

 insertMany' mk xs = zip' xs <$> insertMany (NE.toList $ mk <$> xs)
@ -271,32 +272,32 @@ isInstanceErrorG (Just e) =

 deliverHttp
    :: (MonadSite m, SiteEnv m ~ App)
-    => Doc Activity
+    => Doc Activity URIMode
    -> Maybe LocalURI
-    -> Text
+    -> Host
    -> LocalURI
    -> m (Either APPostError (Response ()))
 deliverHttp doc mfwd h luInbox =
-    deliverActivity (l2f h luInbox) (l2f h <$> mfwd) doc
+    deliverActivity (ObjURI h luInbox) (ObjURI h <$> mfwd) doc

 deliverHttpBL
    :: (MonadSite m, SiteEnv m ~ App)
    => BL.ByteString
    -> Maybe LocalURI
-    -> Text
+    -> Host
    -> LocalURI
    -> m (Either APPostError (Response ()))
 deliverHttpBL body mfwd h luInbox =
-    deliverActivityBL' (l2f h luInbox) (l2f h <$> mfwd) body
+    deliverActivityBL' (ObjURI h luInbox) (ObjURI h <$> mfwd) body

 deliverRemoteDB
    :: BL.ByteString
    -> RemoteActivityId
    -> ProjectId
    -> ByteString
-    -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
    -> AppDB
-        [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
+        [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
 deliverRemoteDB body ractid jid sig recips = do
    let body' = BL.toStrict body
        deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
@ -316,12 +317,12 @@ deliverRemoteHTTP
    -> PrjIdent
    -> BL.ByteString
    -> ByteString
-    -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
+    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
    -> Handler ()
 deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do
    let deliver h inbox =
            let sender = ProjectR shrRecip prjRecip
-            in  forwardActivity (l2f h inbox) sig sender body
+            in  forwardActivity (ObjURI h inbox) sig sender body
    traverse_ (fork . deliverFetched deliver now) fetched
    where
    fork = forkHandler $ \ e -> logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
@ -386,7 +387,7 @@ checkForward shrRecip prjRecip = join <$> do
            Just h -> return h

 parseTarget u = do
-    let (h, lu) = f2l u
+    let ObjURI h lu = u
    (shr, prj) <- parseProject lu
    return (h, shr, prj)
    where
@ -437,14 +438,14 @@ data Recip
    | RecipRC (Entity RemoteCollection)

 deliverRemoteDB'
-    :: Text
+    :: Host
    -> OutboxItemId
-    -> [(Text, NonEmpty LocalURI)]
-    -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    -> [(Host, NonEmpty LocalURI)]
+    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
    -> AppDB
-        ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
-        , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
-        , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+        ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
+        , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+        , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
        )
 deliverRemoteDB' hContext obid recips known = do
    recips' <- for recips $ \ (h, lus) -> do
@ -503,12 +504,12 @@ deliverRemoteDB' hContext obid recips known = do
        noError ((_ , _  , _  , Just _ ), _  ) = Nothing

 deliverRemoteHttp
-    :: Text
+    :: Host
    -> OutboxItemId
-    -> Doc Activity
-    -> ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
-        , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
-        , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+    -> Doc Activity URIMode
+    -> ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
+        , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+        , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
        )
    -> Worker ()
 deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
@ -518,16 +519,17 @@ deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
            (isJust fwd',) <$> deliverHttp doc fwd' h inbox
    now <- liftIO getCurrentTime
    logDebug' $
-        "Launching fetched " <> T.pack (show $ map (snd . fst) fetched)
+        "Launching fetched " <> showHosts fetched
    traverse_ (fork . deliverFetched deliver now) fetched
    logDebug' $
-        "Launching unfetched " <> T.pack (show $ map (snd . fst) unfetched)
+        "Launching unfetched " <> showHosts unfetched
    traverse_ (fork . deliverUnfetched deliver now) unfetched
    logDebug' $
-        "Launching unknown " <> T.pack (show $ map (snd . fst) unknown)
+        "Launching unknown " <> showHosts unknown
    traverse_ (fork . deliverUnfetched deliver now) unknown
    logDebug' "Done (async delivery may still be running)"
    where
+    showHosts = T.pack . show . map (renderAuthority . snd . fst)
    logDebug' t = logDebug $ prefix <> t
        where
        prefix =
@ -545,7 +547,7 @@ deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
                Left err -> do
                    logError $ T.concat
                        [ "Outbox DL delivery #", T.pack $ show dlid
-                        , " error for <", renderFedURI $ l2f h luActor
+                        , " error for <", renderObjURI $ ObjURI h luActor
                        , ">: ",  T.pack $ displayException err
                        ]
                    return $
@ -573,14 +575,14 @@ deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
                                Left err -> do
                                    logError $ T.concat
                                        [ "Outbox DL delivery #", T.pack $ show dlid
-                                        , " error for <", renderFedURI $ l2f h luActor
+                                        , " error for <", renderObjURI $ ObjURI h luActor
                                        , ">: ",  T.pack $ displayException err
                                        ]
                                    updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
                                    update dlid [DeliveryRunning =. False]
                                Right _resp -> delete dlid
        where
-        logDebug'' t = logDebug' $ T.concat ["deliverFetched ", h, t]
+        logDebug'' t = logDebug' $ T.concat ["deliverFetched ", renderAuthority h, t]
    deliverUnfetched deliver now ((iid, h), recips@(r :| rs)) = do
        logDebug'' "Starting"
        let (uraid, luActor, udlid) = r
@ -634,4 +636,4 @@ deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
                                            insert_ $ Delivery raid obid fwd False
                                        Right _ -> delete udlid
        where
-        logDebug'' t = logDebug' $ T.concat ["deliverUnfetched ", h, t]
+        logDebug'' t = logDebug' $ T.concat ["deliverUnfetched ", renderAuthority h, t]
--- a/src/Vervis/Discussion.hs
+++ b/src/Vervis/Discussion.hs
@ -20,7 +20,6 @@ module Vervis.Discussion
    )
 where

-import Control.Arrow (second)
 import Data.Graph.Inductive.Graph (mkGraph, lab')
 import Data.Graph.Inductive.PatriciaTree (Gr)
 import Data.Graph.Inductive.Query.DFS (dffWith)
@ -35,12 +34,14 @@ import qualified Data.HashMap.Lazy as M (fromList, lookup)
 import Network.FedURI

 import Data.Tree.Local (sortForestOn)
+
+import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model

 data MessageTreeNodeAuthor
    = MessageTreeNodeLocal LocalMessageId Sharer
-    | MessageTreeNodeRemote Text LocalURI LocalURI (Maybe Text)
+    | MessageTreeNodeRemote Host LocalURI LocalURI (Maybe Text)

 data MessageTreeNode = MessageTreeNode
    { mtnMessageId :: MessageId
--- a/src/Vervis/FedURI.hs
+++ b/src/Vervis/FedURI.hs
@ -0,0 +1,38 @@
+{- 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/>.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Vervis.FedURI
+    ( URIMode
+    , Host
+    , FedURI
+    , FedSubURI
+    , FedPageURI
+    )
+where
+
+import Network.FedURI
+
+#if DEVELOPMENT
+type URIMode = Dev
+#else
+type URIMode = Fed
+#endif
+
+type Host       = Authority URIMode
+type FedURI     = ObjURI URIMode
+type FedSubURI  = SubURI URIMode
+type FedPageURI = PageURI URIMode
--- a/src/Vervis/Federation.hs
+++ b/src/Vervis/Federation.hs
@ -368,17 +368,17 @@ retryOutboxDelivery = do

    logDebug $
        "Periodic delivery forking linked " <>
-        T.pack (show $ map (snd . fst) dls)
+        T.pack (show $ map (renderAuthority . snd . fst) dls)
    waitsDL <- traverse (fork . deliverLinked deliver now) dls

    logDebug $
        "Periodic delivery forking forwarding " <>
-        T.pack (show $ map (snd . fst) fws)
+        T.pack (show $ map (renderAuthority . snd . fst) fws)
    waitsFW <- traverse (fork . deliverForwarding now) fws

    logDebug $
        "Periodic delivery forking unlinked " <>
-        T.pack (show $ map (snd . fst) udls)
+        T.pack (show $ map (renderAuthority . snd . fst) udls)
    waitsUDL <- traverse (fork . deliverUnlinked deliver now) udls

    logDebug $
@ -474,11 +474,11 @@ retryOutboxDelivery = do
                    return False
                Right success -> return success
    deliverLinked deliver now ((_, h), recips) = do
-        logDebug $ "Periodic deliver starting linked for host " <> h
+        logDebug $ "Periodic deliver starting linked for host " <> renderAuthority h
        waitsR <- for recips $ \ ((raid, (ident, inbox)), delivs) -> fork $ do
            logDebug $
                "Periodic deliver starting linked for actor " <>
-                renderFedURI (l2f h ident)
+                renderObjURI (ObjURI h ident)
            waitsD <- for delivs $ \ (dlid, fwd, doc) -> fork $ do
                let fwd' = if fwd then Just ident else Nothing
                e <- deliver doc fwd' h inbox
@ -486,7 +486,7 @@ retryOutboxDelivery = do
                    Left err -> do
                        logError $ T.concat
                            [ "Periodic DL delivery #", T.pack $ show dlid
-                            , " error for <", renderFedURI $ l2f h ident, ">: "
+                            , " error for <", renderObjURI $ ObjURI h ident, ">: "
                            ,  T.pack $ displayException err
                            ]
                        return False
@ -503,14 +503,14 @@ retryOutboxDelivery = do
            return True
        results <- sequence waitsR
        unless (and results) $
-            logError $ "Periodic DL delivery error for host " <> h
+            logError $ "Periodic DL delivery error for host " <> renderAuthority h
        return True
    deliverUnlinked deliver now ((iid, h), recips) = do
-        logDebug $ "Periodic deliver starting unlinked for host " <> h
+        logDebug $ "Periodic deliver starting unlinked for host " <> renderAuthority h
        waitsR <- for recips $ \ ((uraid, luRecip), delivs) -> fork $ do
            logDebug $
                "Periodic deliver starting unlinked for actor " <>
-                renderFedURI (l2f h luRecip)
+                renderObjURI (ObjURI h luRecip)
            e <- fetchRemoteActor iid h luRecip
            case e of
                Right (Right mera) ->
@ -540,16 +540,16 @@ retryOutboxDelivery = do
            return True
        results <- sequence waitsR
        unless (and results) $
-            logError $ "Periodic UDL delivery error for host " <> h
+            logError $ "Periodic UDL delivery error for host " <> renderAuthority h
        return True
    deliverForwarding now ((_, h), recips) = do
-        logDebug $ "Periodic deliver starting forwarding for host " <> h
+        logDebug $ "Periodic deliver starting forwarding for host " <> renderAuthority h
        waitsR <- for recips $ \ ((raid, inbox), delivs) -> fork $ do
            logDebug $
                "Periodic deliver starting forwarding for inbox " <>
-                renderFedURI (l2f h inbox)
+                renderObjURI (ObjURI h inbox)
            waitsD <- for delivs $ \ (fwid, body, sender, sig) -> fork $ do
-                e <- forwardActivity (l2f h inbox) sig sender body
+                e <- forwardActivity (ObjURI h inbox) sig sender body
                case e of
                    Left _err -> return False
                    Right _resp -> do
@ -565,5 +565,5 @@ retryOutboxDelivery = do
            return True
        results <- sequence waitsR
        unless (and results) $
-            logError $ "Periodic FW delivery error for host " <> h
+            logError $ "Periodic FW delivery error for host " <> renderAuthority h
        return True
--- a/src/Vervis/Federation/Auth.hs
+++ b/src/Vervis/Federation/Auth.hs
@ -94,6 +94,7 @@ import Yesod.Persist.Local

 import Vervis.ActivityPub
 import Vervis.ActorKey
+import Vervis.FedURI
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
@ -114,14 +115,22 @@ data ActivityAuthentication
 data ActivityBody = ActivityBody
    { actbBL         :: BL.ByteString
    , actbObject     :: Object
-    , actbActivity   :: Activity
+    , actbActivity   :: Activity URIMode
    }

 parseKeyId (KeyId k) =
-    case fmap f2l . parseFedURI =<< (first displayException . decodeUtf8') k of
+    case parseRefURI =<< (first displayException . decodeUtf8') k of
        Left e -> throwE $ "keyId isn't a valid FedURI: " ++ e
        Right u -> return u

+verifyActorSig'
+    :: Maybe Algorithm
+    -> ByteString
+    -> Signature
+    -> Host
+    -> LocalRefURI
+    -> Maybe LocalURI
+    -> ExceptT String Handler RemoteAuthor
 verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
    manager <- getsYesod appHttpManager
    (inboxOrVkid, vkd) <- do
@ -201,7 +210,7 @@ verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
                        else errSig2

    return RemoteAuthor
-        { remoteAuthorURI      = l2f host $ vkdActorId vkd
+        { remoteAuthorURI      = ObjURI host $ vkdActorId vkd
        , remoteAuthorInstance = iid
        , remoteAuthorId       = rsid
        -- , actdRawBody   = body
@ -225,7 +234,7 @@ verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do

 verifyActorSig :: Verification -> ExceptT String Handler RemoteAuthor
 verifyActorSig (Verification malgo keyid input signature) = do
-    (host, luKey) <- parseKeyId keyid
+    RefURI host luKey <- parseKeyId keyid
    checkHost host
    mluActorHeader <- getActorHeader host
    verifyActorSig' malgo input signature host luKey mluActorHeader
@ -240,15 +249,19 @@ verifyActorSig (Verification malgo keyid input signature) = do
            [] -> return Nothing
            [b] -> fmap Just . ExceptT . pure $ do
                t <- first displayException $ decodeUtf8' b
-                (h, lu) <- f2l <$> parseFedURI t
-                if h == host
-                    then Right ()
-                    else Left "Key and actor have different hosts"
+                ObjURI h lu <- parseObjURI t
+                unless (h == host) $
+                    Left "Key and actor have different hosts"
                Right lu
            _ -> throwE "Multiple ActivityPub-Actor headers"

-verifySelfSig :: LocalURI -> LocalURI -> ByteString -> Signature -> ExceptT String Handler (Either PersonId ProjectId)
-verifySelfSig luAuthor luKey input (Signature sig) = do
+verifySelfSig
+    :: LocalURI
+    -> LocalRefURI
+    -> ByteString
+    -> Signature
+    -> ExceptT String Handler (Either PersonId ProjectId)
+verifySelfSig luAuthor (LocalRefURI lruKey) input (Signature sig) = do
    author <- do
        route <-
            case decodeRouteLocal luAuthor of
@ -259,7 +272,11 @@ verifySelfSig luAuthor luKey input (Signature sig) = do
            ProjectR shr prj -> return $ Right (shr, prj)
            _ -> throwE "Local author ID isn't an actor route"
    akey <- do
-        route <-
+        route <- do
+            luKey <-
+                case lruKey of
+                    Left l -> return l
+                    Right _ -> throwE "Local key ID has a fragment"
            case decodeRouteLocal luKey of
                Nothing -> throwE "Local key ID isn't a valid route"
                Just r -> return r
@ -286,9 +303,13 @@ verifySelfSig luAuthor luKey input (Signature sig) = do
        sid <- MaybeT $ getKeyBy $ UniqueSharer shr
        MaybeT $ getKeyBy $ UniqueProject prj sid

-verifyForwardedSig :: Text -> LocalURI -> Verification -> ExceptT String Handler ActivityAuthentication
+verifyForwardedSig
+    :: Host
+    -> LocalURI
+    -> Verification
+    -> ExceptT String Handler ActivityAuthentication
 verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) = do
-    (hKey, luKey) <- parseKeyId keyid
+    RefURI hKey luKey <- parseKeyId keyid
    unless (hAuthor == hKey) $
        throwE "Author and forwarded sig key on different hosts"
    local <- hostIsLocal hKey
@ -326,25 +347,26 @@ authenticateActivity now = do
        return (remoteAuthor, wvdoc, body)
    let WithValue raw (Doc hActivity activity) = wv
        uSender = remoteAuthorURI ra
-        (hSender, luSender) = f2l uSender
+        ObjURI hSender luSender = uSender
    auth <-
        if hSender == hActivity
            then do
                unless (activityActor activity == luSender) $
                    throwE $ T.concat
                        [ "Activity's actor <"
-                        , renderFedURI $ l2f hActivity $ activityActor activity
-                        , "> != Signature key's actor <", renderFedURI uSender
+                        , renderObjURI $
+                            ObjURI hActivity $ activityActor activity
+                        , "> != Signature key's actor <", renderObjURI uSender
                        , ">"
                        ]
                return $ ActivityAuthRemote ra
            else do
-                -- TODO CONTINUE
                ma <- checkForward uSender hActivity (activityActor activity)
                case ma of
                    Nothing -> throwE $ T.concat
-                        [ "Activity host <", hActivity
-                        , "> doesn't match signature key host <", hSender, ">"
+                        [ "Activity host <", renderAuthority hActivity
+                        , "> doesn't match signature key host <"
+                        , renderAuthority hSender, ">"
                        ]
                    Just a -> return a
    return (auth, ActivityBody body raw activity)
@ -395,6 +417,6 @@ authenticateActivity now = do
                        [] -> throwE "ActivityPub-Forwarder header missing"
                        [x] -> return x
                        _ -> throwE "Multiple ActivityPub-Forwarder"
-                case parseFedURI =<< (first displayException . decodeUtf8') fwd of
+                case parseObjURI =<< (first displayException . decodeUtf8') fwd of
                    Left e -> throwE $ "ActivityPub-Forwarder isn't a valid FedURI: " <> T.pack e
                    Right u -> return u
--- a/src/Vervis/Federation/Discussion.hs
+++ b/src/Vervis/Federation/Discussion.hs
@ -92,6 +92,7 @@ import Yesod.Persist.Local

 import Vervis.ActivityPub
 --import Vervis.ActorKey
+import Vervis.FedURI
 import Vervis.Federation.Auth
 import Vervis.Foundation
 import Vervis.Model
@ -104,7 +105,7 @@ sharerCreateNoteF
    -> ShrIdent
    -> RemoteAuthor
    -> ActivityBody
-    -> Note
+    -> Note URIMode
    -> ExceptT Text Handler Text
 sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext mpublished _ _) = do
    luCreate <-
@ -143,7 +144,7 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
                    case parent of
                        Left (shrP, lmidP) ->
                            void $ getLocalParentMessageId did shrP lmidP
-                        Right (hParent, luParent) -> do
+                        Right (ObjURI hParent luParent) -> do
                            mrm <- lift $ runMaybeT $ do
                                iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                                MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
@ -152,7 +153,7 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
                                m <- lift $ getJust mid
                                unless (messageRoot m == did) $
                                    throwE "Remote parent belongs to a different discussion"
-            Right (hContext, luContext) -> do
+            Right (ObjURI hContext luContext) -> do
                mdid <- lift $ runMaybeT $ do
                    iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
                    rd <- MaybeT $ getValBy $ UniqueRemoteDiscussionIdent iid luContext
@ -162,7 +163,7 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
                        Left (shrP, lmidP) -> do
                            did <- fromMaybeE mdid "Local parent inexistent, no RemoteDiscussion"
                            void $ getLocalParentMessageId did shrP lmidP
-                        Right (hParent, luParent) -> do
+                        Right (ObjURI hParent luParent) -> do
                            mrm <- lift $ runMaybeT $ do
                                iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                                MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
@ -198,7 +199,7 @@ projectCreateNoteF
    -> PrjIdent
    -> RemoteAuthor
    -> ActivityBody
-    -> Note
+    -> Note URIMode
    -> ExceptT Text Handler Text
 projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent muCtx mpub src content) = do
    luCreate <-
@ -243,7 +244,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
    findRelevantCollections hLocal numCtx = nub . mapMaybe decide . concatRecipients
        where
        decide u = do
-            let (h, lu) = f2l u
+            let ObjURI h lu = u
            guard $ h == hLocal
            route <- decodeRouteLocal lu
            case route of
@ -269,7 +270,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
        meparent <- for mparent $ \ parent ->
            case parent of
                Left (shrParent, lmidParent) -> Left <$> getLocalParentMessageId did shrParent lmidParent
-                Right p@(hParent, luParent) -> do
+                Right p@(ObjURI hParent luParent) -> do
                    mrm <- lift $ runMaybeT $ do
                        iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
                        MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
@ -280,7 +281,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
                            unless (messageRoot m == did) $
                                throwE "Remote parent belongs to a different discussion"
                            return mid
-                        Nothing -> return $ Right $ l2f hParent luParent
+                        Nothing -> return $ Right p
        return (sid, fsidProject, ticketFollowers t, jid, ibid, did, meparent)
    insertToDiscussion luCreate luNote published ibid did meparent fsid = do
        let iidAuthor = remoteAuthorInstance author
@ -322,8 +323,8 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
                insert_ $ InboxItemRemote ibid ractid ibiid
                return $ Just (ractid, mid)
    updateOrphans luNote did mid = do
-        let hAuthor = furiHost $ remoteAuthorURI author
-            uNote = l2f hAuthor luNote
+        let hAuthor = objUriAuthority $ remoteAuthorURI author
+            uNote = ObjURI hAuthor luNote
        related <- selectOrphans uNote (E.==.)
        for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do
            logWarn $ T.concat
@ -357,7 +358,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
        -> SharerId
        -> FollowerSetId
        -> FollowerSetId
-        -> AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+        -> AppDB [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
    deliverLocal ractid recips sid fsidProject fsidTicket = do
        (teamPids, teamRemotes) <-
            if CreateNoteRecipTicketTeam `elem` recips
--- a/src/Vervis/Federation/Ticket.hs
+++ b/src/Vervis/Federation/Ticket.hs
@ -65,6 +65,7 @@ import Database.Persist.Local
 import Yesod.Persist.Local

 import Vervis.ActivityPub
+import Vervis.FedURI
 import Vervis.Federation.Auth
 import Vervis.Foundation
 import Vervis.Model
@ -72,7 +73,11 @@ import Vervis.Model.Ident
 import Vervis.Model.Ticket

 checkOffer
-    :: AP.Ticket -> Text -> ShrIdent -> PrjIdent -> ExceptT Text Handler ()
+    :: AP.Ticket URIMode
+    -> Host
+    -> ShrIdent
+    -> PrjIdent
+    -> ExceptT Text Handler ()
 checkOffer ticket hProject shrProject prjProject = do
    verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'"
    verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'"
@ -86,7 +91,7 @@ sharerOfferTicketF
    -> ShrIdent
    -> RemoteAuthor
    -> ActivityBody
-    -> Offer
+    -> Offer URIMode
    -> ExceptT Text Handler Text
 sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
    (hProject, shrProject, prjProject) <- parseTarget uTarget
@ -133,7 +138,7 @@ sharerAcceptOfferTicketF
    -> ShrIdent
    -> RemoteAuthor
    -> ActivityBody
-    -> Accept
+    -> Accept URIMode
    -> ExceptT Text Handler Text
 sharerAcceptOfferTicketF now shrRecip author body (Accept _uOffer _luTicket) = do
    luAccept <-
@ -164,7 +169,7 @@ sharerRejectOfferTicketF
    -> ShrIdent
    -> RemoteAuthor
    -> ActivityBody
-    -> Reject
+    -> Reject URIMode
    -> ExceptT Text Handler Text
 sharerRejectOfferTicketF now shrRecip author body (Reject _uOffer) = do
    luReject <-
@ -201,7 +206,7 @@ projectOfferTicketF
    -> PrjIdent
    -> RemoteAuthor
    -> ActivityBody
-    -> Offer
+    -> Offer URIMode
    -> ExceptT Text Handler Text
 projectOfferTicketF
    now shrRecip prjRecip author body (Offer ticket uTarget) = do
@ -210,7 +215,7 @@ projectOfferTicketF
            Left t -> do
                logWarn $ T.concat
                    [ recip, " got Offer Ticket with target "
-                    , renderFedURI uTarget
+                    , renderObjURI uTarget
                    ]
                return t
            Right () -> do
@ -245,7 +250,7 @@ projectOfferTicketF
    where
    recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
    checkTarget = do
-        let (h, lu) = f2l uTarget
+        let ObjURI h lu = uTarget
        local <- hostIsLocal h
        unless local $
            throwE $ recip <> " not using; target has different host"
@ -266,7 +271,7 @@ projectOfferTicketF
    findRelevantCollections hLocal = nub . mapMaybe decide . concatRecipients
        where
        decide u = do
-            let (h, lu) = f2l u
+            let ObjURI h lu = u
            guard $ h == hLocal
            route <- decodeRouteLocal lu
            case route of
@ -329,7 +334,7 @@ projectOfferTicketF
        -> [OfferTicketRecipColl]
        -> SharerId
        -> FollowerSetId
-        -> AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+        -> AppDB [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
    deliverLocal ractid recips sid fsid = do
        (teamPids, teamRemotes) <-
            if OfferTicketRecipProjectTeam `elem` recips
@ -363,7 +368,7 @@ projectOfferTicketF
                    withUrlRenderer
                        [hamlet|
                            <p>
-                              <a href="#{renderFedURI $ remoteAuthorURI author}">
+                              <a href="#{renderObjURI $ remoteAuthorURI author}">
                                (?)
                              's ticket accepted by project #
                              <a href=@{ProjectR shrRecip prjRecip}>
@ -389,7 +394,9 @@ projectOfferTicketF
                    , activityAudience = Audience recips [] [] [] [] []
                    , activitySpecific = AcceptActivity Accept
                        { acceptObject =
-                            l2f (furiHost $ remoteAuthorURI author) luOffer
+                            ObjURI
+                                (objUriAuthority $ remoteAuthorURI author)
+                                luOffer
                        , acceptResult =
                            encodeRouteLocal $ TicketR shrRecip prjRecip num
                        }
@ -408,6 +415,7 @@ projectOfferTicketF

    publishAccept luOffer num obiid doc = do
        now <- liftIO getCurrentTime
+        let dont = Authority "dont-do.any-forwarding" Nothing
        remotesHttp <- runDB $ do
            (sid, project) <- do
                sid <- fromJust <$> getKeyBy (UniqueSharer shrRecip)
@ -418,12 +426,12 @@ projectOfferTicketF
            ra <- getJust raidAuthor
            let raInfo = (raidAuthor, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra)
                iidAuthor = remoteAuthorInstance author
-                hAuthor = furiHost $ remoteAuthorURI author
+                hAuthor = objUriAuthority $ remoteAuthorURI author
                hostSection = ((iidAuthor, hAuthor), raInfo :| [])
                remotes = unionRemotes [hostSection] moreRemotes
-            deliverRemoteDB' "dont-do.any-forwarding" obiid [] remotes
+            deliverRemoteDB' dont obiid [] remotes
        site <- askSite
-        liftIO $ runWorker (deliverRemoteHttp "dont-do.any-forwarding" obiid doc remotesHttp) site
+        liftIO $ runWorker (deliverRemoteHttp dont obiid doc remotesHttp) site
        where
        deliverLocal now sid fsid obiid = do
            (pidsTeam, remotesTeam) <- getProjectTeam sid
--- a/src/Vervis/Foundation.hs
+++ b/src/Vervis/Foundation.hs
@ -82,6 +82,7 @@ import Network.FedURI
 import Web.ActivityAccess
 import Web.ActivityPub hiding (TicketDependency)
 import Yesod.ActivityPub
+import Yesod.FedURI
 import Yesod.Hashids
 import Yesod.MonadSite

@ -91,6 +92,7 @@ import Yesod.Paginate.Local

 import Vervis.Access
 import Vervis.ActorKey
+import Vervis.FedURI
 import Vervis.Model
 import Vervis.Model.Group
 import Vervis.Model.Ident
@ -160,11 +162,15 @@ type WorkerDB = PersistConfigBackend (SitePersistConfig App) Worker

 instance Site App where
    type SitePersistConfig App = PostgresConf
-    siteApproot       = ("https://" <>) . appInstanceHost . appSettings
+    siteApproot       =
+        renderObjURI . flip ObjURI topLocalURI . appInstanceHost . appSettings
    sitePersistConfig = appDatabaseConf . appSettings
    sitePersistPool   = appConnPool
    siteLogger        = appLogger

+instance SiteFedURI App where
+    type SiteFedURIMode App = URIMode
+
 -- Please see the documentation for the Yesod typeclass. There are a number
 -- of settings which can be configured by overriding methods here.
 instance Yesod App where
@ -204,11 +210,15 @@ instance Yesod App where
                defaultCsrfHeaderName
                defaultCsrfParamName
          )
-        . ( \ handler ->
+        . ( \ handler -> do
+                {-
                if developmentMode
                    then handler
                    else do
-                        host <- getsYesod $ appInstanceHost . appSettings
+                -}
+                        host <-
+                            getsYesod $
+                                renderAuthority . appInstanceHost . appSettings
                        bs <- lookupHeaders hHost
                        case bs of
                            [b] | b == encodeUtf8 host -> handler
--- a/src/Vervis/Handler/Discussion.hs
+++ b/src/Vervis/Handler/Discussion.hs
@ -55,8 +55,9 @@ import Yesod.Persist.Local

 import Vervis.API
 import Vervis.Discussion
-import Vervis.Form.Discussion
 import Vervis.Federation
+import Vervis.FedURI
+import Vervis.Form.Discussion
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
@ -134,7 +135,7 @@ getDiscussionMessage shr lmid = do
                    return $ route2fed $ TicketR shr prj $ ticketNumber t
                (Nothing, Just rd) -> do
                    i <- getJust $ remoteDiscussionInstance rd
-                    return $ l2f (instanceHost i) (remoteDiscussionIdent rd)
+                    return $ ObjURI (instanceHost i) (remoteDiscussionIdent rd)
        muParent <- for (messageParent m) $ \ midParent -> do
            mlocal <- getBy $ UniqueLocalMessage midParent
            mremote <- getValBy $ UniqueRemoteMessage midParent
@ -149,7 +150,7 @@ getDiscussionMessage shr lmid = do
                (Nothing, Just rmParent) -> do
                    rs <- getJust $ remoteMessageAuthor rmParent
                    i <- getJust $ remoteActorInstance rs
-                    return $ l2f (instanceHost i) (remoteActorIdent rs)
+                    return $ ObjURI (instanceHost i) (remoteActorIdent rs)
        --ob <- getJust $ localMessageCreate lm
        --let activity = docValue $ persistJSONValue $ outboxItemActivity ob

@ -183,7 +184,7 @@ getTopReply replyP = do
    defaultLayout $(widgetFile "discussion/top-reply")

 postTopReply
-    :: Text
+    :: Host
    -> [Route App]
    -> [Route App]
    -> Route App
@ -199,13 +200,13 @@ postTopReply hDest recipsA recipsC context replyP after = do
            FormSuccess nm -> return $ nmContent nm
        encodeRouteFed <- getEncodeRouteHome
        encodeRouteLocal <- getEncodeRouteLocal
-        let encodeRecipRoute = l2f hDest . encodeRouteLocal
+        let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
        shrAuthor <- do
            Entity _ p <- requireVerifiedAuth
            lift $ runDB $ sharerIdent <$> get404 (personIdent p)
        let msg' = T.filter (/= '\r') msg
        contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
-        let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
+        let ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
            uContext = encodeRecipRoute context
            recips = recipsA ++ recipsC
            note = Note
@ -247,7 +248,7 @@ getReply replyG replyP getdid midParent = do
    defaultLayout $(widgetFile "discussion/reply")

 postReply
-    :: Text
+    :: Host
    -> [Route App]
    -> [Route App]
    -> Route App
@ -266,7 +267,7 @@ postReply hDest recipsA recipsC context replyG replyP after getdid midParent = d
            FormSuccess nm -> return $ nmContent nm
        encodeRouteFed <- getEncodeRouteHome
        encodeRouteLocal <- getEncodeRouteLocal
-        let encodeRecipRoute = l2f hDest . encodeRouteLocal
+        let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
        (shrAuthor, uParent) <- do
            Entity _ p <- requireVerifiedAuth
            lift $ runDB $ do
@ -284,11 +285,11 @@ postReply hDest recipsA recipsC context replyG replyP after getdid midParent = d
                        return $ encodeRouteFed $ MessageR (sharerIdent s) lmkhid
                    (Nothing, Just rm) -> do
                        i <- getJust $ remoteMessageInstance rm
-                        return $ l2f (instanceHost i) (remoteMessageIdent rm)
+                        return $ ObjURI (instanceHost i) (remoteMessageIdent rm)
                return (shr, parent)
        let msg' = T.filter (/= '\r') msg
        contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
-        let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
+        let ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
            uContext = encodeRecipRoute context
            recips = recipsA ++ recipsC
            note = Note
--- a/src/Vervis/Handler/Inbox.hs
+++ b/src/Vervis/Handler/Inbox.hs
@ -118,6 +118,7 @@ import Yesod.Persist.Local
 import Vervis.ActivityPub
 import Vervis.ActorKey
 import Vervis.API
+import Vervis.FedURI
 import Vervis.Federation
 import Vervis.Federation.Auth
 import Vervis.Foundation
@ -337,20 +338,20 @@ fedUriField
    :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI
 fedUriField = Field
    { fieldParse = parseHelper $ \ t ->
-        case parseFedURI t of
+        case parseObjURI t of
            Left e  -> Left $ MsgInvalidUrl $ T.pack e <> ": " <> t
            Right u -> Right u
    , fieldView = \theId name attrs val isReq ->
-        [whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderFedURI val}>|]
+        [whamlet|<input ##{theId} name=#{name} *{attrs} type=url :isReq:required value=#{either id renderObjURI val}>|]
    , fieldEnctype = UrlEncoded
    }

 ticketField
-    :: (Route App -> LocalURI) -> Field Handler (Text, ShrIdent, PrjIdent, Int)
+    :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent, Int)
 ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
    where
    toTicket uTicket = runExceptT $ do
-        let (hTicket, luTicket) = f2l uTicket
+        let ObjURI hTicket luTicket = uTicket
        route <-
            case decodeRouteLocal luTicket of
                Nothing -> throwE ("Not a valid route" :: Text)
@ -359,14 +360,14 @@ ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
            TicketR shr prj num -> return (hTicket, shr, prj, num)
            _ -> throwE "Not a ticket route"
    fromTicket (h, shr, prj, num) =
-        l2f h $ encodeRouteLocal $ TicketR shr prj num
+        ObjURI h $ encodeRouteLocal $ TicketR shr prj num

 projectField
-    :: (Route App -> LocalURI) -> Field Handler (Text, ShrIdent, PrjIdent)
+    :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent)
 projectField encodeRouteLocal = checkMMap toProject fromProject fedUriField
    where
    toProject u = runExceptT $ do
-        let (h, lu) = f2l u
+        let ObjURI h lu = u
        route <-
            case decodeRouteLocal lu of
                Nothing -> throwE ("Not a valid route" :: Text)
@ -374,10 +375,10 @@ projectField encodeRouteLocal = checkMMap toProject fromProject fedUriField
        case route of
            ProjectR shr prj -> return (h, shr, prj)
            _ -> throwE "Not a project route"
-    fromProject (h, shr, prj) = l2f h $ encodeRouteLocal $ ProjectR shr prj
+    fromProject (h, shr, prj) = ObjURI h $ encodeRouteLocal $ ProjectR shr prj

 publishCommentForm
-    :: Form ((Text, ShrIdent, PrjIdent, Int), Maybe FedURI, Text)
+    :: Form ((Host, ShrIdent, PrjIdent, Int), Maybe FedURI, Text)
 publishCommentForm html = do
    enc <- getEncodeRouteLocal
    flip renderDivs html $ (,,)
@ -385,12 +386,12 @@ publishCommentForm html = do
        <*> aopt fedUriField       "Replying to" (Just $ Just defp)
        <*> areq textField         "Message"     (Just defmsg)
    where
-    deft = ("forge.angeley.es", text2shr "fr33", text2prj "sandbox", 1)
-    defp = FedURI "forge.angeley.es" "/s/fr33/m/2f1a7" ""
+    deft = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox", 1)
+    defp = ObjURI (Authority "forge.angeley.es" Nothing) $ LocalURI "/s/fr33/m/2f1a7"
    defmsg = "Hi! I'm testing federation. Can you see my message? :)"

 openTicketForm
-    :: Form ((Text, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown)
+    :: Form ((Host, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown)
 openTicketForm html = do
    enc <- getEncodeRouteLocal
    flip renderDivs html $ (,,)
@ -402,7 +403,7 @@ openTicketForm html = do
              areq textareaField    "Description" (Just defd)
            )
    where
-    defj = ("forge.angeley.es", text2shr "fr33", text2prj "sandbox")
+    defj = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox")
    deft = "Time slows down when tasting coconut ice-cream"
    defd = "Is that slow-motion effect intentional? :)"

@ -553,9 +554,9 @@ postSharerOutboxR shrAuthor = do
        encodeRouteLocal <- getEncodeRouteLocal
        let msg' = T.filter (/= '\r') msg
        contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
-        let encodeRecipRoute = l2f hTicket . encodeRouteLocal
+        let encodeRecipRoute = ObjURI hTicket . encodeRouteLocal
            uTicket = encodeRecipRoute $ TicketR shrTicket prj num
-            (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor
+            ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
            collections =
                [ ProjectFollowersR shrTicket prj
                , TicketParticipantsR shrTicket prj num
@ -597,8 +598,8 @@ postSharerOutboxR shrAuthor = do
                            <a href=@{ProjectR shr prj}>
                              ./s/#{shr2text shr}/p/#{prj2text prj}
                          $else
-                            <a href=#{renderFedURI $ encodeRouteFed h $ ProjectR shr prj}>
-                              #{h}/s/#{shr2text shr}/p/#{prj2text prj}
+                            <a href=#{renderObjURI $ encodeRouteFed h $ ProjectR shr prj}>
+                              #{renderAuthority h}/s/#{shr2text shr}/p/#{prj2text prj}
                          : #{preEscapedToHtml title}.
                    |]
        let recipsA = [ProjectR shr prj]
@ -656,7 +657,7 @@ getActorKey choose route = do
        getsYesod appActorKeys
    encodeRouteLocal <- getEncodeRouteLocal
    let key = PublicKey
-            { publicKeyId       = encodeRouteLocal route
+            { publicKeyId       = LocalRefURI $ Left $ encodeRouteLocal route
            , publicKeyExpires  = Nothing
            , publicKeyOwner    = OwnerInstance
            , publicKeyMaterial = actorKey
--- a/src/Vervis/Migration.hs
+++ b/src/Vervis/Migration.hs
@ -71,6 +71,7 @@ import Yesod.MonadSite
 import Data.Either.Local
 import Database.Persist.Local

+import Vervis.FedURI
 import Vervis.Model.Ident
 import Vervis.Foundation (App, Route (..))
 import Vervis.Migration.Model
@ -91,7 +92,7 @@ withPrepare (validate, apply) prepare = (validate, prepare >> apply)
 --withPrePost :: Monad m => Apply m -> Mig m -> Apply m -> Mig m
 --withPrePost pre (validate, apply) post = (validate, pre >> apply >> post)

-changes :: (MonadSite m, SiteEnv m ~ App) => Text -> HashidsContext -> [Mig m]
+changes :: (MonadSite m, SiteEnv m ~ App) => Host -> HashidsContext -> [Mig m]
 changes hLocal ctx =
    [ -- 1
      addEntities model_2016_08_04
@ -316,9 +317,10 @@ changes hLocal ctx =
                    Person201905
                        sid user "" "e@ma.il" False "" defaultTime ""
                        defaultTime ""
-            let localUri = LocalURI "/x/y" ""
-                fedUri = l2f "x.y" localUri
-                doc = Doc "x.y" Activity
+            let localUri = LocalURI "/x/y"
+                h = Authority "x.y" Nothing :: Host
+                fedUri = ObjURI h localUri
+                doc = Doc h Activity
                    { activityId       = Nothing
                    , activityActor    = localUri
                    , activitySummary  = Nothing
@ -339,10 +341,10 @@ changes hLocal ctx =
                                    Nothing -> error "Mig77: Note 'id' not found"
                                    Just (String s) -> s
                                    _ -> error "Mig77: Note 'id' not a string"
-                            fu = case parseFedURI t of
+                            fu = case parseObjURI t of
                                    Left _ -> error "Mig77: Note 'id' invalid FedURI"
                                    Right u -> u
-                            (h, lu) = f2l fu
+                            ObjURI h lu = fu
                        in  if h == hLocal
                                then lu
                                else error "Mig77: Note 'id' on foreign host"
@ -403,8 +405,8 @@ changes hLocal ctx =
                                                , "/t/", T.pack $ show $ ticket201905Number t
                                                ]
                                        return
-                                            ( FedURI hLocal tPath ""
-                                            , map (l2f hLocal . flip LocalURI "")
+                                            ( ObjURI hLocal $ LocalURI tPath
+                                            , map (ObjURI hLocal . LocalURI)
                                                [ jPath
                                                , tPath <> "/participants"
                                                , tPath <> "/team"
@ -414,7 +416,7 @@ changes hLocal ctx =
                                        i <- getJust $
                                            remoteDiscussion201905Instance rd
                                        return
-                                            ( l2f
+                                            ( ObjURI
                                                (instance201905Host i)
                                                (remoteDiscussion201905Ident rd)
                                            , []
@ -435,16 +437,17 @@ changes hLocal ctx =
                                            Left (Entity lmidP lmP) -> do
                                                p <- getJust $ localMessage201905Author lmP
                                                s <- getJust $ person201905Ident p
-                                                let path = T.concat
+                                                let path = LocalURI $ T.concat
                                                        [ "/s/", shr2text $ sharer201905Ident s
                                                        , "/m/", toPathPiece $ encodeKeyHashidPure ctx lmidP
                                                        ]
-                                                return $ FedURI hLocal path ""
+                                                return $ ObjURI hLocal path
                                            Right rmP -> do
                                                i <- getJust $
                                                    remoteMessage201905Instance rmP
                                                return $
-                                                    l2f (instance201905Host i)
+                                                    ObjURI
+                                                        (instance201905Host i)
                                                        (remoteMessage201905Ident rmP)

                            let msg = T.filter (/= '\r') $ message201905Content m
@ -455,7 +458,7 @@ changes hLocal ctx =

                            let aud = Audience recips [] [] [] [] []

-                                luAttrib = LocalURI ("/s/" <> shr2text shr) ""
+                                luAttrib = LocalURI $ "/s/" <> shr2text shr
                                activity luAct luNote = Doc hLocal Activity
                                    { activityId       = Just luAct
                                    , activityActor    = luAttrib
@ -474,7 +477,7 @@ changes hLocal ctx =
                                            }
                                        }
                                    }
-                                tempUri = LocalURI "" ""
+                                tempUri = topLocalURI
                            newObid <- insert OutboxItem201905
                                { outboxItem201905Person    = pid
                                , outboxItem201905Activity  = persistJSONObjectFromDoc $ activity tempUri tempUri
@ -488,8 +491,8 @@ changes hLocal ctx =
                                    [ "/s/", shr2text shr
                                    , "/outbox/", toPathPiece $ encodeKeyHashidPure ctx newObid
                                    ]
-                                luAct = LocalURI obPath ""
-                                luNote = LocalURI notePath ""
+                                luAct = LocalURI obPath
+                                luNote = LocalURI notePath
                                doc = activity luAct luNote
                            update newObid [OutboxItem201905Activity =. persistJSONObjectFromDoc doc]
                            return newObid
@ -706,9 +709,10 @@ changes hLocal ctx =
                    Person20190612
                        sid user "" "e@ma.il" False "" defaultTime ""
                        defaultTime "" ibid
-            let localUri = LocalURI "/x/y" ""
-                fedUri = l2f "x.y" localUri
-                doc = Doc "x.y" Activity
+            let localUri = LocalURI "/x/y"
+                h = Authority "x.y" Nothing :: Host
+                fedUri = ObjURI h localUri
+                doc = Doc h Activity
                    { activityId       = Nothing
                    , activityActor    = localUri
                    , activitySummary  = Nothing
@ -783,7 +787,7 @@ changes hLocal ctx =
                                encodeRouteHome $ ProjectR shrProject prj
                            }
                        }
-                    tempUri = LocalURI "" ""
+                    tempUri = topLocalURI
                obidNew <- insert OutboxItem20190612
                    { outboxItem20190612Person    = pidAuthor
                    , outboxItem20190612Activity  = persistJSONObjectFromDoc $ doc tempUri
@ -869,9 +873,10 @@ changes hLocal ctx =
    , addFieldRefRequired''
        "Ticket"
        (do obid <- insert Outbox20190624
-            let localUri = LocalURI "/x/y" ""
-                fedUri = l2f "x.y" localUri
-                doc = Doc "x.y" Activity
+            let localUri = LocalURI "/x/y"
+                h = Authority "x.y" Nothing :: Host
+                fedUri = ObjURI h localUri
+                doc = Doc h Activity
                    { activityId       = Nothing
                    , activityActor    = localUri
                    , activitySummary  = Nothing
@ -1007,7 +1012,7 @@ changes hLocal ctx =

 migrateDB
    :: (MonadSite m, SiteEnv m ~ App)
-    => Text -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))
+    => Host -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))
 migrateDB hLocal ctx =
    let f cs = fmap (, length cs) <$> runMigrations schemaBackend 1 cs
    in  f $ changes hLocal ctx
--- a/src/Vervis/Migration/Model.hs
+++ b/src/Vervis/Migration/Model.hs
@ -130,6 +130,7 @@ import Database.Persist.Schema.Types (Entity)
 import Database.Persist.Schema.SQL ()
 import Database.Persist.Sql (SqlBackend)

+import Vervis.FedURI
 import Vervis.Migration.TH (schema)
 import Vervis.Model (SharerId)
 import Vervis.Model.Group
@ -147,7 +148,7 @@ import Database.Persist.JSON
 import Network.FedURI
 import Web.ActivityPub

-type PersistActivity = PersistJSON (Doc Activity)
+type PersistActivity = PersistJSON (Doc Activity URIMode)

 model_2016_08_04 :: [Entity SqlBackend]
 model_2016_08_04 = $(schema "2016_08_04")
--- a/src/Vervis/Model.hs
+++ b/src/Vervis/Model.hs
@ -32,9 +32,10 @@ import Crypto.PublicVerifKey
 import Database.Persist.EmailAddress
 import Database.Persist.Graph.Class
 import Database.Persist.JSON
-import Network.FedURI (FedURI, LocalURI)
+import Network.FedURI
 import Web.ActivityPub (Doc, Activity)

+import Vervis.FedURI
 import Vervis.Model.Group
 import Vervis.Model.Ident
 import Vervis.Model.Repo
@ -43,7 +44,7 @@ import Vervis.Model.Ticket
 import Vervis.Model.TH
 import Vervis.Model.Workflow

-type PersistActivity = PersistJSON (Doc Activity)
+type PersistActivity = PersistJSON (Doc Activity URIMode)

 makeEntities $(modelFile "config/models")

--- a/src/Vervis/RemoteActorStore.hs
+++ b/src/Vervis/RemoteActorStore.hs
@ -64,9 +64,10 @@ import Network.FedURI
 import Web.ActivityPub
 import Yesod.MonadSite

+import Vervis.FedURI
 import Vervis.Model

-newtype InstanceMutex = InstanceMutex (TVar (HashMap Text (MVar ())))
+newtype InstanceMutex = InstanceMutex (TVar (HashMap Host (MVar ())))

 newInstanceMutex :: IO InstanceMutex
 newInstanceMutex = InstanceMutex <$> newTVarIO M.empty
@ -95,7 +96,7 @@ withHostLock
       , HandlerSite m ~ site
       , YesodRemoteActorStore site
       )
-    => Text
+    => Host
    -> m a
    -> m a
 withHostLock host action = do
@ -130,7 +131,7 @@ instanceAndActor
    :: ( PersistUniqueWrite (YesodPersistBackend site)
       , BaseBackend (YesodPersistBackend site) ~ SqlBackend
       )
-    => Text
+    => Host
    -> LocalURI
    -> Maybe Text
    -> LocalURI
@ -324,8 +325,8 @@ keyListedByActorShared
       )
    => InstanceId
    -> VerifKeyId
-    -> Text
-    -> LocalURI
+    -> Host
+    -> LocalRefURI
    -> LocalURI
    -> ExceptT String (HandlerFor site) RemoteActorId
 keyListedByActorShared iid vkid host luKey luActor = do
@ -376,7 +377,7 @@ keyListedByActorShared iid vkid host luKey luActor = do
                                return rsid

 data VerifKeyDetail = VerifKeyDetail
-    { vkdKeyId     :: LocalURI
+    { vkdKeyId     :: LocalRefURI
    , vkdKey       :: PublicVerifKey
    , vkdExpires   :: Maybe UTCTime
    , vkdActorId   :: LocalURI
@ -389,7 +390,7 @@ addVerifKey
       , PersistQueryRead (YesodPersistBackend site)
       , PersistUniqueWrite (YesodPersistBackend site)
       )
-    => Text
+    => Host
    -> Maybe Text
    -> LocalURI
    -> VerifKeyDetail
@ -467,7 +468,7 @@ actorFetchShareAction
    -> (site, InstanceId)
    -> IO (Either (Maybe APGetError) (Maybe (Entity RemoteActor)))
 actorFetchShareAction u (site, iid) = flip runWorkerT site $ do
-    let (h, lu) = f2l u
+    let ObjURI h lu = u
    mrecip <- runSiteDB $ runMaybeT
        $   Left <$> MaybeT (getBy $ UniqueRemoteActor iid lu)
        <|> Right <$> MaybeT (getBy $ UniqueRemoteCollection iid lu)
@ -508,7 +509,13 @@ fetchRemoteActor
       , PersistConfigPool (SitePersistConfig site) ~ ConnectionPool
       , PersistConfigBackend (SitePersistConfig site) ~ SqlPersistT
       )
-    => InstanceId -> Text -> LocalURI -> m (Either SomeException (Either (Maybe APGetError) (Maybe (Entity RemoteActor))))
+    => InstanceId
+    -> Host
+    -> LocalURI
+    -> m (Either
+            SomeException
+            (Either (Maybe APGetError) (Maybe (Entity RemoteActor)))
+         )
 fetchRemoteActor iid host luActor = do
    mrecip <- runSiteDB $ runMaybeT
        $   Left <$> MaybeT (getBy $ UniqueRemoteActor iid luActor)
@ -521,7 +528,7 @@ fetchRemoteActor iid host luActor = do
                    Right _ -> Nothing
        Nothing -> do
            site <- askSite
-            liftIO $ runShared (siteActorFetchShare site) (l2f host luActor) (site, iid)
+            liftIO $ runShared (siteActorFetchShare site) (ObjURI host luActor) (site, iid)

 deleteUnusedURAs = do
    uraids <- E.select $ E.from $ \ ura -> do
--- a/src/Vervis/Settings.hs
+++ b/src/Vervis/Settings.hs
@ -50,6 +50,10 @@ import qualified Data.Text as T

 import Yesod.Mail.Send (MailSettings)

+import Network.FedURI
+
+import Vervis.FedURI
+
 developmentMode :: Bool
 developmentMode =
 #if DEVELOPMENT
@ -88,7 +92,7 @@ data AppSettings = AppSettings
      -- which requests are remote and which are for this instance, and for
      -- generating URLs. The database relies on this value, and you shouldn't
      -- change it once you deploy an instance.
-    , appInstanceHost           :: Text
+    , appInstanceHost           :: Host
      -- | Host/interface the server should bind to.
    , appHost                   :: HostPreference
      -- | Port to listen on
@ -193,9 +197,15 @@ instance FromJSON AppSettings where
        appDatabaseConf           <- o .: "database"
        appMaxInstanceKeys        <- o .:? "max-instance-keys"
        appMaxActorKeys           <- o .:? "max-actor-keys"
-        appInstanceHost           <- o .: "instance-host"
+        port                      <- o .: "http-port"
+        appInstanceHost           <- do
+            h <- o .: "instance-host"
+            return $
+                if developmentMode
+                    then Authority h $ Just port
+                    else Authority h Nothing
        appHost                   <- fromString <$> o .: "host"
-        appPort                   <- o .: "http-port"
+        let appPort = fromIntegral port
        appIpFromHeader           <- o .: "ip-from-header"

        appClientSessionKeyFile   <- o .: "client-session-key"
--- a/src/Vervis/Widget/Discussion.hs
+++ b/src/Vervis/Widget/Discussion.hs
@ -48,7 +48,7 @@ import Vervis.Widget.Sharer
 actorLinkW :: MessageTreeNodeAuthor -> Widget
 actorLinkW actor = $(widgetFile "widget/actor-link")
    where
-    shortURI h (LocalURI p f) = h <> p <> f
+    shortURI h (LocalURI p) = renderAuthority h <> p

 messageW
    :: UTCTime -> MessageTreeNode -> (MessageId -> Route App) -> Widget
--- a/src/Vervis/Widget/Sharer.hs
+++ b/src/Vervis/Widget/Sharer.hs
@ -42,11 +42,11 @@ sharerLinkFedW :: Either Sharer (Instance, RemoteActor) -> Widget
 sharerLinkFedW (Left sharer)             = sharerLinkW sharer
 sharerLinkFedW (Right (inztance, actor)) =
    [whamlet|
-        <a href="#{renderFedURI uActor}">
+        <a href="#{renderObjURI uActor}">
          $maybe name <- remoteActorName actor
            #{name}
          $nothing
            (?)
    |]
    where
-    uActor = l2f (instanceHost inztance) (remoteActorIdent actor)
+    uActor = ObjURI (instanceHost inztance) (remoteActorIdent actor)
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
--- a/src/Yesod/ActivityPub.hs
+++ b/src/Yesod/ActivityPub.hs
@ -47,11 +47,12 @@ import Network.HTTP.Signature
 import Database.Persist.JSON
 import Network.FedURI
 import Web.ActivityPub
+import Yesod.FedURI
 import Yesod.MonadSite
 import Yesod.RenderSource

-class Yesod site => YesodActivityPub site where
-    siteInstanceHost          :: site -> Text
+class (Yesod site, SiteFedURI site) => YesodActivityPub site where
+    siteInstanceHost          :: site -> Authority (SiteFedURIMode site)
    sitePostSignedHeaders     :: site -> NonEmpty HeaderName
    siteGetHttpSign           :: (MonadSite m, SiteEnv m ~ site)
                              => m (KeyId, ByteString -> Signature)
@ -64,11 +65,12 @@ class Yesod site => YesodActivityPub site where
 deliverActivity'
    :: ( MonadSite m
       , SiteEnv m ~ site
+       , SiteFedURIMode site ~ u
       , HasHttpManager site
       , YesodActivityPub site
       )
-    => FedURI
-    -> Maybe FedURI
+    => ObjURI u
+    -> Maybe (ObjURI u)
    -> Text
    -> BL.ByteString
    -> m (Either APPostError (Response ()))
@ -82,12 +84,12 @@ deliverActivity' inbox mfwd sender body = do
    case result of
        Left err ->
            logError $ T.concat
-                [ "deliverActivity to inbox <", renderFedURI inbox
+                [ "deliverActivity to inbox <", renderObjURI inbox
                , "> error: ", T.pack $ displayException err
                ]
        Right resp ->
            logDebug $ T.concat
-                [ "deliverActivity to inbox <", renderFedURI inbox
+                [ "deliverActivity to inbox <", renderObjURI inbox
                , "> success: ", T.pack $ show $ responseStatus resp
                ]
    return result
@ -95,26 +97,28 @@ deliverActivity' inbox mfwd sender body = do
 deliverActivity
    :: ( MonadSite m
       , SiteEnv m ~ site
+       , SiteFedURIMode site ~ u
       , HasHttpManager site
       , YesodActivityPub site
       )
-    => FedURI
-    -> Maybe FedURI
-    -> Doc Activity
+    => ObjURI u
+    -> Maybe (ObjURI u)
+    -> Doc Activity u
    -> m (Either APPostError (Response ()))
 deliverActivity inbox mfwd doc@(Doc hAct activity) =
-    let sender = renderFedURI $ l2f hAct (activityActor activity)
+    let sender = renderObjURI $ ObjURI hAct (activityActor activity)
        body = encode doc
    in  deliverActivity' inbox mfwd sender body

 deliverActivityBL
    :: ( MonadSite m
       , SiteEnv m ~ site
+       , SiteFedURIMode site ~ u
       , HasHttpManager site
       , YesodActivityPub site
       )
-    => FedURI
-    -> Maybe FedURI
+    => ObjURI u
+    -> Maybe (ObjURI u)
    -> Route site
    -> BL.ByteString
    -> m (Either APPostError (Response ()))
@ -126,11 +130,12 @@ deliverActivityBL inbox mfwd senderR body = do
 deliverActivityBL'
    :: ( MonadSite m
       , SiteEnv m ~ site
+       , SiteFedURIMode site ~ u
       , HasHttpManager site
       , YesodActivityPub site
       )
-    => FedURI
-    -> Maybe FedURI
+    => ObjURI u
+    -> Maybe (ObjURI u)
    -> BL.ByteString
    -> m (Either APPostError (Response ()))
 deliverActivityBL' inbox mfwd body = do
@ -144,10 +149,11 @@ deliverActivityBL' inbox mfwd body = do
 forwardActivity
    :: ( MonadSite m
       , SiteEnv m ~ site
+       , SiteFedURIMode site ~ u
       , HasHttpManager site
       , YesodActivityPub site
       )
-    => FedURI
+    => ObjURI u
    -> ByteString
    -> Route site
    -> BL.ByteString
@ -163,12 +169,12 @@ forwardActivity inbox sig rSender body = do
    case result of
        Left err ->
            logError $ T.concat
-                [ "forwardActivity to inbox <", renderFedURI inbox
+                [ "forwardActivity to inbox <", renderObjURI inbox
                , "> error: ", T.pack $ displayException err
                ]
        Right resp ->
            logDebug $ T.concat
-                [ "forwardActivity to inbox <", renderFedURI inbox
+                [ "forwardActivity to inbox <", renderObjURI inbox
                , "> success: ", T.pack $ show $ responseStatus resp
                ]
    return result
@ -178,15 +184,15 @@ redirectToPrettyJSON
 redirectToPrettyJSON route = redirect (route, [("prettyjson", "true")])

 provideHtmlAndAP
-    :: (YesodActivityPub site, ActivityPub a)
-    => a -> WidgetFor site () -> HandlerFor site TypedContent
+    :: (YesodActivityPub site, SiteFedURIMode site ~ u, ActivityPub a)
+    => a u -> WidgetFor site () -> HandlerFor site TypedContent
 provideHtmlAndAP object widget = do
    host <- getsYesod siteInstanceHost
    provideHtmlAndAP' host object widget

 provideHtmlAndAP'
-    :: (YesodActivityPub site, ActivityPub a)
-    => Text -> a -> WidgetFor site () -> HandlerFor site TypedContent
+    :: (YesodActivityPub site, SiteFedURIMode site ~ u, ActivityPub a)
+    => Authority u -> a u -> WidgetFor site () -> HandlerFor site TypedContent
 provideHtmlAndAP' host object widget = selectRep $ do
    let doc = Doc host object
    provideAP $ pure doc
--- a/src/Yesod/FedURI.hs
+++ b/src/Yesod/FedURI.hs
@ -14,7 +14,8 @@
 -}

 module Yesod.FedURI
-    ( getEncodeRouteLocal
+    ( SiteFedURI (..)
+    , getEncodeRouteLocal
    , getEncodeRouteHome
    , getEncodeRouteFed
    , decodeRouteLocal
@ -24,12 +25,9 @@ module Yesod.FedURI
    )
 where

-import Control.Monad
-import Data.Text (Text)
 import Data.Text.Encoding
 import Network.HTTP.Types.URI
 import Yesod.Core
-import Yesod.Core.Handler

 import qualified Data.Text as T

@ -38,55 +36,60 @@ import Yesod.MonadSite

 import Yesod.Paginate.Local

-getEncodeRouteLocal :: MonadSite m => m (Route (SiteEnv m) -> LocalURI)
-getEncodeRouteLocal = (\ f -> snd . f2l . f) <$> getEncodeRouteHome
+class UriMode (SiteFedURIMode site) => SiteFedURI site where
+    type SiteFedURIMode site

-getEncodeRouteHome :: MonadSite m => m (Route (SiteEnv m) -> FedURI)
+getEncodeRouteHome
+    :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site)
+    => m (Route site -> ObjURI (SiteFedURIMode site))
 getEncodeRouteHome = toFed <$> askUrlRender
    where
    toFed renderUrl route =
-        case parseFedURI $ renderUrl route of
-            Left e -> error $ "getUrlRender produced invalid FedURI: " ++ e
+        case parseObjURI $ renderUrl route of
+            Left e -> error $ "askUrlRender produced invalid ObjURI: " ++ e
            Right u -> u

-getEncodeRouteFed :: MonadSite m => m (Text -> Route (SiteEnv m) -> FedURI)
-getEncodeRouteFed = toFed <$> askUrlRender
-    where
-    toFed renderUrl host route =
-        case parseFedURI $ renderUrl route of
-            Left e -> error $ "getUrlRender produced invalid FedURI: " ++ e
-            Right u -> u { furiHost = host }
+getEncodeRouteLocal
+    :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site)
+    => m (Route site -> LocalURI)
+getEncodeRouteLocal = (objUriLocal .) <$> getEncodeRouteHome
+
+getEncodeRouteFed
+    :: ( MonadSite m
+       , SiteEnv m ~ site
+       , SiteFedURI site
+       , SiteFedURIMode site ~ u
+       )
+    => m (Authority u -> Route site -> ObjURI u)
+getEncodeRouteFed = (\ f a -> ObjURI a . f) <$> getEncodeRouteLocal

 decodeRouteLocal :: ParseRoute site => LocalURI -> Maybe (Route site)
 decodeRouteLocal =
-    parseRoute . (,[]) . decodePathSegments . encodeUtf8 . luriPath <=< noFrag
-    where
-    noFrag lu =
-        if T.null $ luriFragment lu
-            then Just lu
-            else Nothing
+    parseRoute . (,[]) . decodePathSegments . encodeUtf8 . localUriPath

 getEncodeRoutePageLocal
-    :: (MonadSite m, YesodPaginate (SiteEnv m))
-    => m (Route (SiteEnv m) -> Int -> LocalPageURI)
-getEncodeRoutePageLocal = do
-    encodeRouteLocal <- getEncodeRouteLocal
-    param <- asksSite sitePageParamName
-    return $ \ route page -> LocalPageURI (encodeRouteLocal route) param page
+    :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, YesodPaginate site)
+    => m (Route site -> Int -> LocalPageURI)
+getEncodeRoutePageLocal =
+    (\ f r n -> pageUriLocal $ f r n) <$> getEncodeRoutePageHome

 getEncodeRoutePageHome
-    :: (MonadSite m, YesodPaginate (SiteEnv m))
-    => m (Route (SiteEnv m) -> Int -> FedPageURI)
+    :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, YesodPaginate site)
+    => m (Route site -> Int -> PageURI (SiteFedURIMode site))
 getEncodeRoutePageHome = do
    encodeRouteHome <- getEncodeRouteHome
    param <- asksSite sitePageParamName
-    return $ \ route page -> FedPageURI (encodeRouteHome route) param page
+    return $ \ route page ->
+        let ObjURI a l = encodeRouteHome route
+        in  PageURI a $ LocalPageURI l param page

 getEncodeRoutePageFed
-    :: (MonadSite m, YesodPaginate (SiteEnv m))
-    => m (Text -> Route (SiteEnv m) -> Int -> FedPageURI)
-getEncodeRoutePageFed = do
-    encodeRouteFed <- getEncodeRouteFed
-    param <- asksSite sitePageParamName
-    return $
-        \ host route page -> FedPageURI (encodeRouteFed host route) param page
+    :: ( MonadSite m
+       , SiteEnv m ~ site
+       , SiteFedURI site
+       , YesodPaginate site
+       , SiteFedURIMode site ~ u
+       )
+    => m (Authority u -> Route site -> Int -> PageURI u)
+getEncodeRoutePageFed =
+    (\ f a r n -> PageURI a $ f r n) <$> getEncodeRoutePageLocal
--- a/templates/default-layout.hamlet
+++ b/templates/default-layout.hamlet
@ -52,7 +52,7 @@ $if federationDisabled
            #{h}

 <.instance>
-  Vervis @ #{instanceHost}
+  Vervis @ #{renderAuthority instanceHost}

 ^{breadcrumbsW}

--- a/templates/discussion/widget/message.hamlet
+++ b/templates/discussion/widget/message.hamlet
@ -19,7 +19,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
      <a href=@{MessageR (sharerIdent s) (encodeHid lmid)}>
        #{showTime $ messageCreated msg}
    $of MessageTreeNodeRemote h luMsg _luAuthor _mname
-      <a href="#{renderFedURI $ l2f h luMsg}"}>
+      <a href="#{renderObjURI $ ObjURI h luMsg}"}>
        #{showTime $ messageCreated msg}
 <div>
  ^{showContent $ messageContent msg}
--- a/templates/widget/actor-link.hamlet
+++ b/templates/widget/actor-link.hamlet
@ -22,7 +22,7 @@ $case actor
    <span>
      ./s/#{shr2text $ sharerIdent s}
  $of MessageTreeNodeRemote h _luMsg luAuthor mname
-    <a href="#{renderFedURI $ l2f h luAuthor}">
+    <a href="#{renderObjURI $ ObjURI h luAuthor}">
      $maybe name <- mname
        #{name}
      $nothing
--- a/vervis.cabal
+++ b/vervis.cabal
@ -130,6 +130,7 @@ library
                       Vervis.Federation.Auth
                       Vervis.Federation.Discussion
                       Vervis.Federation.Ticket
+                       Vervis.FedURI
                       Vervis.Field.Key
                       Vervis.Field.Person
                       Vervis.Field.Project