Florent Becker <[email protected]> added the comment: Resolve issue1159: smart caches union. -------------------------------------- Dmitry Kurochkin <[email protected]>**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 <[email protected]>**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 <[email protected]>**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. __________________________________ Darcs bug tracker <[email protected]> <http://bugs.darcs.net/patch215> __________________________________ _______________________________________________ darcs-users mailing list [email protected] http://lists.osuosl.org/mailman/listinfo/darcs-users
