forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Receive remote comments on local ticket discussion

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

8
config/models
View file

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

8
migrations/2019_03_19.model
View file

@ -1,3 +1,7 @@
RawObject
content Value
received UTCTime
LocalMessage
author PersonId
rest MessageId
@ -6,7 +10,11 @@ LocalMessage
RemoteMessage
author RemoteSharerId
instance InstanceId
ident Text
rest MessageId
raw RawObjectId
lostParent Text Maybe
UniqueRemoteMessageIdent instance ident
UniqueRemoteMessage rest

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

@ -19,6 +19,7 @@ module Data.Aeson.Local
, fromEither
, frg
, (.=?)
, WithValue (..)
)
where
@ -57,3 +58,11 @@ infixr 8 .=?
(.=?) :: ToJSON v => Text -> Maybe v -> Series
_ .=? Nothing = mempty
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

20
src/Database/Persist/Local.hs
View file

@ -15,6 +15,8 @@
module Database.Persist.Local
( idAndNew
, getKeyBy
, getValBy
, insertUnique_
)
where
@ -30,6 +32,24 @@ idAndNew :: Either (Entity a) (Key a) -> (Key a, Bool)
idAndNew (Left (Entity iid _)) = (iid, False)
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_
:: ( MonadIO m
, 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)

8
src/Vervis/Foundation.hs
View file

@ -81,6 +81,12 @@ import Vervis.Model.Role
import Vervis.RemoteActorStore
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
-- keep settings and values requiring initialization before your application
-- starts running, such as database connections. Every handler will have
@ -99,7 +105,7 @@ data App = App
, appHashidEncode :: Int64 -> Text
, 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

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

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

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

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

1
src/Vervis/Model.hs
View file

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

8
src/Web/ActivityPub.hs
View file

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

1
vervis.cabal
View file

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