[darcs-users] [patch215] Resolve issue1159: smart caches union. (and 2 more)

Florent Becker bugs at darcs.net
Tue Apr 20 13:27:03 UTC 2010


Florent Becker <florent.becker at ens-lyon.org> added the comment:

Resolve issue1159: smart caches union.
--------------------------------------
Dmitry Kurochkin <dmitry.kurochkin at 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 at 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 at 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.

__________________________________
Darcs bug tracker <bugs at darcs.net>
<http://bugs.darcs.net/patch215>
__________________________________


More information about the darcs-users mailing list