Receive remote comments on local ticket discussion

config/models

@@ -12,6 +12,10 @@
 -- with this software. If not, see
 -- <http://creativecommons.org/publicdomain/zero/1.0/>.
 
+RawObject
+    content  Value
+    received UTCTime
+
 -------------------------------------------------------------------------------
 -- People
 -------------------------------------------------------------------------------
@@ -232,10 +236,14 @@ LocalMessage
     UniqueLocalMessage rest
 
 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
 
 RepoCollab

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
+    author     RemoteSharerId
-    ident   Text
+    instance   InstanceId
-    rest    MessageId
+    ident      Text
+    rest       MessageId
+    raw        RawObjectId
+    lostParent Text           Maybe
 
+    UniqueRemoteMessageIdent instance ident
     UniqueRemoteMessage rest

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

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

src/Vervis/Federation.hs

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

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

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.
             <p>Last 10 activities posted:
             <ul>
-              $forall (time, result) <- acts
+              $forall (time, report) <- acts
                 <li>
                   <div>#{show time}
-                  $case result
+                  $case report
-                    $of Left e
+                    $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)
-    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 ()
+        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
     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

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)

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

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
+    , noteReplyTo   :: Maybe FedURI
-    , noteContent :: Text
+    , 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

vervis.cabal

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