git-remote-ipfs: Load LOBs map only once

monadic-xyz · Jan 23, 2019 · 42294ab · 42294ab
1 parent c779c18
commit 42294ab
Show file tree

Hide file tree

Showing 2 changed files with 22 additions and 8 deletions.
diff --git a/git-remote-ipfs/src/Network/IPFS/Git/RemoteHelper.hs b/git-remote-ipfs/src/Network/IPFS/Git/RemoteHelper.hs
@@ -205,14 +205,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
@@ -223,7 +232,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

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
@@ -40,13 +41,15 @@ module Network.IPFS.Git.RemoteHelper.Trans
 where
 
 import qualified Control.Concurrent.Async as Async
+import           Control.Concurrent.MVar (MVar, newMVar)
 import           Control.Concurrent.QSem
 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(..))
@@ -99,6 +102,7 @@ data Env = Env
     , envGit       :: Git SHA1
     , envClient    :: Servant.ClientEnv
     , envIpfsRoot  :: CID
+    , envLobs      :: MVar (Maybe (HashMap CID CID))
     }
 
 class DisplayError a where
@@ -243,6 +247,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"