forge/Vervis
1
0
Fork 0
Code Pull requests Activity

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

Browse source 
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.
This commit is contained in:
fr33domlover 2019-07-23 13:59:48 +00:00
parent 84765e2b94
commit 8fc5c80dd6
30 changed files with 1240 additions and 750 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

4
config/models
View file

@ -106,7 +106,7 @@ Forwarding
UniqueForwarding recipient activity UniqueForwarding recipient activity
VerifKey VerifKey
ident LocalURI ident LocalRefURI
instance InstanceId instance InstanceId
expires UTCTime Maybe expires UTCTime Maybe
public PublicVerifKey public PublicVerifKey
@ -137,7 +137,7 @@ RemoteActor
UniqueRemoteActor instance ident UniqueRemoteActor instance ident
Instance Instance
host Text host Host
UniqueInstance host UniqueInstance host

2
migrations/2019_05_24.model
View file

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

6
src/Data/Aeson/Local.hs
View file

@ -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) (.:+) :: (FromJSON a, FromJSON b) => Object -> Text -> Parser (Either a b)
o .:+ t = Left <$> o .: t <|> Right <$> o .: t 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 .=? infixr 8 .=?
(.=?) :: ToJSON v => Text -> Maybe v -> Series (.=?) :: ToJSON v => Text -> Maybe v -> Series
_ .=? Nothing = mempty _ .=? Nothing = mempty

683
src/Network/FedURI.hs
View file

@ -16,165 +16,325 @@
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
module Network.FedURI module Network.FedURI
( FedURI (..) ( Authority (..)
, parseFedURI , renderAuthority
, toURI
, renderFedURI
{-
, InstanceURI (..)
, i2f
, f2i
-}
, LocalURI (..) , LocalURI (..)
, l2f , topLocalURI
, f2l , LocalSubURI (..)
, FedPageURI (..)
, LocalPageURI (..) , LocalPageURI (..)
, lp2fp , LocalRefURI (..)
, fp2lp , UriMode ()
, Fed ()
, Dev ()
, ObjURI (..)
, parseObjURI
, uriFromObjURI
, renderObjURI
, SubURI (..)
, uriFromSubURI
, PageURI (..)
, RefURI (..)
, parseRefURI
) )
where where
import Control.Monad ((<=<)) import Control.Monad
import Data.Aeson import Data.Aeson
import Data.Bifunctor (bimap, first) import Data.Bifunctor
import Data.Char import Data.Char
import Data.Hashable import Data.Hashable
import Data.Maybe (fromJust) import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding 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 GHC.Generics (Generic)
import Network.HTTP.Types.URI
import Network.URI
import Text.Read import Text.Read
import Network.HTTP.Types.URI
import Network.URI hiding (scheme, path, query, fragment)
import qualified Data.Text as T 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 where
isAsciiLetter c = isAsciiLower c || isAsciiUpper c 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) 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) <- (param, mval) <-
case parseQueryText $ encodeUtf8 $ T.pack $ uriQuery uri of case parseQueryText $ encodeUtf8 q of
[] -> Left "URI query is empty" [] -> Left "URI query is empty"
[qp] -> Right qp [qp] -> Right qp
_ -> Left "URI has multiple query parameters" _ -> Left "URI has multiple query parameters"
@ -186,85 +346,240 @@ parseFedPageURI t = do
case readMaybe $ T.unpack val of case readMaybe $ T.unpack val of
Nothing -> Left "URI query param value isn't an integer" Nothing -> Left "URI query param value isn't an integer"
Just n -> Right n 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 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

48
src/Vervis/API.hs
View file

@ -99,6 +99,7 @@ import Yesod.Persist.Local
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.ActorKey import Vervis.ActorKey
import Vervis.API.Recipient import Vervis.API.Recipient
import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident 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 -- | 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 -- 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'. -- 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 createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source content) = runExceptT $ do
verifyHostLocal host "Attributed to non-local actor" verifyHostLocal host "Attributed to non-local actor"
verifyNothingE mluNote "Note specifies an id" verifyNothingE mluNote "Note specifies an id"
@ -169,7 +170,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
mmidParent <- for mparent $ \ parent -> mmidParent <- for mparent $ \ parent ->
case parent of case parent of
Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
Right (hParent, luParent) -> do Right (ObjURI hParent luParent) -> do
mrm <- lift $ runMaybeT $ do mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent 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)) return (did, Left <$> mmidParent, Just (sid, ticketFollowers t, ibidProject, fsidProject))
Nothing -> do Nothing -> do
(rd, rdnew) <- lift $ do (rd, rdnew) <- lift $ do
let (hContext, luContext) = f2l uContext let ObjURI hContext luContext = uContext
iid <- either entityKey id <$> insertBy' (Instance hContext) iid <- either entityKey id <$> insertBy' (Instance hContext)
mrd <- getValBy $ UniqueRemoteDiscussionIdent iid luContext mrd <- getValBy $ UniqueRemoteDiscussionIdent iid luContext
case mrd of case mrd of
@ -203,12 +204,12 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
Left (shrParent, lmidParent) -> do Left (shrParent, lmidParent) -> do
when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new" when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new"
Left <$> getLocalParentMessageId did shrParent lmidParent Left <$> getLocalParentMessageId did shrParent lmidParent
Right (hParent, luParent) -> do Right p@(ObjURI hParent luParent) -> do
mrm <- lift $ runMaybeT $ do mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
case mrm of case mrm of
Nothing -> return $ Right $ l2f hParent luParent Nothing -> return $ Right p
Just rm -> Left <$> do Just rm -> Left <$> do
let mid = remoteMessageRest rm let mid = remoteMessageRest rm
m <- lift $ getJust mid m <- lift $ getJust mid
@ -222,15 +223,15 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
<p> <p>
<a href=@{SharerR shrUser}>#{shr2text shrUser} <a href=@{SharerR shrUser}>#{shr2text shrUser}
\ commented on a # \ 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 (lmid, obiid, doc) <- lift $ insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary
moreRemotes <- deliverLocal pid obiid localRecips mcollections moreRemotes <- deliverLocal pid obiid localRecips mcollections
unless (federation || null moreRemotes) $ unless (federation || null moreRemotes) $
throwE "Federation disabled but remote collection members found" 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) 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 return lmid
where where
nonEmptyE :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a) 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 :: FedURI
-> Maybe FedURI -> Maybe FedURI
-> ExceptT Text Handler -> ExceptT Text Handler
( Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)) ( Maybe (Either (ShrIdent, LocalMessageId) FedURI)
, [ShrIdent] , [ShrIdent]
, Maybe (ShrIdent, PrjIdent, Int) , Maybe (ShrIdent, PrjIdent, Int)
, [(Text, NonEmpty LocalURI)] , [(Host, NonEmpty LocalURI)]
) )
parseRecipsContextParent uContext muParent = do parseRecipsContextParent uContext muParent = do
(localsSet, remotes) <- do (localsSet, remotes) <- do
mrecips <- parseAudience aud mrecips <- parseAudience aud
fromMaybeE mrecips "Note without recipients" fromMaybeE mrecips "Note without recipients"
let (hContext, luContext) = f2l uContext let ObjURI hContext luContext = uContext
parent <- parseParent uContext muParent parent <- parseParent uContext muParent
local <- hostIsLocal hContext local <- hostIsLocal hContext
if local if local
@ -264,17 +265,17 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
shrs <- verifyOnlySharers localsSet shrs <- verifyOnlySharers localsSet
return (parent, shrs, Nothing, remotes) return (parent, shrs, Nothing, remotes)
where 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 _ Nothing = return Nothing
parseParent uContext (Just uParent) = parseParent uContext (Just uParent) =
if uParent == uContext if uParent == uContext
then return Nothing then return Nothing
else Just <$> do else Just <$> do
let (hParent, luParent) = f2l uParent let ObjURI hParent luParent = uParent
parentLocal <- hostIsLocal hParent parentLocal <- hostIsLocal hParent
if parentLocal if parentLocal
then Left <$> parseComment luParent then Left <$> parseComment luParent
else return $ Right (hParent, luParent) else return $ Right uParent
parseContextTicket :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent, Int) parseContextTicket :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent, Int)
parseContextTicket luContext = do parseContextTicket luContext = do
@ -326,7 +327,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
-> Text -> Text
-> Text -> Text
-> Html -> 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 insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
mid <- insert Message mid <- insert Message
@ -358,7 +359,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
} }
} }
} }
tempUri = LocalURI "" "" tempUri = topLocalURI
obiid <- insert OutboxItem obiid <- insert OutboxItem
{ outboxItemOutbox = obid { outboxItemOutbox = obid
, outboxItemActivity = , outboxItemActivity =
@ -391,7 +392,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
-> OutboxItemId -> OutboxItemId
-> [ShrIdent] -> [ShrIdent]
-> Maybe (SharerId, FollowerSetId, InboxId, FollowerSetId) -> 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 deliverLocal pidAuthor obid recips mticket = do
recipPids <- traverse getPersonId $ nub recips recipPids <- traverse getPersonId $ nub recips
when (pidAuthor `elem` recipPids) $ when (pidAuthor `elem` recipPids) $
@ -446,8 +447,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
offerTicketC offerTicketC
:: ShrIdent :: ShrIdent
-> TextHtml -> TextHtml
-> Audience -> Audience URIMode
-> Offer -> Offer URIMode
-> Handler (Either Text OutboxItemId) -> Handler (Either Text OutboxItemId)
offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT $ do offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT $ do
(hProject, shrProject, prjProject) <- parseTarget uTarget (hProject, shrProject, prjProject) <- parseTarget uTarget
@ -631,7 +632,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
, activitySummary = Just summary , activitySummary = Just summary
, activityAudience = Audience recips [] [] [] [] [] , activityAudience = Audience recips [] [] [] [] []
, activitySpecific = AcceptActivity Accept , activitySpecific = AcceptActivity Accept
{ acceptObject = l2f hLocal luOffer { acceptObject = ObjURI hLocal luOffer
, acceptResult = , acceptResult =
encodeRouteLocal $ TicketR shrProject prjProject num encodeRouteLocal $ TicketR shrProject prjProject num
} }
@ -678,11 +679,12 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
insert_ $ Follow pidAuthor fsid False insert_ $ Follow pidAuthor fsid False
publishAccept pidAuthor sid jid fsid luOffer num obiid doc = do publishAccept pidAuthor sid jid fsid luOffer num obiid doc = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let dont = Authority "dont-do.any-forwarding" Nothing
remotesHttp <- do remotesHttp <- do
moreRemotes <- deliverLocal now sid fsid obiid moreRemotes <- deliverLocal now sid fsid obiid
deliverRemoteDB' "dont-do.any-forwarding" obiid [] moreRemotes deliverRemoteDB' dont obiid [] moreRemotes
site <- askSite site <- askSite
liftIO $ runWorker (deliverRemoteHttp "dont-do.any-forwarding" obiid doc remotesHttp) site liftIO $ runWorker (deliverRemoteHttp dont obiid doc remotesHttp) site
where where
deliverLocal now sid fsid obiid = do deliverLocal now sid fsid obiid = do
(pidsTeam, remotesTeam) <- getProjectTeam sid (pidsTeam, remotesTeam) <- getProjectTeam sid
@ -727,6 +729,6 @@ getFollowersCollection here getFsid = do
, collectionLast = Nothing , collectionLast = Nothing
, collectionItems = , collectionItems =
map (encodeRouteHome . SharerR) locals ++ 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")]) provideHtmlAndAP followersAP $ redirect (here, [("prettyjson", "true")])

17
src/Vervis/API/Recipient.hs
View file

@ -47,6 +47,7 @@ import Yesod.MonadSite
import Data.List.NonEmpty.Local import Data.List.NonEmpty.Local
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model.Ident import Vervis.Model.Ident
@ -252,7 +253,7 @@ parseRecipients recips = do
unless (null lusInvalid) $ unless (null lusInvalid) $
throwE $ throwE $
"Local recipients are invalid routes: " <> "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 unless (null routesInvalid) $ do
renderUrl <- askUrlRender renderUrl <- askUrlRender
throwE $ throwE $
@ -260,10 +261,10 @@ parseRecipients recips = do
T.pack (show $ map renderUrl routesInvalid) T.pack (show $ map renderUrl routesInvalid)
return (localsSet, remotes) return (localsSet, remotes)
where where
splitRecipients :: Text -> NonEmpty FedURI -> ([LocalURI], [FedURI]) splitRecipients :: Host -> NonEmpty FedURI -> ([LocalURI], [FedURI])
splitRecipients home recips = 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 parseLocalRecipients
:: [LocalURI] -> ([LocalURI], [Route App], LocalRecipientSet) :: [LocalURI] -> ([LocalURI], [Route App], LocalRecipientSet)
@ -287,8 +288,8 @@ parseRecipients recips = do
parseAudience parseAudience
:: (MonadSite m, SiteEnv m ~ App) :: (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 parseAudience audience = do
let recips = concatRecipients audience let recips = concatRecipients audience
for (nonEmpty recips) $ \ recipsNE -> do for (nonEmpty recips) $ \ recipsNE -> do
@ -296,5 +297,5 @@ parseAudience audience = do
return return
(localsSet, groupByHost $ remotes \\ audienceNonActors audience) (localsSet, groupByHost $ remotes \\ audienceNonActors audience)
where where
groupByHost :: [FedURI] -> [(Text, NonEmpty LocalURI)] groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)]
groupByHost = groupAllExtract furiHost (snd . f2l) groupByHost = groupAllExtract objUriAuthority objUriLocal

88
src/Vervis/ActivityPub.hs
View file

@ -102,18 +102,19 @@ import Data.List.NonEmpty.Local
import Data.Tuple.Local import Data.Tuple.Local
import Database.Persist.Local import Database.Persist.Local
import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.RemoteActorStore import Vervis.RemoteActorStore
import Vervis.Settings 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 hostIsLocal h = asksSite $ (== h) . appInstanceHost . appSettings
verifyHostLocal verifyHostLocal
:: (MonadSite m, SiteEnv m ~ App) :: (MonadSite m, SiteEnv m ~ App)
=> Text -> Text -> ExceptT Text m () => Host -> Text -> ExceptT Text m ()
verifyHostLocal h t = do verifyHostLocal h t = do
local <- hostIsLocal h local <- hostIsLocal h
unless local $ throwE t unless local $ throwE t
@ -121,9 +122,9 @@ verifyHostLocal h t = do
parseContext parseContext
:: (MonadSite m, SiteEnv m ~ App) :: (MonadSite m, SiteEnv m ~ App)
=> FedURI => FedURI
-> ExceptT Text m (Either (ShrIdent, PrjIdent, Int) (Text, LocalURI)) -> ExceptT Text m (Either (ShrIdent, PrjIdent, Int) FedURI)
parseContext uContext = do parseContext uContext = do
let c@(hContext, luContext) = f2l uContext let ObjURI hContext luContext = uContext
local <- hostIsLocal hContext local <- hostIsLocal hContext
if local if local
then Left <$> do then Left <$> do
@ -133,14 +134,14 @@ parseContext uContext = do
case route of case route of
TicketR shr prj num -> return (shr, prj, num) TicketR shr prj num -> return (shr, prj, num)
_ -> throwE "Local context isn't a ticket route" _ -> throwE "Local context isn't a ticket route"
else return $ Right c else return $ Right uContext
parseParent parseParent
:: (MonadSite m, SiteEnv m ~ App) :: (MonadSite m, SiteEnv m ~ App)
=> FedURI => FedURI
-> ExceptT Text m (Either (ShrIdent, LocalMessageId) (Text, LocalURI)) -> ExceptT Text m (Either (ShrIdent, LocalMessageId) FedURI)
parseParent uParent = do parseParent uParent = do
let p@(hParent, luParent) = f2l uParent let ObjURI hParent luParent = uParent
local <- hostIsLocal hParent local <- hostIsLocal hParent
if local if local
then Left <$> do then Left <$> do
@ -154,7 +155,7 @@ parseParent uParent = do
"Local parent has non-existent message \ "Local parent has non-existent message \
\hashid" \hashid"
_ -> throwE "Local parent isn't a message route" _ -> throwE "Local parent isn't a message route"
else return $ Right p else return $ Right uParent
newtype FedError = FedError Text deriving Show newtype FedError = FedError Text deriving Show
@ -183,7 +184,7 @@ getLocalParentMessageId did shr lmid = do
throwE "Local parent belongs to a different discussion" throwE "Local parent belongs to a different discussion"
return mid return mid
concatRecipients :: Audience -> [FedURI] concatRecipients :: Audience u -> [ObjURI u]
concatRecipients (Audience to bto cc bcc gen _) = concat [to, bto, cc, bcc, gen] concatRecipients (Audience to bto cc bcc gen _) = concat [to, bto, cc, bcc, gen]
getPersonOrGroupId :: SharerId -> AppDB (Either PersonId GroupId) 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 neither person nor group"
"Found sharer that is both person and 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 getTicketTeam sid = do
id_ <- getPersonOrGroupId sid id_ <- getPersonOrGroupId sid
(,[]) <$> case id_ of (,[]) <$> case id_ of
@ -205,7 +206,7 @@ getTicketTeam sid = do
getProjectTeam = getTicketTeam 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 getFollowers fsid = do
local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson] local <- selectList [FollowTarget ==. fsid] [Asc FollowPerson]
remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do remote <- E.select $ E.from $ \ (rf `E.InnerJoin` rs `E.InnerJoin` i) -> do
@ -230,15 +231,15 @@ getFollowers fsid = do
remote remote
) )
where 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 groupRemotes = groupWithExtractBy ((==) `on` fst) fst snd . map toTuples
where where
toTuples (iid, h, rsid, luA, luI, ms) = ((iid, h), (rsid, luA, luI, ms)) toTuples (iid, h, rsid, luA, luI, ms) = ((iid, h), (rsid, luA, luI, ms))
unionRemotes 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 unionRemotes = unionGroupsOrdWith fst fst4
insertMany' mk xs = zip' xs <$> insertMany (NE.toList $ mk <$> xs) insertMany' mk xs = zip' xs <$> insertMany (NE.toList $ mk <$> xs)
@ -271,32 +272,32 @@ isInstanceErrorG (Just e) =
deliverHttp deliverHttp
:: (MonadSite m, SiteEnv m ~ App) :: (MonadSite m, SiteEnv m ~ App)
=> Doc Activity => Doc Activity URIMode
-> Maybe LocalURI -> Maybe LocalURI
-> Text -> Host
-> LocalURI -> LocalURI
-> m (Either APPostError (Response ())) -> m (Either APPostError (Response ()))
deliverHttp doc mfwd h luInbox = deliverHttp doc mfwd h luInbox =
deliverActivity (l2f h luInbox) (l2f h <$> mfwd) doc deliverActivity (ObjURI h luInbox) (ObjURI h <$> mfwd) doc
deliverHttpBL deliverHttpBL
:: (MonadSite m, SiteEnv m ~ App) :: (MonadSite m, SiteEnv m ~ App)
=> BL.ByteString => BL.ByteString
-> Maybe LocalURI -> Maybe LocalURI
-> Text -> Host
-> LocalURI -> LocalURI
-> m (Either APPostError (Response ())) -> m (Either APPostError (Response ()))
deliverHttpBL body mfwd h luInbox = deliverHttpBL body mfwd h luInbox =
deliverActivityBL' (l2f h luInbox) (l2f h <$> mfwd) body deliverActivityBL' (ObjURI h luInbox) (ObjURI h <$> mfwd) body
deliverRemoteDB deliverRemoteDB
:: BL.ByteString :: BL.ByteString
-> RemoteActivityId -> RemoteActivityId
-> ProjectId -> ProjectId
-> ByteString -> ByteString
-> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-> AppDB -> AppDB
[((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))] [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
deliverRemoteDB body ractid jid sig recips = do deliverRemoteDB body ractid jid sig recips = do
let body' = BL.toStrict body let body' = BL.toStrict body
deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
@ -316,12 +317,12 @@ deliverRemoteHTTP
-> PrjIdent -> PrjIdent
-> BL.ByteString -> BL.ByteString
-> ByteString -> ByteString
-> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))] -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
-> Handler () -> Handler ()
deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do
let deliver h inbox = let deliver h inbox =
let sender = ProjectR shrRecip prjRecip 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 traverse_ (fork . deliverFetched deliver now) fetched
where where
fork = forkHandler $ \ e -> logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e) 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 Just h -> return h
parseTarget u = do parseTarget u = do
let (h, lu) = f2l u let ObjURI h lu = u
(shr, prj) <- parseProject lu (shr, prj) <- parseProject lu
return (h, shr, prj) return (h, shr, prj)
where where
@ -437,14 +438,14 @@ data Recip
| RecipRC (Entity RemoteCollection) | RecipRC (Entity RemoteCollection)
deliverRemoteDB' deliverRemoteDB'
:: Text :: Host
-> OutboxItemId -> OutboxItemId
-> [(Text, NonEmpty LocalURI)] -> [(Host, NonEmpty LocalURI)]
-> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))] -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-> AppDB -> 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 deliverRemoteDB' hContext obid recips known = do
recips' <- for recips $ \ (h, lus) -> do recips' <- for recips $ \ (h, lus) -> do
@ -503,12 +504,12 @@ deliverRemoteDB' hContext obid recips known = do
noError ((_ , _ , _ , Just _ ), _ ) = Nothing noError ((_ , _ , _ , Just _ ), _ ) = Nothing
deliverRemoteHttp deliverRemoteHttp
:: Text :: Host
-> OutboxItemId -> 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 () -> Worker ()
deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do 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 (isJust fwd',) <$> deliverHttp doc fwd' h inbox
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
logDebug' $ logDebug' $
"Launching fetched " <> T.pack (show $ map (snd . fst) fetched) "Launching fetched " <> showHosts fetched
traverse_ (fork . deliverFetched deliver now) fetched traverse_ (fork . deliverFetched deliver now) fetched
logDebug' $ logDebug' $
"Launching unfetched " <> T.pack (show $ map (snd . fst) unfetched) "Launching unfetched " <> showHosts unfetched
traverse_ (fork . deliverUnfetched deliver now) unfetched traverse_ (fork . deliverUnfetched deliver now) unfetched
logDebug' $ logDebug' $
"Launching unknown " <> T.pack (show $ map (snd . fst) unknown) "Launching unknown " <> showHosts unknown
traverse_ (fork . deliverUnfetched deliver now) unknown traverse_ (fork . deliverUnfetched deliver now) unknown
logDebug' "Done (async delivery may still be running)" logDebug' "Done (async delivery may still be running)"
where where
showHosts = T.pack . show . map (renderAuthority . snd . fst)
logDebug' t = logDebug $ prefix <> t logDebug' t = logDebug $ prefix <> t
where where
prefix = prefix =
@ -545,7 +547,7 @@ deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
Left err -> do Left err -> do
logError $ T.concat logError $ T.concat
[ "Outbox DL delivery #", T.pack $ show dlid [ "Outbox DL delivery #", T.pack $ show dlid
, " error for <", renderFedURI $ l2f h luActor , " error for <", renderObjURI $ ObjURI h luActor
, ">: ", T.pack $ displayException err , ">: ", T.pack $ displayException err
] ]
return $ return $
@ -573,14 +575,14 @@ deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
Left err -> do Left err -> do
logError $ T.concat logError $ T.concat
[ "Outbox DL delivery #", T.pack $ show dlid [ "Outbox DL delivery #", T.pack $ show dlid
, " error for <", renderFedURI $ l2f h luActor , " error for <", renderObjURI $ ObjURI h luActor
, ">: ", T.pack $ displayException err , ">: ", T.pack $ displayException err
] ]
updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now] updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
update dlid [DeliveryRunning =. False] update dlid [DeliveryRunning =. False]
Right _resp -> delete dlid Right _resp -> delete dlid
where 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 deliverUnfetched deliver now ((iid, h), recips@(r :| rs)) = do
logDebug'' "Starting" logDebug'' "Starting"
let (uraid, luActor, udlid) = r let (uraid, luActor, udlid) = r
@ -634,4 +636,4 @@ deliverRemoteHttp hContext obid doc (fetched, unfetched, unknown) = do
insert_ $ Delivery raid obid fwd False insert_ $ Delivery raid obid fwd False
Right _ -> delete udlid Right _ -> delete udlid
where where
logDebug'' t = logDebug' $ T.concat ["deliverUnfetched ", h, t] logDebug'' t = logDebug' $ T.concat ["deliverUnfetched ", renderAuthority h, t]

5
src/Vervis/Discussion.hs
View file

@ -20,7 +20,6 @@ module Vervis.Discussion
) )
where where
import Control.Arrow (second)
import Data.Graph.Inductive.Graph (mkGraph, lab') import Data.Graph.Inductive.Graph (mkGraph, lab')
import Data.Graph.Inductive.PatriciaTree (Gr) import Data.Graph.Inductive.PatriciaTree (Gr)
import Data.Graph.Inductive.Query.DFS (dffWith) import Data.Graph.Inductive.Query.DFS (dffWith)
@ -35,12 +34,14 @@ import qualified Data.HashMap.Lazy as M (fromList, lookup)
import Network.FedURI import Network.FedURI
import Data.Tree.Local (sortForestOn) import Data.Tree.Local (sortForestOn)
import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
data MessageTreeNodeAuthor data MessageTreeNodeAuthor
= MessageTreeNodeLocal LocalMessageId Sharer = MessageTreeNodeLocal LocalMessageId Sharer
| MessageTreeNodeRemote Text LocalURI LocalURI (Maybe Text) | MessageTreeNodeRemote Host LocalURI LocalURI (Maybe Text)
data MessageTreeNode = MessageTreeNode data MessageTreeNode = MessageTreeNode
{ mtnMessageId :: MessageId { mtnMessageId :: MessageId

38
src/Vervis/FedURI.hs Normal file
View file

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

28
src/Vervis/Federation.hs
View file

@ -368,17 +368,17 @@ retryOutboxDelivery = do
logDebug $ logDebug $
"Periodic delivery forking linked " <> "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 waitsDL <- traverse (fork . deliverLinked deliver now) dls
logDebug $ logDebug $
"Periodic delivery forking forwarding " <> "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 waitsFW <- traverse (fork . deliverForwarding now) fws
logDebug $ logDebug $
"Periodic delivery forking unlinked " <> "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 waitsUDL <- traverse (fork . deliverUnlinked deliver now) udls
logDebug $ logDebug $
@ -474,11 +474,11 @@ retryOutboxDelivery = do
return False return False
Right success -> return success Right success -> return success
deliverLinked deliver now ((_, h), recips) = do 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 waitsR <- for recips $ \ ((raid, (ident, inbox)), delivs) -> fork $ do
logDebug $ logDebug $
"Periodic deliver starting linked for actor " <> "Periodic deliver starting linked for actor " <>
renderFedURI (l2f h ident) renderObjURI (ObjURI h ident)
waitsD <- for delivs $ \ (dlid, fwd, doc) -> fork $ do waitsD <- for delivs $ \ (dlid, fwd, doc) -> fork $ do
let fwd' = if fwd then Just ident else Nothing let fwd' = if fwd then Just ident else Nothing
e <- deliver doc fwd' h inbox e <- deliver doc fwd' h inbox
@ -486,7 +486,7 @@ retryOutboxDelivery = do
Left err -> do Left err -> do
logError $ T.concat logError $ T.concat
[ "Periodic DL delivery #", T.pack $ show dlid [ "Periodic DL delivery #", T.pack $ show dlid
, " error for <", renderFedURI $ l2f h ident, ">: " , " error for <", renderObjURI $ ObjURI h ident, ">: "
, T.pack $ displayException err , T.pack $ displayException err
] ]
return False return False
@ -503,14 +503,14 @@ retryOutboxDelivery = do
return True return True
results <- sequence waitsR results <- sequence waitsR
unless (and results) $ unless (and results) $
logError $ "Periodic DL delivery error for host " <> h logError $ "Periodic DL delivery error for host " <> renderAuthority h
return True return True
deliverUnlinked deliver now ((iid, h), recips) = do 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 waitsR <- for recips $ \ ((uraid, luRecip), delivs) -> fork $ do
logDebug $ logDebug $
"Periodic deliver starting unlinked for actor " <> "Periodic deliver starting unlinked for actor " <>
renderFedURI (l2f h luRecip) renderObjURI (ObjURI h luRecip)
e <- fetchRemoteActor iid h luRecip e <- fetchRemoteActor iid h luRecip
case e of case e of
Right (Right mera) -> Right (Right mera) ->
@ -540,16 +540,16 @@ retryOutboxDelivery = do
return True return True
results <- sequence waitsR results <- sequence waitsR
unless (and results) $ unless (and results) $
logError $ "Periodic UDL delivery error for host " <> h logError $ "Periodic UDL delivery error for host " <> renderAuthority h
return True return True
deliverForwarding now ((_, h), recips) = do 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 waitsR <- for recips $ \ ((raid, inbox), delivs) -> fork $ do
logDebug $ logDebug $
"Periodic deliver starting forwarding for inbox " <> "Periodic deliver starting forwarding for inbox " <>
renderFedURI (l2f h inbox) renderObjURI (ObjURI h inbox)
waitsD <- for delivs $ \ (fwid, body, sender, sig) -> fork $ do 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 case e of
Left _err -> return False Left _err -> return False
Right _resp -> do Right _resp -> do
@ -565,5 +565,5 @@ retryOutboxDelivery = do
return True return True
results <- sequence waitsR results <- sequence waitsR
unless (and results) $ unless (and results) $
logError $ "Periodic FW delivery error for host " <> h logError $ "Periodic FW delivery error for host " <> renderAuthority h
return True return True

62
src/Vervis/Federation/Auth.hs
View file

@ -94,6 +94,7 @@ import Yesod.Persist.Local
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.ActorKey import Vervis.ActorKey
import Vervis.FedURI
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
@ -114,14 +115,22 @@ data ActivityAuthentication
data ActivityBody = ActivityBody data ActivityBody = ActivityBody
{ actbBL :: BL.ByteString { actbBL :: BL.ByteString
, actbObject :: Object , actbObject :: Object
, actbActivity :: Activity , actbActivity :: Activity URIMode
} }
parseKeyId (KeyId k) = 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 Left e -> throwE $ "keyId isn't a valid FedURI: " ++ e
Right u -> return u 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 verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
manager <- getsYesod appHttpManager manager <- getsYesod appHttpManager
(inboxOrVkid, vkd) <- do (inboxOrVkid, vkd) <- do
@ -201,7 +210,7 @@ verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
else errSig2 else errSig2
return RemoteAuthor return RemoteAuthor
{ remoteAuthorURI = l2f host $ vkdActorId vkd { remoteAuthorURI = ObjURI host $ vkdActorId vkd
, remoteAuthorInstance = iid , remoteAuthorInstance = iid
, remoteAuthorId = rsid , remoteAuthorId = rsid
-- , actdRawBody = body -- , actdRawBody = body
@ -225,7 +234,7 @@ verifyActorSig' malgo input (Signature signature) host luKey mluActorHeader = do
verifyActorSig :: Verification -> ExceptT String Handler RemoteAuthor verifyActorSig :: Verification -> ExceptT String Handler RemoteAuthor
verifyActorSig (Verification malgo keyid input signature) = do verifyActorSig (Verification malgo keyid input signature) = do
(host, luKey) <- parseKeyId keyid RefURI host luKey <- parseKeyId keyid
checkHost host checkHost host
mluActorHeader <- getActorHeader host mluActorHeader <- getActorHeader host
verifyActorSig' malgo input signature host luKey mluActorHeader verifyActorSig' malgo input signature host luKey mluActorHeader
@ -240,15 +249,19 @@ verifyActorSig (Verification malgo keyid input signature) = do
[] -> return Nothing [] -> return Nothing
[b] -> fmap Just . ExceptT . pure $ do [b] -> fmap Just . ExceptT . pure $ do
t <- first displayException $ decodeUtf8' b 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 Right lu
_ -> throwE "Multiple ActivityPub-Actor headers" _ -> 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 author <- do
route <- route <-
case decodeRouteLocal luAuthor of case decodeRouteLocal luAuthor of
@ -259,7 +272,11 @@ verifySelfSig luAuthor luKey input (Signature sig) = do
ProjectR shr prj -> return $ Right (shr, prj) ProjectR shr prj -> return $ Right (shr, prj)
_ -> throwE "Local author ID isn't an actor route" _ -> throwE "Local author ID isn't an actor route"
akey <- do 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 case decodeRouteLocal luKey of
Nothing -> throwE "Local key ID isn't a valid route" Nothing -> throwE "Local key ID isn't a valid route"
Just r -> return r Just r -> return r
@ -286,9 +303,13 @@ verifySelfSig luAuthor luKey input (Signature sig) = do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr sid <- MaybeT $ getKeyBy $ UniqueSharer shr
MaybeT $ getKeyBy $ UniqueProject prj sid 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 verifyForwardedSig hAuthor luAuthor (Verification malgo keyid input signature) = do
(hKey, luKey) <- parseKeyId keyid RefURI hKey luKey <- parseKeyId keyid
unless (hAuthor == hKey) $ unless (hAuthor == hKey) $
throwE "Author and forwarded sig key on different hosts" throwE "Author and forwarded sig key on different hosts"
local <- hostIsLocal hKey local <- hostIsLocal hKey
@ -326,25 +347,26 @@ authenticateActivity now = do
return (remoteAuthor, wvdoc, body) return (remoteAuthor, wvdoc, body)
let WithValue raw (Doc hActivity activity) = wv let WithValue raw (Doc hActivity activity) = wv
uSender = remoteAuthorURI ra uSender = remoteAuthorURI ra
(hSender, luSender) = f2l uSender ObjURI hSender luSender = uSender
auth <- auth <-
if hSender == hActivity if hSender == hActivity
then do then do
unless (activityActor activity == luSender) $ unless (activityActor activity == luSender) $
throwE $ T.concat throwE $ T.concat
[ "Activity's actor <" [ "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 return $ ActivityAuthRemote ra
else do else do
-- TODO CONTINUE
ma <- checkForward uSender hActivity (activityActor activity) ma <- checkForward uSender hActivity (activityActor activity)
case ma of case ma of
Nothing -> throwE $ T.concat 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 Just a -> return a
return (auth, ActivityBody body raw activity) return (auth, ActivityBody body raw activity)
@ -395,6 +417,6 @@ authenticateActivity now = do
[] -> throwE "ActivityPub-Forwarder header missing" [] -> throwE "ActivityPub-Forwarder header missing"
[x] -> return x [x] -> return x
_ -> throwE "Multiple ActivityPub-Forwarder" _ -> 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 Left e -> throwE $ "ActivityPub-Forwarder isn't a valid FedURI: " <> T.pack e
Right u -> return u Right u -> return u

23
src/Vervis/Federation/Discussion.hs
View file

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

36
src/Vervis/Federation/Ticket.hs
View file

@ -65,6 +65,7 @@ import Database.Persist.Local
import Yesod.Persist.Local import Yesod.Persist.Local
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.FedURI
import Vervis.Federation.Auth import Vervis.Federation.Auth
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
@ -72,7 +73,11 @@ import Vervis.Model.Ident
import Vervis.Model.Ticket import Vervis.Model.Ticket
checkOffer checkOffer
:: AP.Ticket -> Text -> ShrIdent -> PrjIdent -> ExceptT Text Handler () :: AP.Ticket URIMode
-> Host
-> ShrIdent
-> PrjIdent
-> ExceptT Text Handler ()
checkOffer ticket hProject shrProject prjProject = do checkOffer ticket hProject shrProject prjProject = do
verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'" verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'"
verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'" verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'"
@ -86,7 +91,7 @@ sharerOfferTicketF
-> ShrIdent -> ShrIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Offer -> Offer URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
(hProject, shrProject, prjProject) <- parseTarget uTarget (hProject, shrProject, prjProject) <- parseTarget uTarget
@ -133,7 +138,7 @@ sharerAcceptOfferTicketF
-> ShrIdent -> ShrIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Accept -> Accept URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
sharerAcceptOfferTicketF now shrRecip author body (Accept _uOffer _luTicket) = do sharerAcceptOfferTicketF now shrRecip author body (Accept _uOffer _luTicket) = do
luAccept <- luAccept <-
@ -164,7 +169,7 @@ sharerRejectOfferTicketF
-> ShrIdent -> ShrIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Reject -> Reject URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
sharerRejectOfferTicketF now shrRecip author body (Reject _uOffer) = do sharerRejectOfferTicketF now shrRecip author body (Reject _uOffer) = do
luReject <- luReject <-
@ -201,7 +206,7 @@ projectOfferTicketF
-> PrjIdent -> PrjIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Offer -> Offer URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
projectOfferTicketF projectOfferTicketF
now shrRecip prjRecip author body (Offer ticket uTarget) = do now shrRecip prjRecip author body (Offer ticket uTarget) = do
@ -210,7 +215,7 @@ projectOfferTicketF
Left t -> do Left t -> do
logWarn $ T.concat logWarn $ T.concat
[ recip, " got Offer Ticket with target " [ recip, " got Offer Ticket with target "
, renderFedURI uTarget , renderObjURI uTarget
] ]
return t return t
Right () -> do Right () -> do
@ -245,7 +250,7 @@ projectOfferTicketF
where where
recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip] recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
checkTarget = do checkTarget = do
let (h, lu) = f2l uTarget let ObjURI h lu = uTarget
local <- hostIsLocal h local <- hostIsLocal h
unless local $ unless local $
throwE $ recip <> " not using; target has different host" throwE $ recip <> " not using; target has different host"
@ -266,7 +271,7 @@ projectOfferTicketF
findRelevantCollections hLocal = nub . mapMaybe decide . concatRecipients findRelevantCollections hLocal = nub . mapMaybe decide . concatRecipients
where where
decide u = do decide u = do
let (h, lu) = f2l u let ObjURI h lu = u
guard $ h == hLocal guard $ h == hLocal
route <- decodeRouteLocal lu route <- decodeRouteLocal lu
case route of case route of
@ -329,7 +334,7 @@ projectOfferTicketF
-> [OfferTicketRecipColl] -> [OfferTicketRecipColl]
-> SharerId -> 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 fsid = do deliverLocal ractid recips sid fsid = do
(teamPids, teamRemotes) <- (teamPids, teamRemotes) <-
if OfferTicketRecipProjectTeam `elem` recips if OfferTicketRecipProjectTeam `elem` recips
@ -363,7 +368,7 @@ projectOfferTicketF
withUrlRenderer withUrlRenderer
[hamlet| [hamlet|
<p> <p>
<a href="#{renderFedURI $ remoteAuthorURI author}"> <a href="#{renderObjURI $ remoteAuthorURI author}">
(?) (?)
's ticket accepted by project # 's ticket accepted by project #
<a href=@{ProjectR shrRecip prjRecip}> <a href=@{ProjectR shrRecip prjRecip}>
@ -389,7 +394,9 @@ projectOfferTicketF
, activityAudience = Audience recips [] [] [] [] [] , activityAudience = Audience recips [] [] [] [] []
, activitySpecific = AcceptActivity Accept , activitySpecific = AcceptActivity Accept
{ acceptObject = { acceptObject =
l2f (furiHost $ remoteAuthorURI author) luOffer ObjURI
(objUriAuthority $ remoteAuthorURI author)
luOffer
, acceptResult = , acceptResult =
encodeRouteLocal $ TicketR shrRecip prjRecip num encodeRouteLocal $ TicketR shrRecip prjRecip num
} }
@ -408,6 +415,7 @@ projectOfferTicketF
publishAccept luOffer num obiid doc = do publishAccept luOffer num obiid doc = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let dont = Authority "dont-do.any-forwarding" Nothing
remotesHttp <- runDB $ do remotesHttp <- runDB $ do
(sid, project) <- do (sid, project) <- do
sid <- fromJust <$> getKeyBy (UniqueSharer shrRecip) sid <- fromJust <$> getKeyBy (UniqueSharer shrRecip)
@ -418,12 +426,12 @@ projectOfferTicketF
ra <- getJust raidAuthor ra <- getJust raidAuthor
let raInfo = (raidAuthor, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra) let raInfo = (raidAuthor, remoteActorIdent ra, remoteActorInbox ra, remoteActorErrorSince ra)
iidAuthor = remoteAuthorInstance author iidAuthor = remoteAuthorInstance author
hAuthor = furiHost $ remoteAuthorURI author hAuthor = objUriAuthority $ remoteAuthorURI author
hostSection = ((iidAuthor, hAuthor), raInfo :| []) hostSection = ((iidAuthor, hAuthor), raInfo :| [])
remotes = unionRemotes [hostSection] moreRemotes remotes = unionRemotes [hostSection] moreRemotes
deliverRemoteDB' "dont-do.any-forwarding" obiid [] remotes deliverRemoteDB' dont obiid [] remotes
site <- askSite site <- askSite
liftIO $ runWorker (deliverRemoteHttp "dont-do.any-forwarding" obiid doc remotesHttp) site liftIO $ runWorker (deliverRemoteHttp dont obiid doc remotesHttp) site
where where
deliverLocal now sid fsid obiid = do deliverLocal now sid fsid obiid = do
(pidsTeam, remotesTeam) <- getProjectTeam sid (pidsTeam, remotesTeam) <- getProjectTeam sid

16
src/Vervis/Foundation.hs
View file

@ -82,6 +82,7 @@ import Network.FedURI
import Web.ActivityAccess import Web.ActivityAccess
import Web.ActivityPub hiding (TicketDependency) import Web.ActivityPub hiding (TicketDependency)
import Yesod.ActivityPub import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids import Yesod.Hashids
import Yesod.MonadSite import Yesod.MonadSite
@ -91,6 +92,7 @@ import Yesod.Paginate.Local
import Vervis.Access import Vervis.Access
import Vervis.ActorKey import Vervis.ActorKey
import Vervis.FedURI
import Vervis.Model import Vervis.Model
import Vervis.Model.Group import Vervis.Model.Group
import Vervis.Model.Ident import Vervis.Model.Ident
@ -160,11 +162,15 @@ type WorkerDB = PersistConfigBackend (SitePersistConfig App) Worker
instance Site App where instance Site App where
type SitePersistConfig App = PostgresConf type SitePersistConfig App = PostgresConf
siteApproot = ("https://" <>) . appInstanceHost . appSettings siteApproot =
renderObjURI . flip ObjURI topLocalURI . appInstanceHost . appSettings
sitePersistConfig = appDatabaseConf . appSettings sitePersistConfig = appDatabaseConf . appSettings
sitePersistPool = appConnPool sitePersistPool = appConnPool
siteLogger = appLogger siteLogger = appLogger
instance SiteFedURI App where
type SiteFedURIMode App = URIMode
-- Please see the documentation for the Yesod typeclass. There are a number -- Please see the documentation for the Yesod typeclass. There are a number
-- of settings which can be configured by overriding methods here. -- of settings which can be configured by overriding methods here.
instance Yesod App where instance Yesod App where
@ -204,11 +210,15 @@ instance Yesod App where
defaultCsrfHeaderName defaultCsrfHeaderName
defaultCsrfParamName defaultCsrfParamName
) )
. ( \ handler -> . ( \ handler -> do
{-
if developmentMode if developmentMode
then handler then handler
else do else do
host <- getsYesod $ appInstanceHost . appSettings -}
host <-
getsYesod $
renderAuthority . appInstanceHost . appSettings
bs <- lookupHeaders hHost bs <- lookupHeaders hHost
case bs of case bs of
[b] | b == encodeUtf8 host -> handler [b] | b == encodeUtf8 host -> handler

21
src/Vervis/Handler/Discussion.hs
View file

@ -55,8 +55,9 @@ import Yesod.Persist.Local
import Vervis.API import Vervis.API
import Vervis.Discussion import Vervis.Discussion
import Vervis.Form.Discussion
import Vervis.Federation import Vervis.Federation
import Vervis.FedURI
import Vervis.Form.Discussion
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
@ -134,7 +135,7 @@ getDiscussionMessage shr lmid = do
return $ route2fed $ TicketR shr prj $ ticketNumber t return $ route2fed $ TicketR shr prj $ ticketNumber t
(Nothing, Just rd) -> do (Nothing, Just rd) -> do
i <- getJust $ remoteDiscussionInstance rd i <- getJust $ remoteDiscussionInstance rd
return $ l2f (instanceHost i) (remoteDiscussionIdent rd) return $ ObjURI (instanceHost i) (remoteDiscussionIdent rd)
muParent <- for (messageParent m) $ \ midParent -> do muParent <- for (messageParent m) $ \ midParent -> do
mlocal <- getBy $ UniqueLocalMessage midParent mlocal <- getBy $ UniqueLocalMessage midParent
mremote <- getValBy $ UniqueRemoteMessage midParent mremote <- getValBy $ UniqueRemoteMessage midParent
@ -149,7 +150,7 @@ getDiscussionMessage shr lmid = do
(Nothing, Just rmParent) -> do (Nothing, Just rmParent) -> do
rs <- getJust $ remoteMessageAuthor rmParent rs <- getJust $ remoteMessageAuthor rmParent
i <- getJust $ remoteActorInstance rs i <- getJust $ remoteActorInstance rs
return $ l2f (instanceHost i) (remoteActorIdent rs) return $ ObjURI (instanceHost i) (remoteActorIdent rs)
--ob <- getJust $ localMessageCreate lm --ob <- getJust $ localMessageCreate lm
--let activity = docValue $ persistJSONValue $ outboxItemActivity ob --let activity = docValue $ persistJSONValue $ outboxItemActivity ob
@ -183,7 +184,7 @@ getTopReply replyP = do
defaultLayout $(widgetFile "discussion/top-reply") defaultLayout $(widgetFile "discussion/top-reply")
postTopReply postTopReply
:: Text :: Host
-> [Route App] -> [Route App]
-> [Route App] -> [Route App]
-> Route App -> Route App
@ -199,13 +200,13 @@ postTopReply hDest recipsA recipsC context replyP after = do
FormSuccess nm -> return $ nmContent nm FormSuccess nm -> return $ nmContent nm
encodeRouteFed <- getEncodeRouteHome encodeRouteFed <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
let encodeRecipRoute = l2f hDest . encodeRouteLocal let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
shrAuthor <- do shrAuthor <- do
Entity _ p <- requireVerifiedAuth Entity _ p <- requireVerifiedAuth
lift $ runDB $ sharerIdent <$> get404 (personIdent p) lift $ runDB $ sharerIdent <$> get404 (personIdent p)
let msg' = T.filter (/= '\r') msg let msg' = T.filter (/= '\r') msg
contentHtml <- ExceptT . pure $ renderPandocMarkdown msg' contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor let ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
uContext = encodeRecipRoute context uContext = encodeRecipRoute context
recips = recipsA ++ recipsC recips = recipsA ++ recipsC
note = Note note = Note
@ -247,7 +248,7 @@ getReply replyG replyP getdid midParent = do
defaultLayout $(widgetFile "discussion/reply") defaultLayout $(widgetFile "discussion/reply")
postReply postReply
:: Text :: Host
-> [Route App] -> [Route App]
-> [Route App] -> [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 FormSuccess nm -> return $ nmContent nm
encodeRouteFed <- getEncodeRouteHome encodeRouteFed <- getEncodeRouteHome
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
let encodeRecipRoute = l2f hDest . encodeRouteLocal let encodeRecipRoute = ObjURI hDest . encodeRouteLocal
(shrAuthor, uParent) <- do (shrAuthor, uParent) <- do
Entity _ p <- requireVerifiedAuth Entity _ p <- requireVerifiedAuth
lift $ runDB $ do lift $ runDB $ do
@ -284,11 +285,11 @@ postReply hDest recipsA recipsC context replyG replyP after getdid midParent = d
return $ encodeRouteFed $ MessageR (sharerIdent s) lmkhid return $ encodeRouteFed $ MessageR (sharerIdent s) lmkhid
(Nothing, Just rm) -> do (Nothing, Just rm) -> do
i <- getJust $ remoteMessageInstance rm i <- getJust $ remoteMessageInstance rm
return $ l2f (instanceHost i) (remoteMessageIdent rm) return $ ObjURI (instanceHost i) (remoteMessageIdent rm)
return (shr, parent) return (shr, parent)
let msg' = T.filter (/= '\r') msg let msg' = T.filter (/= '\r') msg
contentHtml <- ExceptT . pure $ renderPandocMarkdown msg' contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
let (hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor let ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
uContext = encodeRecipRoute context uContext = encodeRecipRoute context
recips = recipsA ++ recipsC recips = recipsA ++ recipsC
note = Note note = Note

37
src/Vervis/Handler/Inbox.hs
View file

@ -118,6 +118,7 @@ import Yesod.Persist.Local
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.ActorKey import Vervis.ActorKey
import Vervis.API import Vervis.API
import Vervis.FedURI
import Vervis.Federation import Vervis.Federation
import Vervis.Federation.Auth import Vervis.Federation.Auth
import Vervis.Foundation import Vervis.Foundation
@ -337,20 +338,20 @@ fedUriField
:: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m FedURI
fedUriField = Field fedUriField = Field
{ fieldParse = parseHelper $ \ t -> { fieldParse = parseHelper $ \ t ->
case parseFedURI t of case parseObjURI t of
Left e -> Left $ MsgInvalidUrl $ T.pack e <> ": " <> t Left e -> Left $ MsgInvalidUrl $ T.pack e <> ": " <> t
Right u -> Right u Right u -> Right u
, fieldView = \theId name attrs val isReq -> , 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 , fieldEnctype = UrlEncoded
} }
ticketField 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 ticketField encodeRouteLocal = checkMMap toTicket fromTicket fedUriField
where where
toTicket uTicket = runExceptT $ do toTicket uTicket = runExceptT $ do
let (hTicket, luTicket) = f2l uTicket let ObjURI hTicket luTicket = uTicket
route <- route <-
case decodeRouteLocal luTicket of case decodeRouteLocal luTicket of
Nothing -> throwE ("Not a valid route" :: Text) 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) TicketR shr prj num -> return (hTicket, shr, prj, num)
_ -> throwE "Not a ticket route" _ -> throwE "Not a ticket route"
fromTicket (h, shr, prj, num) = fromTicket (h, shr, prj, num) =
l2f h $ encodeRouteLocal $ TicketR shr prj num ObjURI h $ encodeRouteLocal $ TicketR shr prj num
projectField projectField
:: (Route App -> LocalURI) -> Field Handler (Text, ShrIdent, PrjIdent) :: (Route App -> LocalURI) -> Field Handler (Host, ShrIdent, PrjIdent)
projectField encodeRouteLocal = checkMMap toProject fromProject fedUriField projectField encodeRouteLocal = checkMMap toProject fromProject fedUriField
where where
toProject u = runExceptT $ do toProject u = runExceptT $ do
let (h, lu) = f2l u let ObjURI h lu = u
route <- route <-
case decodeRouteLocal lu of case decodeRouteLocal lu of
Nothing -> throwE ("Not a valid route" :: Text) Nothing -> throwE ("Not a valid route" :: Text)
@ -374,10 +375,10 @@ projectField encodeRouteLocal = checkMMap toProject fromProject fedUriField
case route of case route of
ProjectR shr prj -> return (h, shr, prj) ProjectR shr prj -> return (h, shr, prj)
_ -> throwE "Not a project route" _ -> 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 publishCommentForm
:: Form ((Text, ShrIdent, PrjIdent, Int), Maybe FedURI, Text) :: Form ((Host, ShrIdent, PrjIdent, Int), Maybe FedURI, Text)
publishCommentForm html = do publishCommentForm html = do
enc <- getEncodeRouteLocal enc <- getEncodeRouteLocal
flip renderDivs html $ (,,) flip renderDivs html $ (,,)
@ -385,12 +386,12 @@ publishCommentForm html = do
<*> aopt fedUriField "Replying to" (Just $ Just defp) <*> aopt fedUriField "Replying to" (Just $ Just defp)
<*> areq textField "Message" (Just defmsg) <*> areq textField "Message" (Just defmsg)
where 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? :)" defmsg = "Hi! I'm testing federation. Can you see my message? :)"
openTicketForm openTicketForm
:: Form ((Text, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown) :: Form ((Host, ShrIdent, PrjIdent), TextHtml, TextPandocMarkdown)
openTicketForm html = do openTicketForm html = do
enc <- getEncodeRouteLocal enc <- getEncodeRouteLocal
flip renderDivs html $ (,,) flip renderDivs html $ (,,)
@ -402,7 +403,7 @@ openTicketForm html = do
areq textareaField "Description" (Just defd) areq textareaField "Description" (Just defd)
) )
where 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" deft = "Time slows down when tasting coconut ice-cream"
defd = "Is that slow-motion effect intentional? :)" defd = "Is that slow-motion effect intentional? :)"
@ -553,9 +554,9 @@ postSharerOutboxR shrAuthor = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
let msg' = T.filter (/= '\r') msg let msg' = T.filter (/= '\r') msg
contentHtml <- ExceptT . pure $ renderPandocMarkdown msg' contentHtml <- ExceptT . pure $ renderPandocMarkdown msg'
let encodeRecipRoute = l2f hTicket . encodeRouteLocal let encodeRecipRoute = ObjURI hTicket . encodeRouteLocal
uTicket = encodeRecipRoute $ TicketR shrTicket prj num uTicket = encodeRecipRoute $ TicketR shrTicket prj num
(hLocal, luAuthor) = f2l $ encodeRouteFed $ SharerR shrAuthor ObjURI hLocal luAuthor = encodeRouteFed $ SharerR shrAuthor
collections = collections =
[ ProjectFollowersR shrTicket prj [ ProjectFollowersR shrTicket prj
, TicketParticipantsR shrTicket prj num , TicketParticipantsR shrTicket prj num
@ -597,8 +598,8 @@ postSharerOutboxR shrAuthor = do
<a href=@{ProjectR shr prj}> <a href=@{ProjectR shr prj}>
./s/#{shr2text shr}/p/#{prj2text prj} ./s/#{shr2text shr}/p/#{prj2text prj}
$else $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}. : #{preEscapedToHtml title}.
|] |]
let recipsA = [ProjectR shr prj] let recipsA = [ProjectR shr prj]
@ -656,7 +657,7 @@ getActorKey choose route = do
getsYesod appActorKeys getsYesod appActorKeys
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
let key = PublicKey let key = PublicKey
{ publicKeyId = encodeRouteLocal route { publicKeyId = LocalRefURI $ Left $ encodeRouteLocal route
, publicKeyExpires = Nothing , publicKeyExpires = Nothing
, publicKeyOwner = OwnerInstance , publicKeyOwner = OwnerInstance
, publicKeyMaterial = actorKey , publicKeyMaterial = actorKey

53
src/Vervis/Migration.hs
View file

@ -71,6 +71,7 @@ import Yesod.MonadSite
import Data.Either.Local import Data.Either.Local
import Database.Persist.Local import Database.Persist.Local
import Vervis.FedURI
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Foundation (App, Route (..)) import Vervis.Foundation (App, Route (..))
import Vervis.Migration.Model 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 :: Monad m => Apply m -> Mig m -> Apply m -> Mig m
--withPrePost pre (validate, apply) post = (validate, pre >> apply >> post) --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 = changes hLocal ctx =
[ -- 1 [ -- 1
addEntities model_2016_08_04 addEntities model_2016_08_04
@ -316,9 +317,10 @@ changes hLocal ctx =
Person201905 Person201905
sid user "" "e@ma.il" False "" defaultTime "" sid user "" "e@ma.il" False "" defaultTime ""
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 { activityId = Nothing
, activityActor = localUri , activityActor = localUri
, activitySummary = Nothing , activitySummary = Nothing
@ -339,10 +341,10 @@ changes hLocal ctx =
Nothing -> error "Mig77: Note 'id' not found" Nothing -> error "Mig77: Note 'id' not found"
Just (String s) -> s Just (String s) -> s
_ -> error "Mig77: Note 'id' not a string" _ -> error "Mig77: Note 'id' not a string"
fu = case parseFedURI t of fu = case parseObjURI t of
Left _ -> error "Mig77: Note 'id' invalid FedURI" Left _ -> error "Mig77: Note 'id' invalid FedURI"
Right u -> u Right u -> u
(h, lu) = f2l fu ObjURI h lu = fu
in if h == hLocal in if h == hLocal
then lu then lu
else error "Mig77: Note 'id' on foreign host" else error "Mig77: Note 'id' on foreign host"
@ -403,8 +405,8 @@ changes hLocal ctx =
, "/t/", T.pack $ show $ ticket201905Number t , "/t/", T.pack $ show $ ticket201905Number t
] ]
return return
( FedURI hLocal tPath "" ( ObjURI hLocal $ LocalURI tPath
, map (l2f hLocal . flip LocalURI "") , map (ObjURI hLocal . LocalURI)
[ jPath [ jPath
, tPath <> "/participants" , tPath <> "/participants"
, tPath <> "/team" , tPath <> "/team"
@ -414,7 +416,7 @@ changes hLocal ctx =
i <- getJust $ i <- getJust $
remoteDiscussion201905Instance rd remoteDiscussion201905Instance rd
return return
( l2f ( ObjURI
(instance201905Host i) (instance201905Host i)
(remoteDiscussion201905Ident rd) (remoteDiscussion201905Ident rd)
, [] , []
@ -435,16 +437,17 @@ changes hLocal ctx =
Left (Entity lmidP lmP) -> do Left (Entity lmidP lmP) -> do
p <- getJust $ localMessage201905Author lmP p <- getJust $ localMessage201905Author lmP
s <- getJust $ person201905Ident p s <- getJust $ person201905Ident p
let path = T.concat let path = LocalURI $ T.concat
[ "/s/", shr2text $ sharer201905Ident s [ "/s/", shr2text $ sharer201905Ident s
, "/m/", toPathPiece $ encodeKeyHashidPure ctx lmidP , "/m/", toPathPiece $ encodeKeyHashidPure ctx lmidP
] ]
return $ FedURI hLocal path "" return $ ObjURI hLocal path
Right rmP -> do Right rmP -> do
i <- getJust $ i <- getJust $
remoteMessage201905Instance rmP remoteMessage201905Instance rmP
return $ return $
l2f (instance201905Host i) ObjURI
(instance201905Host i)
(remoteMessage201905Ident rmP) (remoteMessage201905Ident rmP)
let msg = T.filter (/= '\r') $ message201905Content m let msg = T.filter (/= '\r') $ message201905Content m
@ -455,7 +458,7 @@ changes hLocal ctx =
let aud = Audience recips [] [] [] [] [] let aud = Audience recips [] [] [] [] []
luAttrib = LocalURI ("/s/" <> shr2text shr) "" luAttrib = LocalURI $ "/s/" <> shr2text shr
activity luAct luNote = Doc hLocal Activity activity luAct luNote = Doc hLocal Activity
{ activityId = Just luAct { activityId = Just luAct
, activityActor = luAttrib , activityActor = luAttrib
@ -474,7 +477,7 @@ changes hLocal ctx =
} }
} }
} }
tempUri = LocalURI "" "" tempUri = topLocalURI
newObid <- insert OutboxItem201905 newObid <- insert OutboxItem201905
{ outboxItem201905Person = pid { outboxItem201905Person = pid
, outboxItem201905Activity = persistJSONObjectFromDoc $ activity tempUri tempUri , outboxItem201905Activity = persistJSONObjectFromDoc $ activity tempUri tempUri
@ -488,8 +491,8 @@ changes hLocal ctx =
[ "/s/", shr2text shr [ "/s/", shr2text shr
, "/outbox/", toPathPiece $ encodeKeyHashidPure ctx newObid , "/outbox/", toPathPiece $ encodeKeyHashidPure ctx newObid
] ]
luAct = LocalURI obPath "" luAct = LocalURI obPath
luNote = LocalURI notePath "" luNote = LocalURI notePath
doc = activity luAct luNote doc = activity luAct luNote
update newObid [OutboxItem201905Activity =. persistJSONObjectFromDoc doc] update newObid [OutboxItem201905Activity =. persistJSONObjectFromDoc doc]
return newObid return newObid
@ -706,9 +709,10 @@ changes hLocal ctx =
Person20190612 Person20190612
sid user "" "e@ma.il" False "" defaultTime "" sid user "" "e@ma.il" False "" defaultTime ""
defaultTime "" ibid 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 { activityId = Nothing
, activityActor = localUri , activityActor = localUri
, activitySummary = Nothing , activitySummary = Nothing
@ -783,7 +787,7 @@ changes hLocal ctx =
encodeRouteHome $ ProjectR shrProject prj encodeRouteHome $ ProjectR shrProject prj
} }
} }
tempUri = LocalURI "" "" tempUri = topLocalURI
obidNew <- insert OutboxItem20190612 obidNew <- insert OutboxItem20190612
{ outboxItem20190612Person = pidAuthor { outboxItem20190612Person = pidAuthor
, outboxItem20190612Activity = persistJSONObjectFromDoc $ doc tempUri , outboxItem20190612Activity = persistJSONObjectFromDoc $ doc tempUri
@ -869,9 +873,10 @@ changes hLocal ctx =
, addFieldRefRequired'' , addFieldRefRequired''
"Ticket" "Ticket"
(do obid <- insert Outbox20190624 (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 { activityId = Nothing
, activityActor = localUri , activityActor = localUri
, activitySummary = Nothing , activitySummary = Nothing
@ -1007,7 +1012,7 @@ changes hLocal ctx =
migrateDB migrateDB
:: (MonadSite m, SiteEnv m ~ App) :: (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 = migrateDB hLocal ctx =
let f cs = fmap (, length cs) <$> runMigrations schemaBackend 1 cs let f cs = fmap (, length cs) <$> runMigrations schemaBackend 1 cs
in f $ changes hLocal ctx in f $ changes hLocal ctx

3
src/Vervis/Migration/Model.hs
View file

@ -130,6 +130,7 @@ import Database.Persist.Schema.Types (Entity)
import Database.Persist.Schema.SQL () import Database.Persist.Schema.SQL ()
import Database.Persist.Sql (SqlBackend) import Database.Persist.Sql (SqlBackend)
import Vervis.FedURI
import Vervis.Migration.TH (schema) import Vervis.Migration.TH (schema)
import Vervis.Model (SharerId) import Vervis.Model (SharerId)
import Vervis.Model.Group import Vervis.Model.Group
@ -147,7 +148,7 @@ import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Web.ActivityPub import Web.ActivityPub
type PersistActivity = PersistJSON (Doc Activity) type PersistActivity = PersistJSON (Doc Activity URIMode)
model_2016_08_04 :: [Entity SqlBackend] model_2016_08_04 :: [Entity SqlBackend]
model_2016_08_04 = $(schema "2016_08_04") model_2016_08_04 = $(schema "2016_08_04")

5
src/Vervis/Model.hs
View file

@ -32,9 +32,10 @@ import Crypto.PublicVerifKey
import Database.Persist.EmailAddress import Database.Persist.EmailAddress
import Database.Persist.Graph.Class import Database.Persist.Graph.Class
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI (FedURI, LocalURI) import Network.FedURI
import Web.ActivityPub (Doc, Activity) import Web.ActivityPub (Doc, Activity)
import Vervis.FedURI
import Vervis.Model.Group import Vervis.Model.Group
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Model.Repo import Vervis.Model.Repo
@ -43,7 +44,7 @@ import Vervis.Model.Ticket
import Vervis.Model.TH import Vervis.Model.TH
import Vervis.Model.Workflow import Vervis.Model.Workflow
type PersistActivity = PersistJSON (Doc Activity) type PersistActivity = PersistJSON (Doc Activity URIMode)
makeEntities $(modelFile "config/models") makeEntities $(modelFile "config/models")

27
src/Vervis/RemoteActorStore.hs
View file

@ -64,9 +64,10 @@ import Network.FedURI
import Web.ActivityPub import Web.ActivityPub
import Yesod.MonadSite import Yesod.MonadSite
import Vervis.FedURI
import Vervis.Model import Vervis.Model
newtype InstanceMutex = InstanceMutex (TVar (HashMap Text (MVar ()))) newtype InstanceMutex = InstanceMutex (TVar (HashMap Host (MVar ())))
newInstanceMutex :: IO InstanceMutex newInstanceMutex :: IO InstanceMutex
newInstanceMutex = InstanceMutex <$> newTVarIO M.empty newInstanceMutex = InstanceMutex <$> newTVarIO M.empty
@ -95,7 +96,7 @@ withHostLock
, HandlerSite m ~ site , HandlerSite m ~ site
, YesodRemoteActorStore site , YesodRemoteActorStore site
) )
=> Text => Host
-> m a -> m a
-> m a -> m a
withHostLock host action = do withHostLock host action = do
@ -130,7 +131,7 @@ instanceAndActor
:: ( PersistUniqueWrite (YesodPersistBackend site) :: ( PersistUniqueWrite (YesodPersistBackend site)
, BaseBackend (YesodPersistBackend site) ~ SqlBackend , BaseBackend (YesodPersistBackend site) ~ SqlBackend
) )
=> Text => Host
-> LocalURI -> LocalURI
-> Maybe Text -> Maybe Text
-> LocalURI -> LocalURI
@ -324,8 +325,8 @@ keyListedByActorShared
) )
=> InstanceId => InstanceId
-> VerifKeyId -> VerifKeyId
-> Text -> Host
-> LocalURI -> LocalRefURI
-> LocalURI -> LocalURI
-> ExceptT String (HandlerFor site) RemoteActorId -> ExceptT String (HandlerFor site) RemoteActorId
keyListedByActorShared iid vkid host luKey luActor = do keyListedByActorShared iid vkid host luKey luActor = do
@ -376,7 +377,7 @@ keyListedByActorShared iid vkid host luKey luActor = do
return rsid return rsid
data VerifKeyDetail = VerifKeyDetail data VerifKeyDetail = VerifKeyDetail
{ vkdKeyId :: LocalURI { vkdKeyId :: LocalRefURI
, vkdKey :: PublicVerifKey , vkdKey :: PublicVerifKey
, vkdExpires :: Maybe UTCTime , vkdExpires :: Maybe UTCTime
, vkdActorId :: LocalURI , vkdActorId :: LocalURI
@ -389,7 +390,7 @@ addVerifKey
, PersistQueryRead (YesodPersistBackend site) , PersistQueryRead (YesodPersistBackend site)
, PersistUniqueWrite (YesodPersistBackend site) , PersistUniqueWrite (YesodPersistBackend site)
) )
=> Text => Host
-> Maybe Text -> Maybe Text
-> LocalURI -> LocalURI
-> VerifKeyDetail -> VerifKeyDetail
@ -467,7 +468,7 @@ actorFetchShareAction
-> (site, InstanceId) -> (site, InstanceId)
-> IO (Either (Maybe APGetError) (Maybe (Entity RemoteActor))) -> IO (Either (Maybe APGetError) (Maybe (Entity RemoteActor)))
actorFetchShareAction u (site, iid) = flip runWorkerT site $ do actorFetchShareAction u (site, iid) = flip runWorkerT site $ do
let (h, lu) = f2l u let ObjURI h lu = u
mrecip <- runSiteDB $ runMaybeT mrecip <- runSiteDB $ runMaybeT
$ Left <$> MaybeT (getBy $ UniqueRemoteActor iid lu) $ Left <$> MaybeT (getBy $ UniqueRemoteActor iid lu)
<|> Right <$> MaybeT (getBy $ UniqueRemoteCollection iid lu) <|> Right <$> MaybeT (getBy $ UniqueRemoteCollection iid lu)
@ -508,7 +509,13 @@ fetchRemoteActor
, PersistConfigPool (SitePersistConfig site) ~ ConnectionPool , PersistConfigPool (SitePersistConfig site) ~ ConnectionPool
, PersistConfigBackend (SitePersistConfig site) ~ SqlPersistT , 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 fetchRemoteActor iid host luActor = do
mrecip <- runSiteDB $ runMaybeT mrecip <- runSiteDB $ runMaybeT
$ Left <$> MaybeT (getBy $ UniqueRemoteActor iid luActor) $ Left <$> MaybeT (getBy $ UniqueRemoteActor iid luActor)
@ -521,7 +528,7 @@ fetchRemoteActor iid host luActor = do
Right _ -> Nothing Right _ -> Nothing
Nothing -> do Nothing -> do
site <- askSite site <- askSite
liftIO $ runShared (siteActorFetchShare site) (l2f host luActor) (site, iid) liftIO $ runShared (siteActorFetchShare site) (ObjURI host luActor) (site, iid)
deleteUnusedURAs = do deleteUnusedURAs = do
uraids <- E.select $ E.from $ \ ura -> do uraids <- E.select $ E.from $ \ ura -> do

16
src/Vervis/Settings.hs
View file

@ -50,6 +50,10 @@ import qualified Data.Text as T
import Yesod.Mail.Send (MailSettings) import Yesod.Mail.Send (MailSettings)
import Network.FedURI
import Vervis.FedURI
developmentMode :: Bool developmentMode :: Bool
developmentMode = developmentMode =
#if DEVELOPMENT #if DEVELOPMENT
@ -88,7 +92,7 @@ data AppSettings = AppSettings
-- which requests are remote and which are for this instance, and for -- which requests are remote and which are for this instance, and for
-- generating URLs. The database relies on this value, and you shouldn't -- generating URLs. The database relies on this value, and you shouldn't
-- change it once you deploy an instance. -- change it once you deploy an instance.
, appInstanceHost :: Text , appInstanceHost :: Host
-- | Host/interface the server should bind to. -- | Host/interface the server should bind to.
, appHost :: HostPreference , appHost :: HostPreference
-- | Port to listen on -- | Port to listen on
@ -193,9 +197,15 @@ instance FromJSON AppSettings where
appDatabaseConf <- o .: "database" appDatabaseConf <- o .: "database"
appMaxInstanceKeys <- o .:? "max-instance-keys" appMaxInstanceKeys <- o .:? "max-instance-keys"
appMaxActorKeys <- o .:? "max-actor-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" appHost <- fromString <$> o .: "host"
appPort <- o .: "http-port" let appPort = fromIntegral port
appIpFromHeader <- o .: "ip-from-header" appIpFromHeader <- o .: "ip-from-header"
appClientSessionKeyFile <- o .: "client-session-key" appClientSessionKeyFile <- o .: "client-session-key"

2
src/Vervis/Widget/Discussion.hs
View file

@ -48,7 +48,7 @@ import Vervis.Widget.Sharer
actorLinkW :: MessageTreeNodeAuthor -> Widget actorLinkW :: MessageTreeNodeAuthor -> Widget
actorLinkW actor = $(widgetFile "widget/actor-link") actorLinkW actor = $(widgetFile "widget/actor-link")
where where
shortURI h (LocalURI p f) = h <> p <> f shortURI h (LocalURI p) = renderAuthority h <> p
messageW messageW
:: UTCTime -> MessageTreeNode -> (MessageId -> Route App) -> Widget :: UTCTime -> MessageTreeNode -> (MessageId -> Route App) -> Widget

4
src/Vervis/Widget/Sharer.hs
View file

@ -42,11 +42,11 @@ sharerLinkFedW :: Either Sharer (Instance, RemoteActor) -> Widget
sharerLinkFedW (Left sharer) = sharerLinkW sharer sharerLinkFedW (Left sharer) = sharerLinkW sharer
sharerLinkFedW (Right (inztance, actor)) = sharerLinkFedW (Right (inztance, actor)) =
[whamlet| [whamlet|
<a href="#{renderFedURI uActor}"> <a href="#{renderObjURI uActor}">
$maybe name <- remoteActorName actor $maybe name <- remoteActorName actor
#{name} #{name}
$nothing $nothing
(?) (?)
|] |]
where where
uActor = l2f (instanceHost inztance) (remoteActorIdent actor) uActor = ObjURI (instanceHost inztance) (remoteActorIdent actor)

632
src/Web/ActivityPub.hs
View file

File diff suppressed because it is too large Load diff

48
src/Yesod/ActivityPub.hs
View file

@ -47,11 +47,12 @@ import Network.HTTP.Signature
import Database.Persist.JSON import Database.Persist.JSON
import Network.FedURI import Network.FedURI
import Web.ActivityPub import Web.ActivityPub
import Yesod.FedURI
import Yesod.MonadSite import Yesod.MonadSite
import Yesod.RenderSource 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 sitePostSignedHeaders :: site -> NonEmpty HeaderName
siteGetHttpSign :: (MonadSite m, SiteEnv m ~ site) siteGetHttpSign :: (MonadSite m, SiteEnv m ~ site)
=> m (KeyId, ByteString -> Signature) => m (KeyId, ByteString -> Signature)
@ -64,11 +65,12 @@ class Yesod site => YesodActivityPub site where
deliverActivity' deliverActivity'
:: ( MonadSite m :: ( MonadSite m
, SiteEnv m ~ site , SiteEnv m ~ site
, SiteFedURIMode site ~ u
, HasHttpManager site , HasHttpManager site
, YesodActivityPub site , YesodActivityPub site
) )
=> FedURI => ObjURI u
-> Maybe FedURI -> Maybe (ObjURI u)
-> Text -> Text
-> BL.ByteString -> BL.ByteString
-> m (Either APPostError (Response ())) -> m (Either APPostError (Response ()))
@ -82,12 +84,12 @@ deliverActivity' inbox mfwd sender body = do
case result of case result of
Left err -> Left err ->
logError $ T.concat logError $ T.concat
[ "deliverActivity to inbox <", renderFedURI inbox [ "deliverActivity to inbox <", renderObjURI inbox
, "> error: ", T.pack $ displayException err , "> error: ", T.pack $ displayException err
] ]
Right resp -> Right resp ->
logDebug $ T.concat logDebug $ T.concat
[ "deliverActivity to inbox <", renderFedURI inbox [ "deliverActivity to inbox <", renderObjURI inbox
, "> success: ", T.pack $ show $ responseStatus resp , "> success: ", T.pack $ show $ responseStatus resp
] ]
return result return result
@ -95,26 +97,28 @@ deliverActivity' inbox mfwd sender body = do
deliverActivity deliverActivity
:: ( MonadSite m :: ( MonadSite m
, SiteEnv m ~ site , SiteEnv m ~ site
, SiteFedURIMode site ~ u
, HasHttpManager site , HasHttpManager site
, YesodActivityPub site , YesodActivityPub site
) )
=> FedURI => ObjURI u
-> Maybe FedURI -> Maybe (ObjURI u)
-> Doc Activity -> Doc Activity u
-> m (Either APPostError (Response ())) -> m (Either APPostError (Response ()))
deliverActivity inbox mfwd doc@(Doc hAct activity) = deliverActivity inbox mfwd doc@(Doc hAct activity) =
let sender = renderFedURI $ l2f hAct (activityActor activity) let sender = renderObjURI $ ObjURI hAct (activityActor activity)
body = encode doc body = encode doc
in deliverActivity' inbox mfwd sender body in deliverActivity' inbox mfwd sender body
deliverActivityBL deliverActivityBL
:: ( MonadSite m :: ( MonadSite m
, SiteEnv m ~ site , SiteEnv m ~ site
, SiteFedURIMode site ~ u
, HasHttpManager site , HasHttpManager site
, YesodActivityPub site , YesodActivityPub site
) )
=> FedURI => ObjURI u
-> Maybe FedURI -> Maybe (ObjURI u)
-> Route site -> Route site
-> BL.ByteString -> BL.ByteString
-> m (Either APPostError (Response ())) -> m (Either APPostError (Response ()))
@ -126,11 +130,12 @@ deliverActivityBL inbox mfwd senderR body = do
deliverActivityBL' deliverActivityBL'
:: ( MonadSite m :: ( MonadSite m
, SiteEnv m ~ site , SiteEnv m ~ site
, SiteFedURIMode site ~ u
, HasHttpManager site , HasHttpManager site
, YesodActivityPub site , YesodActivityPub site
) )
=> FedURI => ObjURI u
-> Maybe FedURI -> Maybe (ObjURI u)
-> BL.ByteString -> BL.ByteString
-> m (Either APPostError (Response ())) -> m (Either APPostError (Response ()))
deliverActivityBL' inbox mfwd body = do deliverActivityBL' inbox mfwd body = do
@ -144,10 +149,11 @@ deliverActivityBL' inbox mfwd body = do
forwardActivity forwardActivity
:: ( MonadSite m :: ( MonadSite m
, SiteEnv m ~ site , SiteEnv m ~ site
, SiteFedURIMode site ~ u
, HasHttpManager site , HasHttpManager site
, YesodActivityPub site , YesodActivityPub site
) )
=> FedURI => ObjURI u
-> ByteString -> ByteString
-> Route site -> Route site
-> BL.ByteString -> BL.ByteString
@ -163,12 +169,12 @@ forwardActivity inbox sig rSender body = do
case result of case result of
Left err -> Left err ->
logError $ T.concat logError $ T.concat
[ "forwardActivity to inbox <", renderFedURI inbox [ "forwardActivity to inbox <", renderObjURI inbox
, "> error: ", T.pack $ displayException err , "> error: ", T.pack $ displayException err
] ]
Right resp -> Right resp ->
logDebug $ T.concat logDebug $ T.concat
[ "forwardActivity to inbox <", renderFedURI inbox [ "forwardActivity to inbox <", renderObjURI inbox
, "> success: ", T.pack $ show $ responseStatus resp , "> success: ", T.pack $ show $ responseStatus resp
] ]
return result return result
@ -178,15 +184,15 @@ redirectToPrettyJSON
redirectToPrettyJSON route = redirect (route, [("prettyjson", "true")]) redirectToPrettyJSON route = redirect (route, [("prettyjson", "true")])
provideHtmlAndAP 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 provideHtmlAndAP object widget = do
host <- getsYesod siteInstanceHost host <- getsYesod siteInstanceHost
provideHtmlAndAP' host object widget provideHtmlAndAP' host object widget
provideHtmlAndAP' 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 provideHtmlAndAP' host object widget = selectRep $ do
let doc = Doc host object let doc = Doc host object
provideAP $ pure doc provideAP $ pure doc

79
src/Yesod/FedURI.hs
View file

@ -14,7 +14,8 @@
-} -}
module Yesod.FedURI module Yesod.FedURI
( getEncodeRouteLocal ( SiteFedURI (..)
, getEncodeRouteLocal
, getEncodeRouteHome , getEncodeRouteHome
, getEncodeRouteFed , getEncodeRouteFed
, decodeRouteLocal , decodeRouteLocal
@ -24,12 +25,9 @@ module Yesod.FedURI
) )
where where
import Control.Monad
import Data.Text (Text)
import Data.Text.Encoding import Data.Text.Encoding
import Network.HTTP.Types.URI import Network.HTTP.Types.URI
import Yesod.Core import Yesod.Core
import Yesod.Core.Handler
import qualified Data.Text as T import qualified Data.Text as T
@ -38,55 +36,60 @@ import Yesod.MonadSite
import Yesod.Paginate.Local 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 getEncodeRouteHome = toFed <$> askUrlRender
where where
toFed renderUrl route = 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 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 site => LocalURI -> Maybe (Route site)
decodeRouteLocal = decodeRouteLocal =
parseRoute . (,[]) . decodePathSegments . encodeUtf8 . luriPath <=< noFrag parseRoute . (,[]) . decodePathSegments . encodeUtf8 . localUriPath
where
noFrag lu =
if T.null $ luriFragment lu
then Just lu
else Nothing
getEncodeRoutePageLocal 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 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 getEncodeRoutePageHome = do
encodeRouteHome <- getEncodeRouteHome encodeRouteHome <- getEncodeRouteHome
param <- asksSite sitePageParamName 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 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

2
templates/default-layout.hamlet
View file

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

2
templates/discussion/widget/message.hamlet
View file

@ -19,7 +19,7 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<a href=@{MessageR (sharerIdent s) (encodeHid lmid)}> <a href=@{MessageR (sharerIdent s) (encodeHid lmid)}>
#{showTime $ messageCreated msg} #{showTime $ messageCreated msg}
$of MessageTreeNodeRemote h luMsg _luAuthor _mname $of MessageTreeNodeRemote h luMsg _luAuthor _mname
<a href="#{renderFedURI $ l2f h luMsg}"}> <a href="#{renderObjURI $ ObjURI h luMsg}"}>
#{showTime $ messageCreated msg} #{showTime $ messageCreated msg}
<div> <div>
^{showContent $ messageContent msg} ^{showContent $ messageContent msg}

2
templates/widget/actor-link.hamlet
View file

@ -22,7 +22,7 @@ $case actor
<span> <span>
./s/#{shr2text $ sharerIdent s} ./s/#{shr2text $ sharerIdent s}
$of MessageTreeNodeRemote h _luMsg luAuthor mname $of MessageTreeNodeRemote h _luMsg luAuthor mname
<a href="#{renderFedURI $ l2f h luAuthor}"> <a href="#{renderObjURI $ ObjURI h luAuthor}">
$maybe name <- mname $maybe name <- mname
#{name} #{name}
$nothing $nothing

1
vervis.cabal
View file

@ -130,6 +130,7 @@ library
Vervis.Federation.Auth Vervis.Federation.Auth
Vervis.Federation.Discussion Vervis.Federation.Discussion
Vervis.Federation.Ticket Vervis.Federation.Ticket
Vervis.FedURI
Vervis.Field.Key Vervis.Field.Key
Vervis.Field.Person Vervis.Field.Person
Vervis.Field.Project Vervis.Field.Project