forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Create Note outbox handler, not in use yet

Browse source 
I wrote a function handleOutboxNote that's supposed to do the whole outbox POST
handler process. There's an outbox item table in the DB now, I adapted things
in various source files. Ticket comment federation work is still in progress.
This commit is contained in:
fr33domlover 2019-03-28 21:08:30 +00:00
parent cdb1c8b121
commit 228e954706
12 changed files with 560 additions and 134 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

19
config/models
View file

@ -43,6 +43,11 @@ Person
UniquePersonLogin login
UniquePersonEmail email
OutboxItem
person PersonId
activity PersistActivity
published UTCTime
VerifKey
ident LocalURI
instance InstanceId
@ -225,10 +230,11 @@ TicketClaimRequest
Discussion
RemoteDiscussion
sharer RemoteSharerId
instance InstanceId
ident LocalURI
discuss DiscussionId
actor RemoteSharerId Maybe
instance InstanceId
ident LocalURI
discuss DiscussionId
unlinkedActor FedURI Maybe
UniqueRemoteDiscussionIdent instance ident
UniqueRemoteDiscussion discuss
@ -240,8 +246,9 @@ Message
root DiscussionId
LocalMessage
author PersonId
rest MessageId
author PersonId
rest MessageId
unlinkedParent FedURI Maybe
UniqueLocalMessage rest

3
config/routes
View file

@ -26,7 +26,6 @@
/publish PublishR GET
/inbox InboxR GET POST
/outbox OutboxR GET POST
/akey1 ActorKey1R GET
/akey2 ActorKey2R GET
@ -51,6 +50,8 @@
/s SharersR GET
/s/#ShrIdent SharerR GET
/s/#ShrIdent/outbox OutboxR GET POST
/s/#ShrIdent/outbox/#Text OutboxItemR GET
/p PeopleR GET

21
migrations/2019_03_19.model
View file

@ -1,19 +1,26 @@
RemoteRawObject
content PersistJSONObject
content PersistJSONValue
received UTCTime
OutboxItem
person PersonId
activity PersistJSONValue
published UTCTime
RemoteDiscussion
sharer RemoteSharerId
instance InstanceId
ident Text
discuss DiscussionId
actor RemoteSharerId Maybe
instance InstanceId
ident Text
discuss DiscussionId
unlinkedActor Text Maybe
UniqueRemoteDiscussionIdent instance ident
UniqueRemoteDiscussion discuss
LocalMessage
author PersonId
rest MessageId
author PersonId
rest MessageId
unlinkedParent Text Maybe
UniqueLocalMessage rest

9
src/Data/Either/Local.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2019 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -16,6 +16,7 @@
module Data.Either.Local
( maybeRight
, maybeLeft
, requireEither
)
where
@ -28,3 +29,9 @@ maybeRight (Right b) = Just b
maybeLeft :: Either a b -> Maybe a
maybeLeft (Left a) = Just a
maybeLeft (Right _) = Nothing
requireEither :: Maybe a -> Maybe b -> Either Bool (Either a b)
requireEither Nothing Nothing = Left False
requireEither (Just _) (Just _) = Left True
requireEither (Just x) Nothing = Right $ Left x
requireEither Nothing (Just y) = Right $ Right y

543
src/Vervis/Federation.hs
View file

@ -15,40 +15,143 @@
module Vervis.Federation
( handleInboxActivity
, handleOutboxNote
)
where
import Prelude
import Control.Concurrent.STM.TVar
import Control.Exception hiding (Handler)
import Control.Monad
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Aeson (Object)
import Data.Foldable
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time.Clock
import Data.Traversable
import Database.Persist
import Database.Persist.Sql
import Network.HTTP.Types.Header
import Network.HTTP.Types.URI
import Yesod.Core hiding (logWarn)
import Yesod.Core hiding (logError, logWarn, logInfo)
import Yesod.Persist.Core
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Database.Esqueleto as E
import Network.HTTP.Signature
import Database.Persist.JSON
import Network.FedURI
import Web.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Data.Either.Local
import Database.Persist.Local
import Vervis.ActorKey
import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.RemoteActorStore
import Vervis.Settings
hostIsLocal :: (MonadHandler m, HandlerSite m ~ App) => Text -> m Bool
hostIsLocal h = getsYesod $ (== h) . appInstanceHost . appSettings
verifyHostLocal
:: (MonadHandler m, HandlerSite m ~ App)
=> Text -> Text -> ExceptT Text m ()
verifyHostLocal h t = do
local <- hostIsLocal h
unless local $ throwE t
parseAudience :: Monad m => Audience -> Text -> ExceptT Text m FedURI
parseAudience (Audience to bto cc bcc aud) t =
case toSingleton to of
Just fu
| V.null bto && V.null cc && V.null bcc && V.null aud ->
return fu
_ -> throwE t
where
toSingleton v =
case V.toList v of
[x] -> Just x
_ -> Nothing
fromMaybeE :: Monad m => Maybe a -> Text -> ExceptT Text m a
fromMaybeE Nothing t = throwE t
fromMaybeE (Just x) _ = return x
requireEitherM
:: MonadIO m => Maybe a -> Maybe b -> String -> String -> m (Either a b)
requireEitherM mx my f t =
case requireEither mx my of
Left b -> liftIO $ throwIO $ userError $ if b then t else f
Right exy -> return exy
prependError :: Monad m => Text -> ExceptT Text m a -> ExceptT Text m a
prependError t a = do
r <- lift $ runExceptT a
case r of
Left e -> throwE $ t <> ": " <> e
Right x -> return x
parseProject :: Monad m => LocalURI -> ExceptT Text m (ShrIdent, PrjIdent)
parseProject luRecip = do
route <- case decodeRouteLocal luRecip of
Nothing -> throwE "Got Create Note with recipient that isn't a valid route"
Just r -> return r
case route of
ProjectR shr prj -> return (shr, prj)
_ -> throwE "Got Create Note with non-project recipient"
parseTicket :: Monad m => (ShrIdent, PrjIdent) -> LocalURI -> ExceptT Text m Int
parseTicket project luContext = do
route <- case decodeRouteLocal luContext of
Nothing -> throwE "Local context isn't a valid route"
Just r -> return r
case route of
TicketR shr prj num ->
if (shr, prj) == project
then return num
else throwE "Local context ticket doesn't belong to the recipient project"
_ -> throwE "Local context isn't a ticket route"
parseComment :: LocalURI -> ExceptT Text Handler (ShrIdent, LocalMessageId)
parseComment luParent = do
route <- case decodeRouteLocal luParent of
Nothing -> throwE "Not a local route"
Just r -> return r
case route of
MessageR shr hid -> do
decodeHid <- getsYesod appHashidDecode
case toSqlKey <$> decodeHid hid of
Nothing -> throwE "Non-existent local message hashid"
Just k -> return (shr, k)
_ -> throwE "Not a local message route"
getLocalParentMessageId :: DiscussionId -> ShrIdent -> LocalMessageId -> ExceptT Text AppDB MessageId
getLocalParentMessageId did shr lmid = do
mlm <- lift $ get lmid
lm <- fromMaybeE mlm "Local parent: no such lmid"
p <- lift $ getJust $ localMessageAuthor lm
s <- lift $ getJust $ personIdent p
unless (shr == sharerIdent s) $ throwE "Local parent: No such message, lmid mismatches sharer"
let mid = localMessageRest lm
m <- lift $ getJust mid
unless (messageRoot m == did) $
throwE "Local parent belongs to a different discussion"
return mid
-- | Handle an activity that came to our inbox. Return a description of what we
-- did, and whether we stored the activity or not (so that we can decide
-- whether to log it for debugging).
@ -57,10 +160,10 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
case specific of
CreateActivity (Create note) -> do
result <- runExceptT $ handleCreate iidActor hActor rsidActor raw audience note
return $
case result of
Left e -> (e, False)
Right (uNew, luTicket) ->
case result of
Left e -> logWarn e >> return ("Create Note: " <> e, False)
Right (uNew, luTicket) ->
return
( T.concat
[ "Inserted remote comment <"
, renderFedURI uNew
@ -72,73 +175,20 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
)
_ -> return ("Unsupported activity type", False)
where
toSingleton v =
case V.toList v of
[x] -> Just x
_ -> Nothing
--result t = logWarn t >> return (t, False)
done t = logWarn t >> throwE t
fromMaybeE Nothing t = done t
fromMaybeE (Just x) _ = return x
--hostIsLocal :: (MonadHandler m, HandlerSite m ~ App) => Text -> m Bool
hostIsLocal h = getsYesod $ (== h) . appInstanceHost . appSettings
verifyLocal fu t = do
let (h, lu) = f2l fu
local <- hostIsLocal h
if local
then return lu
else done t
parseAudience (Audience to bto cc bcc aud) =
case toSingleton to of
Just fu
| V.null bto && V.null cc && V.null bcc && V.null aud ->
return fu
_ -> done "Got a Create Note with a not-just-single-to audience"
local2route = parseRoute . (,[]) . decodePathSegments . encodeUtf8 . luriPath <=< noFrag
where
noFrag lu =
if T.null $ luriFragment lu
then Just lu
else Nothing
parseProject uRecip = do
let (hRecip, luRecip) = f2l uRecip
local <- hostIsLocal hRecip
unless local $ done "Got Create Note with non-local recipient"
route <- case local2route luRecip of
Nothing -> done "Got Create Note with recipient that isn't a valid route"
Just r -> return r
case route of
ProjectR shr prj -> return (shr, prj)
_ -> done "Got Create Note with non-project recipient"
parseTicket project luContext = do
route <- case local2route luContext of
Nothing -> done "Got Create Note with context that isn't a valid route"
Just r -> return r
case route of
TicketR shr prj num ->
if (shr, prj) == project
then return num
else done "Got Create Note under ticket that doesn't belong to the recipient project"
_ -> done "Got Create Note with non-ticket context"
parseParent luContext ticket uParent = do
else throwE t
parseParent :: LocalURI -> FedURI -> ExceptT Text Handler (Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI)))
parseParent luContext uParent = do
let (hParent, luParent) = f2l uParent
local <- hostIsLocal hParent
if local
then if luParent == luContext
then return Nothing
else do
route <- case local2route luParent of
Nothing -> done "Got Create Note with local non-route parent"
Just r -> return r
case route of
TicketMessageR shr prj num hid -> do
unless (ticket == (shr, prj, num)) $
done "Got Create Note with local parent not under the same ticket as the context"
decodeHid <- getsYesod appHashidDecode
case toSqlKey <$> decodeHid hid of
Nothing -> done "Got Create Note non-existent ticket message parent hashid"
Just k -> return $ Just $ Left k
_ -> done "Got Create Note with local non-ticket-message parent"
else prependError "Local parent" $ Just . Left <$> parseComment luParent
else return $ Just $ Right (hParent, luParent)
selectOrphans uNote did op =
E.select $ E.from $ \ (rm `E.InnerJoin` m) -> do
@ -150,20 +200,21 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
handleCreate iidActor hActor rsidActor raw audience (Note mluNote _luAttrib _aud muParent muContext mpublished content) = do
luNote <- fromMaybeE mluNote "Got Create Note without note id"
(shr, prj) <- do
uRecip <- parseAudience audience
parseProject uRecip
(hRecip, luRecip) <- f2l <$> parseAudience audience "Got a Create Note with a not-just-single-to audience"
verifyHostLocal hRecip "Non-local recipient"
parseProject luRecip
luContext <- do
uContext <- fromMaybeE muContext "Got a Create Note without context"
verifyLocal uContext "Got a Create Note with non-local context"
num <- parseTicket (shr, prj) luContext
mparent <- do
uParent <- fromMaybeE muParent "Got a Create Note without inReplyTo"
parseParent luContext (shr, prj, num) uParent
parseParent luContext uParent
published <- fromMaybeE mpublished "Got Create Note without 'published' field"
ExceptT $ runDB $ runExceptT $ do
mrmid <- lift $ getKeyBy $ UniqueRemoteMessageIdent iidActor luNote
for_ mrmid $ \ rmid ->
done $
throwE $
"Got a Create Note with a note ID we already have, \
\RemoteMessageId " <> T.pack (show rmid)
mdid <- lift $ runMaybeT $ do
@ -172,33 +223,23 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
t <- MaybeT $ getValBy $ UniqueTicket jid num
return $ ticketDiscuss t
did <- fromMaybeE mdid "Got Create Note on non-existent ticket"
meparent <-
case mparent of
Nothing -> return Nothing
Just parent ->
case parent of
Left lmid -> do
mlm <- lift $ get lmid
lm <- fromMaybeE mlm "Got Create Note replying to non-existent local message, no such lmid"
let mid = localMessageRest lm
meparent <- for mparent $ \ parent ->
case parent of
Left (shrParent, lmid) -> Left <$> getLocalParentMessageId did shrParent lmid
Right (hParent, luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
case mrm of
Nothing -> do
logWarn "Got Create Note replying to a remote message we don't have"
return $ Right $ l2f hParent luParent
Just rm -> do
let mid = remoteMessageRest rm
m <- lift $ getJust mid
unless (messageRoot m == did) $
done "Got Create Note replying to non-existent local message, lmid not under the context ticket"
return $ Just $ Left mid
Right (hParent, luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
case mrm of
Nothing -> do
logWarn "Got Create Note replying to a remote message we don't have"
return $ Just $ Right $ l2f hParent luParent
Just rm -> do
let mid = remoteMessageRest rm
m <- lift $ getJust mid
unless (messageRoot m == did) $
done "Got Create Note replying to remote message which belongs to a different discussion"
return $ Just $ Left mid
throwE "Got Create Note replying to remote message which belongs to a different discussion"
return $ Left mid
now <- liftIO getCurrentTime
rroid <- lift $ insert $ RemoteRawObject (PersistJSON raw) now
mid <- lift $ insert Message
@ -247,3 +288,323 @@ handleInboxActivity raw hActor iidActor rsidActor (Activity _id _luActor audienc
, " because they have different DiscussionId!"
]
return (uNote, luContext)
-- | Handle a Note submitted by a local user to their outbox. It can be either
-- a comment on a local ticket, or a comment on some remote context. Return an
-- error message if the Note is rejected, otherwise the new 'LocalMessageId'.
handleOutboxNote :: Text -> Note -> Handler (Either Text LocalMessageId)
handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished content) = runExceptT $ do
verifyHostLocal host "Attributed to non-local actor"
verifyNothing mluNote "Note specifies an id"
verifyNothing mpublished "Note specifies published"
uContext <- fromMaybeE muContext "Note without context"
uRecip <- parseAudience aud "Note has not-just-single-to audience"
recipContextParent <- parseRecipContextParent uRecip uContext muParent
(lmid, mdeliver) <- ExceptT $ runDB $ runExceptT $ do
(pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
case recipContextParent of
(mparent, Left (shr, prj, num)) -> do
mdid <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
jid <- MaybeT $ getKeyBy $ UniqueProject prj sid
t <- MaybeT $ getValBy $ UniqueTicket jid num
return $ ticketDiscuss t
did <- fromMaybeE mdid "Context: No such local ticket"
mmidParent <- for mparent $ \ parent ->
case parent of
Left (shrParent, lmidParent) -> getLocalParentMessageId did shrParent lmidParent
Right (hParent, luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
rm <- fromMaybeE mrm "Remote parent unknown locally"
let mid = remoteMessageRest rm
m <- lift $ getJust mid
unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion"
return mid
let meparent = Left <$> mmidParent
(lmid, _doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent content
return (lmid, Nothing)
(mparent, Right (hRecip, luRecip, luContext)) -> do
(did, rdid, rdnew, mluInbox) <- do
miid <- lift $ getKeyBy $ UniqueInstance hRecip
erd <-
case miid of
Just iid -> findExistingRemoteDiscussion iid hRecip luRecip luContext
Nothing -> return Nothing
case erd of
Just (d, rd, minb) -> return (d, rd, False, minb)
Nothing -> ExceptT $ withHostLock hRecip $ runExceptT $ storeRemoteDiscussion miid hRecip luRecip luContext
meparent <- for mparent $ \ parent ->
case parent of
Left (shrParent, lmidParent) -> do
when rdnew $ throwE "Local parent inexistent, RemoteDiscussion is new"
Left <$> getLocalParentMessageId did shrParent lmidParent
Right (hParent, luParent) -> do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
MaybeT $ getValBy $ UniqueRemoteMessageIdent iid luParent
case mrm of
Nothing -> return $ Right $ l2f hParent luParent
Just rm -> Left <$> do
let mid = remoteMessageRest rm
m <- lift $ getJust mid
unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion"
return mid
(lmid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent content
return (lmid, Just (doc, hRecip, maybe (Right (luRecip, rdid)) Left mluInbox))
let handleDeliverError e = logError $ "Outbox POST handler: delivery failed! " <> T.pack (displayException e)
lift $ for_ mdeliver $ \ (doc, hRecip, einb) -> forkHandler handleDeliverError $ do
uInbox <-
case einb of
Left luInbox -> return $ l2f hRecip luInbox
Right (luRecip, rdid) -> do
mluInbox <- runDB $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hRecip
rs <- MaybeT $ getValBy $ UniqueRemoteSharer iid luRecip
return $ remoteSharerInbox rs
case mluInbox of
Just luInbox -> return $ l2f hRecip luInbox
Nothing -> do
manager <- getsYesod appHttpManager
eactor <- fetchAPID manager actorId hRecip luRecip
case eactor of
Left s -> fail $ "Fetched recipient actor: " ++ s
Right actor -> withHostLock hRecip $ runDB $ do
iid <- either entityKey id <$> insertBy (Instance hRecip)
let luInbox = actorInbox actor
rsid <- either entityKey id <$> insertBy (RemoteSharer luRecip iid luInbox)
update rdid [RemoteDiscussionActor =. Just rsid, RemoteDiscussionUnlinkedActor =. Nothing]
return $ l2f hRecip luInbox
-- TODO based on the httpPostAP usage in postOutboxR
manager <- getsYesod appHttpManager
(akey1, akey2, new1) <- liftIO . readTVarIO =<< getsYesod appActorKeys
renderUrl <- getUrlRender
let (keyID, akey) =
if new1
then (renderUrl ActorKey1R, akey1)
else (renderUrl ActorKey2R, akey2)
sign b = (KeyId $ encodeUtf8 keyID, actorKeySign akey b)
actorID = renderFedURI $ l2f host luAttrib
eres <- httpPostAP manager uInbox (hRequestTarget :| [hHost, hDate, hActivityPubActor]) sign actorID doc
case eres of
Left e -> logError $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e)
Right _ -> logInfo $ T.concat
[ "Successful delivery of <"
, renderFedURI $ l2f (docHost doc) (activityId $ docValue doc)
, " to <"
, renderFedURI uRecip
, ">"
]
return lmid
where
verifyNothing :: Monad m => Maybe a -> Text -> ExceptT Text m ()
verifyNothing Nothing _ = return ()
verifyNothing (Just _) t = throwE t
verifySameHost
:: Monad m => Text -> FedURI -> Text -> ExceptT Text m LocalURI
verifySameHost h fu t = do
let (h', lu) = f2l fu
if h == h'
then return lu
else throwE t
parseRecipContextParent
:: FedURI
-> FedURI
-> Maybe FedURI
-> ExceptT
Text
Handler
( Maybe (Either (ShrIdent, LocalMessageId) (Text, LocalURI))
, Either
(ShrIdent, PrjIdent, Int)
(Text, LocalURI, LocalURI)
)
parseRecipContextParent uRecip uContext muParent = do
let r@(hRecip, luRecip) = f2l uRecip
luContext <- verifySameHost hRecip uContext "Recipient and context on different hosts"
meparent <-
case muParent of
Nothing -> return Nothing
Just uParent ->
if uParent == uContext
then return Nothing
else Just <$> do
let (hParent, luParent) = f2l uParent
parentLocal <- hostIsLocal hParent
if parentLocal
then Left <$> parseComment luParent
else return $ Right (hParent, luParent)
local <- hostIsLocal hRecip
if local
then do
(shr, prj) <- parseProject luRecip
num <- parseTicket (shr, prj) luContext
return (meparent, Left (shr, prj, num))
else do
when (luRecip == luContext) $
throwE "Identical recipient and context"
{-
mrs <- lift $ runDB $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hRecip
MaybeT $ getBy $ UniqueRemoteSharer iid luRecip
erecip <-
case mrs of
Just ers -> return $ Left ers
Nothing -> do
manager <- getsYesod appHttpManager
eactor <- fetchAPID manager actorId hRecip luRecip
case eactor of
Left s -> throwE $ "Fetched recipient actor: " <> T.pack s
Right actor -> return $ Right actor
-}
return (meparent, Right (hRecip, luRecip, luContext))
verifyIsLoggedInUser
:: LocalURI -> Text -> ExceptT Text AppDB (PersonId, ShrIdent)
verifyIsLoggedInUser lu t = do
Entity pid p <- requireVerifiedAuth
s <- lift $ getJust $ personIdent p
route2local <- getEncodeRouteLocal
let shr = sharerIdent s
if route2local (SharerR shr) == lu
then return (pid, shr)
else throwE t
findExistingRemoteDiscussion
:: InstanceId
-> Text
-> LocalURI
-> LocalURI
-> ExceptT Text AppDB
(Maybe (DiscussionId, RemoteDiscussionId, Maybe LocalURI))
findExistingRemoteDiscussion iid hRecip luRecip luContext = do
merd <- lift $ getBy $ UniqueRemoteDiscussionIdent iid luContext
for merd $ \ (Entity rdid rd) -> do
eactor <-
requireEitherM
(remoteDiscussionActor rd)
(remoteDiscussionUnlinkedActor rd)
"RemoteDiscussion actor and unlinkedActor both unset"
"RemoteDiscussion actor and unlinkedActor both set"
minb <- case eactor of
Left rsid -> do
rs <- lift $ getJust rsid
unless (remoteSharerInstance rs == iid && remoteSharerIdent rs == luRecip) $
throwE "Known remote context, but its actor doesn't match the new Note's recipient"
return $ Just $ remoteSharerInbox rs
Right uActor -> do
unless (uActor == l2f hRecip luRecip) $
throwE "Known remote context, but its unlinked actor doesn't match the new Note's recipient"
return Nothing
return (remoteDiscussionDiscuss rd, rdid, minb)
insertRemoteDiscussion
:: InstanceId
-> Bool
-> Text
-> LocalURI
-> LocalURI
-> AppDB (DiscussionId, RemoteDiscussionId, Maybe LocalURI)
insertRemoteDiscussion iid inew hRecip luRecip luContext = do
mrs <-
if inew
then return Nothing
else getBy $ UniqueRemoteSharer iid luRecip
did <- insert Discussion
rdid <- insert RemoteDiscussion
{ remoteDiscussionActor = entityKey <$> mrs
, remoteDiscussionInstance = iid
, remoteDiscussionIdent = luContext
, remoteDiscussionDiscuss = did
, remoteDiscussionUnlinkedActor =
case mrs of
Nothing -> Just $ l2f hRecip luRecip
Just _ -> Nothing
}
return (did, rdid, remoteSharerInbox . entityVal <$> mrs)
storeRemoteDiscussion
:: Maybe InstanceId
-> Text
-> LocalURI
-> LocalURI
-> ExceptT Text AppDB
(DiscussionId, RemoteDiscussionId, Bool, Maybe LocalURI)
storeRemoteDiscussion miid hRecip luRecip luContext = do
(iid, inew) <-
case miid of
Just i -> return (i, False)
Nothing -> lift $ idAndNew <$> insertBy (Instance hRecip)
if inew
then do
(did, rdid, minb) <- lift $ insertRemoteDiscussion iid True hRecip luRecip luContext
return (did, rdid, True, minb)
else do
erd <- findExistingRemoteDiscussion iid hRecip luRecip luContext
case erd of
Just (did, rdid, minb) -> return (did, rdid, False, minb)
Nothing -> do
(did, rdid, minb) <- lift $ insertRemoteDiscussion iid False hRecip luRecip luContext
return (did, rdid, True, minb)
insertMessage
:: LocalURI
-> ShrIdent
-> PersonId
-> FedURI
-> DiscussionId
-> Maybe FedURI
-> Maybe (Either MessageId FedURI)
-> Text
-> AppDB (LocalMessageId, Doc Activity)
insertMessage luAttrib shrUser pid uContext did muParent meparent content = do
now <- liftIO getCurrentTime
mid <- insert Message
{ messageCreated = now
, messageContent = content
, messageParent =
case meparent of
Just (Left midParent) -> Just midParent
_ -> Nothing
, messageRoot = did
}
lmid <- insert LocalMessage
{ localMessageAuthor = pid
, localMessageRest = mid
, localMessageUnlinkedParent =
case meparent of
Just (Right uParent) -> Just uParent
_ -> Nothing
}
route2local <- getEncodeRouteLocal
encodeHid <- getsYesod appHashidEncode
let activity luAct = Doc host Activity
{ activityId = luAct
, activityActor = luAttrib
, activityAudience = aud
, activitySpecific = CreateActivity Create
{ createObject = Note
{ noteId = Just $ route2local $ MessageR shrUser $ encodeHid $ fromSqlKey lmid
, noteAttrib = luAttrib
, noteAudience = aud
, noteReplyTo = Just $ fromMaybe uContext muParent
, noteContext = Just uContext
, notePublished = Just now
, noteContent = content
}
}
}
obid <- insert OutboxItem
{ outboxItemPerson = pid
, outboxItemActivity = PersistJSON $ activity $ LocalURI "" ""
, outboxItemPublished = now
}
let luAct = route2local $ OutboxItemR shrUser $ encodeHid $ fromSqlKey obid
doc = activity luAct
update obid [OutboxItemActivity =. PersistJSON doc]
return (lmid, doc)

5
src/Vervis/Foundation.hs
View file

@ -210,7 +210,7 @@ instance Yesod App where
| a == resendVerifyR -> personFromResendForm
(AuthR (PluginR "account" ["verify", u, _]), False) -> personUnver u
(OutboxR , True) -> personAny
(OutboxR shr , True) -> person shr
(GroupsR , True) -> personAny
(GroupNewR , _ ) -> personAny
@ -767,7 +767,8 @@ instance YesodBreadcrumbs App where
PublishR -> ("Publish", Just HomeR)
InboxR -> ("Inbox", Just HomeR)
OutboxR -> ("Outbox", Just HomeR)
OutboxR shr -> ("Outbox", Just $ SharerR shr)
OutboxItemR shr hid -> ("#" <> hid, Just $ OutboxR shr)
ActorKey1R -> ("Actor Key 1", Nothing)
ActorKey2R -> ("Actor Key 2", Nothing)

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

@ -125,12 +125,24 @@ getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do
(Nothing, Just rd) -> do
let iid = remoteDiscussionInstance rd
i <- getJust iid
rs <- getJust $ remoteDiscussionSharer rd
unless (iid == remoteSharerInstance rs) $
fail "RemoteDiscussion and its sharer on different hosts"
let hInstance = instanceHost i
mrs <- traverse getJust $ remoteDiscussionActor rd
let muActor = f2l <$> remoteDiscussionUnlinkedActor rd
luActor <-
case (mrs, muActor) of
(Nothing, Nothing) -> fail "RemoteDiscussion actor and unlinkedActor both unset"
(Just _, Just _) -> fail "RemoteDiscussion actor and unlinkedActor both set"
(Just rs, Nothing) -> do
unless (iid == remoteSharerInstance rs) $
fail "RemoteDiscussion and its actor on different hosts"
return $ remoteSharerIdent rs
(Nothing, Just (h, lu)) -> do
unless (hInstance == h) $
fail "RemoteDiscussion and its unlinked actor on different hosts"
return lu
return
( l2f (instanceHost i) (remoteSharerIdent rs)
, l2f (instanceHost i) (remoteDiscussionIdent rd)
( l2f hInstance luActor
, l2f hInstance (remoteDiscussionIdent rd)
)
muParent <- for (messageParent m) $ \ midParent -> do
mlocal <- getBy $ UniqueLocalMessage midParent
@ -186,8 +198,9 @@ postTopReply replyP after getdid = do
, messageRoot = did
}
lmid <- insert LocalMessage
{ localMessageAuthor = author
, localMessageRest = mid
{ localMessageAuthor = author
, localMessageRest = mid
, localMessageUnlinkedParent = Nothing
}
return lmid
setMessage "Message submitted."
@ -237,8 +250,9 @@ postReply replyG replyP after getdid mid = do
, messageRoot = did
}
lmid <- insert LocalMessage
{ localMessageAuthor = author
, localMessageRest = mid
{ localMessageAuthor = author
, localMessageRest = mid
, localMessageUnlinkedParent = Nothing
}
return lmid
setMessage "Message submitted."

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

@ -18,6 +18,7 @@ module Vervis.Handler.Inbox
, postInboxR
, getPublishR
, getOutboxR
, getOutboxItemR
, postOutboxR
, getActorKey1R
, getActorKey2R
@ -212,40 +213,45 @@ activityForm = renderDivs $ (,,,)
defctx = FedURI "forge.angeley.es" "/s/fr33/p/sandbox/t/1" ""
defmsg = "Hi! I'm testing federation. Can you see my message? :)"
activityWidget :: Widget -> Enctype -> Widget
activityWidget widget enctype =
activityWidget :: ShrIdent -> Widget -> Enctype -> Widget
activityWidget shr widget enctype =
[whamlet|
<p>
This is a federation test page. Provide a recepient actor URI and
message text, and a Create activity creating a new Note will be sent
to the destination server.
<form method=POST action=@{OutboxR} enctype=#{enctype}>
<form method=POST action=@{OutboxR shr} enctype=#{enctype}>
^{widget}
<input type=submit>
|]
getUserShrIdent :: Handler ShrIdent
getUserShrIdent = do
Entity _ p <- requireVerifiedAuth
s <- runDB $ get404 $ personIdent p
return $ sharerIdent s
getPublishR :: Handler Html
getPublishR = do
shr <- getUserShrIdent
((_result, widget), enctype) <- runFormPost activityForm
defaultLayout $ activityWidget widget enctype
defaultLayout $ activityWidget shr widget enctype
getOutboxR :: Handler TypedContent
getOutboxR :: ShrIdent -> Handler TypedContent
getOutboxR = error "Not implemented yet"
postOutboxR :: Handler Html
postOutboxR = do
getOutboxItemR :: ShrIdent -> Text -> Handler TypedContent
getOutboxItemR = error "Not implemented yet"
postOutboxR :: ShrIdent -> Handler Html
postOutboxR shr = do
federation <- getsYesod $ appFederation . appSettings
unless federation badMethod
((result, widget), enctype) <- runFormPost activityForm
defaultLayout $ activityWidget widget enctype
case result of
FormMissing -> setMessage "Field(s) missing"
FormFailure _l -> setMessage "Invalid input, see below"
FormSuccess (to, mparent, mcontext, msg) -> do
shr <- do
Entity _pid person <- requireVerifiedAuth
sharer <- runDB $ get404 $ personIdent person
return $ sharerIdent sharer
renderUrl <- getUrlRender
route2uri <- getEncodeRouteFed
now <- liftIO getCurrentTime
@ -282,7 +288,7 @@ postOutboxR = do
case eres' of
Left e -> setMessage $ toHtml $ "Failed to POST to recipient's inbox: " <> T.pack (displayException e)
Right _ -> setMessage "Activity posted! You can go to the target server's /inbox to see the result."
defaultLayout $ activityWidget widget enctype
defaultLayout $ activityWidget shr widget enctype
where
fetchInboxURI :: Manager -> Text -> LocalURI -> Handler (Maybe LocalURI)
fetchInboxURI manager h lto = do

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

@ -40,7 +40,7 @@ import Data.ByteString (ByteString)
import Data.Text (Text)
import Data.Time (UTCTime)
import Database.Persist.Class (EntityField)
import Database.Persist.JSON (PersistJSONObject)
import Database.Persist.JSON (PersistJSONValue)
import Database.Persist.Schema.Types (Entity)
import Database.Persist.Schema.SQL ()
import Database.Persist.Sql (SqlBackend)

3
src/Vervis/Model.hs
View file

@ -30,6 +30,7 @@ import Database.Persist.EmailAddress
import Database.Persist.Graph.Class
import Database.Persist.JSON
import Network.FedURI (FedURI, LocalURI)
import Web.ActivityPub (Doc, Activity)
import Vervis.Model.Group
import Vervis.Model.Ident
@ -39,6 +40,8 @@ import Vervis.Model.Ticket
import Vervis.Model.TH
import Vervis.Model.Workflow
type PersistActivity = PersistJSON (Doc Activity)
makeEntities $(modelFile "config/models")
instance PersistUserCredentials Person where

10
src/Vervis/RemoteActorStore.hs
View file

@ -83,10 +83,14 @@ stateTVar var f = do
return a
withHostLock
:: YesodRemoteActorStore site
:: ( MonadHandler m
, MonadUnliftIO m
, HandlerSite m ~ site
, YesodRemoteActorStore site
)
=> Text
-> HandlerFor site a
-> HandlerFor site a
-> m a
-> m a
withHostLock host action = do
InstanceMutex tvar <- getsYesod siteInstanceMutex
mvar <- liftIO $ do

15
src/Yesod/FedURI.hs
View file

@ -16,14 +16,20 @@
module Yesod.FedURI
( getEncodeRouteFed
, getEncodeRouteLocal
, decodeRouteLocal
)
where
import Prelude
import Control.Monad
import Data.Text.Encoding
import Network.HTTP.Types.URI
import Yesod.Core
import Yesod.Core.Handler
import qualified Data.Text as T
import Network.FedURI
getEncodeRouteFed :: MonadHandler m => m (Route (HandlerSite m) -> FedURI)
@ -36,3 +42,12 @@ getEncodeRouteFed = toFed <$> getUrlRender
getEncodeRouteLocal :: MonadHandler m => m (Route (HandlerSite m) -> LocalURI)
getEncodeRouteLocal = (\ f -> snd . f2l . f) <$> getEncodeRouteFed
decodeRouteLocal :: ParseRoute site => LocalURI -> Maybe (Route site)
decodeRouteLocal =
parseRoute . (,[]) . decodePathSegments . encodeUtf8 . luriPath <=< noFrag
where
noFrag lu =
if T.null $ luriFragment lu
then Just lu
else Nothing