Receive remote comments on local ticket discussion

This commit is contained in:
fr33domlover 2019-03-21 22:57:15 +00:00
parent 72f96a0dff
commit ad3a20d783
11 changed files with 360 additions and 27 deletions

View file

@ -12,6 +12,10 @@
-- with this software. If not, see -- with this software. If not, see
-- <http://creativecommons.org/publicdomain/zero/1.0/>. -- <http://creativecommons.org/publicdomain/zero/1.0/>.
RawObject
content Value
received UTCTime
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
-- People -- People
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
@ -232,10 +236,14 @@ LocalMessage
UniqueLocalMessage rest UniqueLocalMessage rest
RemoteMessage RemoteMessage
author RemoteSharerId author RemoteSharerId
ident LocalURI instance InstanceId
rest MessageId ident LocalURI
rest MessageId
raw RawObjectId
lostParent FedURI Maybe
UniqueRemoteMessageIdent instance ident
UniqueRemoteMessage rest UniqueRemoteMessage rest
RepoCollab RepoCollab

View file

@ -1,3 +1,7 @@
RawObject
content Value
received UTCTime
LocalMessage LocalMessage
author PersonId author PersonId
rest MessageId rest MessageId
@ -5,8 +9,12 @@ LocalMessage
UniqueLocalMessage rest UniqueLocalMessage rest
RemoteMessage RemoteMessage
author RemoteSharerId author RemoteSharerId
ident Text instance InstanceId
rest MessageId ident Text
rest MessageId
raw RawObjectId
lostParent Text Maybe
UniqueRemoteMessageIdent instance ident
UniqueRemoteMessage rest UniqueRemoteMessage rest

View file

@ -19,6 +19,7 @@ module Data.Aeson.Local
, fromEither , fromEither
, frg , frg
, (.=?) , (.=?)
, WithValue (..)
) )
where where
@ -57,3 +58,11 @@ infixr 8 .=?
(.=?) :: ToJSON v => Text -> Maybe v -> Series (.=?) :: ToJSON v => Text -> Maybe v -> Series
_ .=? Nothing = mempty _ .=? Nothing = mempty
k .=? (Just v) = k .= v k .=? (Just v) = k .= v
data WithValue a = WithValue
{ wvRaw :: Value
, wvParsed :: a
}
instance FromJSON a => FromJSON (WithValue a) where
parseJSON v = WithValue v <$> parseJSON v

View file

@ -15,6 +15,8 @@
module Database.Persist.Local module Database.Persist.Local
( idAndNew ( idAndNew
, getKeyBy
, getValBy
, insertUnique_ , insertUnique_
) )
where where
@ -30,6 +32,24 @@ idAndNew :: Either (Entity a) (Key a) -> (Key a, Bool)
idAndNew (Left (Entity iid _)) = (iid, False) idAndNew (Left (Entity iid _)) = (iid, False)
idAndNew (Right iid) = (iid, True) idAndNew (Right iid) = (iid, True)
getKeyBy
:: ( MonadIO m
, PersistRecordBackend record backend
, PersistUniqueRead backend
)
=> Unique record
-> ReaderT backend m (Maybe (Key record))
getKeyBy u = fmap entityKey <$> getBy u
getValBy
:: ( MonadIO m
, PersistRecordBackend record backend
, PersistUniqueRead backend
)
=> Unique record
-> ReaderT backend m (Maybe record)
getValBy u = fmap entityVal <$> getBy u
insertUnique_ insertUnique_
:: ( MonadIO m :: ( MonadIO m
, PersistRecordBackend record backend , PersistRecordBackend record backend

247
src/Vervis/Federation.hs Normal file
View file

@ -0,0 +1,247 @@
{- This file is part of Vervis.
-
- Written in 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/>.
-}
module Vervis.Federation
( handleActivity
)
where
import Prelude
import Control.Monad
import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Aeson (Value)
import Data.Foldable
import Data.Text (Text)
import Data.Text.Encoding
import Data.Time.Clock
import Database.Persist
import Database.Persist.Sql
import Network.HTTP.Types.URI
import Yesod.Core hiding (logWarn)
import Yesod.Persist.Core
import qualified Data.Text as T
import qualified Data.Vector as V
import qualified Database.Esqueleto as E
import Network.FedURI
import Web.ActivityPub
import Database.Persist.Local
import Vervis.Foundation
import Vervis.Model
import Vervis.Settings
-- | 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).
handleActivity :: Value -> Text -> InstanceId -> RemoteSharerId -> Activity -> Handler (Text, Bool)
handleActivity raw hActor iidActor rsidActor (Activity _id _luActor audience specific) =
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) ->
( T.concat
[ "Inserted remote comment <"
, renderFedURI uNew
, "> into discussion of local ticket <"
, luriPath luTicket
, ">."
]
, True
)
_ -> 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
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 return $ Just $ Right (hParent, luParent)
selectOrphans uNote did op =
E.select $ E.from $ \ (rm `E.InnerJoin` m) -> do
E.on $ rm E.^. RemoteMessageRest E.==. m E.^. MessageId
E.where_ $
rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&.
m E.^. MessageRoot `op` E.val did
return (rm E.^. RemoteMessageId, m E.^. MessageId)
handleCreate iidActor hActor rsidActor raw audience (Note luNote muParent muContext mpublished content) = do
(shr, prj) <- do
uRecip <- parseAudience audience
parseProject uRecip
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
published <- fromMaybeE mpublished "Got Create Note without 'published' field"
ExceptT $ runDB $ runExceptT $ do
mrmid <- lift $ getKeyBy $ UniqueRemoteMessageIdent iidActor luNote
for_ mrmid $ \ rmid ->
done $
"Got a Create Note with a note ID we already have, \
\RemoteMessageId " <> T.pack (show rmid)
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 "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
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
now <- liftIO getCurrentTime
roid <- lift $ insert $ RawObject raw now
mid <- lift $ insert Message
{ messageCreated = published
, messageContent = content
, messageParent =
case meparent of
Just (Left midParent) -> Just midParent
_ -> Nothing
, messageRoot = did
}
lift $ insert_ RemoteMessage
{ remoteMessageAuthor = rsidActor
, remoteMessageInstance = iidActor
, remoteMessageIdent = luNote
, remoteMessageRest = mid
, remoteMessageRaw = roid
, remoteMessageLostParent =
case meparent of
Just (Right uParent) -> Just uParent
_ -> Nothing
}
-- Now we need to check orphans. These are RemoteMessages whose
-- associated Message doesn't have a parent, but the original Note
-- does have an inReplyTo which isn't the same as the context. It's
-- possible that this new activity we just got, this new Note, is
-- exactly that lost parent.
let uNote = l2f hActor luNote
related <- lift $ selectOrphans uNote did (E.==.)
lift $ for_ related $ \ (E.Value rmidOrphan, E.Value midOrphan) -> do
logWarn $ T.concat
[ "Found parent for related orphan RemoteMessage #"
, T.pack (show rmidOrphan)
, ", setting its parent now to Message #"
, T.pack (show mid)
]
update rmidOrphan [RemoteMessageLostParent =. Nothing]
update midOrphan [MessageParent =. Just mid]
unrelated <- lift $ selectOrphans uNote did (E.!=.)
for_ unrelated $ \ (E.Value rmidOrphan, E.Value _midOrphan) ->
logWarn $ T.concat
[ "Found parent for unrelated orphan RemoteMessage #"
, T.pack (show rmidOrphan)
, ", NOT settings its parent to Message #"
, T.pack (show mid)
, " because they have different DiscussionId!"
]
return (uNote, luContext)

View file

@ -81,6 +81,12 @@ import Vervis.Model.Role
import Vervis.RemoteActorStore import Vervis.RemoteActorStore
import Vervis.Widget (breadcrumbsW, revisionW) import Vervis.Widget (breadcrumbsW, revisionW)
data ActivityReport
= ActivityReportHandlerError String
| ActivityReportWorkerError ByteString BL.ByteString SomeException
| ActivityReportUsed Text
| ActivityReportUnused ByteString BL.ByteString Text
-- | The foundation datatype for your application. This can be a good place to -- | The foundation datatype for your application. This can be a good place to
-- keep settings and values requiring initialization before your application -- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have -- starts running, such as database connections. Every handler will have
@ -99,7 +105,7 @@ data App = App
, appHashidEncode :: Int64 -> Text , appHashidEncode :: Int64 -> Text
, appHashidDecode :: Text -> Maybe Int64 , appHashidDecode :: Text -> Maybe Int64
, appActivities :: TVar (Vector (UTCTime, Either String (ByteString, BL.ByteString))) , appActivities :: TVar (Vector (UTCTime, ActivityReport))
} }
-- This is where we define all of the routes in our application. For a full -- This is where we define all of the routes in our application. For a full

View file

@ -30,6 +30,7 @@ import Control.Concurrent.STM.TVar (readTVarIO, modifyTVar')
import Control.Exception (displayException) import Control.Exception (displayException)
import Control.Monad import Control.Monad
import Control.Monad.IO.Class (liftIO) import Control.Monad.IO.Class (liftIO)
import Control.Monad.Logger.CallStack
import Control.Monad.STM (atomically) import Control.Monad.STM (atomically)
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe import Control.Monad.Trans.Maybe
@ -78,12 +79,14 @@ import Yesod.HttpSignature (verifyRequestSignature)
import qualified Network.HTTP.Signature as S (Algorithm (..)) import qualified Network.HTTP.Signature as S (Algorithm (..))
import Data.Aeson.Encode.Pretty.ToEncoding import Data.Aeson.Encode.Pretty.ToEncoding
import Data.Aeson.Local
import Database.Persist.Local import Database.Persist.Local
import Network.FedURI import Network.FedURI
import Web.ActivityPub import Web.ActivityPub
import Yesod.Auth.Unverified import Yesod.Auth.Unverified
import Vervis.ActorKey import Vervis.ActorKey
import Vervis.Federation
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.RemoteActorStore import Vervis.RemoteActorStore
@ -103,34 +106,55 @@ getInboxR = do
results. results.
<p>Last 10 activities posted: <p>Last 10 activities posted:
<ul> <ul>
$forall (time, result) <- acts $forall (time, report) <- acts
<li> <li>
<div>#{show time} <div>#{show time}
$case result $case report
$of Left e $of ActivityReportHandlerError e
<div>Handler error:
<div>#{e} <div>#{e}
$of Right (ct, o) $of ActivityReportWorkerError ct o e
<div><code>#{BC.unpack ct} <div><code>#{BC.unpack ct}
<div><pre>#{decodeUtf8 o} <div><pre>#{decodeUtf8 o}
<div>#{displayException e}
$of ActivityReportUsed msg
<div>#{msg}
$of ActivityReportUnused ct o msg
<div><code>#{BC.unpack ct}
<div><pre>#{decodeUtf8 o}
<div>#{msg}
|] |]
postInboxR :: Handler () postInboxR :: Handler ()
postInboxR = do postInboxR = do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
r <- runExceptT $ getActivity now r <- runExceptT $ getActivity now
let item = (now, second (second encodePretty) r)
acts <- getsYesod appActivities
liftIO $ atomically $ modifyTVar' acts $ \ vec ->
let vec' = item `V.cons` vec
in if V.length vec' > 10
then V.init vec'
else vec'
case r of case r of
Right _ -> return () Right (ct, (WithValue raw d@(Doc h a), (iid, rsid))) ->
Left _ -> notAuthenticated forkHandler (handleWorkerError now ct d) $ do
(msg, stored) <- handleActivity raw h iid rsid a
if stored
then recordUsed now msg
else recordUnused now ct d msg
Left e -> do
recordError now e
notAuthenticated
where where
liftE = ExceptT . pure liftE = ExceptT . pure
getActivity :: UTCTime -> ExceptT String Handler (ContentType, Doc Activity) handleWorkerError now ct d e = do
logError $ "postInboxR worker error: " <> T.pack (displayException e)
recordActivity now $ ActivityReportWorkerError ct (encodePretty d) e
recordActivity now item = do
acts <- getsYesod appActivities
liftIO $ atomically $ modifyTVar' acts $ \ vec ->
let vec' = (now, item) `V.cons` vec
in if V.length vec' > 10
then V.init vec'
else vec'
recordUsed now msg = recordActivity now $ ActivityReportUsed msg
recordUnused now ct d msg = recordActivity now $ ActivityReportUnused ct (encodePretty d) msg
recordError now e = recordActivity now $ ActivityReportHandlerError e
getActivity :: UTCTime -> ExceptT String Handler (ContentType, (WithValue (Doc Activity), (InstanceId, RemoteSharerId)))
getActivity now = do getActivity now = do
contentType <- do contentType <- do
ctypes <- lookupHeaders "Content-Type" ctypes <- lookupHeaders "Content-Type"
@ -143,12 +167,14 @@ postInboxR = do
_ -> Left "More than one Content-Type given" _ -> Left "More than one Content-Type given"
HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now HttpSigVerResult result <- ExceptT . fmap (first displayException) $ verifyRequestSignature now
(h, luActor) <- f2l . actorDetailId <$> liftE result (h, luActor) <- f2l . actorDetailId <$> liftE result
d@(Doc h' a) <- requireJsonBody ActorDetail uActor iid rsid <- liftE result
let (h, luActor) = f2l uActor
wv@(WithValue v (Doc h' a)) <- requireJsonBody
unless (h == h') $ unless (h == h') $
throwE "Activity host doesn't match signature key host" throwE "Activity host doesn't match signature key host"
unless (activityActor a == luActor) $ unless (activityActor a == luActor) $
throwE "Activity's actor != Signature key's actor" throwE "Activity's actor != Signature key's actor"
return (contentType, d) return (contentType, (wv, (iid, rsid)))
{- {-
jsonField :: (FromJSON a, ToJSON a) => Field Handler a jsonField :: (FromJSON a, ToJSON a) => Field Handler a

View file

@ -35,6 +35,7 @@ where
import Prelude import Prelude
import Data.Aeson (Value)
import Data.ByteString (ByteString) import Data.ByteString (ByteString)
import Data.Text (Text) import Data.Text (Text)
import Data.Time (UTCTime) import Data.Time (UTCTime)

View file

@ -28,6 +28,7 @@ import Yesod.Auth.Account (PersistUserCredentials (..))
import Crypto.PublicVerifKey import Crypto.PublicVerifKey
import Database.Persist.EmailAddress import Database.Persist.EmailAddress
import Database.Persist.Graph.Class import Database.Persist.Graph.Class
import Database.Persist.Postgresql.JSON ()
import Network.FedURI (FedURI, LocalURI) import Network.FedURI (FedURI, LocalURI)
import Vervis.Model.Group import Vervis.Model.Group

View file

@ -316,11 +316,13 @@ instance ActivityPub Actor where
<> "publicKey" `pair` encodePublicKeySet host pkeys <> "publicKey" `pair` encodePublicKeySet host pkeys
data Note = Note data Note = Note
{ noteId :: LocalURI { noteId :: LocalURI
--, noteAttrib :: LocalURI --, noteAttrib :: LocalURI
--, noteTo :: FedURI --, noteTo :: FedURI
, noteReplyTo :: Maybe FedURI , noteReplyTo :: Maybe FedURI
, noteContent :: Text , noteContext :: Maybe FedURI
, notePublished :: Maybe UTCTime
, noteContent :: Text
} }
parseNote :: Value -> Parser (Text, (Note, LocalURI)) parseNote :: Value -> Parser (Text, (Note, LocalURI))
@ -331,6 +333,8 @@ parseNote = withObject "Note" $ \ o -> do
fmap (h,) $ fmap (h,) $
(,) <$> (Note id_ (,) <$> (Note id_
<$> o .:? "inReplyTo" <$> o .:? "inReplyTo"
<*> o .:? "context"
<*> o .:? "published"
<*> o .: "content" <*> o .: "content"
) )
<*> withHost h (f2l <$> o .: "attributedTo") <*> withHost h (f2l <$> o .: "attributedTo")
@ -342,12 +346,14 @@ parseNote = withObject "Note" $ \ o -> do
else fail "URI host mismatch" else fail "URI host mismatch"
encodeNote :: Text -> Note -> LocalURI -> Encoding encodeNote :: Text -> Note -> LocalURI -> Encoding
encodeNote host (Note id_ mreply content) attrib = encodeNote host (Note id_ mreply mcontext mpublished content) attrib =
pairs pairs
$ "type" .= ("Note" :: Text) $ "type" .= ("Note" :: Text)
<> "id" .= l2f host id_ <> "id" .= l2f host id_
<> "attributedTo" .= l2f host attrib <> "attributedTo" .= l2f host attrib
<> "inReplyTo" .=? mreply <> "inReplyTo" .=? mreply
<> "context" .=? mcontext
<> "published" .=? mpublished
<> "content" .= content <> "content" .= content
data Accept = Accept data Accept = Accept

View file

@ -111,6 +111,7 @@ library
Vervis.Content Vervis.Content
Vervis.Darcs Vervis.Darcs
Vervis.Discussion Vervis.Discussion
Vervis.Federation
Vervis.Field.Key Vervis.Field.Key
Vervis.Field.Person Vervis.Field.Person
Vervis.Field.Project Vervis.Field.Project