Resolve issue1159: smart caches union.
--------------------------------------
Dmitry Kurochkin <dmitry.kurochkin@gmail.com>**20100416235644
hunk ./src/Darcs/Repository/Cache.hs 74
> unionCaches :: Cache -> Cache -> Cache
> unionCaches (Ca a) (Ca b) = Ca (nub (a++b))
>
> +unionRemoteCaches :: Cache -> Cache -> String -> IO (Cache)
> +unionRemoteCaches local (Ca remote) repourl
> + | is_file repourl = do f <- filtered
> + return $ local `unionCaches` Ca f
> + | otherwise = return local
> + where filtered = mapM (\x -> fn x `catchall` return Nothing) remote >>=
> + return . catMaybes
> + fn :: CacheLoc -> IO (Maybe CacheLoc)
> + fn (Cache Repo Writable _) = return Nothing
> + fn c@(Cache t _ url)
> + | is_file url = do
> + ex <- doesDirectoryExist url
> + if ex then do p <- getPermissions url
> + return $ Just $
> + if writable c && SD.writable p
> + then c else Cache t NotWritable url
> + else return Nothing
> + | otherwise = return $ Just c
> +
> repo2cache :: String -> Cache
> repo2cache r = Ca [Cache Repo NotWritable r]
>
Can you add a haddock for this function, in a followup patch? Your
patch description would do all right.
This means that cache propagation is a bit slower now, but more
correct. This seems right to me.
URL: add maxPipelineLength function, rename maxPipeLength to
maxPipelineLengthRef.
----------------------------------------------------------------------------------
Dmitry Kurochkin <dmitry.kurochkin@gmail.com>**20100418140129
hunk ./src/URL.hs 4
> {-# LANGUAGE CPP, ForeignFunctionInterface #-}
>
> module URL ( copyUrl, copyUrlFirst, pipeliningEnabledByDefault,
> - setDebugHTTP, setHTTPPipelining, waitUrl,
> - Cachable(Cachable, Uncachable, MaxAge),
> + setDebugHTTP, setHTTPPipelining, maxPipelineLength,
> + waitUrl, Cachable(Cachable, Uncachable, MaxAge),
> environmentHelpProxy, environmentHelpProxyPassword
> ) where
>
hunk ./src/URL.hs 95
> pipeliningEnabledByDefault = False
> #endif
>
> -{-# NOINLINE maxPipeLength #-}
> -maxPipeLength :: IORef Int
> -maxPipeLength = unsafePerformIO $ newIORef $
> +{-# NOINLINE maxPipelineLengthRef #-}
> +maxPipelineLengthRef :: IORef Int
> +maxPipelineLengthRef = unsafePerformIO $ newIORef $
> #ifdef CURL_PIPELINING_DEFAULT
> pipeliningLimit
> #else
hunk ./src/URL.hs 104
> 1
> #endif
>
> +maxPipelineLength :: IO Int
> +maxPipelineLength = readIORef maxPipelineLengthRef
> +
> {-# NOINLINE urlNotifications #-}
> urlNotifications :: MVar (Map String (MVar String))
> urlNotifications = unsafePerformIO $ newMVar Map.empty
hunk ./src/URL.hs 185
> checkWaitToStart = do
> st <- get
> let l = pipeLength st
> - mpl <- liftIO $ readIORef maxPipeLength
> + mpl <- liftIO maxPipelineLength
> when (l < mpl) $ do
> let w = waitToStart st
> case readQ w of
hunk ./src/URL.hs 284
> #endif
>
> setHTTPPipelining :: Bool -> IO ()
> -setHTTPPipelining False = writeIORef maxPipeLength 1
> -setHTTPPipelining True = writeIORef maxPipeLength
> +setHTTPPipelining False = writeIORef maxPipelineLengthRef 1
> +setHTTPPipelining True = writeIORef maxPipelineLengthRef
> #ifdef CURL_PIPELINING
> pipeliningLimit
> #else
Ok, just renaming things.
Darcs.Repository: use pipelining when copying patches.
------------------------------------------------------
Dmitry Kurochkin <dmitry.kurochkin@gmail.com>**20100418150302
hunk ./src/Darcs/Repository.hs 76
> make_new_pending
> )
> import Darcs.Repository.Merge( tentativelyMergePatches,
considerMergeToWorking )
> -import Darcs.Repository.Cache ( unionRemoteCaches,
fetchFileUsingCache, HashedDir(..) )
> +import Darcs.Repository.Cache ( unionRemoteCaches, fetchFileUsingCache,
> + speculateFileUsingCache, HashedDir(..) )
> import Darcs.Patch.Set ( PatchSet, SealedPatchSet )
> #ifdef GADT_WITNESSES
> import Darcs.Patch.Set ( Origin )
hunk ./src/Darcs/Repository.hs 82
> #endif
> +import URL ( maxPipelineLength )
>
> import Control.Monad ( unless, when )
hunk ./src/Darcs/Repository.hs 85
> -import Data.Either(Either(..))
> +import Data.Either ( Either(..), rights )
> import System.Directory ( createDirectory, renameDirectory )
> import System.IO.Error ( isAlreadyExistsError )
>
hunk ./src/Darcs/Repository.hs 308
> do unless (Complete `elem` opts) $
> putInfo "Copying patches, to get lazy
repository hit ctrl-C..."
> r <- read_repo torepository
> - let peekaboo :: PatchInfoAnd p C(x y) -> IO ()
> - peekaboo x = case extractHash x of
> - Left _ -> return ()
> - Right h -> fetchFileUsingCache c
HashedPatchesDir h >> return ()
> - sequence_ $ mapRL peekaboo $ progressRLShowTags
"Copying patches" $ concatRL r
> + pipelineLength <- maxPipelineLength
> + let patches = concatRL r
> + ppatches = progressRLShowTags "Copying patches"
patches
> + (first, other) = splitAt (pipelineLength - 1) $
tail $ hashes patches
> + speculate | pipelineLength > 1 = [] : first : map
(:[]) other
> + | otherwise = []
> + mapM_ fetchAndSpeculate $ zip (hashes ppatches)
(speculate ++ repeat [])
> where putInfo = when (not $ Quiet `elem` opts) . putStrLn
hunk ./src/Darcs/Repository.hs 316
> + hashes = rights . mapRL extractHash
> + fetchAndSpeculate :: (String, [String]) -> IO ()
> + fetchAndSpeculate (f, ss) = do
> + fetchFileUsingCache c HashedPatchesDir f
> + mapM_ (speculateFileUsingCache c HashedPatchesDir) ss
>
> add_to_pending :: RepoPatch p => Repository p C(r u t) -> FL Prim C(u
y) -> IO ()
> add_to_pending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts =
return ()
This seems correct.
|
