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.
Thoughts, as always, welcome. --nwf;
Thu Aug 7 05:49:18 EDT 2008 [EMAIL PROTECTED]
* Make Darcs.Repository.Prefs export the cache hash function
Fri Aug 8 10:53:30 EDT 2008 [EMAIL PROTECTED]
* Move hashed repository IO out of Darcs.Repository.Prefs
New patches:
[Make Darcs.Repository.Prefs export the cache hash function
[EMAIL PROTECTED] 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
[Move hashed repository IO out of Darcs.Repository.Prefs
[EMAIL PROTECTED] hunk ./src/Darcs/Commands/ShowRepo.lhs 48
-import Darcs.Repository.Prefs ( Cache, get_preflist )
+import Darcs.Repository.Prefs ( get_preflist )
+import Darcs.Repository.InternalTypes ( Cache )
hunk ./src/Darcs/Repository.lhs 74
-import Darcs.Repository.Prefs ( unionCaches, fetchFileUsingCache )
+import Darcs.Repository.Prefs ( unionCaches )
+import Darcs.Repository.HashedIO ( fetchFileUsingCache )
hunk ./src/Darcs/Repository/HashedIO.lhs 22
- slurpHashed, hashSlurped ) where
+ slurpHashed, hashSlurped,
hunk ./src/Darcs/Repository/HashedIO.lhs 24
+ cacheHash, okayHash, takeHash,
+ Cache, cleanCaches,
+ fetchFileUsingCache, speculateFileUsingCache,
writeFileUsingCache,
+ findFileMtimeUsingCache, setFileMtimeUsingCache,
peekInCache,
+ repo2cache
+ ) where
+
+import System.Posix ( setFileTimes )
+import System.Posix.Files ( linkCount, modificationTime, getSymbolicLinkStatus
)
hunk ./src/Darcs/Repository/HashedIO.lhs 35
-import Control.Monad ( when )
-import Data.Maybe ( isJust )
+import Control.Monad ( when, guard, liftM )
+import Data.Maybe ( isJust, listToMaybe )
+import System.IO ( hPutStrLn, stderr )
hunk ./src/Darcs/Repository/HashedIO.lhs 40
-import Workaround ( createDirectoryIfMissing )
+import Workaround ( createDirectoryIfMissing, createLink )
hunk ./src/Darcs/Repository/HashedIO.lhs 42
-import Darcs.Repository.Prefs ( Cache, fetchFileUsingCache,
writeFileUsingCache,
- peekInCache, speculateFileUsingCache,
- findFileMtimeUsingCache,
setFileMtimeUsingCache )
hunk ./src/Darcs/Repository/HashedIO.lhs 44
-import Darcs.Flags ( DarcsFlag )
-import Darcs.Lock ( writeAtomicFilePS )
-import Darcs.Utils ( withCurrentDirectory )
-import Darcs.Progress ( debugMessage, beginTedious, endTedious, tediousSize,
finishedOneIO, progress )
+import Darcs.External ( gzFetchFilePS, fetchFilePS, speculateFileOrUrl,
copyFileOrUrl,
+ Cachable( Cachable ) )
+import Darcs.Flags ( DarcsFlag(..) )
+import Darcs.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS )
+import Darcs.Utils ( withCurrentDirectory, catchall )
+import Darcs.Progress ( debugMessage, beginTedious, endTedious, tediousSize,
finishedOneIO, progress,
+ progressList, debugFail )
+import Darcs.URL ( is_file )
hunk ./src/Darcs/Repository/HashedIO.lhs 54
-import FastPackedString ( PackedString, packString, unpackPS, linesPS,
unlinesPS, nilPS, lengthPS )
+import FastPackedString ( PackedString, packString, unpackPS, linesPS,
unlinesPS, nilPS, lengthPS,
+ gzWriteFilePS, dropPS )
hunk ./src/Darcs/Repository/HashedIO.lhs 57
+import Crypt.SHA256 ( sha256sum )
+import Darcs.Repository.InternalTypes (Cache(..), CacheType(..),
WritableOrNot(..), CacheLoc(..) )
+import Darcs.Global ( darcsdir )
+import System.Directory ( doesFileExist, removeFile, getDirectoryContents )
hunk ./src/Darcs/Repository/HashedIO.lhs 75
- HashDir { permissions = RW, cache = c,
- options = fs, rootHash = h }
- return $ rootHash hd
+ HashDir { _hd_permissions = RW, cache = c,
+ options = fs, _hd_rootHash = h }
+ return $ _hd_rootHash hd
hunk ./src/Darcs/Repository/HashedIO.lhs 79
-
-data HashDir r p = HashDir { permissions :: !r, cache :: !Cache,
- options :: ![DarcsFlag], rootHash :: !String }
+data HashDir r p = HashDir { _hd_permissions :: !r, _hd_cache :: !Cache,
+ _hd_options :: ![DarcsFlag], _hd_rootHash ::
!String }
hunk ./src/Darcs/Repository/HashedIO.lhs 162
-identifyThing fn | fn' == fp2fn "" = do h <- gets rootHash
+identifyThing fn | fn' == fp2fn "" = do h <- gets _hd_rootHash
hunk ./src/Darcs/Repository/HashedIO.lhs 185
-readhash h = do c <- gets cache
+readhash h = do c <- gets _hd_cache
hunk ./src/Darcs/Repository/HashedIO.lhs 200
- put $ hd { rootHash = h }
+ put $ hd { _hd_rootHash = h }
hunk ./src/Darcs/Repository/HashedIO.lhs 202
- h' <- gets rootHash
+ h' <- gets _hd_rootHash
hunk ./src/Darcs/Repository/HashedIO.lhs 208
- put $ hd { rootHash = h }
+ put $ hd { _hd_rootHash = h }
hunk ./src/Darcs/Repository/HashedIO.lhs 216
- (HashDir { permissions = RO, cache = c, options =
opts, rootHash = h })
+ (HashDir { _hd_permissions = RO, _hd_cache = c,
+ _hd_options = opts, _hd_rootHash = h })
hunk ./src/Darcs/Repository/HashedIO.lhs 223
- cc <- gets rootHash >>= readdir
+ cc <- gets _hd_rootHash >>= readdir
hunk ./src/Darcs/Repository/HashedIO.lhs 227
- speculate c = do cac <- gets cache
+ speculate c = do cac <- gets _hd_cache
hunk ./src/Darcs/Repository/HashedIO.lhs 235
- modify $ \hd -> hd { rootHash = h }
+ modify $ \hd -> hd { _hd_rootHash = h }
hunk ./src/Darcs/Repository/HashedIO.lhs 271
-writeHashFile ps = do c <- gets cache
- opts <- gets options
+writeHashFile ps = do c <- gets _hd_cache
+ opts <- gets _hd_options
hunk ./src/Darcs/Repository/HashedIO.lhs 277
- (HashDir { permissions = RO, cache = c,
- options = opts, rootHash = h })
+ (HashDir { _hd_permissions = RO, _hd_cache =
c,
+ _hd_options = opts, _hd_rootHash
= h })
hunk ./src/Darcs/Repository/HashedIO.lhs 282
- hroot <- gets rootHash
+ hroot <- gets _hd_rootHash
hunk ./src/Darcs/Repository/HashedIO.lhs 302
- (HashDir { permissions = RW, cache = c,
- options = opts, rootHash =
sha1PS nilPS })
+ (HashDir { _hd_permissions = RW,
_hd_cache = c,
+ _hd_options = opts,
_hd_rootHash = sha1PS nilPS })
hunk ./src/Darcs/Repository/HashedIO.lhs 329
-syncHashed c s r = do runStateT sh $ HashDir {permissions=RW, cache=c,
options=[], rootHash=r}
+syncHashed c s r = do runStateT sh $ HashDir {_hd_permissions=RW, _hd_cache=c,
+ _hd_options=[], _hd_rootHash=r}
hunk ./src/Darcs/Repository/HashedIO.lhs 349
-copyHashed k c opts z = do runStateT cph $ HashDir { permissions = RO, cache =
c,
- options = opts, rootHash
= z }
+copyHashed k c opts z = do runStateT cph $ HashDir { _hd_permissions = RO,
_hd_cache = c,
+ _hd_options = opts,
_hd_rootHash = z }
hunk ./src/Darcs/Repository/HashedIO.lhs 368
- runStateT (cp $ fp2fn ff) $ HashDir { permissions = RO, cache = c,
- options=opts, rootHash = root }
+ runStateT (cp $ fp2fn ff) $ HashDir { _hd_permissions = RO, _hd_cache =
c,
+ _hd_options=opts, _hd_rootHash =
root }
hunk ./src/Darcs/Repository/HashedIO.lhs 395
+\end{code}
+
+\begin{code}
+repo2cache :: String -> Cache
+repo2cache r = Ca [Cache RepoCache 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 RepoCache 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 RepoCache 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 RepoCache 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 RepoCache 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 RepoCache 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 RepoCache 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 ()
+
hunk ./src/Darcs/Repository/HashedRepo.lhs 32
- write_tentative_inventory, copy_repo,
slurp_all_but_darcs
+ write_tentative_inventory, copy_repo,
slurp_all_but_darcs,
hunk ./src/Darcs/Repository/HashedRepo.lhs 45
-import Darcs.Repository.Prefs ( Cache, fetchFileUsingCache,
speculateFileUsingCache, writeFileUsingCache,
- unionCaches, cleanCaches, repo2cache,
okayHash, takeHash )
+import Darcs.Repository.InternalTypes ( Cache )
+import Darcs.Repository.Prefs ( unionCaches )
+import Darcs.Repository.HashedIO ( fetchFileUsingCache,
speculateFileUsingCache, writeFileUsingCache,
+ cleanCaches, repo2cache, okayHash, takeHash
)
hunk ./src/Darcs/Repository/InternalTypes.lhs 21
- , extractCache
+ , extractCache,
+ WritableOrNot(..), CacheType(..),
CacheLoc(..), Cache(..)
hunk ./src/Darcs/Repository/InternalTypes.lhs 25
-import Darcs.Repository.Prefs ( Cache )
hunk ./src/Darcs/Repository/InternalTypes.lhs 40
+
+
+data WritableOrNot = Writable | NotWritable deriving ( Show )
+data CacheType = RepoCache | Directory deriving ( Eq, Show )
+data CacheLoc = Cache !CacheType !WritableOrNot !String
+newtype Cache = Ca [CacheLoc] -- abstract type for hiding cache
+
+instance Eq CacheLoc where
+ (Cache RepoCache _ a) == (Cache RepoCache _ b) = a == b
+ (Cache Directory _ a) == (Cache Directory _ b) = a == b
+ _ == _ = False
+instance Show CacheLoc where
+ show (Cache RepoCache Writable a) = "thisrepo:" ++ a
+ show (Cache RepoCache 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
+
+
+
hunk ./src/Darcs/Repository/Prefs.lhs 30
- cacheHash, okayHash, takeHash,
- Cache, getCaches, unionCaches, cleanCaches,
- fetchFileUsingCache, speculateFileUsingCache,
writeFileUsingCache,
- findFileMtimeUsingCache, setFileMtimeUsingCache,
peekInCache,
- repo2cache
+ getCaches, unionCaches
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 Text.Regex ( Regex, mkRegex, matchRegex, )
+import Workaround ( getCurrentDirectory )
+import Control.Monad ( liftM, unless, when, mplus )
+import Text.Regex ( Regex, mkRegex, matchRegex )
hunk ./src/Darcs/Repository/Prefs.lhs 38
-import Data.Maybe ( isNothing, isJust, catMaybes, listToMaybe )
-import Data.List ( nub, isPrefixOf )
+import Data.Maybe ( isNothing, isJust, catMaybes )
+import Data.List ( isPrefixOf, nub )
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, RemoteRepo, Ephemeral ) )
+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.InternalTypes (Cache(..), CacheType(..),
WritableOrNot(..), CacheLoc(..))
hunk ./src/Darcs/Repository/Prefs.lhs 384
-\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 417
+
+\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 RepoCache NotWritable thisdir]
+ else [Cache RepoCache Writable thisdir]
+ return $ Ca $ nub $ thisrepo ++ maincache ++ here ++
+ [Cache RepoCache NotWritable repodir] ++ there
+ where parsehs = catMaybes . map readln . noncomments
+ readln l | take 5 l == "repo:" = Just (Cache RepoCache NotWritable
(drop 5 l))
+ | take 9 l == "thisrepo:" = Just (Cache RepoCache
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
+
+unionCaches :: Cache -> Cache -> Cache
+unionCaches (Ca a) (Ca b) = Ca (nub (a++b))
+\end{code}
Context:
[UF8.lhs: remove unusued functions/imports/docs
[EMAIL PROTECTED]
[Resolve issue974 : do not pass both -optc-g and -opta-g to GHC
Eric Kow <[EMAIL PROTECTED]>**20080807073620]
[make this test more cross-platform
Simon Michael <[EMAIL PROTECTED]>**20080807103433]
[document how to run unit tests
Simon Michael <[EMAIL PROTECTED]>**20080807030416]
[move (most) failing tests to bugs for clean test output
Simon Michael <[EMAIL PROTECTED]>**20080806191336]
[fix an old spelling error
Simon Michael <[EMAIL PROTECTED]>**20080806170432]
[make searching for "test:" in makefile work
Simon Michael <[EMAIL PROTECTED]>**20080805222241]
[run only normal (expected to pass) tests by default
Simon Michael <[EMAIL PROTECTED]>**20080805222108]
[Downplay quantum mechanics link.
Eric Kow <[EMAIL PROTECTED]>**20080806124109
Besides, darcs has far more than 3 users by now.
]
[Make patch theory intro more inviting to math people.
Eric Kow <[EMAIL PROTECTED]>**20080806123411]
[cleanup and slight rewrite of the test docs
Simon Michael <[EMAIL PROTECTED]>**20080806165949]
[make order of running tests consistent
Simon Michael <[EMAIL PROTECTED]>**20080806172123]
[small makefile refactoring: allow just the normal tests to be run, without
bugs/*
Simon Michael <[EMAIL PROTECTED]>**20080805203242]
[Rectify dist help
[EMAIL PROTECTED]
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 <[EMAIL PROTECTED]>**20080803181216]
[Canonize Gaetan Lehmann and Daniel Buenzli.
Eric Kow <[EMAIL PROTECTED]>**20080730104357
(for Daniel B, avoid an accent in his name)
]
[configure: check for packages needed with split base.
Eric Kow <[EMAIL PROTECTED]>**20080730103840
Now that all packages must be used explicitly.
]
[fix type witness compile errors specific to ghc 6.8
Jason Dagit <[EMAIL PROTECTED]>**20080722182729]
[avoid import of unused function fromMaybe.
David Roundy <[EMAIL PROTECTED]>**20080729172825]
[configure: suggest regex-compat before text
Eric Kow <[EMAIL PROTECTED]>**20080725095336]
[configure: mention Haskell in 'try installing' suggestion
Eric Kow <[EMAIL PROTECTED]>**20080725095015]
[Typo (Text.Regex)
Eric Kow <[EMAIL PROTECTED]>**20080715121708]
[Use haskeline to have a readline-like behavior when asking something to the
user
[EMAIL PROTECTED]
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 <[EMAIL PROTECTED]>**20080604123728]
[add configure check for Network.URI.
David Roundy <[EMAIL PROTECTED]>**20080711011914]
[add -hide-all-packages to default GHCFLAGS.
David Roundy <[EMAIL PROTECTED]>**20080711010952]
[add support for outputting patch numbers in darcs changes.
David Roundy <[EMAIL PROTECTED]>**20080710011211]
[add support for matching single patches by index.
David Roundy <[EMAIL PROTECTED]>**20080710004512]
[add support for matching ranges of patches (counting back from present).
David Roundy <[EMAIL PROTECTED]>**20080710003225]
[Better avoid silly manpage error.
Trent W. Buck <[EMAIL PROTECTED]>**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 <[EMAIL PROTECTED]>**20080704024232]
[darcs --overview no longer works, so don't document it.
Trent W. Buck <[EMAIL PROTECTED]>**20080704030804]
[Avoid silly manpage error.
Trent W. Buck <[EMAIL PROTECTED]>**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
[EMAIL PROTECTED]
'twas causing lhs/haddock difficulties where a \end{code} wasn't getting
recognized.
]
[rm haddock CPP business
[EMAIL PROTECTED]
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 <[EMAIL PROTECTED]>**20080624170035]
[fix makefile to remember to regenerate version information after running
configure.
David Roundy <[EMAIL PROTECTED]>**20080624170001]
[TAG 2.0.2
David Roundy <[EMAIL PROTECTED]>**20080624012041]
Patch bundle hash:
3238922e7661a55322ab4b144a9e88378dd9eb4e
pgpLSisfeYXRm.pgp
Description: PGP signature
_______________________________________________ darcs-users mailing list [email protected] http://lists.osuosl.org/mailman/listinfo/darcs-users
