git-remote-ipfs: Load LOBs map only once

monadic-xyz · Jan 22, 2019 · 9eab23f · 9eab23f
1 parent 5c1f432
commit 9eab23f
Show file tree

Hide file tree

Showing 2 changed files with 24 additions and 10 deletions.
diff --git a/git-remote-ipfs/src/Network/IPFS/Git/RemoteHelper.hs b/git-remote-ipfs/src/Network/IPFS/Git/RemoteHelper.hs
@@ -11,7 +11,7 @@ module Network.IPFS.Git.RemoteHelper
 where
 
 import           Control.Concurrent.Async (forConcurrently, forConcurrently_)
-import           Control.Concurrent.MVar (newMVar, withMVar)
+import           Control.Concurrent.MVar (modifyMVar, newMVar, withMVar)
 import           Control.Exception.Safe
                  ( MonadCatch
                  , SomeException
@@ -212,14 +212,23 @@ processPush _ localRef remoteRef = do
 
 processFetch :: Text -> RemoteHelper ProcessError ()
 processFetch sha = do
-    repo  <- Git.getGit
-    root  <- asks envIpfsRoot
-    cid   <- liftEitherRH . first CidError $ cidFromHexShaText sha
-    lobjs <- ipfs $ largeObjects root -- XXX: load lobjs only once
-    lck   <- liftIO $ newMVar ()
-    go repo root lobjs lck cid
+    repo <- Git.getGit
+    root <- asks envIpfsRoot
+    cid  <- liftEitherRH . first CidError $ cidFromHexShaText sha
+    lck  <- liftIO $ newMVar ()
+    lobs <- do
+        env <- ask
+        (>>= either throwError pure)
+            . liftIO . modifyMVar (envLobs env) $ \case
+                Just ls -> pure (Just ls, Right ls)
+                Nothing ->
+                    runRemoteHelper env (ipfs (largeObjects root)) >>= \case
+                        Left  e  -> pure (Nothing, Left  e)
+                        Right ls -> pure (Just ls, Right ls)
+
+    go repo root lobs lck cid
   where
-    go !repo !root !lobjs lck cid = do
+    go !repo !root !lobs lck cid = do
         ref  <- liftEitherRH . first CidError $ cidToRef @Git.SHA1 cid
         have <-
             -- Nb. mutex here as we might access the same packfile concurrently
@@ -230,7 +239,7 @@ processFetch sha = do
                 fmt ("fetch: Skipping " % fref % " (" % fcid % ")") ref cid
             Nothing -> do
                 raw <- do
-                    blk <- ipfs $ provideBlock lobjs cid
+                    blk <- ipfs $ provideBlock lobs cid
                     case blk of
                         Just  b -> pure b
                         Nothing -> ipfs $ getBlock cid
@@ -241,7 +250,7 @@ processFetch sha = do
                 env <- ask
                 liftIO . forConcurrently_ (objectLinks obj) $
                     either throwM pure <=<
-                        runRemoteHelper env . go repo root lobjs lck
+                        runRemoteHelper env . go repo root lobs lck
 
 --------------------------------------------------------------------------------
 

diff --git a/git-remote-ipfs/src/Network/IPFS/Git/RemoteHelper/Trans.hs b/git-remote-ipfs/src/Network/IPFS/Git/RemoteHelper/Trans.hs
@@ -12,6 +12,7 @@ module Network.IPFS.Git.RemoteHelper.Trans
     , envOptions
     , envClient
     , envIpfsRoot
+    , envLobs
 
     , RemoteHelper
     , RemoteHelperT
@@ -34,12 +35,14 @@ module Network.IPFS.Git.RemoteHelper.Trans
     )
 where
 
+import           Control.Concurrent.MVar (MVar, newMVar)
 import           Control.Exception.Safe
 import qualified Control.Lens as Lens
 import           Control.Monad.Except
 import           Control.Monad.Reader
 import qualified Data.Aeson.Lens as Lens
 import           Data.Bifunctor (first)
+import           Data.HashMap.Strict (HashMap)
 import           Data.IORef (IORef, newIORef, readIORef)
 import           Data.Maybe (fromMaybe)
 import           Data.Proxy (Proxy(..))
@@ -92,6 +95,7 @@ data Env = Env
     , envGit       :: Git SHA1
     , envClient    :: Servant.ClientEnv
     , envIpfsRoot  :: CID
+    , envLobs      :: MVar (Maybe (HashMap CID CID))
     }
 
 data RemoteHelperError a = RemoteHelperError
@@ -190,6 +194,7 @@ newEnv envLogger envOptions = do
     envVerbosity <- newIORef 1
     envDryRun    <- newIORef False
     envGit       <- findRepo >>= openRepo
+    envLobs      <- newMVar Nothing
     ipfsBase     <-
         Servant.parseBaseUrl
             =<< fromMaybe "http://localhost:5001" <$> lookupEnv "IPFS_API_URL"