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 . + - + - ♡ 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 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