[darcs-users] darcs patch: Split Cache mostly out of Darsc/Repository/Prefs into its own file (take 2)
Nathaniel W Filardo
nwf at cs.jhu.edu
Wed Aug 13 10:02:51 UTC 2008
On Sat, Aug 09, 2008 at 03:53:40AM -0400, Nathaniel W Filardo wrote:
> Split the material dealing with hashed repository formats and caches mostly
> out of Prefs (into InternalTypes and HashedIO). This restores Prefs to
> being mostly _darcs/prefs/* handling code. Compiles and passes tests, but
> not sure it's the maximally right answer.
This is a second attempt at this patch, which instead of moving things into
InternalTypes and HashedIO, moves the Cache logic out to
Darcs/Repository/Cache. This is much less involved than the last patch,
being mostly a move and scattered updates to imports.
The one notable change it does make (as a second patch in the bundle) is to
export the cache hash function in hopes of it being useful for issue861. If
desired, I can submit a version without.
--nwf;
-------------- next part --------------
Thu Aug 7 05:49:18 EDT 2008 nwf at cs.jhu.edu
* Make Darcs.Repository.Prefs export the cache hash function
Wed Aug 13 05:43:29 EDT 2008 nwf at cs.jhu.edu
* Split Cache mostly out of Darsc/Repository/Prefs into its own file (take 2)
New patches:
[Make Darcs.Repository.Prefs export the cache hash function
nwf at cs.jhu.edu**20080807094918] hunk ./src/Darcs/Repository/Prefs.lhs 30
- okayHash, takeHash,
+ cacheHash, okayHash, takeHash,
hunk ./src/Darcs/Repository/Prefs.lhs 424
+-- This function computes the cache hash (i.e. filename) of a packed string.
+cacheHash :: PackedString -> String
+cacheHash ps = case show (lengthPS ps) of
+ x | l > 10 -> sha256sum ps
+ | otherwise -> take (10-l) (repeat '0') ++ x ++'-':sha256sum ps
+ where l = length x
+
hunk ./src/Darcs/Repository/Prefs.lhs 584
- where hash = case show (lengthPS ps) of
- x | l > 10 -> sha256sum ps
- | otherwise -> take (10-l) (repeat '0') ++ x ++'-':sha256sum ps
- where l = length x
+ where hash = cacheHash ps
[Split Cache mostly out of Darsc/Repository/Prefs into its own file (take 2)
nwf at cs.jhu.edu**20080813094329] hunk ./GNUmakefile 94
+ Cache.lhs \
hunk ./src/Darcs/Commands/ShowRepo.lhs 45
+import Darcs.Repository.Cache ( Cache )
hunk ./src/Darcs/Commands/ShowRepo.lhs 49
-import Darcs.Repository.Prefs ( Cache, get_preflist )
+import Darcs.Repository.Prefs ( get_preflist )
hunk ./src/Darcs/Repository.lhs 74
-import Darcs.Repository.Prefs ( unionCaches, fetchFileUsingCache )
+import Darcs.Repository.Cache ( unionCaches, fetchFileUsingCache )
addfile ./src/Darcs/Repository/Cache.lhs
hunk ./src/Darcs/Repository/Cache.lhs 1
+\begin{code}
+{-# OPTIONS_GHC -cpp -fglasgow-exts #-}
+#include "gadts.h"
+module Darcs.Repository.Cache (
+ cacheHash, okayHash, takeHash,
+ Cache(..), CacheType(..), CacheLoc(..), WritableOrNot(..),
+ unionCaches, cleanCaches,
+ fetchFileUsingCache, speculateFileUsingCache, writeFileUsingCache,
+ findFileMtimeUsingCache, setFileMtimeUsingCache, peekInCache,
+ repo2cache
+ ) where
+
+import Control.Monad ( liftM, when, guard )
+import Data.List ( nub )
+import Data.Maybe ( listToMaybe )
+import System.Directory ( removeFile, doesFileExist, getDirectoryContents )
+import System.Posix ( setFileTimes )
+import System.Posix.Files ( linkCount, modificationTime, getSymbolicLinkStatus )
+import System.Posix.Types ( EpochTime )
+import System.IO ( hPutStrLn, stderr )
+
+import Crypt.SHA256 ( sha256sum )
+import FastPackedString ( PackedString, unpackPS, gzWriteFilePS, lengthPS,
+ linesPS, dropPS )
+import SHA1 ( sha1PS )
+import Workaround ( createLink, createDirectoryIfMissing )
+
+import Darcs.External ( gzFetchFilePS, fetchFilePS, speculateFileOrUrl, copyFileOrUrl,
+ Cachable( Cachable ) )
+import Darcs.Flags ( DarcsFlag( NoCompress ) )
+import Darcs.Global ( darcsdir )
+import Darcs.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS )
+import Darcs.Progress ( progressList, debugMessage, debugFail )
+import Darcs.SlurpDirectory ( undefined_time )
+import Darcs.URL ( is_file )
+import Darcs.Utils ( withCurrentDirectory, catchall )
+
+\end{code}
+
+\begin{code}
+data WritableOrNot = Writable | NotWritable deriving ( Show )
+data CacheType = Repo | Directory deriving ( Eq, Show )
+data CacheLoc = Cache !CacheType !WritableOrNot !String
+newtype Cache = Ca [CacheLoc] -- abstract type for hiding cache
+
+instance Eq CacheLoc where
+ (Cache Repo _ a) == (Cache Repo _ b) = a == b
+ (Cache Directory _ a) == (Cache Directory _ b) = a == b
+ _ == _ = False
+instance Show CacheLoc where
+ show (Cache Repo Writable a) = "thisrepo:" ++ a
+ show (Cache Repo NotWritable a) = "repo:" ++ a
+ show (Cache Directory Writable a) = "cache:" ++ a
+ show (Cache Directory NotWritable a) = "readonly:" ++ a
+instance Show Cache where
+ show (Ca cs) = unlines $ map show cs
+
+unionCaches :: Cache -> Cache -> Cache
+unionCaches (Ca a) (Ca b) = Ca (nub (a++b))
+
+repo2cache :: String -> Cache
+repo2cache r = Ca [Cache Repo NotWritable r]
+
+-- This function computes the cache hash (i.e. filename) of a packed string.
+cacheHash :: PackedString -> String
+cacheHash ps = case show (lengthPS ps) of
+ x | l > 10 -> sha256sum ps
+ | otherwise -> take (10-l) (repeat '0') ++ x ++'-':sha256sum ps
+ where l = length x
+
+okayHash :: String -> Bool
+okayHash s = length s == 40 || length s == 64 || length s == 75
+
+takeHash :: PackedString -> Maybe (String, PackedString)
+takeHash ps = do h <- listToMaybe $ linesPS ps
+ guard $ okayHash $ unpackPS h
+ Just (unpackPS h, dropPS (lengthPS h) ps)
+
+checkHash :: String -> PackedString -> Bool
+checkHash h s | length h == 40 = sha1PS s == h
+ | length h == 64 = sha256sum s == h
+ | length h == 75 = lengthPS s == read (take 10 h) && sha256sum s == drop 11 h
+ | otherwise = False
+
+
+findFileMtimeUsingCache :: Cache -> String -> String -> IO EpochTime
+findFileMtimeUsingCache (Ca cache) subdir f = mt cache
+ where mt [] = return undefined_time
+ mt (Cache Repo Writable r:_) = (modificationTime `fmap`
+ getSymbolicLinkStatus (r++"/"++darcsdir++"/"++subdir++"/"++f))
+ `catchall` return undefined_time
+ mt (_:cs) = mt cs
+
+setFileMtimeUsingCache :: Cache -> String -> String -> EpochTime -> IO ()
+setFileMtimeUsingCache (Ca cache) subdir f t = st cache
+ where st [] = return ()
+ st (Cache Repo Writable r:_) = setFileTimes (r++"/"++darcsdir++"/"++subdir++"/"++f) t t
+ `catchall` return ()
+ st (_:cs) = st cs
+
+fetchFileUsingCache :: Cache -> String -> String -> IO (String, PackedString)
+fetchFileUsingCache = fetchFileUsingCachePrivate Anywhere
+
+peekInCache :: Cache -> String -> String -> IO Bool
+peekInCache (Ca cache) subdir f = cacheHasIt cache `catchall` return False
+ where cacheHasIt [] = return False
+ cacheHasIt (Cache _ NotWritable _:cs) = cacheHasIt cs
+ cacheHasIt (Cache t Writable d:cs) = do ex <- doesFileExist (fn t d)
+ if ex then return True
+ else cacheHasIt cs
+ fn Directory d = d ++ "/" ++ subdir ++ "/" ++ f
+ fn Repo r = r ++ "/"++darcsdir++"/" ++ subdir ++ "/" ++ f
+
+speculateFileUsingCache :: Cache -> String -> String -> IO ()
+speculateFileUsingCache c sd h = do debugMessage $ "Speculating on "++h
+ copyFileUsingCache OnlySpeculate c sd h
+
+data OrOnlySpeculate = ActuallyCopy | OnlySpeculate deriving ( Eq )
+
+copyFileUsingCache :: OrOnlySpeculate -> Cache -> String -> String -> IO ()
+copyFileUsingCache oos (Ca cache) subdir f =
+ do debugMessage $ "I'm doing copyFileUsingCache on "++subdir++"/"++f
+ Just stickItHere <- cacheLoc cache
+ createDirectoryIfMissing False (reverse $ dropWhile (/='/') $ reverse stickItHere)
+ sfuc cache stickItHere
+ `catchall` return ()
+ where cacheLoc [] = return Nothing
+ cacheLoc (Cache _ NotWritable _:cs) = cacheLoc cs
+ cacheLoc (Cache t Writable d:cs) =
+ do ex <- doesFileExist (fn t d)
+ if ex then fail "Bug in darcs: This exception should be caught in speculateFileUsingCache"
+ else do othercache <- cacheLoc cs
+ case othercache of Just x -> return $ Just x
+ Nothing -> return $ Just (fn t d)
+ sfuc [] _ = return ()
+ sfuc (Cache t NotWritable d:_) out = if oos == OnlySpeculate
+ then speculateFileOrUrl (fn t d) out
+ else copyFileOrUrl [] (fn t d) out Cachable
+ sfuc (_:cs) out = sfuc cs out
+ fn Directory d = d ++ "/" ++ subdir ++ "/" ++ f
+ fn Repo r = r ++ "/"++darcsdir++"/" ++ subdir ++ "/" ++ f
+
+
+data FromWhere = LocalOnly | Anywhere deriving ( Eq )
+
+fetchFileUsingCachePrivate :: FromWhere -> Cache -> String -> String -> IO (String, PackedString)
+fetchFileUsingCachePrivate fromWhere (Ca cache) subdir f =
+ do when (fromWhere == Anywhere) $ copyFileUsingCache ActuallyCopy (Ca cache) subdir f
+ ffuc cache
+ `catchall` debugFail ("Couldn't fetch `"++f++"'\nin subdir "++subdir++
+ " from sources:\n\n"++show (Ca cache))
+ where ffuc (Cache t NotWritable d:cs)
+ | Anywhere == fromWhere || is_file (fn t d) =
+ do debugMessage $ "In fetchFileUsingCachePrivate I'm going manually"
+ debugMessage $ " getting "++f
+ debugMessage $ " from "++fn t d
+ x <- gzFetchFilePS (fn t d) Cachable
+ if not $ checkHash f x
+ then do x' <- fetchFilePS (fn t d) Cachable
+ when (not $ checkHash f x') $
+ do hPutStrLn stderr $ "Hash failure in "++d++" of hash "++f
+ fail $ "Hash failure in "++d++" of hash "++f
+ return (fn t d, x')
+ else return (fn t d, x) -- FIXME: create links in caches
+ `catchall` ffuc cs
+ ffuc (Cache t Writable d:cs) =
+ do x1 <- gzFetchFilePS (fn t d) Cachable
+ x <- if not $ checkHash f x1
+ then do x2 <- fetchFilePS (fn t d) Cachable
+ when (not $ checkHash f x2) $
+ do hPutStrLn stderr $ "Hash failure in "++d++" of hash "++f
+ removeFile (fn t d)
+ fail $ "Hash failure in "++d++" of hash "++f
+ return x2
+ else return x1
+ mapM_ (tryLinking (fn t d)) cs
+ return (fn t d, x)
+ `catchall` do (fname,x) <- ffuc cs
+ do createCache t d subdir
+ createLink fname (fn t d)
+ return (fn t d, x)
+ `catchall`
+ do gzWriteFilePS (fn t d) x `catchall` return ()
+ return (fname,x)
+ ffuc (_:cs) = ffuc cs
+ ffuc [] = debugFail $ "No sources from which to fetch file `"++f++"'\n"++ show (Ca cache)
+ tryLinking ff (Cache Directory Writable d) =
+ do createDirectoryIfMissing False (d++"/"++subdir)
+ createLink ff (fn Directory d)
+ `catchall` return ()
+ tryLinking _ _ = return ()
+ fn Directory d = d ++ "/" ++ subdir ++ "/" ++ f
+ fn Repo r = r ++ "/"++darcsdir++"/" ++ subdir ++ "/" ++ f
+
+createCache :: CacheType -> String -> String -> IO ()
+createCache Directory d subdir = createDirectoryIfMissing True (d ++ "/" ++ subdir)
+createCache _ _ _ = return ()
+
+writeFileUsingCache :: Cache -> [DarcsFlag] -> String -> PackedString -> IO String
+writeFileUsingCache (Ca cache) opts subdir ps =
+ (fetchFileUsingCachePrivate LocalOnly (Ca cache) subdir hash >> return hash) `catchall`
+ wfuc cache `catchall`
+ debugFail ("Couldn't write `"++hash++"'\nin subdir "++subdir++" to sources:\n\n"++
+ show (Ca cache))
+ where hash = cacheHash ps
+ wfuc (Cache _ NotWritable _:cs) = wfuc cs
+ wfuc (Cache t Writable d:_) =
+ do createCache t d subdir
+ if NoCompress `elem` opts
+ then writeAtomicFilePS (fn t d) ps -- FIXME: create links in caches
+ else gzWriteAtomicFilePS (fn t d) ps -- FIXME: create links in caches
+ return hash
+ wfuc [] = debugFail $ "No location to write file `" ++ subdir ++"/"++hash ++ "'"
+ fn Directory d = d ++ "/" ++ subdir ++ "/" ++ hash
+ fn Repo r = r ++ "/"++darcsdir++"/" ++ subdir ++ "/" ++ hash
+
+cleanCaches :: Cache -> String -> IO ()
+cleanCaches (Ca cs) subdir = mapM_ cleanCache cs
+ where cleanCache (Cache Directory Writable d) =
+ (withCurrentDirectory (d++"/"++subdir) $
+ do fs <- getDirectoryContents "."
+ mapM_ clean $ progressList ("Cleaning cache "++d++"/"++subdir) $
+ filter okayHash fs) `catchall` return ()
+ cleanCache _ = return ()
+ clean f = do lc <- linkCount `liftM` getSymbolicLinkStatus f
+ when (lc < 2) $ removeFile f
+ `catchall` return ()
+
+\end{code}
+
hunk ./src/Darcs/Repository/HashedIO.lhs 36
-import Darcs.Repository.Prefs ( Cache, fetchFileUsingCache, writeFileUsingCache,
+import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, writeFileUsingCache,
hunk ./src/Darcs/Repository/HashedRepo.lhs 45
-import Darcs.Repository.Prefs ( Cache, fetchFileUsingCache, speculateFileUsingCache, writeFileUsingCache,
+import Darcs.Repository.Cache ( Cache, fetchFileUsingCache, speculateFileUsingCache,
+ writeFileUsingCache,
hunk ./src/Darcs/Repository/InternalTypes.lhs 24
-import Darcs.Repository.Prefs ( Cache )
+import Darcs.Repository.Cache ( Cache )
hunk ./src/Darcs/Repository/Prefs.lhs 30
- cacheHash, okayHash, takeHash,
- Cache, getCaches, unionCaches, cleanCaches,
- fetchFileUsingCache, speculateFileUsingCache, writeFileUsingCache,
- findFileMtimeUsingCache, setFileMtimeUsingCache, peekInCache,
- repo2cache
+ getCaches,
hunk ./src/Darcs/Repository/Prefs.lhs 33
-import System.Posix ( setFileTimes )
-import System.IO ( hPutStrLn, stderr )
hunk ./src/Darcs/Repository/Prefs.lhs 34
-import System.Posix.Files ( linkCount, modificationTime, getSymbolicLinkStatus )
-import System.Posix.Types ( EpochTime )
-import Workaround ( getCurrentDirectory, createLink, createDirectoryIfMissing )
-import System.Directory ( removeFile, doesFileExist, getDirectoryContents )
-import Control.Monad ( liftM, unless, when, mplus, guard )
+import Workaround ( getCurrentDirectory )
+import Control.Monad ( liftM, unless, when, mplus )
hunk ./src/Darcs/Repository/Prefs.lhs 38
-import Data.Maybe ( isNothing, isJust, catMaybes, listToMaybe )
+import Data.Maybe ( isNothing, isJust, catMaybes )
hunk ./src/Darcs/Repository/Prefs.lhs 42
-import Darcs.SlurpDirectory ( undefined_time )
-import Darcs.Flags ( DarcsFlag( NoSetDefault, DryRun, Ephemeral, NoCompress, RemoteRepo ) )
-import Darcs.Utils ( withCurrentDirectory, catchall, stripCr )
+import Darcs.Flags ( DarcsFlag( NoSetDefault, DryRun, Ephemeral, RemoteRepo ) )
+import Darcs.Utils ( catchall, stripCr )
hunk ./src/Darcs/Repository/Prefs.lhs 46
-import Darcs.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS )
hunk ./src/Darcs/Repository/Prefs.lhs 47
-import Darcs.URL ( is_file )
-import Darcs.External ( gzFetchFilePS, fetchFilePS, speculateFileOrUrl, copyFileOrUrl,
- Cachable( Cachable ) )
-import Darcs.Progress ( progressList, debugMessage, debugFail )
-import SHA1 ( sha1PS )
-import Crypt.SHA256 ( sha256sum )
-import FastPackedString ( PackedString, nilPS, unpackPS, gzWriteFilePS, lengthPS,
- linesPS, dropPS )
+import Darcs.External ( gzFetchFilePS, Cachable( Cachable ) )
+import FastPackedString ( nilPS, unpackPS )
hunk ./src/Darcs/Repository/Prefs.lhs 50
+import Darcs.Repository.Cache ( Cache(..), CacheType(..), CacheLoc(..),
+ WritableOrNot(..) )
hunk ./src/Darcs/Repository/Prefs.lhs 385
-\begin{code}
-data WritableOrNot = Writable | NotWritable deriving ( Show )
-data CacheType = Repo | Directory deriving ( Eq, Show )
-data CacheLoc = Cache !CacheType !WritableOrNot !String
-newtype Cache = Ca [CacheLoc] -- abstract type for hiding cache
-
-instance Eq CacheLoc where
- (Cache Repo _ a) == (Cache Repo _ b) = a == b
- (Cache Directory _ a) == (Cache Directory _ b) = a == b
- _ == _ = False
-instance Show CacheLoc where
- show (Cache Repo Writable a) = "thisrepo:" ++ a
- show (Cache Repo NotWritable a) = "repo:" ++ a
- show (Cache Directory Writable a) = "cache:" ++ a
- show (Cache Directory NotWritable a) = "readonly:" ++ a
-instance Show Cache where
- show (Ca cs) = unlines $ map show cs
-
-unionCaches :: Cache -> Cache -> Cache
-unionCaches (Ca a) (Ca b) = Ca (nub (a++b))
-
-repo2cache :: String -> Cache
-repo2cache r = Ca [Cache Repo NotWritable r]
-
--- This function computes the cache hash (i.e. filename) of a packed string.
-cacheHash :: PackedString -> String
-cacheHash ps = case show (lengthPS ps) of
- x | l > 10 -> sha256sum ps
- | otherwise -> take (10-l) (repeat '0') ++ x ++'-':sha256sum ps
- where l = length x
-
-okayHash :: String -> Bool
-okayHash s = length s == 40 || length s == 64 || length s == 75
-
-takeHash :: PackedString -> Maybe (String, PackedString)
-takeHash ps = do h <- listToMaybe $ linesPS ps
- guard $ okayHash $ unpackPS h
- Just (unpackPS h, dropPS (lengthPS h) ps)
-
-checkHash :: String -> PackedString -> Bool
-checkHash h s | length h == 40 = sha1PS s == h
- | length h == 64 = sha256sum s == h
- | length h == 75 = lengthPS s == read (take 10 h) && sha256sum s == drop 11 h
- | otherwise = False
-
-getCaches :: [DarcsFlag] -> String -> IO Cache
-getCaches opts repodir =
- do here <- parsehs `fmap` get_preffile (darcsdir ++ "/prefs/sources")
- there <- (parsehs . lines . unpackPS) `fmap`
- (gzFetchFilePS (repodir ++ "/" ++ darcsdir ++ "/prefs/sources") Cachable
- `catchall` return nilPS)
- maincache <- parsehs `fmap` get_global "sources"
- thisdir <- getCurrentDirectory
- let thisrepo = if Ephemeral `elem` opts
- then [Cache Repo NotWritable thisdir]
- else [Cache Repo Writable thisdir]
- return $ Ca $ nub $ thisrepo ++ maincache ++ here ++
- [Cache Repo NotWritable repodir] ++ there
- where parsehs = catMaybes . map readln . noncomments
- readln l | take 5 l == "repo:" = Just (Cache Repo NotWritable (drop 5 l))
- | take 9 l == "thisrepo:" = Just (Cache Repo Writable (drop 9 l))
- | take 6 l == "cache:" = Just (Cache Directory Writable (drop 6 l))
- | take 9 l == "readonly:" = Just (Cache Directory NotWritable (drop 9 l))
- | otherwise = Nothing
-
-findFileMtimeUsingCache :: Cache -> String -> String -> IO EpochTime
-findFileMtimeUsingCache (Ca cache) subdir f = mt cache
- where mt [] = return undefined_time
- mt (Cache Repo Writable r:_) = (modificationTime `fmap`
- getSymbolicLinkStatus (r++"/"++darcsdir++"/"++subdir++"/"++f))
- `catchall` return undefined_time
- mt (_:cs) = mt cs
-
-setFileMtimeUsingCache :: Cache -> String -> String -> EpochTime -> IO ()
-setFileMtimeUsingCache (Ca cache) subdir f t = st cache
- where st [] = return ()
- st (Cache Repo Writable r:_) = setFileTimes (r++"/"++darcsdir++"/"++subdir++"/"++f) t t
- `catchall` return ()
- st (_:cs) = st cs
-
-fetchFileUsingCache :: Cache -> String -> String -> IO (String, PackedString)
-fetchFileUsingCache = fetchFileUsingCachePrivate Anywhere
-
-peekInCache :: Cache -> String -> String -> IO Bool
-peekInCache (Ca cache) subdir f = cacheHasIt cache `catchall` return False
- where cacheHasIt [] = return False
- cacheHasIt (Cache _ NotWritable _:cs) = cacheHasIt cs
- cacheHasIt (Cache t Writable d:cs) = do ex <- doesFileExist (fn t d)
- if ex then return True
- else cacheHasIt cs
- fn Directory d = d ++ "/" ++ subdir ++ "/" ++ f
- fn Repo r = r ++ "/"++darcsdir++"/" ++ subdir ++ "/" ++ f
-
-speculateFileUsingCache :: Cache -> String -> String -> IO ()
-speculateFileUsingCache c sd h = do debugMessage $ "Speculating on "++h
- copyFileUsingCache OnlySpeculate c sd h
-
-data OrOnlySpeculate = ActuallyCopy | OnlySpeculate deriving ( Eq )
-
-copyFileUsingCache :: OrOnlySpeculate -> Cache -> String -> String -> IO ()
-copyFileUsingCache oos (Ca cache) subdir f =
- do debugMessage $ "I'm doing copyFileUsingCache on "++subdir++"/"++f
- Just stickItHere <- cacheLoc cache
- createDirectoryIfMissing False (reverse $ dropWhile (/='/') $ reverse stickItHere)
- sfuc cache stickItHere
- `catchall` return ()
- where cacheLoc [] = return Nothing
- cacheLoc (Cache _ NotWritable _:cs) = cacheLoc cs
- cacheLoc (Cache t Writable d:cs) =
- do ex <- doesFileExist (fn t d)
- if ex then fail "Bug in darcs: This exception should be caught in speculateFileUsingCache"
- else do othercache <- cacheLoc cs
- case othercache of Just x -> return $ Just x
- Nothing -> return $ Just (fn t d)
- sfuc [] _ = return ()
- sfuc (Cache t NotWritable d:_) out = if oos == OnlySpeculate
- then speculateFileOrUrl (fn t d) out
- else copyFileOrUrl [] (fn t d) out Cachable
- sfuc (_:cs) out = sfuc cs out
- fn Directory d = d ++ "/" ++ subdir ++ "/" ++ f
- fn Repo r = r ++ "/"++darcsdir++"/" ++ subdir ++ "/" ++ f
-
-
-data FromWhere = LocalOnly | Anywhere deriving ( Eq )
-
-fetchFileUsingCachePrivate :: FromWhere -> Cache -> String -> String -> IO (String, PackedString)
-fetchFileUsingCachePrivate fromWhere (Ca cache) subdir f =
- do when (fromWhere == Anywhere) $ copyFileUsingCache ActuallyCopy (Ca cache) subdir f
- ffuc cache
- `catchall` debugFail ("Couldn't fetch `"++f++"'\nin subdir "++subdir++
- " from sources:\n\n"++show (Ca cache))
- where ffuc (Cache t NotWritable d:cs)
- | Anywhere == fromWhere || is_file (fn t d) =
- do debugMessage $ "In fetchFileUsingCachePrivate I'm going manually"
- debugMessage $ " getting "++f
- debugMessage $ " from "++fn t d
- x <- gzFetchFilePS (fn t d) Cachable
- if not $ checkHash f x
- then do x' <- fetchFilePS (fn t d) Cachable
- when (not $ checkHash f x') $
- do hPutStrLn stderr $ "Hash failure in "++d++" of hash "++f
- fail $ "Hash failure in "++d++" of hash "++f
- return (fn t d, x')
- else return (fn t d, x) -- FIXME: create links in caches
- `catchall` ffuc cs
- ffuc (Cache t Writable d:cs) =
- do x1 <- gzFetchFilePS (fn t d) Cachable
- x <- if not $ checkHash f x1
- then do x2 <- fetchFilePS (fn t d) Cachable
- when (not $ checkHash f x2) $
- do hPutStrLn stderr $ "Hash failure in "++d++" of hash "++f
- removeFile (fn t d)
- fail $ "Hash failure in "++d++" of hash "++f
- return x2
- else return x1
- mapM_ (tryLinking (fn t d)) cs
- return (fn t d, x)
- `catchall` do (fname,x) <- ffuc cs
- do createCache t d subdir
- createLink fname (fn t d)
- return (fn t d, x)
- `catchall`
- do gzWriteFilePS (fn t d) x `catchall` return ()
- return (fname,x)
- ffuc (_:cs) = ffuc cs
- ffuc [] = debugFail $ "No sources from which to fetch file `"++f++"'\n"++ show (Ca cache)
- tryLinking ff (Cache Directory Writable d) =
- do createDirectoryIfMissing False (d++"/"++subdir)
- createLink ff (fn Directory d)
- `catchall` return ()
- tryLinking _ _ = return ()
- fn Directory d = d ++ "/" ++ subdir ++ "/" ++ f
- fn Repo r = r ++ "/"++darcsdir++"/" ++ subdir ++ "/" ++ f
-
-createCache :: CacheType -> String -> String -> IO ()
-createCache Directory d subdir = createDirectoryIfMissing True (d ++ "/" ++ subdir)
-createCache _ _ _ = return ()
-
-writeFileUsingCache :: Cache -> [DarcsFlag] -> String -> PackedString -> IO String
-writeFileUsingCache (Ca cache) opts subdir ps =
- (fetchFileUsingCachePrivate LocalOnly (Ca cache) subdir hash >> return hash) `catchall`
- wfuc cache `catchall`
- debugFail ("Couldn't write `"++hash++"'\nin subdir "++subdir++" to sources:\n\n"++
- show (Ca cache))
- where hash = cacheHash ps
- wfuc (Cache _ NotWritable _:cs) = wfuc cs
- wfuc (Cache t Writable d:_) =
- do createCache t d subdir
- if NoCompress `elem` opts
- then writeAtomicFilePS (fn t d) ps -- FIXME: create links in caches
- else gzWriteAtomicFilePS (fn t d) ps -- FIXME: create links in caches
- return hash
- wfuc [] = debugFail $ "No location to write file `" ++ subdir ++"/"++hash ++ "'"
- fn Directory d = d ++ "/" ++ subdir ++ "/" ++ hash
- fn Repo r = r ++ "/"++darcsdir++"/" ++ subdir ++ "/" ++ hash
-
-cleanCaches :: Cache -> String -> IO ()
-cleanCaches (Ca cs) subdir = mapM_ cleanCache cs
- where cleanCache (Cache Directory Writable d) =
- (withCurrentDirectory (d++"/"++subdir) $
- do fs <- getDirectoryContents "."
- mapM_ clean $ progressList ("Cleaning cache "++d++"/"++subdir) $
- filter okayHash fs) `catchall` return ()
- cleanCache _ = return ()
- clean f = do lc <- linkCount `liftM` getSymbolicLinkStatus f
- when (lc < 2) $ removeFile f
- `catchall` return ()
-
-\end{code}
hunk ./src/Darcs/Repository/Prefs.lhs 419
+
+\begin{code}
+getCaches :: [DarcsFlag] -> String -> IO Cache
+getCaches opts repodir =
+ do here <- parsehs `fmap` get_preffile (darcsdir ++ "/prefs/sources")
+ there <- (parsehs . lines . unpackPS) `fmap`
+ (gzFetchFilePS (repodir ++ "/" ++ darcsdir ++ "/prefs/sources") Cachable
+ `catchall` return nilPS)
+ maincache <- parsehs `fmap` get_global "sources"
+ thisdir <- getCurrentDirectory
+ let thisrepo = if Ephemeral `elem` opts
+ then [Cache Repo NotWritable thisdir]
+ else [Cache Repo Writable thisdir]
+ return $ Ca $ nub $ thisrepo ++ maincache ++ here ++
+ [Cache Repo NotWritable repodir] ++ there
+ where parsehs = catMaybes . map readln . noncomments
+ readln l | take 5 l == "repo:" = Just (Cache Repo NotWritable (drop 5 l))
+ | take 9 l == "thisrepo:" = Just (Cache Repo Writable (drop 9 l))
+ | take 6 l == "cache:" = Just (Cache Directory Writable (drop 6 l))
+ | take 9 l == "readonly:" = Just (Cache Directory NotWritable (drop 9 l))
+ | otherwise = Nothing
+\end{code}
+
Context:
[Generalize HashRepo.clean_pristine to HashIO.clean_hashdir.
me at mornfall.net**20080812002708]
[Add writeSlurpy to roll out a copy of slurpy into a filesystem.
me at mornfall.net**20080812002345]
[fix breakage in URL.
David Roundy <droundy at darcs.net>**20080812141220]
[Parametrize "pristine.hashed" in a bunch of functions.
me at mornfall.net**20080812002114]
[Rework URL module for multi threading.
Dmitry Kurochkin <dmitry.kurochkin at gmail.com>**20080811221209]
[Add thread synchronization to URL module and resume select() if interrupted by signal in curl module.
Dmitry Kurochkin <dmitry.kurochkin at gmail.com>**20080810092810]
[Handle error case with empty URL in URL.waitNextUrl function.
Dmitry Kurochkin <dmitry.kurochkin at gmail.com>**20080809221755]
[Add --debug-http flag to enable curl and libwww debug at run-time instead of compile-time.
Dmitry Kurochkin <dmitry.kurochkin at gmail.com>**20080809154834]
[Print a warning when the remote end does not have darcs 2.
Eric Kow <E.Y.Kow at brighton.ac.uk>**20080811100933
Two reasons:
(1) right now people get a scary warning from ssh when it can't fetch
some non-essential files (it used to be that we would send stderr from ssh
to /dev/null, but that has other problems...)
(2) darcs transfer-mode more widely deployed could help a lot of people
wrt darcs performance
]
[Added a beware note to the unrecord command
lele at nautilus.homeip.net**20080811145756]
[Fixed typo
lele at nautilus.homeip.net**20080801162427]
[Better debug messages in URL module.
Dmitry Kurochkin <dmitry.kurochkin at gmail.com>**20080809215247]
[make Convert.lhs compile.
David Roundy <droundy at darcs.net>**20080810201725]
[improve type safety of Darcs.Repository.Internal.
Jason Dagit <dagit at codersbase.com>**20080810051109]
[Refactor `darcs convert' warning at kowey's request.
Trent W. Buck <trentbuck at gmail.com>**20080810110014]
[Expand formats text based in part on suggestions from darcs-users
Max Battcher <me at worldmaker.net>**20080809184043]
[Fixes to global cache text based on darcs-users suggestions
Max Battcher <me at worldmaker.net>**20080809181424]
[Add user-focused documentation of repository format options
Max Battcher <me at worldmaker.net>**20080807195429]
[Highlight the global cache as a best practice
Max Battcher <me at worldmaker.net>**20080807193918]
[Describe best practice in `darcs convert --help'.
Trent W. Buck <trentbuck at gmail.com>**20080810110615]
[add type witnesses to Population
Jason Dagit <dagit at codersbase.com>**20080808053252]
[add type witnesses to CommandsAux
Jason Dagit <dagit at codersbase.com>**20080808052738]
[Add type witnesses to more modules, rounding out Darcs/Repository/*
Jason Dagit <dagit at codersbase.com>**20080808050947]
[fixed a bug in identity_commutes property
Jason Dagit <dagit at codersbase.com>**20080808023025
In the right identity check the patch order should have gone from
(identity :> p) to (p2 :> i2). I added a rigid type context too
so that ghc 6.8 and newer would type the definition.
]
[Make Darcs.Repository.Internal compile with type witnesses.
Jason Dagit <dagit at codersbase.com>**20080808015343]
[UF8.lhs: remove unusued functions/imports/docs
gwern0 at gmail.com**20080807221826]
[Resolve issue974 : do not pass both -optc-g and -opta-g to GHC
Eric Kow <E.Y.Kow at brighton.ac.uk>**20080807073620]
[make this test more cross-platform
Simon Michael <simon at joyful.com>**20080807103433]
[document how to run unit tests
Simon Michael <simon at joyful.com>**20080807030416]
[move (most) failing tests to bugs for clean test output
Simon Michael <simon at joyful.com>**20080806191336]
[fix an old spelling error
Simon Michael <simon at joyful.com>**20080806170432]
[make searching for "test:" in makefile work
Simon Michael <simon at joyful.com>**20080805222241]
[run only normal (expected to pass) tests by default
Simon Michael <simon at joyful.com>**20080805222108]
[Downplay quantum mechanics link.
Eric Kow <E.Y.Kow at brighton.ac.uk>**20080806124109
Besides, darcs has far more than 3 users by now.
]
[Make patch theory intro more inviting to math people.
Eric Kow <E.Y.Kow at brighton.ac.uk>**20080806123411]
[cleanup and slight rewrite of the test docs
Simon Michael <simon at joyful.com>**20080806165949]
[make order of running tests consistent
Simon Michael <simon at joyful.com>**20080806172123]
[small makefile refactoring: allow just the normal tests to be run, without bugs/*
Simon Michael <simon at joyful.com>**20080805203242]
[Rectify dist help
lele at nautilus.homeip.net**20080804080322
Removed the "make dist" suggestion, the manual is a better place for that.
Instead, make clear that it operates on a clean copy of the tree, and
mention the "predist" functionality.
]
[website: explain that darcs 2 is required to get the darcs source.
Simon Michael <simon at joyful.com>**20080803181216]
[Canonize Gaetan Lehmann and Daniel Buenzli.
Eric Kow <E.Y.Kow at brighton.ac.uk>**20080730104357
(for Daniel B, avoid an accent in his name)
]
[configure: check for packages needed with split base.
Eric Kow <E.Y.Kow at brighton.ac.uk>**20080730103840
Now that all packages must be used explicitly.
]
[fix type witness compile errors specific to ghc 6.8
Jason Dagit <dagit at codersbase.com>**20080722182729]
[avoid import of unused function fromMaybe.
David Roundy <droundy at darcs.net>**20080729172825]
[configure: suggest regex-compat before text
Eric Kow <E.Y.Kow at brighton.ac.uk>**20080725095336]
[configure: mention Haskell in 'try installing' suggestion
Eric Kow <E.Y.Kow at brighton.ac.uk>**20080725095015]
[Typo (Text.Regex)
Eric Kow <E.Y.Kow at brighton.ac.uk>**20080715121708]
[Use haskeline to have a readline-like behavior when asking something to the user
gaetan.lehmann at jouy.inra.fr**20080719065033
Unlike the implementations using readline or editline packages, this code
code doesn't break the Ctrl-C behavior.
]
[Improve generic rules for English plurals.
Eric Kow <E.Y.Kow at brighton.ac.uk>**20080604123728]
[add configure check for Network.URI.
David Roundy <droundy at darcs.net>**20080711011914]
[add -hide-all-packages to default GHCFLAGS.
David Roundy <droundy at darcs.net>**20080711010952]
[add support for outputting patch numbers in darcs changes.
David Roundy <droundy at darcs.net>**20080710011211]
[add support for matching single patches by index.
David Roundy <droundy at darcs.net>**20080710004512]
[add support for matching ranges of patches (counting back from present).
David Roundy <droundy at darcs.net>**20080710003225]
[Better avoid silly manpage error.
Trent W. Buck <trentbuck at gmail.com>**20080704024920
It turned out only initialize's help string used 'quotes', so just
remove them. This makes init's docstring consistent with the others.
]
[Missing period at end of sentence.
Trent W. Buck <trentbuck at gmail.com>**20080704024232]
[darcs --overview no longer works, so don't document it.
Trent W. Buck <trentbuck at gmail.com>**20080704030804]
[Avoid silly manpage error.
Trent W. Buck <trentbuck at gmail.com>**20080703010733
man (nroff) treats an apostrophe in the first column specially,
resulting in a syntax error without this patch.
Ideally, all cases of 'foo' in the manpage (i.e. docstrings) should
become `foo', since man -Tps turns ` and ' into left and right single
quotes respectively.
]
[obliterate whitespace in Darcs.Commands.Get
gwern0 at gmail.com**20080627192026
'twas causing lhs/haddock difficulties where a \end{code} wasn't getting recognized.
]
[rm haddock CPP business
gwern0 at gmail.com**20080627191413
Try as I might, I can't see any reason to special-case some Haddock CPP logic to deal with some *commented-out guards*, unless CPP magically restores and uncomments the code if Haddock isn't being run.
]
[make pull less verbose when --verbose flag is given.
David Roundy <droundy at darcs.net>**20080624170035]
[fix makefile to remember to regenerate version information after running configure.
David Roundy <droundy at darcs.net>**20080624170001]
[TAG 2.0.2
David Roundy <droundy at darcs.net>**20080624012041]
Patch bundle hash:
cc7ae2115dbc5490eb145193a3052ce550106388
-------------- next part --------------
A non-text attachment was scrubbed...
Name: not available
Type: application/pgp-signature
Size: 189 bytes
Desc: not available
Url : http://lists.osuosl.org/pipermail/darcs-users/attachments/20080813/fc83d930/attachment-0001.pgp
More information about the darcs-users
mailing list