From ad3a20d783d134bbf64b82f270127149d61a8c06 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 21 Mar 2019 22:57:15 +0000 Subject: [PATCH] Receive remote comments on local ticket discussion --- config/models | 14 +- migrations/2019_03_19.model | 14 +- src/Data/Aeson/Local.hs | 9 ++ src/Database/Persist/Local.hs | 20 +++ src/Vervis/Federation.hs | 247 ++++++++++++++++++++++++++++++++++ src/Vervis/Foundation.hs | 8 +- src/Vervis/Handler/Inbox.hs | 58 +++++--- src/Vervis/Migration/Model.hs | 1 + src/Vervis/Model.hs | 1 + src/Web/ActivityPub.hs | 14 +- vervis.cabal | 1 + 11 files changed, 360 insertions(+), 27 deletions(-) create mode 100644 src/Vervis/Federation.hs diff --git a/config/models b/config/models index 5dcf278..1982245 100644 --- a/config/models +++ b/config/models @@ -12,6 +12,10 @@ -- with this software. If not, see -- . +RawObject + content Value + received UTCTime + ------------------------------------------------------------------------------- -- People ------------------------------------------------------------------------------- @@ -232,10 +236,14 @@ LocalMessage UniqueLocalMessage rest RemoteMessage - author RemoteSharerId - ident LocalURI - rest MessageId + author RemoteSharerId + instance InstanceId + ident LocalURI + rest MessageId + raw RawObjectId + lostParent FedURI Maybe + UniqueRemoteMessageIdent instance ident UniqueRemoteMessage rest RepoCollab diff --git a/migrations/2019_03_19.model b/migrations/2019_03_19.model index 03d72ba..dd1a562 100644 --- a/migrations/2019_03_19.model +++ b/migrations/2019_03_19.model @@ -1,3 +1,7 @@ +RawObject + content Value + received UTCTime + LocalMessage author PersonId rest MessageId @@ -5,8 +9,12 @@ LocalMessage UniqueLocalMessage rest RemoteMessage - author RemoteSharerId - ident Text - rest MessageId + author RemoteSharerId + instance InstanceId + ident Text + rest MessageId + raw RawObjectId + lostParent Text Maybe + UniqueRemoteMessageIdent instance ident UniqueRemoteMessage rest diff --git a/src/Data/Aeson/Local.hs b/src/Data/Aeson/Local.hs index 3a71cd3..39a75ef 100644 --- a/src/Data/Aeson/Local.hs +++ b/src/Data/Aeson/Local.hs @@ -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 diff --git a/src/Database/Persist/Local.hs b/src/Database/Persist/Local.hs index a69005f..20bc02f 100644 --- a/src/Database/Persist/Local.hs +++ b/src/Database/Persist/Local.hs @@ -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 diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs new file mode 100644 index 0000000..93c6552 --- /dev/null +++ b/src/Vervis/Federation.hs @@ -0,0 +1,247 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +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) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 96fb58b..cd09051 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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 diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 08b609b..06578da 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -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.

Last 10 activities posted:

    - $forall (time, result) <- acts + $forall (time, report) <- acts
  • #{show time} - $case result - $of Left e + $case report + $of ActivityReportHandlerError e +
    Handler error:
    #{e} - $of Right (ct, o) + $of ActivityReportWorkerError ct o e
    #{BC.unpack ct} 
    #{decodeUtf8 o}
+                      
    #{displayException e}
+                    $of ActivityReportUsed msg
+                      
    #{msg}
+                    $of ActivityReportUnused ct o msg
+                      
    #{BC.unpack ct}
+                      
    #{decodeUtf8 o}
+                      
    #{msg}
         |]
 
 postInboxR :: Handler ()
 postInboxR = do
     now <- liftIO getCurrentTime
     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
-        Right _ -> return ()
-        Left _ -> notAuthenticated
+        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
-    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
         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
diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs
index 08fb209..b76c6c1 100644
--- a/src/Vervis/Migration/Model.hs
+++ b/src/Vervis/Migration/Model.hs
@@ -35,6 +35,7 @@ where
 
 import Prelude
 
+import Data.Aeson (Value)
 import Data.ByteString (ByteString)
 import Data.Text (Text)
 import Data.Time (UTCTime)
diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs
index 8206df2..9f68b7a 100644
--- a/src/Vervis/Model.hs
+++ b/src/Vervis/Model.hs
@@ -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
diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index 9afa62a..ff9a462 100644
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@@ -316,11 +316,13 @@ instance ActivityPub Actor where
         <> "publicKey"         `pair` encodePublicKeySet host pkeys
 
 data Note = Note
-    { noteId      :: LocalURI
+    { noteId        :: LocalURI
     --, noteAttrib  :: LocalURI
     --, noteTo      :: FedURI
-    , noteReplyTo :: Maybe FedURI
-    , noteContent :: Text
+    , noteReplyTo   :: Maybe FedURI
+    , noteContext   :: Maybe FedURI
+    , notePublished :: Maybe UTCTime
+    , noteContent   :: Text
     }
 
 parseNote :: Value -> Parser (Text, (Note, LocalURI))
@@ -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
diff --git a/vervis.cabal b/vervis.cabal
index 1301209..b9972af 100644
--- a/vervis.cabal
+++ b/vervis.cabal
@@ -111,6 +111,7 @@ library
                        Vervis.Content
                        Vervis.Darcs
                        Vervis.Discussion
+                       Vervis.Federation
                        Vervis.Field.Key
                        Vervis.Field.Person
                        Vervis.Field.Project