From 8fc5c80dd6132d3d9fa363239c04356a0c054740 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Tue, 23 Jul 2019 13:59:48 +0000
Subject: [PATCH] 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.
---
 config/models                              |   4 +-
 migrations/2019_05_24.model                |   2 +-
 src/Data/Aeson/Local.hs                    |   6 +
 src/Network/FedURI.hs                      | 683 +++++++++++++++------
 src/Vervis/API.hs                          |  48 +-
 src/Vervis/API/Recipient.hs                |  17 +-
 src/Vervis/ActivityPub.hs                  |  88 +--
 src/Vervis/Discussion.hs                   |   5 +-
 src/Vervis/FedURI.hs                       |  38 ++
 src/Vervis/Federation.hs                   |  28 +-
 src/Vervis/Federation/Auth.hs              |  62 +-
 src/Vervis/Federation/Discussion.hs        |  23 +-
 src/Vervis/Federation/Ticket.hs            |  36 +-
 src/Vervis/Foundation.hs                   |  16 +-
 src/Vervis/Handler/Discussion.hs           |  21 +-
 src/Vervis/Handler/Inbox.hs                |  37 +-
 src/Vervis/Migration.hs                    |  53 +-
 src/Vervis/Migration/Model.hs              |   3 +-
 src/Vervis/Model.hs                        |   5 +-
 src/Vervis/RemoteActorStore.hs             |  27 +-
 src/Vervis/Settings.hs                     |  16 +-
 src/Vervis/Widget/Discussion.hs            |   2 +-
 src/Vervis/Widget/Sharer.hs                |   4 +-
 src/Web/ActivityPub.hs                     | 632 ++++++++++---------
 src/Yesod/ActivityPub.hs                   |  48 +-
 src/Yesod/FedURI.hs                        |  79 +--
 templates/default-layout.hamlet            |   2 +-
 templates/discussion/widget/message.hamlet |   2 +-
 templates/widget/actor-link.hamlet         |   2 +-
 vervis.cabal                               |   1 +
 30 files changed, 1240 insertions(+), 750 deletions(-)
 create mode 100644 src/Vervis/FedURI.hs

diff --git a/config/models b/config/models
index 8dbac42..4e2804e 100644
--- 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
 
diff --git a/migrations/2019_05_24.model b/migrations/2019_05_24.model
index bb58171..d684820 100644
--- 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
 
diff --git a/src/Data/Aeson/Local.hs b/src/Data/Aeson/Local.hs
index 123d646..8891aa6 100644
--- 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
diff --git a/src/Network/FedURI.hs b/src/Network/FedURI.hs
index c814eba..bbcb80c 100644
--- 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
diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs
index e179b3d..8d07802 100644
--- 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")])
diff --git a/src/Vervis/API/Recipient.hs b/src/Vervis/API/Recipient.hs
index ebf1d9b..92691a3 100644
--- 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
diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs
index f80ab58..63a6493 100644
--- 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]
diff --git a/src/Vervis/Discussion.hs b/src/Vervis/Discussion.hs
index 7870d52..5fc2a59 100644
--- 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
diff --git a/src/Vervis/FedURI.hs b/src/Vervis/FedURI.hs
new file mode 100644
index 0000000..b3a8530
--- /dev/null
+++ 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
diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs
index 16b35d8..5bb2bc7 100644
--- 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
diff --git a/src/Vervis/Federation/Auth.hs b/src/Vervis/Federation/Auth.hs
index 01ca2b8..ffe0558 100644
--- 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
diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs
index 72e1d93..e2cb5b8 100644
--- 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
diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs
index ab62885..8a1b2aa 100644
--- 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
diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs
index a9e6985..42b22c2 100644
--- 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
diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs
index 3760444..3cf4213 100644
--- 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
diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs
index 6703138..55e06ac 100644
--- 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
diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs
index 8cc4ad2..2a6159f 100644
--- 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
diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs
index 3762e71..e946768 100644
--- 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")
diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs
index 19639ca..5cb8ae3 100644
--- 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")
 
diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs
index 640634e..816f213 100644
--- 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
diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs
index d4eafb1..d1fcfad 100644
--- 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"
diff --git a/src/Vervis/Widget/Discussion.hs b/src/Vervis/Widget/Discussion.hs
index 0bd4f3b..7f4be1e 100644
--- 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
diff --git a/src/Vervis/Widget/Sharer.hs b/src/Vervis/Widget/Sharer.hs
index 1e6932e..287ca47 100644
--- 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)
diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index 74aa8fb..9755b18 100644
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@@ -57,7 +57,6 @@ module Web.ActivityPub
     , Activity (..)
 
       -- * Utilities
-    , publicURI
     , hActivityPubActor
     , provideAP
     , provideAP'
@@ -82,7 +81,7 @@ where
 
 import Control.Applicative ((<|>), optional)
 import Control.Exception (Exception, displayException, try)
-import Control.Monad (when, unless, (<=<), join)
+import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Writer (Writer)
@@ -91,36 +90,30 @@ import Data.Aeson
 import Data.Aeson.Encoding (pair)
 import Data.Aeson.Types (Parser, typeMismatch, listEncoding)
 import Data.Bifunctor
-import Data.Bitraversable (bitraverse)
 import Data.ByteString (ByteString)
 import Data.Foldable (for_)
 import Data.List
-import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
+import Data.List.NonEmpty (NonEmpty (..))
 import Data.Proxy
-import Data.PEM
 import Data.Semigroup (Endo, First (..))
 import Data.Text (Text)
 import Data.Text.Encoding (encodeUtf8, decodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Data.Traversable
-import Data.Vector (Vector)
 import Network.HTTP.Client hiding (Proxy, proxy)
 import Network.HTTP.Client.Conduit.ActivityPub (httpAPEither)
 import Network.HTTP.Simple (JSONException)
 import Network.HTTP.Types.Header (HeaderName, hContentType)
-import Network.URI
 import Text.HTML.SanitizeXSS
 import Yesod.Core.Content (ContentType)
 import Yesod.Core.Handler (ProvidedRep, provideRepType)
 
 import Network.HTTP.Client.Signature
 
-import qualified Data.ByteString as B
-import qualified Data.ByteString.Base64 as B64
 import qualified Data.ByteString.Char8 as BC
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.HashMap.Strict as M
-import qualified Data.Text as T (pack, unpack)
+import qualified Data.Text as T
 import qualified Data.Vector as V
 import qualified Network.HTTP.Signature as S
 
@@ -130,41 +123,38 @@ import Network.HTTP.Digest
 
 import Data.Aeson.Local
 
-proxy :: a -> Proxy a
+proxy :: a u -> Proxy a
 proxy _ = Proxy
 
-as2Context :: FedURI
-as2Context = FedURI "www.w3.org" "/ns/activitystreams" ""
+as2Context :: Text
+as2Context = "https://www.w3.org/ns/activitystreams"
 
-secContext :: FedURI
-secContext = FedURI "w3id.org" "/security/v1" ""
+secContext :: Text
+secContext = "https://w3id.org/security/v1"
 
-forgeContext :: FedURI
-forgeContext = FedURI "forgefed.peers.community" "/ns" ""
+forgeContext :: Text
+forgeContext = "https://forgefed.peers.community/ns"
 
-extContext :: FedURI
-extContext = FedURI "angeley.es" "/as2-ext" ""
+extContext :: Text
+extContext = "https://angeley.es/as2-ext"
 
-publicURI :: FedURI
-publicURI = FedURI "www.w3.org" "/ns/activitystreams" "#Public"
-
-publicT :: Text
-publicT = renderFedURI publicURI
+publicURI :: Text
+publicURI = "https://www.w3.org/ns/activitystreams#Public"
 
 class ActivityPub a where
-    jsonldContext :: Proxy a -> [FedURI]
-    parseObject   :: Object -> Parser (Text, a)
-    toSeries      :: Text -> a -> Series
+    jsonldContext :: Proxy a -> [Text]
+    parseObject   :: UriMode u => Object -> Parser (Authority u, a u)
+    toSeries      :: UriMode u => Authority u -> a u -> Series
 
-data Doc a = Doc
-    { docHost  :: Text
-    , docValue :: a
+data Doc a u = Doc
+    { docAuthority :: Authority u
+    , docValue     :: a u
     }
 
-instance ActivityPub a => FromJSON (Doc a) where
+instance (ActivityPub a, UriMode u) => FromJSON (Doc a u) where
     parseJSON = withObject "Doc" $ \ o -> uncurry Doc <$> parseObject o
 
-instance ActivityPub a => ToJSON (Doc a) where
+instance (ActivityPub a, UriMode u) => ToJSON (Doc a u) where
     toJSON = error "toJSON Doc"
     toEncoding (Doc h v) =
         pairs
@@ -200,8 +190,8 @@ ownerShared :: Owner -> Bool
 ownerShared OwnerInstance  = True
 ownerShared (OwnerActor _) = False
 
-data PublicKey = PublicKey
-    { publicKeyId       :: LocalURI
+data PublicKey u = PublicKey
+    { publicKeyId       :: LocalRefURI
     , publicKeyExpires  :: Maybe UTCTime
     , publicKeyOwner    :: Owner
     , publicKeyMaterial :: PublicVerifKey
@@ -214,60 +204,62 @@ instance ActivityPub PublicKey where
         for_ mtyp $ \ t ->
             when (t /= ("Key" :: Text)) $
                 fail "PublicKey @type isn't Key"
-        (host, id_) <- f2l <$> (o .: "@id" <|> o .: "id")
+        RefURI authority id_ <- o .: "@id" <|> o .: "id"
         shared <- o .:|? "isShared" .!= False
-        fmap (host,) $
+        fmap (authority,) $
             PublicKey id_
                 <$> o .:? "expires"
-                <*> (mkOwner shared =<< withHost host o "owner")
+                <*> (mkOwner shared =<< withAuthorityO authority (o .: "owner"))
                 <*> (either fail return . decodePublicVerifKeyPEM =<<
                         o .: "publicKeyPem"
                     )
         where
-        withHost h o t = do
-            (h', lu) <- f2l <$> o .: t
-            if h == h'
-                then return lu
-                else fail "URI host mismatch"
-        mkOwner True  (LocalURI "" "") = return OwnerInstance
-        mkOwner True  _                = fail "Shared key but owner isn't instance URI"
-        mkOwner False lu               = return $ OwnerActor lu
-    toSeries host (PublicKey id_ mexpires owner mat)
-        =  "@id"          .=  l2f host id_
+        mkOwner True  lu
+            | lu == topLocalURI = return OwnerInstance
+        mkOwner True  _         = fail "Shared key but owner isn't instance URI"
+        mkOwner False lu        = return $ OwnerActor lu
+    toSeries authority (PublicKey id_ mexpires owner mat)
+        =  "@id"          .=  RefURI authority id_
         <> "expires"      .=? mexpires
-        <> "owner"        .=  mkOwner host owner
+        <> "owner"        .=  mkOwner authority owner
         <> "publicKeyPem" .=  encodePublicVerifKeyPEM mat
         <> "isShared"     .=  ownerShared owner
         where
-        mkOwner h OwnerInstance   = FedURI h "" ""
-        mkOwner h (OwnerActor lu) = l2f h lu
+        mkOwner a OwnerInstance   = ObjURI a topLocalURI
+        mkOwner a (OwnerActor lu) = ObjURI a lu
 
-parsePublicKeySet :: Value -> Parser (Text, [Either LocalURI PublicKey])
+parsePublicKeySet
+    :: UriMode u
+    => Value
+    -> Parser (Authority u, [Either LocalURI (PublicKey u)])
 parsePublicKeySet v =
     case v of
         Array a ->
             case V.toList a of
                 [] -> fail "No public keys"
                 k : ks -> do
-                    (h, e) <- parseKey k
-                    es <- traverse (withHost h . parseKey) ks
-                    return (h, e : es)
+                    (a, e) <- parseKey k
+                    es <- traverse (withAuthorityT a . parseKey) ks
+                    return (a, e : es)
         _ -> second (: []) <$> parseKey v
     where
-    parseKey (String t) = second Left . f2l <$> either fail return (parseFedURI t)
-    parseKey (Object o) = second Right <$> parseObject o
-    parseKey v          = typeMismatch "PublicKeySet Item" v
+    parseKey v@(String _) = second Left . f2l <$> parseJSON v
+        where
+        f2l (ObjURI a l)  = (a, l)
+    parseKey (Object o)   = second Right <$> parseObject o
+    parseKey v            = typeMismatch "PublicKeySet Item" v
 
-encodePublicKeySet :: Text -> [Either LocalURI PublicKey] -> Encoding
-encodePublicKeySet host es =
+encodePublicKeySet
+    :: UriMode u => Authority u -> [Either LocalURI (PublicKey u)] -> Encoding
+encodePublicKeySet authority es =
     case es of
         [e] -> renderKey e
         _   -> listEncoding renderKey es
     where
-    renderKey (Left lu)  = toEncoding $ l2f host lu
-    renderKey (Right pk) = pairs $ toSeries host pk
+    renderKey (Left lu)  = toEncoding $ ObjURI authority lu
+    renderKey (Right pk) = pairs $ toSeries authority pk
 
-data Actor = Actor
+data Actor u = Actor
     { actorId         :: LocalURI
     , actorType       :: ActorType
     , actorUsername   :: Maybe Text
@@ -276,37 +268,37 @@ data Actor = Actor
     , actorInbox      :: LocalURI
     , actorOutbox     :: Maybe LocalURI
     , actorFollowers  :: Maybe LocalURI
-    , actorPublicKeys :: [Either LocalURI PublicKey]
+    , actorPublicKeys :: [Either LocalURI (PublicKey u)]
     }
 
 instance ActivityPub Actor where
     jsonldContext _ = [as2Context, secContext, extContext]
     parseObject o = do
-        (host, id_) <- f2l <$> o .: "id"
-        fmap (host,) $
+        ObjURI authority id_ <- o .: "id"
+        fmap (authority,) $
             Actor id_
                 <$> o .: "type"
                 <*> o .:? "preferredUsername"
                 <*> o .:? "name"
                 <*> o .:? "summary"
-                <*> withHost host (f2l <$> o .: "inbox")
-                <*> withHostMaybe host (fmap f2l <$> o .:? "outbox")
-                <*> withHostMaybe host (fmap f2l <$> o .:? "followers")
-                <*> withHost host (parsePublicKeySet =<< o .: "publicKey")
-    toSeries host
+                <*> withAuthorityO authority (o .: "inbox")
+                <*> withAuthorityMaybeO authority (o .:? "outbox")
+                <*> withAuthorityMaybeO authority (o .:? "followers")
+                <*> withAuthorityT authority (parsePublicKeySet =<< o .: "publicKey")
+    toSeries authority
         (Actor id_ typ musername mname msummary inbox outbox followers pkeys)
-            =  "id"                .=     l2f host id_
+            =  "id"                .=     ObjURI authority id_
             <> "type"              .=     typ
             <> "preferredUsername" .=?    musername
             <> "name"              .=?    mname
             <> "summary"           .=?    msummary
-            <> "inbox"             .=     l2f host inbox
-            <> "outbox"            .=?    (l2f host <$> outbox)
-            <> "followers"         .=?    (l2f host <$> followers)
-            <> "publicKey"         `pair` encodePublicKeySet host pkeys
+            <> "inbox"             .=     ObjURI authority inbox
+            <> "outbox"            .=?    (ObjURI authority <$> outbox)
+            <> "followers"         .=?    (ObjURI authority <$> followers)
+            <> "publicKey"         `pair` encodePublicKeySet authority pkeys
 
-data Project = Project
-    { projectActor :: Actor
+data Project u = Project
+    { projectActor :: Actor u
     , projectTeam  :: LocalURI
     }
 
@@ -318,10 +310,10 @@ instance ActivityPub Project where
             fail "Actor type isn't Project"
         fmap (h,) $
             Project a
-                <$> withHost h (f2l <$> o .:| "team")
-    toSeries host (Project actor team)
-        =  toSeries host actor
-        <> "team" .= l2f host team
+                <$> withAuthorityO h (o .:| "team")
+    toSeries authority (Project actor team)
+        =  toSeries authority actor
+        <> "team" .= ObjURI authority team
 
 data CollectionType = CollectionTypeUnordered | CollectionTypeOrdered
 
@@ -339,7 +331,7 @@ instance ToJSON CollectionType where
             CollectionTypeUnordered -> "Collection" :: Text
             CollectionTypeOrdered   -> "OrderedCollection"
 
-data Collection a = Collection
+data Collection a u = Collection
     { collectionId         :: LocalURI
     , collectionType       :: CollectionType
     , collectionTotalItems :: Maybe Int
@@ -352,22 +344,22 @@ data Collection a = Collection
 instance (FromJSON a, ToJSON a) => ActivityPub (Collection a) where
     jsonldContext _ = [as2Context, forgeContext, extContext]
     parseObject o = do
-        (host, id_) <- f2l <$> o .: "id"
-        fmap (host,) $
+        ObjURI authority id_ <- o .: "id"
+        fmap (authority,) $
             Collection id_
                 <$> o .: "type"
                 <*> o .:? "totalItems"
-                <*> withHostMaybe host (fmap f2l <$> o .:? "current")
-                <*> withHostMaybe host (fmap fp2lp <$> o .:? "first")
-                <*> withHostMaybe host (fmap fp2lp <$> o .:? "last")
+                <*> withAuthorityMaybeO authority (o .:? "current")
+                <*> withAuthorityMaybeP authority (o .:? "first")
+                <*> withAuthorityMaybeP authority (o .:? "last")
                 <*> optional (o .: "items" <|> o .: "orderedItems") .!= []
-    toSeries host (Collection id_ typ total curr firzt last items)
-        =  "id"         .=  l2f host id_
+    toSeries authority (Collection id_ typ total curr firzt last items)
+        =  "id"         .=  ObjURI authority id_
         <> "type"       .=  typ
         <> "totalItems" .=? total
-        <> "current"    .=? (l2f host <$> curr)
-        <> "first"      .=? (lp2fp host <$> firzt)
-        <> "last"       .=? (lp2fp host <$> last)
+        <> "current"    .=? (ObjURI authority <$> curr)
+        <> "first"      .=? (PageURI authority <$> firzt)
+        <> "last"       .=? (PageURI authority <$> last)
         <> "items"      .=% items
 
 data CollectionPageType
@@ -388,7 +380,7 @@ instance ToJSON CollectionPageType where
             CollectionPageTypeUnordered -> "CollectionPage" :: Text
             CollectionPageTypeOrdered   -> "OrderedCollectionPage"
 
-data CollectionPage a = CollectionPage
+data CollectionPage a u = CollectionPage
     { collectionPageId         :: LocalPageURI
     , collectionPageType       :: CollectionPageType
     , collectionPageTotalItems :: Maybe Int
@@ -405,33 +397,33 @@ data CollectionPage a = CollectionPage
 instance (FromJSON a, ToJSON a) => ActivityPub (CollectionPage a) where
     jsonldContext _ = [as2Context, forgeContext, extContext]
     parseObject o = do
-        (host, id_) <- fp2lp <$> o .: "id"
-        fmap (host,) $
+        PageURI authority id_ <- o .: "id"
+        fmap (authority,) $
             CollectionPage id_
                 <$> o .: "type"
                 <*> o .:? "totalItems"
-                <*> withHostMaybe host (fmap fp2lp <$> o .:? "current")
-                <*> withHostMaybe host (fmap fp2lp <$> o .:? "first")
-                <*> withHostMaybe host (fmap fp2lp <$> o .:? "last")
-                <*> withHost host (f2l <$> o .: "partOf")
-                <*> withHostMaybe host (fmap fp2lp <$> o .:? "prev")
-                <*> withHostMaybe host (fmap fp2lp <$> o .:? "next")
+                <*> withAuthorityMaybeP authority (o .:? "current")
+                <*> withAuthorityMaybeP authority (o .:? "first")
+                <*> withAuthorityMaybeP authority (o .:? "last")
+                <*> withAuthorityO authority (o .: "partOf")
+                <*> withAuthorityMaybeP authority (o .:? "prev")
+                <*> withAuthorityMaybeP authority (o .:? "next")
                 <*> o .:? "startIndex"
                 <*> optional (o .: "items" <|> o .: "orderedItems") .!= []
-    toSeries host (CollectionPage id_ typ total curr firzt last partOf prev next ind items)
-        =  "id"         .=  lp2fp host id_
+    toSeries authority (CollectionPage id_ typ total curr firzt last partOf prev next ind items)
+        =  "id"         .=  PageURI authority id_
         <> "type"       .=  typ
         <> "totalItems" .=? total
-        <> "current"    .=? (lp2fp host <$> curr)
-        <> "first"      .=? (lp2fp host <$> firzt)
-        <> "last"       .=? (lp2fp host <$> last)
-        <> "partOf"     .=  (l2f host partOf)
-        <> "prev"       .=? (lp2fp host <$> prev)
-        <> "next"       .=? (lp2fp host <$> next)
+        <> "current"    .=? (PageURI authority <$> curr)
+        <> "first"      .=? (PageURI authority <$> firzt)
+        <> "last"       .=? (PageURI authority <$> last)
+        <> "partOf"     .=  (ObjURI authority partOf)
+        <> "prev"       .=? (PageURI authority <$> prev)
+        <> "next"       .=? (PageURI authority <$> next)
         <> "startIndex" .=? ind
         <> "items"      .=% items
 
-data Recipient = RecipientActor Actor | RecipientCollection (Collection FedURI)
+data Recipient u = RecipientActor (Actor u) | RecipientCollection (Collection (ObjURI u) u)
 
 instance ActivityPub Recipient where
     jsonldContext _ = [as2Context, secContext, forgeContext, extContext]
@@ -441,30 +433,30 @@ instance ActivityPub Recipient where
     toSeries h (RecipientActor a)      = toSeries h a
     toSeries h (RecipientCollection c) = toSeries h c
 
-data Audience = Audience
-    { audienceTo        :: [FedURI]
-    , audienceBto       :: [FedURI]
-    , audienceCc        :: [FedURI]
-    , audienceBcc       :: [FedURI]
-    , audienceGeneral   :: [FedURI]
-    , audienceNonActors :: [FedURI]
+data Audience u = Audience
+    { audienceTo        :: [ObjURI u]
+    , audienceBto       :: [ObjURI u]
+    , audienceCc        :: [ObjURI u]
+    , audienceBcc       :: [ObjURI u]
+    , audienceGeneral   :: [ObjURI u]
+    , audienceNonActors :: [ObjURI u]
     }
 
-newtype AdaptAudience = AdaptAudience
-    { unAdapt :: FedURI
+newtype AdaptAudience u = AdaptAudience
+    { unAdapt :: ObjURI u
     }
 
-instance FromJSON AdaptAudience where
+instance UriMode u => FromJSON (AdaptAudience u) where
     parseJSON = fmap AdaptAudience . parseJSON . adapt
         where
         adapt v =
             case v of
                 String t
-                    | t == "Public"    -> String publicT
-                    | t == "as:Public" -> String publicT
+                    | t == "as:Public" -> String "Public"
+                    | t == publicURI   -> String "Public"
                 _ -> v
 
-parseAudience :: Object -> Parser Audience
+parseAudience :: UriMode u => Object -> Parser (Audience u)
 parseAudience o =
     Audience
         <$> o .:& "to"
@@ -481,7 +473,7 @@ parseAudience o =
         l <- obj .:|? key .!= []
         return $ map unAdapt l
 
-encodeAudience :: Audience -> Series
+encodeAudience :: UriMode u => Audience u -> Series
 encodeAudience (Audience to bto cc bcc aud nons)
     =  "to"        .=% to
     <> "bto"       .=% bto
@@ -490,29 +482,68 @@ encodeAudience (Audience to bto cc bcc aud nons)
     <> "audience"  .=% aud
     <> "nonActors" .=% nons
 
-data Note = Note
+data Note u = Note
     { noteId        :: Maybe LocalURI
     , noteAttrib    :: LocalURI
-    , noteAudience  :: Audience
-    , noteReplyTo   :: Maybe FedURI
-    , noteContext   :: Maybe FedURI
+    , noteAudience  :: Audience u
+    , noteReplyTo   :: Maybe (ObjURI u)
+    , noteContext   :: Maybe (ObjURI u)
     , notePublished :: Maybe UTCTime
     , noteSource    :: Text
     , noteContent   :: Text
     }
 
-withHost h a = do
-    (h', v) <- a
-    if h == h'
+withAuthorityT a m = do
+    (a', v) <- m
+    if a == a'
         then return v
-        else fail "URI host mismatch"
+        else fail "URI authority mismatch"
 
-withHostMaybe h a = do
-    mp <- a
-    for mp $ \ (h', v) ->
-        if h == h'
+withAuthorityO a m = do
+    ObjURI a' v <- m
+    if a == a'
+        then return v
+        else fail "URI authority mismatch"
+
+withAuthorityS a m = do
+    SubURI a' v <- m
+    if a == a'
+        then return v
+        else fail "URI authority mismatch"
+
+withAuthorityP a m = do
+    PageURI a' v <- m
+    if a == a'
+        then return v
+        else fail "URI authority mismatch"
+
+withAuthorityMaybeT a m = do
+    mu <- m
+    for mu $ \ (a', v) ->
+        if a == a'
             then return v
-            else fail "URI host mismatch"
+            else fail "URI authority mismatch"
+
+withAuthorityMaybeO a m = do
+    mu <- m
+    for mu $ \ (ObjURI a' v) ->
+        if a == a'
+            then return v
+            else fail "URI authority mismatch"
+
+withAuthorityMaybeS a m = do
+    mu <- m
+    for mu $ \ (SubURI a' v) ->
+        if a == a'
+            then return v
+            else fail "URI authority mismatch"
+
+withAuthorityMaybeP a m = do
+    mu <- m
+    for mu $ \ (PageURI a' v) ->
+        if a == a'
+            then return v
+            else fail "URI authority mismatch"
 
 instance ActivityPub Note where
     jsonldContext _ = [as2Context, extContext]
@@ -530,10 +561,10 @@ instance ActivityPub Note where
         unless (sourceType == ("text/markdown; variant=Pandoc" :: Text)) $
             fail "source mediaType isn't Pandoc Markdown"
 
-        (h, attrib) <- f2l <$> o .: "attributedTo"
-        fmap (h,) $
+        ObjURI a attrib <- o .: "attributedTo"
+        fmap (a,) $
             Note
-                <$> withHostMaybe h (fmap f2l <$> o .:? "id")
+                <$> withAuthorityMaybeO a (o .:? "id")
                 <*> pure attrib
                 <*> parseAudience o
                 <*> o .:? "inReplyTo"
@@ -541,10 +572,10 @@ instance ActivityPub Note where
                 <*> o .:? "published"
                 <*> source .: "content"
                 <*> (sanitizeBalance <$> o .: "content")
-    toSeries host (Note mid attrib aud mreply mcontext mpublished src content)
+    toSeries authority (Note mid attrib aud mreply mcontext mpublished src content)
         =  "type"         .=  ("Note" :: Text)
-        <> "id"           .=? (l2f host <$> mid)
-        <> "attributedTo" .=  l2f host attrib
+        <> "id"           .=? (ObjURI authority <$> mid)
+        <> "attributedTo" .=  ObjURI authority attrib
         <> encodeAudience aud
         <> "inReplyTo"    .=? mreply
         <> "context"      .=? mcontext
@@ -571,12 +602,12 @@ instance ToJSON RelationshipProperty where
         toEncoding $ case at of
             RelDependsOn -> "dependsOn" :: Text
 
-data Relationship = Relationship
-    { relationshipId           :: Maybe FedURI
+data Relationship u = Relationship
+    { relationshipId           :: Maybe (ObjURI u)
     , relationshipExtraTypes   :: [Text]
-    , relationshipSubject      :: FedURI
+    , relationshipSubject      :: ObjURI u
     , relationshipProperty     :: Either RelationshipProperty Text
-    , relationshipObject       :: FedURI
+    , relationshipObject       :: ObjURI u
     , relationshipAttributedTo :: LocalURI
     , relationshipPublished    :: Maybe UTCTime
     , relationshipUpdated      :: Maybe UTCTime
@@ -590,9 +621,9 @@ instance ActivityPub Relationship where
         unless (("Relationship" :: Text) `elem` typs) $
             fail "type isn't Relationship"
 
-        (h, attributedTo) <- f2l <$> o .: "attributedTo"
+        ObjURI a attributedTo <- o .: "attributedTo"
 
-        fmap (h,) $
+        fmap (a,) $
             Relationship
                 <$> o .:? "id"
                 <*> pure (delete "Relationship" typs)
@@ -604,7 +635,7 @@ instance ActivityPub Relationship where
                 <*> o .:? "updated"
                 <*> (TextHtml . sanitizeBalance <$> o .: "summary")
 
-    toSeries host
+    toSeries authority
         (Relationship id_ typs subject property object attributedTo published
                       updated summary)
             =  "id"           .=? id_
@@ -612,15 +643,15 @@ instance ActivityPub Relationship where
             <> "subject"      .=  subject
             <> "relationship" .=+ property
             <> "object"       .=  object
-            <> "attributedTo" .=  l2f host attributedTo
+            <> "attributedTo" .=  ObjURI authority attributedTo
             <> "published"    .=? published
             <> "updated"      .=? updated
             <> "summary"      .=  summary
 
-data TicketDependency = TicketDependency
-    { ticketDepId           :: Maybe FedURI
-    , ticketDepParent       :: FedURI
-    , ticketDepChild        :: FedURI
+data TicketDependency u = TicketDependency
+    { ticketDepId           :: Maybe (ObjURI u)
+    , ticketDepParent       :: ObjURI u
+    , ticketDepChild        :: ObjURI u
     , ticketDepAttributedTo :: LocalURI
     , ticketDepPublished    :: Maybe UTCTime
     , ticketDepUpdated      :: Maybe UTCTime
@@ -630,14 +661,14 @@ data TicketDependency = TicketDependency
 instance ActivityPub TicketDependency where
     jsonldContext _ = [as2Context, forgeContext]
     parseObject o = do
-        (h, rel) <- parseObject o
+        (a, rel) <- parseObject o
         unless ("TicketDependency" `elem` relationshipExtraTypes rel) $
             fail "type isn't TicketDependency"
 
         unless (relationshipProperty rel == Left RelDependsOn) $
             fail "relationship isn't dependsOn"
 
-        return (h, rel2td rel)
+        return (a, rel2td rel)
         where
         rel2td rel = TicketDependency
             { ticketDepId           = relationshipId rel
@@ -649,7 +680,7 @@ instance ActivityPub TicketDependency where
             , ticketDepSummary      = relationshipSummary rel
             }
 
-    toSeries h = toSeries h . td2rel
+    toSeries a = toSeries a . td2rel
         where
         td2rel td = Relationship
             { relationshipId           = ticketDepId td
@@ -684,9 +715,9 @@ data TicketLocal = TicketLocal
     , ticketReverseDeps  :: LocalURI
     }
 
-parseTicketLocal :: Object -> Parser (Maybe (Text, TicketLocal))
+parseTicketLocal :: UriMode u => Object -> Parser (Maybe (Authority u, TicketLocal))
 parseTicketLocal o = do
-    mid <- fmap f2l <$> o .:? "id"
+    mid <- o .:? "id"
     case mid of
         Nothing -> do
             verifyNothing "context"
@@ -697,37 +728,37 @@ parseTicketLocal o = do
             verifyNothing "dependencies"
             verifyNothing "dependants"
             return Nothing
-        Just (h, id_) ->
-            fmap (Just . (h,)) $
+        Just (ObjURI a id_) ->
+            fmap (Just . (a,)) $
                 TicketLocal
                     <$> pure id_
-                    <*> withHost h (f2l <$> o .: "context")
-                    <*> withHost h (f2l <$> o .: "replies")
-                    <*> withHost h (f2l <$> o .: "participants")
-                    <*> withHost h (f2l <$> o .: "team")
-                    <*> withHost h (f2l <$> o .: "history")
-                    <*> withHost h (f2l <$> o .: "dependencies")
-                    <*> withHost h (f2l <$> o .: "dependants")
+                    <*> withAuthorityO a (o .: "context")
+                    <*> withAuthorityO a (o .: "replies")
+                    <*> withAuthorityO a (o .: "participants")
+                    <*> withAuthorityO a (o .: "team")
+                    <*> withAuthorityO a (o .: "history")
+                    <*> withAuthorityO a (o .: "dependencies")
+                    <*> withAuthorityO a (o .: "dependants")
     where
     verifyNothing t =
         if t `M.member` o
             then fail $ T.unpack t ++ " field found, expected none"
             else return ()
 
-encodeTicketLocal :: Text -> TicketLocal -> Series
+encodeTicketLocal :: UriMode u => Authority u -> TicketLocal -> Series
 encodeTicketLocal
-    h (TicketLocal id_ context replies participants team events deps rdeps)
-        =  "id"           .= l2f h id_
-        <> "context"      .= l2f h context
-        <> "replies"      .= l2f h replies
-        <> "participants" .= l2f h participants
-        <> "team"         .= l2f h team
-        <> "history"      .= l2f h events
-        <> "dependencies" .= l2f h deps
-        <> "dependants"   .= l2f h rdeps
+    a (TicketLocal id_ context replies participants team events deps rdeps)
+        =  "id"           .= ObjURI a id_
+        <> "context"      .= ObjURI a context
+        <> "replies"      .= ObjURI a replies
+        <> "participants" .= ObjURI a participants
+        <> "team"         .= ObjURI a team
+        <> "history"      .= ObjURI a events
+        <> "dependencies" .= ObjURI a deps
+        <> "dependants"   .= ObjURI a rdeps
 
-data Ticket = Ticket
-    { ticketLocal        :: Maybe (Text, TicketLocal)
+data Ticket u = Ticket
+    { ticketLocal        :: Maybe (Authority u, TicketLocal)
     , ticketAttributedTo :: LocalURI
     , ticketPublished    :: Maybe UTCTime
     , ticketUpdated      :: Maybe UTCTime
@@ -735,7 +766,7 @@ data Ticket = Ticket
     , ticketSummary      :: TextHtml
     , ticketContent      :: TextHtml
     , ticketSource       :: TextPandocMarkdown
-    , ticketAssignedTo   :: Maybe FedURI
+    , ticketAssignedTo   :: Maybe (ObjURI u)
     , ticketIsResolved   :: Bool
     }
 
@@ -755,9 +786,9 @@ instance ActivityPub Ticket where
         unless (sourceType == ("text/markdown; variant=Pandoc" :: Text)) $
             fail "source mediaType isn't Pandoc Markdown"
 
-        (h, attributedTo) <- f2l <$> o .: "attributedTo"
+        ObjURI a attributedTo <- o .: "attributedTo"
 
-        fmap (h,) $
+        fmap (a,) $
             Ticket
                 <$> parseTicketLocal o
                 <*> pure attributedTo
@@ -770,13 +801,13 @@ instance ActivityPub Ticket where
                 <*> o .:? "assignedTo"
                 <*> o .: "isResolved"
 
-    toSeries host
+    toSeries authority
         (Ticket local attributedTo published updated name summary content
                 source assignedTo isResolved)
 
             =   maybe mempty (uncurry encodeTicketLocal) local
             <> "type"         .=  ("Ticket" :: Text)
-            <> "attributedTo" .=  l2f host attributedTo
+            <> "attributedTo" .=  ObjURI authority attributedTo
             <> "published"    .=? published
             <> "updated"      .=? updated
             <> "name"         .=? name
@@ -790,131 +821,130 @@ instance ActivityPub Ticket where
             <> "assignedTo"   .=? assignedTo
             <> "isResolved"   .=  isResolved
 
-data Accept = Accept
-    { acceptObject :: FedURI
+data Accept u = Accept
+    { acceptObject :: ObjURI u
     , acceptResult :: LocalURI
     }
 
-parseAccept :: Text -> Object -> Parser Accept
-parseAccept h o =
+parseAccept :: UriMode u => Authority u -> Object -> Parser (Accept u)
+parseAccept a o =
     Accept
         <$> o .: "object"
-        <*> (withHost h $ f2l <$> o .: "result")
+        <*> withAuthorityO a (o .: "result")
 
-encodeAccept :: Text -> Accept -> Series
-encodeAccept host (Accept obj result)
+encodeAccept :: UriMode u => Authority u -> Accept u -> Series
+encodeAccept authority (Accept obj result)
     =  "object" .= obj
-    <> "result" .= l2f host result
+    <> "result" .= ObjURI authority result
 
-data Create = Create
-    { createObject :: Note
+data Create u = Create
+    { createObject :: Note u
     }
 
-parseCreate :: Object -> Text -> LocalURI -> Parser Create
-parseCreate o h luActor = do
-    note <- withHost h $ parseObject =<< o .: "object"
+parseCreate :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Create u)
+parseCreate o a luActor = do
+    note <- withAuthorityT a $ parseObject =<< o .: "object"
     unless (luActor == noteAttrib note) $ fail "Create actor != Note attrib"
     return $ Create note
 
-encodeCreate :: Text -> LocalURI -> Create -> Series
-encodeCreate host actor (Create obj) =
-    "object" `pair` pairs (toSeries host obj)
+encodeCreate :: UriMode u => Authority u -> LocalURI -> Create u -> Series
+encodeCreate authority actor (Create obj) =
+    "object" `pair` pairs (toSeries authority obj)
 
-data Follow = Follow
-    { followObject :: FedURI
+data Follow u = Follow
+    { followObject :: ObjURI u
     , followHide   :: Bool
     }
 
-parseFollow :: Object -> Parser Follow
+parseFollow :: UriMode u => Object -> Parser (Follow u)
 parseFollow o =
     Follow
         <$> o .: "object"
         <*> o .: "hide"
 
-encodeFollow :: Follow -> Series
+encodeFollow :: UriMode u => Follow u -> Series
 encodeFollow (Follow obj hide)
     =  "object" .= obj
     <> "hide"   .= hide
 
-data Offer = Offer
-    { offerObject :: Ticket
-    , offerTarget :: FedURI
+data Offer u = Offer
+    { offerObject :: Ticket u
+    , offerTarget :: ObjURI u
     }
 
-parseOffer :: Object -> Text -> LocalURI -> Parser Offer
-parseOffer o h luActor = do
-    ticket <- withHost h $ parseObject =<< o .: "object"
+parseOffer :: UriMode u => Object -> Authority u -> LocalURI -> Parser (Offer u)
+parseOffer o a luActor = do
+    ticket <- withAuthorityT a $ parseObject =<< o .: "object"
     unless (luActor == ticketAttributedTo ticket) $
         fail "Offer actor != Ticket attrib"
-    target <- o .: "target"
-    for_ (ticketLocal ticket) $ \ (host, local) -> do
-        let (hTarget, luTarget) = f2l target
-        unless (hTarget == host) $
+    target@(ObjURI hTarget luTarget) <- o .: "target"
+    for_ (ticketLocal ticket) $ \ (authority, local) -> do
+        unless (hTarget == authority) $
             fail "Offer target host != Ticket local host"
         unless (luTarget == ticketContext local) $
             fail "Offer target != Ticket context"
     return $ Offer ticket target
 
-encodeOffer :: Text -> LocalURI -> Offer -> Series
-encodeOffer host actor (Offer obj target)
-    =  "object" `pair` pairs (toSeries host obj)
+encodeOffer :: UriMode u => Authority u -> LocalURI -> Offer u -> Series
+encodeOffer authority actor (Offer obj target)
+    =  "object" `pair` pairs (toSeries authority obj)
     <> "target" .= target
 
-data Reject = Reject
-    { rejectObject :: FedURI
+data Reject u = Reject
+    { rejectObject :: ObjURI u
     }
 
-parseReject :: Object -> Parser Reject
+parseReject :: UriMode u => Object -> Parser (Reject u)
 parseReject o = Reject <$> o .: "object"
 
-encodeReject :: Reject -> Series
+encodeReject :: UriMode u => Reject u -> Series
 encodeReject (Reject obj) = "object" .= obj
 
-data SpecificActivity
-    = AcceptActivity Accept
-    | CreateActivity Create
-    | FollowActivity Follow
-    | OfferActivity  Offer
-    | RejectActivity Reject
+data SpecificActivity u
+    = AcceptActivity (Accept u)
+    | CreateActivity (Create u)
+    | FollowActivity (Follow u)
+    | OfferActivity  (Offer u)
+    | RejectActivity (Reject u)
 
-data Activity = Activity
+data Activity u = Activity
     { activityId       :: Maybe LocalURI
     , activityActor    :: LocalURI
     , activitySummary  :: Maybe TextHtml
-    , activityAudience :: Audience
-    , activitySpecific :: SpecificActivity
+    , activityAudience :: Audience u
+    , activitySpecific :: SpecificActivity u
     }
 
 instance ActivityPub Activity where
     jsonldContext _ = [as2Context, forgeContext, extContext]
     parseObject o = do
-        (h, actor) <- f2l <$> o .: "actor"
-        fmap (h,) $
+        ObjURI a actor <- o .: "actor"
+        fmap (a,) $
             Activity
-                <$> withHostMaybe h (fmap f2l <$> o .:? "id")
+                <$> withAuthorityMaybeO a (o .:? "id")
                 <*> pure actor
                 <*> (fmap (TextHtml . sanitizeBalance) <$> o .:? "summary")
                 <*> parseAudience o
                 <*> do
                     typ <- o .: "type"
                     case typ of
-                        "Accept" -> AcceptActivity <$> parseAccept h o
-                        "Create" -> CreateActivity <$> parseCreate o h actor
+                        "Accept" -> AcceptActivity <$> parseAccept a o
+                        "Create" -> CreateActivity <$> parseCreate o a actor
                         "Follow" -> FollowActivity <$> parseFollow o
-                        "Offer"  -> OfferActivity  <$> parseOffer o h actor
+                        "Offer"  -> OfferActivity  <$> parseOffer o a actor
                         "Reject" -> RejectActivity <$> parseReject o
                         _ ->
                             fail $
                                 "Unrecognized activity type: " ++ T.unpack typ
-    toSeries host (Activity id_ actor summary audience specific)
+    toSeries authority (Activity id_ actor summary audience specific)
         =  "type"    .=  activityType specific
-        <> "id"      .=? (l2f host <$> id_)
-        <> "actor"   .=  l2f host actor
+        <> "id"      .=? (ObjURI authority <$> id_)
+        <> "actor"   .=  ObjURI authority actor
         <> "summary" .=? summary
         <> encodeAudience audience
-        <> encodeSpecific host actor specific
+        <> encodeSpecific authority actor specific
         where
-        activityType :: SpecificActivity -> Text
+        activityType :: SpecificActivity u -> Text
         activityType (AcceptActivity _) = "Accept"
         activityType (CreateActivity _) = "Create"
         activityType (FollowActivity _) = "Follow"
@@ -961,14 +991,15 @@ instance Exception APGetError
 -- * Verify the _Content-Type_ response header
 -- * Parse the JSON response body
 httpGetAP
-    :: (MonadIO m, FromJSON a)
+    :: (MonadIO m, UriMode u, FromJSON a)
     => Manager
-    -> FedURI
+    -> Either (ObjURI u) (SubURI u)
     -> m (Either APGetError (Response a))
 httpGetAP manager uri =
     liftIO $
         mkResult <$> try (httpAPEither manager =<< requestFromURI (toURI uri))
     where
+    toURI = either uriFromObjURI uriFromSubURI
     lookup' x = map snd . filter ((== x) . fst)
     mkResult (Left e)  = Left $ APGetErrorHTTP e
     mkResult (Right r) =
@@ -1011,14 +1042,14 @@ hForwardedSignature = "Forwarded-Signature"
 -- * Perform the POST request
 -- * Verify the response status is 2xx
 httpPostAP
-    :: (MonadIO m, ToJSON a)
+    :: (MonadIO m, UriMode u, ToJSON a)
     => Manager
-    -> FedURI
+    -> ObjURI u
     -> NonEmpty HeaderName
     -> S.KeyId
     -> (ByteString -> S.Signature)
     -> Text
-    -> Maybe (Either FedURI ByteString)
+    -> Maybe (Either (ObjURI u) ByteString)
     -> a
     -> m (Either APPostError (Response ()))
 httpPostAP manager uri headers keyid sign uSender mfwd value =
@@ -1027,19 +1058,19 @@ httpPostAP manager uri headers keyid sign uSender mfwd value =
 -- | Like 'httpPostAP', except it takes the object as a raw lazy
 -- 'BL.ByteString'. It's your responsibility to make sure it's valid JSON.
 httpPostAPBytes
-    :: MonadIO m
+    :: (MonadIO m, UriMode u)
     => Manager
-    -> FedURI
+    -> ObjURI u
     -> NonEmpty HeaderName
     -> S.KeyId
     -> (ByteString -> S.Signature)
     -> Text
-    -> Maybe (Either FedURI ByteString)
+    -> Maybe (Either (ObjURI u) ByteString)
     -> BL.ByteString
     -> m (Either APPostError (Response ()))
 httpPostAPBytes manager uri headers keyid sign uSender mfwd body =
     liftIO $ runExceptT $ do
-        req <- requestFromURI $ toURI uri
+        req <- requestFromURI $ uriFromObjURI uri
         let digest = formatHttpBodyDigest SHA256 "SHA-256" $ hashlazy body
             req' =
                 setRequestCheckStatus $
@@ -1055,7 +1086,7 @@ httpPostAPBytes manager uri headers keyid sign uSender mfwd body =
                 Nothing -> return req''
                 Just (Left uRecip) ->
                     tryExceptT APPostErrorSig $
-                        signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign Nothing $ consHeader hActivityPubForwarder (encodeUtf8 $ renderFedURI uRecip) req''
+                        signRequestInto hForwardingSignature (hDigest :| [hActivityPubForwarder]) Nothing keyid sign Nothing $ consHeader hActivityPubForwarder (encodeUtf8 $ renderObjURI uRecip) req''
                 Just (Right sig) ->
                     return $
                         consHeader hForwardedSignature sig $
@@ -1087,10 +1118,10 @@ data Fetched = Fetched
       --   we received.
     }
 
-fetchAP' :: (MonadIO m, FromJSON a) => Manager -> FedURI -> ExceptT APGetError m a
+fetchAP' :: (MonadIO m, UriMode u, FromJSON a) => Manager -> Either (ObjURI u) (SubURI u) -> ExceptT APGetError m a
 fetchAP' m u = ExceptT $ second responseBody <$> httpGetAP m u
 
-fetchAP :: (MonadIO m, FromJSON a) => Manager -> FedURI -> ExceptT String m a
+fetchAP :: (MonadIO m, UriMode u, FromJSON a) => Manager -> Either (ObjURI u) (SubURI u) -> ExceptT String m a
 fetchAP m u = withExceptT displayException $ fetchAP' m u
 
 {-
@@ -1102,20 +1133,20 @@ fetchAPH m h lu = do
         else throwE "Object @id URI's host doesn't match the URI we fetched"
 -}
 
-fetchAPID' :: (MonadIO m, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either (Maybe APGetError) a)
+fetchAPID' :: (MonadIO m, UriMode u, ActivityPub a) => Manager -> (a u -> LocalURI) -> Authority u -> LocalURI -> m (Either (Maybe APGetError) (a u))
 fetchAPID' m getId h lu = runExceptT $ do
-    Doc h' v <- withExceptT Just $ fetchAP' m $ l2f h lu
+    Doc h' v <- withExceptT Just $ fetchAP' m $ Left $ ObjURI h lu
     if h == h' && getId v == lu
         then return v
         else throwE Nothing
 
-fetchRecipient :: MonadIO m => Manager -> Text -> LocalURI -> m (Either (Maybe APGetError) Recipient)
+fetchRecipient :: (MonadIO m, UriMode u) => Manager -> Authority u -> LocalURI -> m (Either (Maybe APGetError) (Recipient u))
 fetchRecipient m = fetchAPID' m getId
     where
     getId (RecipientActor a)      = actorId a
     getId (RecipientCollection c) = collectionId c
 
-fetchAPID :: (MonadIO m, ActivityPub a) => Manager -> (a -> LocalURI) -> Text -> LocalURI -> m (Either String a)
+fetchAPID :: (MonadIO m, UriMode u, ActivityPub a) => Manager -> (a u -> LocalURI) -> Authority u -> LocalURI -> m (Either String (a u))
 fetchAPID m getId h lu = first showError <$> fetchAPID' m getId h lu
     where
     showError Nothing  = "Object @id doesn't match the URI we fetched"
@@ -1130,17 +1161,17 @@ data FetchAPError
     deriving Show
 
 fetchAPIDOrH'
-    :: (MonadIO m, ActivityPub a, ActivityPub b)
+    :: (MonadIO m, UriMode u, ActivityPub a, ActivityPub b)
     => Manager
-    -> (a -> LocalURI)
-    -> Text
-    -> LocalURI
-    -> ExceptT FetchAPError m (Either a b)
-fetchAPIDOrH' m getId h lu = do
-    e <- withExceptT FetchAPErrorGet $ fetchAP' m $ l2f h lu
+    -> (a u -> LocalRefURI)
+    -> Authority u
+    -> LocalRefURI
+    -> ExceptT FetchAPError m (Either (a u) (b u))
+fetchAPIDOrH' m getId h (LocalRefURI lu) = do
+    e <- withExceptT FetchAPErrorGet $ fetchAP' m $ bimap (ObjURI h) (SubURI h) lu
     case e of
         Left' (Doc h' x) ->
-            if h == h' && getId x == lu
+            if h == h' && getId x == LocalRefURI lu
                 then return $ Left x
                 else throwE FetchAPErrorIdMismatch
         Right' (Doc h' y) ->
@@ -1149,31 +1180,41 @@ fetchAPIDOrH' m getId h lu = do
                 else throwE FetchAPErrorHostMismatch
 
 fetchAPIDOrH
-    :: (MonadIO m, ActivityPub a, ActivityPub b)
+    :: (MonadIO m, UriMode u, ActivityPub a, ActivityPub b)
     => Manager
-    -> (a -> LocalURI)
-    -> Text
-    -> LocalURI
-    -> ExceptT String m (Either a b)
+    -> (a u -> LocalRefURI)
+    -> Authority u
+    -> LocalRefURI
+    -> ExceptT String m (Either (a u) (b u))
 fetchAPIDOrH m getId h lu = withExceptT show $ fetchAPIDOrH' m getId h lu
 
 -- | Fetches the given actor and checks whether it lists the given key (as a
 -- URI, not as an embedded object). If it does, returns 'Right' the fetched
 -- actor. Otherwise, or if an error occurs during fetching, returns 'Left' an
 -- error message.
-keyListedByActor :: MonadIO m => Manager -> Text -> LocalURI -> LocalURI -> m (Either String Actor)
+keyListedByActor
+    :: (MonadIO m, UriMode u)
+    => Manager
+    -> Authority u
+    -> LocalRefURI
+    -> LocalURI
+    -> m (Either String (Actor u))
 keyListedByActor manager host luKey luActor = runExceptT $ do
     actor <- ExceptT $ fetchAPID manager actorId host luActor
     if keyUriListed luKey actor
         then return actor
         else throwE "Actor publicKey has no URI matching pkey @id"
     where
-    keyUriListed uk a =
-        let match (Left uri) = uri == uk
+    keyUriListed (LocalRefURI uk) a =
+        let match (Left uri) = Left uri == uk
             match (Right _)  = False
         in  any match $ actorPublicKeys a
 
-matchKeyObj :: (Foldable f, Monad m) => LocalURI -> f (Either LocalURI PublicKey) -> ExceptT String m PublicKey
+matchKeyObj
+    :: (Foldable f, Monad m, UriMode u)
+    => LocalRefURI
+    -> f (Either LocalURI (PublicKey u))
+    -> ExceptT String m (PublicKey u)
 matchKeyObj luKey es =
     case find' (match luKey) es of
         Nothing -> throwE "keyId resolved to actor which doesn't have a key object with that ID"
@@ -1214,16 +1255,16 @@ verifyAlgo (Just a) k =
 
 -- | Fetch a key we don't have cached locally.
 fetchUnknownKey
-    :: MonadIO m
+    :: (MonadIO m, UriMode u)
     => Manager
     -- ^ Manager for making HTTP requests
     -> Maybe S.Algorithm
     -- ^ Signature algorithm possibly specified in the HTTP signature header
-    -> Text
+    -> Authority u
     -- ^ Instance host
     -> Maybe LocalURI
     -- ^ Actor URI possibly provided in the HTTP request's actor header
-    -> LocalURI
+    -> LocalRefURI
     -- ^ Key URI provided in HTTP signature header
     -> ExceptT String m Fetched
 fetchUnknownKey manager malgo host mluActor luKey = do
@@ -1253,9 +1294,10 @@ fetchUnknownKey manager malgo host mluActor luKey = do
                     , fetchedKeyShared  = oi
                     }
             Right actor -> do
-                if actorId actor == luKey { luriFragment = "" }
-                    then return ()
-                    else throwE "Actor ID doesn't match the keyid URI we fetched"
+                case luKey of
+                    LocalRefURI (Right lsu) |
+                        actorId actor == localSubUriResource lsu -> return ()
+                    _ -> throwE "Actor ID doesn't match the keyid URI we fetched"
                 for_ mluActor $ \ lu ->
                     if actorId actor == lu
                         then return ()
@@ -1283,19 +1325,19 @@ keyDetail pk = (publicKeyMaterial pk, publicKeyExpires pk)
 -- | Fetch a personal key we already have cached locally, but we'd like to
 -- refresh the local copy by fetching the key again from the server.
 fetchKnownPersonalKey
-    :: MonadIO m
+    :: (MonadIO m, UriMode u)
     => Manager
     -- ^ Manager for making HTTP requests
     -> Maybe S.Algorithm
     -- ^ Signature algorithm possibly specified in the HTTP signature header
-    -> Text
+    -> Authority u
     -- ^ Instance host
     -> LocalURI
     -- ^ Key owner actor ID URI
-    -> LocalURI
+    -> LocalRefURI
     -- ^ Key URI
     -> ExceptT String m (PublicVerifKey, Maybe UTCTime)
-fetchKnownPersonalKey manager malgo host luOwner luKey = do
+fetchKnownPersonalKey manager malgo host luOwner luKey@(LocalRefURI ek) = do
     obj <- fetchAPIDOrH manager publicKeyId host luKey
     (material, mexpires) <-
         case obj of
@@ -1306,9 +1348,9 @@ fetchKnownPersonalKey manager malgo host luOwner luKey = do
                         when (luOwner /= owner) $ throwE "Key owner changed"
                 return $ keyDetail pkey
             Right actor -> do
-                when (actorId actor /= luKey { luriFragment = "" }) $
+                unless (Right (actorId actor) == second localSubUriResource ek) $
                     throwE "Actor ID doesn't match the keyid URI we fetched"
-                when (actorId actor /= luOwner) $
+                unless (actorId actor == luOwner) $
                     throwE "Key owner changed"
                 pk <- matchKeyObj luKey $ actorPublicKeys actor
                 case publicKeyOwner pk of
@@ -1323,22 +1365,22 @@ fetchKnownPersonalKey manager malgo host luOwner luKey = do
 -- | Fetch a shared key we already have cached locally, but we'd like to
 -- refresh the local copy by fetching the key again from the server.
 fetchKnownSharedKey
-    :: MonadIO m
+    :: (MonadIO m, UriMode u)
     => Manager
     -- ^ Manager for making HTTP requests
     -> Maybe S.Algorithm
     -- ^ Signature algorithm possibly specified in the HTTP signature header
-    -> Text
+    -> Authority u
     -- ^ Instance host
     -> LocalURI
     -- ^ Actor ID from HTTP actor header
-    -> LocalURI
+    -> LocalRefURI
     -- ^ Key URI
     -> ExceptT String m (PublicVerifKey, Maybe UTCTime)
 fetchKnownSharedKey manager malgo host luActor luKey = do
     obj <- fetchAPIDOrH manager publicKeyId host luKey
     pkey <-
-        case obj :: Either PublicKey Actor of
+        case asKeyOrActor host obj of
             Left pk -> return pk
             Right _actor -> throwE "Expected stand-alone key, got embedded key"
     case publicKeyOwner pkey of
@@ -1347,3 +1389,9 @@ fetchKnownSharedKey manager malgo host luActor luKey = do
     let (material, mexpires) = keyDetail pkey
     ExceptT . pure $ verifyAlgo malgo material
     return (material, mexpires)
+    where
+    asKeyOrActor
+        :: Authority u
+        -> Either (PublicKey u) (Actor u)
+        -> Either (PublicKey u) (Actor u)
+    asKeyOrActor _ = id
diff --git a/src/Yesod/ActivityPub.hs b/src/Yesod/ActivityPub.hs
index 13d2262..9cb12a6 100644
--- 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
diff --git a/src/Yesod/FedURI.hs b/src/Yesod/FedURI.hs
index 54ea8e6..50a8cd8 100644
--- 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
diff --git a/templates/default-layout.hamlet b/templates/default-layout.hamlet
index 4ae0091..09804b4 100644
--- a/templates/default-layout.hamlet
+++ b/templates/default-layout.hamlet
@@ -52,7 +52,7 @@ $if federationDisabled
             #{h}
 
 <.instance>
-  Vervis @ #{instanceHost}
+  Vervis @ #{renderAuthority instanceHost}
 
 ^{breadcrumbsW}
 
diff --git a/templates/discussion/widget/message.hamlet b/templates/discussion/widget/message.hamlet
index e9824fb..be5b8e3 100644
--- 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}
diff --git a/templates/widget/actor-link.hamlet b/templates/widget/actor-link.hamlet
index c22ca27..1beb92a 100644
--- 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
diff --git a/vervis.cabal b/vervis.cabal
index e18fcfc..5369593 100644
--- 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