From fdbe46741b6772dee04022222e366cc26ccfbb81 Mon Sep 17 00:00:00 2001
From: fr33domlover <fr33domlover@riseup.net>
Date: Sat, 9 Mar 2019 17:12:43 +0000
Subject: [PATCH] When POSTing an activity, protect remote actor DB insertion
 with withHostLock

---
 src/Database/Persist/Local.hs  | 40 ++++++++++++++++++++++++++++++++++
 src/Vervis/Handler/Inbox.hs    | 28 +++++++++++++++++-------
 src/Vervis/RemoteActorStore.hs |  4 +---
 vervis.cabal                   |  1 +
 4 files changed, 62 insertions(+), 11 deletions(-)
 create mode 100644 src/Database/Persist/Local.hs

diff --git a/src/Database/Persist/Local.hs b/src/Database/Persist/Local.hs
new file mode 100644
index 0000000..a69005f
--- /dev/null
+++ b/src/Database/Persist/Local.hs
@@ -0,0 +1,40 @@
+{- 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 Database.Persist.Local
+    ( idAndNew
+    , insertUnique_
+    )
+where
+
+import Prelude
+
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Reader
+import Database.Persist
+
+idAndNew :: Either (Entity a) (Key a) -> (Key a, Bool)
+idAndNew (Left (Entity iid _)) = (iid, False)
+idAndNew (Right iid)           = (iid, True)
+
+insertUnique_
+    :: ( MonadIO m
+       , PersistRecordBackend record backend
+       , PersistUniqueWrite backend
+       )
+    => record
+    -> ReaderT backend m ()
+insertUnique_ = void . insertUnique
diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs
index 5de40f1..f77e04b 100644
--- a/src/Vervis/Handler/Inbox.hs
+++ b/src/Vervis/Handler/Inbox.hs
@@ -77,6 +77,7 @@ import Yesod.HttpSignature (verifyRequestSignature)
 import qualified Network.HTTP.Signature as S (Algorithm (..))
 
 import Data.Aeson.Encode.Pretty.ToEncoding
+import Database.Persist.Local
 import Network.FedURI
 import Web.ActivityPub
 import Yesod.Auth.Unverified
@@ -84,6 +85,7 @@ import Yesod.Auth.Unverified
 import Vervis.ActorKey
 import Vervis.Foundation
 import Vervis.Model
+import Vervis.RemoteActorStore
 import Vervis.Settings (AppSettings (appHttpSigTimeLimit))
 
 getInboxR :: Handler Html
@@ -248,11 +250,15 @@ postOutboxR = do
     where
     fetchInboxURI :: Manager -> Text -> LocalURI -> Handler (Maybe LocalURI)
     fetchInboxURI manager h lto = do
-        mrs <- runDB $ runMaybeT $ do
-            Entity iid _ <- MaybeT $ getBy $ UniqueInstance h
-            MaybeT $ getBy $ UniqueRemoteSharer iid lto
+        mrs <- runDB $ do
+            mi <- getBy $ UniqueInstance h
+            case mi of
+                Nothing -> return $ Left Nothing
+                Just (Entity iid _) ->
+                    maybe (Left $ Just iid) Right <$>
+                        getBy (UniqueRemoteSharer iid lto)
         case mrs of
-            Nothing -> do
+            Left miid -> do
                 eres <- fetchAPID manager actorId h lto
                 case eres of
                     Left s -> do
@@ -263,13 +269,19 @@ postOutboxR = do
                             , T.pack s
                             ]
                         return Nothing
-                    Right actor -> do
+                    Right actor -> withHostLock h $ do
                         let inbox = actorInbox actor
                         runDB $ do
-                            iid <- either entityKey id <$> insertBy (Instance h)
-                            insert_ $ RemoteSharer lto iid inbox
+                            (iid, inew) <-
+                                case miid of
+                                    Just iid -> return (iid, False)
+                                    Nothing -> idAndNew <$> insertBy (Instance h)
+                            let rs = RemoteSharer lto iid inbox
+                            if inew
+                                then insert_ rs
+                                else insertUnique_ rs
                         return $ Just inbox
-            Just (Entity _rsid rs) -> return $ Just $ remoteSharerInbox rs
+            Right (Entity _rsid rs) -> return $ Just $ remoteSharerInbox rs
 
 getActorKey :: ((ActorKey, ActorKey, Bool) -> ActorKey) -> Route App -> Handler TypedContent
 getActorKey choose route = do
diff --git a/src/Vervis/RemoteActorStore.hs b/src/Vervis/RemoteActorStore.hs
index 86f1c7d..920168a 100644
--- a/src/Vervis/RemoteActorStore.hs
+++ b/src/Vervis/RemoteActorStore.hs
@@ -49,6 +49,7 @@ import Yesod.Persist.Core
 import qualified Crypto.PubKey.Ed25519 as E
 import qualified Data.HashMap.Strict as M
 
+import Database.Persist.Local
 import Network.FedURI
 import Web.ActivityPub
 
@@ -132,9 +133,6 @@ instanceAndActor host luActor luInbox = do
         else do
             (rsid, rsnew) <- idAndNew <$> insertBy rs
             return (iid, rsid, Just rsnew)
-    where
-    idAndNew (Left (Entity iid _)) = (iid, False)
-    idAndNew (Right iid)           = (iid, True)
 
 actorRoom
     :: ( PersistQueryRead (YesodPersistBackend site)
diff --git a/vervis.cabal b/vervis.cabal
index 2916b6a..a0d97cb 100644
--- a/vervis.cabal
+++ b/vervis.cabal
@@ -72,6 +72,7 @@ library
                        Database.Esqueleto.Local
                        Database.Persist.Class.Local
                        Database.Persist.Sql.Local
+                       Database.Persist.Local
                        Database.Persist.Local.Class.PersistEntityHierarchy
                        Database.Persist.Local.RecursionDoc
                        Diagrams.IntransitiveDAG