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

@@ -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
 

migrations/2019_05_24.model

@@ -43,7 +43,7 @@ LocalMessage
     UniqueLocalMessage rest
 
 Instance
-    host Text
+    host Host
 
     UniqueInstance host
 

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

src/Network/FedURI.hs

@@ -16,165 +16,325 @@
 {-# LANGUAGE DeriveGeneric #-}
 
 module Network.FedURI
-    ( FedURI (..)
+    ( Authority (..)
-    , parseFedURI
+    , renderAuthority
-    , toURI
-    , renderFedURI
-
-    {-
-    , InstanceURI (..)
-    , i2f
-    , f2i
-    -}
-
     , LocalURI (..)
-    , l2f
+    , topLocalURI
-    , f2l
+    , LocalSubURI (..)
-
-    , FedPageURI (..)
     , LocalPageURI (..)
-    , lp2fp
+    , LocalRefURI (..)
-    , fp2lp
+    , 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 Data.Word
-import Database.Persist.Sql (PersistFieldSql (..))
+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:
+data Scheme = Plain | Secure deriving Eq
---
+
--- * The scheme is HTTPS
+data Full
--- * The authority part is present
+
--- * The authority part doesn't have userinfo
+data Authority t = Authority
--- * The authority host needs to match certain rules
+    { authorityHost :: Text
--- * The authority part doesn't have a port number
+    , authorityPort :: Maybe Word16
--- * There is no query part
--- * A fragment part may be present
-data FedURI = FedURI
-    { furiHost     :: Text
-    , furiPath     :: Text
-    , furiFragment :: Text
     }
-    deriving (Eq, Generic)
+    deriving (Eq, Ord, Generic)
 
-instance Hashable FedURI
+instance UriMode t => Hashable (Authority t)
 
-instance FromJSON FedURI where
+parseAuthority :: UriMode t => Text -> Either String (Authority t)
-    parseJSON = withText "FedURI" $ either fail return . parseFedURI
+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
+renderAuthority :: Authority t -> Text
-    toJSON = error "toJSON FedURI"
+renderAuthority (Authority h Nothing)  = h
-    toEncoding = toEncoding . renderFedURI
+renderAuthority (Authority h (Just p)) = T.concat [h, ":", T.pack $ show p]
 
-instance PersistField FedURI where
+instance UriMode t => FromJSON (Authority t) where
-    toPersistValue = toPersistValue . renderFedURI
+    parseJSON = withText "Authority" $ either fail return . parseAuthority
-    fromPersistValue = first T.pack . parseFedURI <=< fromPersistValue
 
-instance PersistFieldSql FedURI where
+instance UriMode t => ToJSON (Authority t) where
-    sqlType = sqlType . fmap renderFedURI
+    toJSON = toJSON . renderAuthority
+    toEncoding = toEncoding . renderAuthority
 
-parseFedURI :: Text -> Either String FedURI
+instance UriMode t => PersistField (Authority t) where
-parseFedURI t = do
+    toPersistValue = toPersistValue . renderAuthority
-    uri <- case parseURI $ T.unpack t of
+    fromPersistValue = first T.pack . parseAuthority <=< fromPersistValue
-        Nothing -> Left "Invalid absolute URI"
+
-        Just u -> Right u
+instance UriMode t => PersistFieldSql (Authority t) where
-    if uriScheme uri == "https:"
+    sqlType = sqlType . fmap renderAuthority
-        then Right ()
+
-        else Left "URI scheme isn't https"
+data FullURI = FullURI
-    URIAuth ui h p <- case uriAuthority uri of
+    { fullUriScheme    :: Scheme
-        Nothing -> Left "URI has empty authority"
+    , fullUriAuthority :: Authority Full
-        Just a -> Right a
+    , fullUriPath      :: Text
-    if ui == ""
+    , fullUriQuery     :: Text
-        then Right ()
+    , fullUriFragment  :: Text
-        else Left "URI has non-empty userinfo"
+    }
-    if p == ""
+
-        then Right ()
+parseFullURI :: Text -> Either String FullURI
-        else Left "URI has non-empty port"
+parseFullURI t = do
-    if any (== '.') h
+    uri <-
-        then Right ()
+        case parseURI $ T.unpack t of
-        else Left "Host doesn't contain periods"
+            Nothing -> Left "Invalid absolute URI"
-    if any isAsciiLetter h
+            Just u -> Right u
-        then Right ()
+    scheme <-
-        else Left "Host doesn't contain ASCII letters"
+        case uriScheme uri of
-    if uriQuery uri == ""
+            "http:" -> Right Plain
-        then Right ()
+            "https:" -> Right Secure
-        else Left "URI query is non-empty"
+            _ -> Left "URI scheme isn't http/s"
-    Right FedURI
+    URIAuth userInfo host port <-
-        { furiHost     = T.pack h
+        case uriAuthority uri of
-        , furiPath     = T.pack $ uriPath uri
+            Nothing -> Left "URI has empty authority"
-        , furiFragment = T.pack $ uriFragment uri
+            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
+fromFullURI :: FullURI -> URI
-toURI (FedURI h p f) = URI
+fromFullURI (FullURI scheme (Authority host mport) path query fragment) = URI
-    { uriScheme    = "https:"
+    { uriScheme    =
-    , uriAuthority = Just $ URIAuth "" (T.unpack h) ""
+        case scheme of
-    , uriPath      = T.unpack p
+            Plain -> "http:"
-    , uriQuery     = ""
+            Secure -> "https:"
-    , uriFragment  = T.unpack f
+    , 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
+renderFullURI :: FullURI -> Text
-renderFedURI = T.pack . flip (uriToString id) "" . toURI
+renderFullURI = T.pack . flip (uriToString id) "" . fromFullURI
 
--- | A 'FedURI' with a page number specified as a query parameter
+instance FromJSON FullURI where
-data FedPageURI = FedPageURI
+    parseJSON = withText "FullURI" $ either fail return . parseFullURI
-    { fpuriResource :: FedURI
+
-    , fpuriParam    :: Text
+instance ToJSON FullURI where
-    , fpuriPage     :: Int
+    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
+dummyAuthority :: Authority Fed
-    parseJSON = withText "FedPageURI" $ either fail return . parseFedPageURI
+dummyAuthority = Authority "h.h" Nothing
 
-instance ToJSON FedPageURI where
+dummyPrefix :: Text
-    toJSON = error "toJSON FedPageURI"
+dummyPrefix = renderObjURI $ ObjURI dummyAuthority topLocalURI
-    toEncoding = toEncoding . renderFedPageURI
 
-parseFedPageURI :: Text -> Either String FedPageURI
+instance PersistField LocalURI where
-parseFedPageURI t = do
+    toPersistValue = toPersistValue . renderLocalURI
-    uri <- case parseURI $ T.unpack t of
+        where
-        Nothing -> Left "Invalid absolute URI"
+        renderLocalURI
-        Just u -> Right u
+            = fromJust
-    if uriScheme uri == "https:"
+            . T.stripPrefix dummyPrefix
-        then Right ()
+            . renderObjURI
-        else Left "URI scheme isn't https"
+            . ObjURI dummyAuthority
-    URIAuth ui h p <- case uriAuthority uri of
+    fromPersistValue
-        Nothing -> Left "URI has empty authority"
+        =   bimap T.pack objUriLocal . parseObjURI' . (dummyPrefix <>)
-        Just a -> Right a
+        <=< fromPersistValue
-    if ui == ""
+        where
-        then Right ()
+        parseObjURI' :: Text -> Either String (ObjURI Fed)
-        else Left "URI has non-empty userinfo"
+        parseObjURI' = parseObjURI
-    if p == ""
+
-        then Right ()
+instance PersistFieldSql LocalURI where
-        else Left "URI has non-empty port"
+    sqlType = sqlType . fmap localUriPath
-    if any (== '.') h
+
-        then Right ()
+topLocalURI :: LocalURI
-        else Left "Host doesn't contain periods"
+topLocalURI = LocalURI ""
-    if any isAsciiLetter h
+
-        then Right ()
+data FullObjURI = FullObjURI
-        else Left "Host doesn't contain ASCII letters"
+    { _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
+    unless (page >= 1) $
-        then Right ()
+        Left "URI page number isn't positive"
-        else Left "URI page number isn't positive"
+    unless (f == "") $
-    Right FedPageURI
+        Left "URI fragment is non-empty"
-        { fpuriResource = FedURI
+    Right $ FullPageURI s a $ LocalPageURI (LocalURI p) param page
-            { furiHost     = T.pack h
+
-            , furiPath     = T.pack $ uriPath uri
+fromFullPageURI :: FullPageURI -> FullURI
-            , furiFragment = T.pack $ uriFragment uri
+fromFullPageURI (FullPageURI s a (LocalPageURI (LocalURI p) param page)) =
-            }
+    FullURI s a p q ""
-        , fpuriParam = param
-        , fpuriPage  = page
-        }
     where
-    isAsciiLetter c = isAsciiLower c || isAsciiUpper c
+    q = T.concat ["?", param, "=", T.pack $ show page]
 
-toPageURI :: FedPageURI -> URI
+instance FromJSON FullPageURI where
-toPageURI (FedPageURI (FedURI h p f) qp qv) = URI
+    parseJSON = either fail return . toFullPageURI <=< parseJSON
-    { uriScheme    = "https:"
+
-    , uriAuthority = Just $ URIAuth "" (T.unpack h) ""
+instance ToJSON FullPageURI where
-    , uriPath      = T.unpack p
+    toJSON = toJSON . fromFullPageURI
-    , uriQuery     = "?" ++ T.unpack qp ++ "=" ++ show qv
+    toEncoding = toEncoding . fromFullPageURI
-    , uriFragment  = T.unpack f
+
+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
+toFullRefURI :: FullURI -> Either String FullRefURI
-renderFedPageURI = T.pack . flip (uriToString id) "" . toPageURI
+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
 
-{-
+fromFullRefURI :: FullRefURI -> FullURI
-newtype InstanceURI = InstanceURI
+fromFullRefURI (FullRefURI s a (LocalRefURI e)) =
-    { iuriHost :: Text
+    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
+instance UriMode t => Hashable (ObjURI t)
-i2f (InstanceURI h) = FedURI h "" ""
 
-f2i :: FedURI -> InstanceURI
+toObjURI :: UriMode t => FullObjURI -> Either String (ObjURI t)
-f2i = InstanceURI . furiHost
+toObjURI (FullObjURI s a l) = flip ObjURI l <$> checkAuthority s a
--}
 
-data LocalURI = LocalURI
+fromObjURI :: UriMode t => ObjURI t -> FullObjURI
-    { luriPath     :: Text
+fromObjURI (ObjURI a l) = FullObjURI (authorityScheme a) (toFull a) l
-    , luriFragment :: Text
+
+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
+instance UriMode t => Hashable (SubURI t)
-dummyHost = "h.h"
 
-dummyPrefix :: Text
+toSubURI :: UriMode t => FullSubURI -> Either String (SubURI t)
-dummyPrefix = "https://" <> dummyHost
+toSubURI (FullSubURI s a l) = flip SubURI l <$> checkAuthority s a
 
-renderLocalURI :: LocalURI -> Text
+fromSubURI :: UriMode t => SubURI t -> FullSubURI
-renderLocalURI = fromJust . T.stripPrefix dummyPrefix . renderFedURI . l2f dummyHost
+fromSubURI (SubURI a l) = FullSubURI (authorityScheme a) (toFull a) l
 
-instance PersistField LocalURI where
+uriFromSubURI :: UriMode t => SubURI t -> URI
-    toPersistValue = toPersistValue . renderLocalURI
+uriFromSubURI = fromFullURI . fromFullSubURI . fromSubURI
-    fromPersistValue = bimap T.pack (snd . f2l) . parseFedURI . (dummyPrefix <>) <=< fromPersistValue
 
-instance PersistFieldSql LocalURI where
+instance UriMode t => FromJSON (SubURI t) where
-    sqlType = sqlType . fmap renderLocalURI
+    parseJSON = either fail return . toSubURI <=< parseJSON
 
-l2f :: Text -> LocalURI -> FedURI
+instance UriMode t => ToJSON (SubURI t) where
-l2f h (LocalURI p f) = FedURI h p f
+    toJSON = toJSON . fromSubURI
+    toEncoding = toEncoding . fromSubURI
 
-f2l :: FedURI -> (Text, LocalURI)
+instance UriMode t => PersistField (SubURI t) where
-f2l (FedURI h p f) = (h, LocalURI p f)
+    toPersistValue = toPersistValue . fromSubURI
+    fromPersistValue = first T.pack . toSubURI <=< fromPersistValue
 
-data LocalPageURI = LocalPageURI
+instance UriMode t => PersistFieldSql (SubURI t) where
-    { lpuriResource :: LocalURI
+    sqlType = sqlType . fmap fromSubURI
-    , lpuriParam    :: Text
+
-    , lpuriPage     :: Int
+data PageURI t = PageURI
+    { pageUriAuthority :: Authority t
+    , pageUriLocal     :: LocalPageURI
     }
-    deriving Eq
+    deriving (Eq, Generic)
 
-lp2fp :: Text -> LocalPageURI -> FedPageURI
+instance UriMode t => Hashable (PageURI t)
-lp2fp h (LocalPageURI lu p n) = FedPageURI (l2f h lu) p n
 
-fp2lp :: FedPageURI -> (Text, LocalPageURI)
+toPageURI :: UriMode t => FullPageURI -> Either String (PageURI t)
-fp2lp (FedPageURI fu p n) =
+toPageURI (FullPageURI s a l) = flip PageURI l <$> checkAuthority s a
-    let (h, lu) = f2l fu
+
-    in  (h, LocalPageURI lu p n)
+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

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
+    -> Audience URIMode
-    -> Offer
+    -> 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")])

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
+        let (local, remote) = NE.partition ((== home) . objUriAuthority) recips
-        in  (map (snd . f2l) local, remote)
+        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
+    => Audience URIMode
-    -> ExceptT Text m (Maybe (LocalRecipientSet, [(Text, NonEmpty LocalURI)]))
+    -> 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 :: [FedURI] -> [(Host, NonEmpty LocalURI)]
-    groupByHost = groupAllExtract furiHost (snd . f2l)
+    groupByHost = groupAllExtract objUriAuthority objUriLocal

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, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-    -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-    -> [((InstanceId, Text), 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)]
+    -> [(Host, NonEmpty LocalURI)]
-    -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
     -> AppDB
-        ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
+        ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
-        , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+        , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
-        , [((InstanceId, Text), 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
+    -> Doc Activity URIMode
-    -> ( [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
+    -> ( [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, DeliveryId))]
-        , [((InstanceId, Text), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
+        , [((InstanceId, Host), NonEmpty (UnfetchedRemoteActorId, LocalURI, UnlinkedDeliveryId))]
-        , [((InstanceId, Text), 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]

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

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

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

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
+                ObjURI h lu <- parseObjURI t
-                if h == host
+                unless (h == host) $
-                    then Right ()
+                    Left "Key and actor have different hosts"
-                    else 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
-verifySelfSig luAuthor luKey input (Signature sig) = do
+    :: 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
+                        , renderObjURI $
-                        , "> != Signature key's actor <", renderFedURI uSender
+                            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
+                        [ "Activity host <", renderAuthority hActivity
-                        , "> doesn't match signature key host <", hSender, ">"
+                        , "> 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

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
+        let hAuthor = objUriAuthority $ remoteAuthorURI author
-            uNote = l2f hAuthor luNote
+            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

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

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

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

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)
+    deft = (Authority "forge.angeley.es" Nothing, text2shr "fr33", text2prj "sandbox", 1)
-    defp = FedURI "forge.angeley.es" "/s/fr33/m/2f1a7" ""
+    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}>
+                            <a href=#{renderObjURI $ encodeRouteFed h $ ProjectR shr prj}>
-                              #{h}/s/#{shr2text shr}/p/#{prj2text 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

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" ""
+            let localUri = LocalURI "/x/y"
-                fedUri = l2f "x.y" localUri
+                h = Authority "x.y" Nothing :: Host
-                doc = Doc "x.y" Activity
+                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 ""
+                                            ( ObjURI hLocal $ LocalURI tPath
-                                            , map (l2f hLocal . flip LocalURI "")
+                                            , 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 ""
+                                luAct = LocalURI obPath
-                                luNote = LocalURI notePath ""
+                                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" ""
+            let localUri = LocalURI "/x/y"
-                fedUri = l2f "x.y" localUri
+                h = Authority "x.y" Nothing :: Host
-                doc = Doc "x.y" Activity
+                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" ""
+            let localUri = LocalURI "/x/y"
-                fedUri = l2f "x.y" localUri
+                h = Authority "x.y" Nothing :: Host
-                doc = Doc "x.y" Activity
+                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

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")

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")
 

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
+    -> Host
-    -> LocalURI
+    -> 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

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"

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

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)

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
+class (Yesod site, SiteFedURI site) => YesodActivityPub site where
-    siteInstanceHost          :: site -> Text
+    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
+    => ObjURI u
-    -> Maybe FedURI
+    -> 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
+    => ObjURI u
-    -> Maybe FedURI
+    -> Maybe (ObjURI u)
-    -> Doc Activity
+    -> 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
+    => ObjURI u
-    -> Maybe FedURI
+    -> 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
+    => ObjURI u
-    -> Maybe FedURI
+    -> 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)
+    :: (YesodActivityPub site, SiteFedURIMode site ~ u, ActivityPub a)
-    => a -> WidgetFor site () -> HandlerFor site TypedContent
+    => a u -> WidgetFor site () -> HandlerFor site TypedContent
 provideHtmlAndAP object widget = do
     host <- getsYesod siteInstanceHost
     provideHtmlAndAP' host object widget
 
 provideHtmlAndAP'
-    :: (YesodActivityPub site, ActivityPub a)
+    :: (YesodActivityPub site, SiteFedURIMode site ~ u, ActivityPub a)
-    => Text -> a -> WidgetFor site () -> HandlerFor site TypedContent
+    => Authority u -> a u -> WidgetFor site () -> HandlerFor site TypedContent
 provideHtmlAndAP' host object widget = selectRep $ do
     let doc = Doc host object
     provideAP $ pure doc

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)
+class UriMode (SiteFedURIMode site) => SiteFedURI site where
-getEncodeRouteLocal = (\ f -> snd . f2l . f) <$> getEncodeRouteHome
+    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
+        case parseObjURI $ renderUrl route of
-            Left e -> error $ "getUrlRender produced invalid FedURI: " ++ e
+            Left e -> error $ "askUrlRender produced invalid ObjURI: " ++ e
             Right u -> u
 
-getEncodeRouteFed :: MonadSite m => m (Text -> Route (SiteEnv m) -> FedURI)
+getEncodeRouteLocal
-getEncodeRouteFed = toFed <$> askUrlRender
+    :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site)
-    where
+    => m (Route site -> LocalURI)
-    toFed renderUrl host route =
+getEncodeRouteLocal = (objUriLocal .) <$> getEncodeRouteHome
-        case parseFedURI $ renderUrl route of
+
-            Left e -> error $ "getUrlRender produced invalid FedURI: " ++ e
+getEncodeRouteFed
-            Right u -> u { furiHost = host }
+    :: ( 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
+    parseRoute . (,[]) . decodePathSegments . encodeUtf8 . localUriPath
-    where
-    noFrag lu =
-        if T.null $ luriFragment lu
-            then Just lu
-            else Nothing
 
 getEncodeRoutePageLocal
-    :: (MonadSite m, YesodPaginate (SiteEnv m))
+    :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, YesodPaginate site)
-    => m (Route (SiteEnv m) -> Int -> LocalPageURI)
+    => m (Route site -> Int -> LocalPageURI)
-getEncodeRoutePageLocal = do
+getEncodeRoutePageLocal =
-    encodeRouteLocal <- getEncodeRouteLocal
+    (\ f r n -> pageUriLocal $ f r n) <$> getEncodeRoutePageHome
-    param <- asksSite sitePageParamName
-    return $ \ route page -> LocalPageURI (encodeRouteLocal route) param page
 
 getEncodeRoutePageHome
-    :: (MonadSite m, YesodPaginate (SiteEnv m))
+    :: (MonadSite m, SiteEnv m ~ site, SiteFedURI site, YesodPaginate site)
-    => m (Route (SiteEnv m) -> Int -> FedPageURI)
+    => 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))
+    :: ( MonadSite m
-    => m (Text -> Route (SiteEnv m) -> Int -> FedPageURI)
+       , SiteEnv m ~ site
-getEncodeRoutePageFed = do
+       , SiteFedURI site
-    encodeRouteFed <- getEncodeRouteFed
+       , YesodPaginate site
-    param <- asksSite sitePageParamName
+       , SiteFedURIMode site ~ u
-    return $
+       )
-        \ host route page -> FedPageURI (encodeRouteFed host route) param page
+    => m (Authority u -> Route site -> Int -> PageURI u)
+getEncodeRoutePageFed =
+    (\ f a r n -> PageURI a $ f r n) <$> getEncodeRoutePageLocal

templates/default-layout.hamlet

@@ -52,7 +52,7 @@ $if federationDisabled
             #{h}
 
 <.instance>
-  Vervis @ #{instanceHost}
+  Vervis @ #{renderAuthority instanceHost}
 
 ^{breadcrumbsW}
 

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}

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

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