darcs-beta 2.2.98.1 → 2.2.98.2
raw patch · 13 files changed
+172/−96 lines, 13 filesdep ~HTTPdep ~hashed-storage
Dependency ranges changed: HTTP, hashed-storage
Files
- README +38/−28
- darcs-beta.cabal +7/−6
- release/distributed-context +1/−1
- src/ByteStringUtils.hs +25/−8
- src/Darcs/Arguments.lhs +18/−1
- src/Darcs/Commands/GZCRCs.lhs +25/−16
- src/Darcs/Commands/ShowIndex.lhs +5/−5
- src/Darcs/Flags.hs +1/−1
- src/Darcs/Global.hs +1/−0
- src/Darcs/Gorsvet.hs +40/−29
- src/Darcs/Repository/Cache.hs +5/−1
- tests/hspwd.hs +5/−0
- tests/issue1248.sh +1/−0
README view
@@ -11,35 +11,27 @@ Compilation and Installation ============================ -Darcs currently supports two build systems: a traditional autotools--based system, and an experimental cabal-based system. Currently-AUTOTOOLS IS RECOMMENDED; in later releases it will be deprecated and-eventually removed (in favour of cabal).+Darcs currently supports two build systems: a cabal-based system and a legacy+autotools-based system, and a cabal-based system. CABAL IS RECOMMENDED and the+autotools system is deprecated: in future releases, autotools support will be+removed. If a "configure" file is present, autotools is supported. If a "Setup.lhs" file is present, cabal is supported. Currently there is a separate source tarball for each build system; either can be used in unstable checkouts. --Using Autotools------------------If you have the normal, autotools-based tarball, this sequence should work-for you (if you are in doubt, this is likely the case):-- $ ./configure- $ make- # make install--You first need to run `autoconf` if you obtained the source tree from the-darcs repository (but this is not needed for release tarballs).--For more information, please see the manual:-- * http://www.darcs.net/manual- * doc/manual/darcs.ps-+Using GHC 6.10.3 or newer is STRONGLY RECOMMENDED. You can compile darcs with+GHC 6.8, but there are several caveats. If you are using 6.8.2 or older, please+disable mmap support (pass -f-mmap to cabal install or runghc Setup configure+below). Note that the GHC 6.8.2 that ships with Debian Lenny is not affected+and it should be safe to keep mmap enabled. It is also recommended to disable+use of Hackage zlib when compiling with GHC 6.8.2 (including the Debian Lenny+version): pass -f-zlib to cabal. When using zlib, we have seen occasional+crashes with error messages like "openBinaryFile: file locked" -- this is a+known GHC 6.8.2 bug (and is fixed in GHC 6.8.3). Last, if you are using a+64-bit system, darcs may hang when you exit a pager when compiled with GHC+older than 6.10.3. Although this is harmless, it is quite inconvenient. Using Cabal -----------@@ -47,12 +39,11 @@ This method requires the cabal package, version 1.6 or higher. The cabal-install package is also recommended. -If you have the "cabal-install" package on your system (that is, there-is a "cabal" executable in your path), you can use the following-commands to create an executable in ~/.cabal/bin/darcs.+If you have the "cabal-install" package on your system (that is, there is a+"cabal" executable in your path), you can use the following command to create+an executable in ~/.cabal/bin/darcs (this will also automatically fetch and+build dependencies from the Hackage server). - $ cabal configure- $ cabal build $ cabal install Otherwise, if you have the "cabal" package but not the "cabal-install"@@ -72,6 +63,25 @@ Please also note that the cabal-based build by default requires the cURL library (and development headers). If, for some reason, you cannot provide cURL, please pass "-f-curl" to the configure step above.++Using Autotools+---------------++If you have the normal, autotools-based tarball, this sequence should work+for you (if you are in doubt, this is likely the case):++ $ ./configure+ $ make+ # make install++You first need to run `autoconf` if you obtained the source tree from the+darcs repository (but this is not needed for release tarballs).++For more information, please see the manual:++ * http://www.darcs.net/manual+ * doc/manual/darcs.ps+ Hacking =======
darcs-beta.cabal view
@@ -1,5 +1,5 @@ Name: darcs-beta-version: 2.2.98.1+version: 2.2.98.2 License: GPL License-file: COPYING Author: David Roundy <droundy@darcs.net>, <darcs-users@darcs.net>@@ -64,6 +64,7 @@ Distribution/ShellHarness.hs tests/repos/*.tgz tests/repos/README tests/*.sh+ tests/hspwd.hs tests/network/*.sh tests/lib tests/example_binary.png@@ -317,7 +318,7 @@ html == 1.0.*, filepath == 1.1.*, haskeline >= 0.6.1 && < 0.7,- hashed-storage >= 0.3.3.1 && < 0.4+ hashed-storage >= 0.3.4 && < 0.4 if !os(windows) build-depends: unix >= 1.0 && < 2.4@@ -352,7 +353,7 @@ if flag(http) build-depends: network == 2.2.*,- HTTP >= 3000.0 && < 3001.2+ HTTP >= 3000.0 && < 4000.1 cpp-options: -DHAVE_HTTP x-have-http: @@ -450,7 +451,7 @@ html == 1.0.*, filepath == 1.1.*, haskeline >= 0.6.1 && < 0.7,- hashed-storage >= 0.3.3.1 && < 0.4+ hashed-storage >= 0.3.4 && < 0.4 if !os(windows) build-depends: unix >= 1.0 && < 2.4@@ -479,9 +480,9 @@ pkgconfig-depends: libcurl >= 7.19.1 cpp-options: -DCURL_PIPELINING -DCURL_PIPELINING_DEFAULT - if flag(http)+ if flag(http) build-depends: network == 2.2.*,- HTTP >= 3000.0 && < 3001.2+ HTTP >= 3000.0 && < 4000.1 cpp-options: -DHAVE_HTTP x-have-http:
release/distributed-context view
@@ -1,1 +1,1 @@-Just "\nContext:\n\n[TAG 2.2.98.1\nPetr Rockai <me@mornfall.net>**20090623155657\n Ignore-this: b388b0221526b2609dec75bb733bfc4c\n] \n"+Just "\nContext:\n\n[TAG 2.2.98.2\nPetr Rockai <me@mornfall.net>**20090709104304\n Ignore-this: d9832c9f7b7c2c78ae83fda2524162ca\n] \n"
src/ByteStringUtils.hs view
@@ -345,8 +345,12 @@ #ifdef HAVE_HASKELL_ZLIB -gzDecompress :: forall m . (Functor m, Monad m) => m () -> Maybe Int -> BL.ByteString -> m [B.ByteString]-gzDecompress reportBadCRC mbufsize =+-- |Decompress the given bytestring into a lazy list of chunks, along with a boolean+-- flag indicating (if True) that the CRC was corrupted.+-- Inspecting the flag will cause the entire list of chunks to be evaluated (but if+-- you throw away the list immediately this should run in constant space).+gzDecompress :: Maybe Int -> BL.ByteString -> ([B.ByteString], Bool)+gzDecompress mbufsize = -- This is what the code would be without the bad CRC recovery logic: -- return . BL.toChunks . GZ.decompressWith decompressParams toListWarn . ZI.decompressWithErrors ZI.GZip decompressParams@@ -355,14 +359,24 @@ Just bufsize -> GZ.defaultDecompressParams { GZ.decompressBufferSize = bufsize } Nothing -> GZ.defaultDecompressParams - toListWarn :: ZI.DecompressStream -> m [B.ByteString]- toListWarn ZI.StreamEnd = return []- toListWarn (ZI.StreamChunk x xs) = fmap (x:) (toListWarn xs)+ toListWarn :: ZI.DecompressStream -> ([B.ByteString], Bool)+ toListWarn = foldDecompressStream (\x ~(xs, b) -> (x:xs, b)) ([], False) handleBad++ -- cut and paste from Zlib since it's not currently exported (interface not yet certain)+ foldDecompressStream :: (B.ByteString -> a -> a) -> a+ -> (ZI.DecompressError -> String -> a)+ -> ZI.DecompressStream -> a+ foldDecompressStream chunk end err = fold+ where+ fold ZI.StreamEnd = end+ fold (ZI.StreamChunk bs stream) = chunk bs (fold stream)+ fold (ZI.StreamError code msg) = err code msg+ -- For a while a bug in darcs caused gzip files with good data but bad CRCs to be -- produced. Trap bad CRC messages, run the specified action to report that it happened, -- but continue on the assumption that the data is valid.- toListWarn (ZI.StreamError ZI.DataError "incorrect data check") = reportBadCRC >> return []- toListWarn (ZI.StreamError _ msg) = fail msg+ handleBad ZI.DataError "incorrect data check" = ([], True)+ handleBad _ msg = error msg #else @@ -401,7 +415,10 @@ -- Passing the length to gzDecompress means that it produces produces one chunk, -- which in turn means that B.concat won't need to copy data. -- If the length is wrong this will just affect efficiency, not correctness- fmap B.concat . (gzDecompress (addCRCWarning f) (Just len) =<<) $+ let doDecompress buf = let (res, bad) = gzDecompress (Just len) buf+ in do when bad $ addCRCWarning f+ return res+ in fmap B.concat . (doDecompress =<<) $ #ifdef HAVE_OLD_BYTESTRING -- bytestring < 0.9.1 had a bug where it did not know to close handles upon EOF -- performance would be better with a newer bytestring and lazy
src/Darcs/Arguments.lhs view
@@ -83,7 +83,7 @@ patch_select_flag, network_options, no_cache, allow_unrelated_repos,- check_or_repair+ check_or_repair, just_this_repo ) where import System.Console.GetOpt import System.Directory ( doesDirectoryExist )@@ -292,6 +292,7 @@ getContent AllowUnrelatedRepos = NoContent getContent Check = NoContent getContent Repair = NoContent+getContent JustThisRepo = NoContent get_content :: DarcsFlag -> Maybe String get_content f = do StringContent s <- Just $ getContent f@@ -1562,6 +1563,22 @@ allow_unrelated_repos = DarcsNoArgOption [] ["ignore-unrelated-repos"] AllowUnrelatedRepos "do not check if repositories are unrelated"+\end{code}++\begin{code}+just_this_repo :: DarcsOption+\end{code}++\begin{options}+--just-this-repo+\end{options}+This option limits the check or repair to the current repo and+omits any caches or other repos listed as a source of patches.++\begin{code}+just_this_repo =+ DarcsNoArgOption [] ["just-this-repo"] JustThisRepo+ "Limit the check or repair to the current repo" \end{code} \begin{code}
src/Darcs/Commands/GZCRCs.lhs view
@@ -18,12 +18,13 @@ \subsection{darcs gzcrcs} \darcsCommand{gzcrcs} \begin{code}+{-# LANGUAGE CPP #-} module Darcs.Commands.GZCRCs ( gzcrcs, doCRCWarnings ) where import Control.Arrow ( (***) )-import Control.Monad ( when )+import Control.Monad ( when, unless ) import Control.Monad.Trans ( liftIO )-import Control.Monad.Writer ( runWriter, runWriterT, tell )+import Control.Monad.Writer ( runWriterT, tell ) import Data.List ( intersperse ) import Data.Monoid ( Any(..), Sum(..) ) @@ -34,8 +35,8 @@ import System.Exit ( ExitCode(..), exitWith ) import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag( Quiet, Verbose, Check, Repair ),- check_or_repair, working_repo_dir,+import Darcs.Arguments ( DarcsFlag( Quiet, Verbose, Check, Repair, JustThisRepo ),+ check_or_repair, working_repo_dir, just_this_repo ) import Darcs.Repository ( Repository, amInRepository, withRepository ) import Darcs.Patch ( RepoPatch )@@ -48,7 +49,7 @@ -- Could move the relevant code into Darcs.Repository modules -- but it doesn't really seem worth it. import Darcs.Repository.InternalTypes ( extractCache )-import Darcs.Repository.Cache ( Cache(..), writable, hashedFilePath, allHashedDirs )+import Darcs.Repository.Cache ( Cache(..), writable, isthisrepo, hashedFilePath, allHashedDirs ) #ifdef HAVE_HASKELL_ZLIB@@ -66,7 +67,7 @@ getCRCWarnings = noChecking "getCRCWarnings" resetCRCWarnings :: IO () resetCRCWarnings = noChecking "resetCRCWarnings"-gzDecompress :: forall m . (Functor m, Monad m) => m () -> Maybe Int -> BL.ByteString -> m [B.ByteString]+gzDecompress :: Maybe Int -> BL.ByteString -> ([B.ByteString], Bool) gzDecompress = noChecking "gzDecompress" #endif @@ -79,8 +80,14 @@ "Versions of darcs >=1.0.4 and <2.2.0 had a bug that caused compressed files " ++ "with bad CRCs (but valid data) to be written out. CRCs were not checked on " ++ "reading, so this bug wasn't noticed.",- "This command inspects your repository and caches for this corruption and optionally " ++- "repairs it.",+ "This command inspects your repository for this corruption and optionally repairs it.",+ "By default it also does this for any caches you have configured and any other " +++ "local repositories listed as sources of patches for this one, perhaps because of a " +++ "lazy get. You can limit the scope to just the current repo with the --just-this-repo " +++ "flag.",+ "Note that readonly caches, or other repositories listed as sources, " +++ "will be checked but not repaired. Also, this command will abort if it encounters " +++ "any non-CRC corruption in compressed files.", "You may wish to also run 'darcs check --complete' before repairing the corruption. " ++ "This is not done automatically because it might result in needing to fetch extra " ++ "patches if the repository is lazy.",@@ -89,10 +96,7 @@ "caused by bad data and the old CRCs might be useful in recovering that data.", "If you were warned about CRC errors during an operation involving another repository, " ++ "then it is possible that the other repository contains the corrupt CRCs, so you " ++- "should arrange for that repository to also be checked/repaired.",- "Note that readonly caches, or other repositories that were sources for lazy gets, " ++- "will be checked but not repaired. Also, this command will abort if it encounters " ++- "any non-CRC corruption in compressed files."+ "should arrange for that repository to also be checked/repaired." ] formatText :: [String] -> String@@ -133,6 +137,7 @@ command_argdefaults = nodefaults, command_advanced_options = [], command_basic_options = [check_or_repair,+ just_this_repo, working_repo_dir ]} @@ -140,10 +145,15 @@ gzcrcs_cmd opts _ | Check `elem` opts || Repair `elem` opts = withRepository opts (gzcrcs' opts) gzcrcs_cmd _ _ = error "You must specify --check or --repair for gzcrcs" +#ifdef GADT_WITNESSES+gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p r u t -> IO ()+#else gzcrcs' :: (RepoPatch p) => [DarcsFlag] -> Repository p -> IO ()+#endif gzcrcs' opts repo = do let Ca locs = extractCache repo ((), Any checkFailed) <- runWriterT $ flip mapM_ locs $ \loc -> do+ unless (JustThisRepo `elem` opts && not (isthisrepo loc)) $ do let w = writable loc flip mapM_ allHashedDirs $ \hdir -> do let dir = hashedFilePath loc hdir ""@@ -151,7 +161,7 @@ when exists $ do liftIO $ putInfo $ text $ "Checking " ++ dir ++ (if w then "" else " (readonly)") files <- liftIO $ getDirectoryContents dir- ((), Sum (count :: Int)) <- runWriterT $ flip mapM_ files $ \file -> do+ ((), Sum count) <- runWriterT $ flip mapM_ files $ \file -> do let fn = dir ++ file isfile <- liftIO $ doesFileExist fn when isfile $ do@@ -160,13 +170,12 @@ Nothing -> return () Just len -> do contents <- liftIO $ B.readFile fn- let (uncompressed, Any isCorrupt)- = runWriter . gzDecompress (tell (Any True)) (Just len) . BL.fromChunks $ [contents]+ let (uncompressed, isCorrupt) = gzDecompress (Just len) . BL.fromChunks $ [contents] when isCorrupt $ do tell (Sum 1) -- count of files in current directory liftIO $ putVerbose $ text $ "Corrupt: " ++ fn when (w && Repair `elem` opts) $ liftIO $ gzWriteAtomicFilePSs fn uncompressed- when (count > 0) $ do+ when (count > (0 :: Int)) $ do liftIO $ putInfo $ text $ "Found " ++ show count ++ " corrupt file" ++ (if count > 1 then "s" else "") ++ (if Repair `elem` opts then (if w then " (repaired)" else " (not repaired") else "")
src/Darcs/Commands/ShowIndex.lhs view
@@ -31,10 +31,10 @@ import Darcs.Commands ( DarcsCommand(..), nodefaults, command_alias ) import Darcs.Repository ( amInRepository, withRepository, ($-) ) -import Darcs.Gorsvet( checkIndex, readIndex )+import Darcs.Gorsvet( readIndex ) import Storage.Hashed( readDarcsPristine, floatPath ) import Storage.Hashed.Darcs( darcsFormatHash )-import Storage.Hashed.Tree( list, expand, itemHash, TreeItem( SubTree ) )+import Storage.Hashed.Tree( list, expand, itemHash, Tree, TreeItem( SubTree ) ) import Storage.Hashed.AnchoredPath( anchorPath ) import qualified Data.ByteString.Char8 as BS@@ -67,6 +67,7 @@ "For files, the fields correspond to file size, sha256 of the pristine " ++ "file content and the filename." } +dump :: [DarcsFlag] -> Tree -> IO () dump opts tree = do let line | NullFlag `elem` opts = \t -> putStr t >> putChar '\0' | otherwise = putStrLn@@ -84,11 +85,10 @@ show_index_cmd :: [DarcsFlag] -> [String] -> IO () show_index_cmd opts _ = withRepository opts $- \repo -> do- checkIndex repo- readIndex >>= dump opts+ readIndex repo >>= dump opts show_pristine_cmd :: [DarcsFlag] -> [String] -> IO ()-show_pristine_cmd opts _ = withRepository opts $- \repo -> do+show_pristine_cmd opts _ = withRepository opts $- \_ -> do readDarcsPristine "." >>= dump opts \end{code}
src/Darcs/Flags.hs view
@@ -87,7 +87,7 @@ | HTTPPipelining | NoHTTPPipelining | NoCache | AllowUnrelatedRepos- | Check | Repair+ | Check | Repair | JustThisRepo | NullFlag deriving ( Eq, Show )
src/Darcs/Global.hs view
@@ -15,6 +15,7 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. +{-# LANGUAGE CPP #-} -- | This was originally Tomasz Zielonka's AtExit module, slightly generalised -- to include global variables. Here, we attempt to cover broad, global -- features, such as exit handlers. These features slightly break the Haskellian
src/Darcs/Gorsvet.hs view
@@ -1,5 +1,5 @@ {-# LANGUAGE CPP, FlexibleInstances #-}-{-# OPTIONS_GHC -cpp -fglasgow-exts #-}+{-# OPTIONS_GHC -cpp -fglasgow-exts -fno-warn-orphans #-} -- Copyright (C) 2009 Petr Rockai --@@ -27,13 +27,12 @@ module Darcs.Gorsvet where -import Prelude hiding ( read, filter, writeFile, readFile )+import Prelude hiding ( all, filter, lines, read, readFile, writeFile ) -- darcs stuff import ByteStringUtils( is_funky ) import Darcs.Repository ( Repository, slurp_pending ) import Darcs.Repository.Internal ( read_pending )-import Darcs.External ( backupByCopying ) import Darcs.Patch ( RepoPatch, Prim, hunk, canonize, binary, apply , sort_coalesceFL, addfile, rmfile, adddir, rmdir, invert) import Darcs.Ordered ( FL(..), (+>+) )@@ -41,8 +40,9 @@ import Darcs.IO import Darcs.Sealed ( Sealed(Sealed), seal ) import Darcs.Patch( apply_to_filepaths )+import Darcs.Patch.Patchy ( Apply ) import Darcs.Patch.TouchesFiles ( choose_touching )-import Darcs.Patch.FileName ( fn2fp )+import Darcs.Patch.FileName ( fn2fp, FileName ) import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.ByteString.Char8 as BS@@ -69,6 +69,7 @@ , cwd, tree, TreeIO ) import Storage.Hashed +floatFn :: FileName -> AnchoredPath floatFn = floatPath . fn2fp instance ReadableDirectory TreeIO where@@ -78,7 +79,7 @@ wd <- gets cwd modify (\x -> x { cwd = floatFn d }) x <- action- modify (\x -> x { cwd = wd })+ modify (\x' -> x' { cwd = wd }) return x mGetDirectoryContents = error "get dir contents" mReadFilePS p = do x <- readFile (floatFn p) -- ratify readFile: ...@@ -110,11 +111,11 @@ diff p Nothing (Just (SubTree _)) = return $ adddir (anchorPath "" p) :>: NilFL diff p Nothing b'@(Just (File _)) =- do diff <- diff p (Just (File emptyBlob)) b'- return $ addfile (anchorPath "" p) :>: diff+ do diff' <- diff p (Just (File emptyBlob)) b'+ return $ addfile (anchorPath "" p) :>: diff' diff p a'@(Just (File _)) Nothing =- do diff <- diff p a' (Just (File emptyBlob))- return $ diff +>+ (rmfile (anchorPath "" p) :>: NilFL)+ do diff' <- diff p a' (Just (File emptyBlob))+ return $ diff' +>+ (rmfile (anchorPath "" p) :>: NilFL) diff p (Just (File a')) (Just (File b')) = do a <- read a' b <- read b'@@ -140,12 +141,14 @@ strict = BS.concat . BL.toChunks #endif +readRecorded :: (RepoPatch p) => Repository p C(r u t) -> IO Tree+readRecorded _ = readDarcsPristine "."+ readRecordedAndPending :: (RepoPatch p) => Repository p C(r u t) -> IO Tree readRecordedAndPending repo = do- pristine <- readDarcsPristine "."+ pristine <- readRecorded repo Sealed pending <- pendingChanges repo []- (_, t) <- virtualTreeIO (apply [] pending) pristine- return t+ applyToTree pending pristine pendingChanges :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO (Sealed (FL Prim C(r)))@@ -160,13 +163,11 @@ _ -> choose_touching pre_files pending return relevant -readIndex :: IO Tree-readIndex = I.readIndex "_darcs/index" darcsTreeHash+applyToTree patch tree = snd `fmap` virtualTreeIO (apply [] patch) tree unrecordedChanges :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t) -> [SubPath] -> IO (FL Prim C(r y)) unrecordedChanges opts repo paths = do- checkIndex repo pristine <- readDarcsPristine "." Sealed pending <- pendingChanges repo paths (_, current') <- virtualTreeIO (apply [] pending) pristine@@ -176,12 +177,13 @@ let current = relevant current' working <- case (LookForAdds `elem` opts, IgnoreTimes `elem` opts) of (False, False) -> do- all <- readIndex+ all <- readIndex repo expand (relevant all) (False, True) -> do guide <- expand current all <- readPlainTree "." return $ relevant $ (restrict guide) all+ -- TODO (True, False) could use a more efficient implementation... (True, _) -> do all <- readPlainTree "." return $ relevant $ nonboring all@@ -190,29 +192,34 @@ diff <- treeDiff ft current working return $ sort_coalesceFL (pending +>+ diff) +applyToTentativePristine :: (Apply p) => t -> p C(x y) -> IO () applyToTentativePristine _ patches = do pristine <- readDarcsPristine "."- (_, tree) <- hashedTreeIO (apply [] patches)- pristine "_darcs/pristine.hashed"+ (_, t) <- hashedTreeIO (apply [] patches)+ pristine "_darcs/pristine.hashed" BS.writeFile "_darcs/tentative_pristine" $ BS.concat [BS.pack "pristine:"- , darcsFormatHash (fromJust $ treeHash tree)]+ , darcsFormatHash (fromJust $ treeHash t)] applyToWorking :: (RepoPatch p) => Repository p C(r u t) -> Sealed (FL Prim C(u)) -> IO Tree-applyToWorking _ (Sealed patches) =- do working <- readIndex+applyToWorking repo (Sealed patches) =+ do working <- readIndex repo snd `fmap` plainTreeIO (apply [] patches) working "." +filter_paths :: [AnchoredPath] -> AnchoredPath -> t -> Bool filter_paths files = \p _ -> any (\x -> x `isPrefix` p || p `isPrefix` x) files +restrict_paths :: [AnchoredPath] -> Tree -> Tree restrict_paths files = if null files then id else filter $ filter_paths files +restrict_subpaths :: [SubPath] -> Tree -> Tree restrict_subpaths = restrict_paths . map (floatPath . fn2fp . sp2fn) +restrictSubpaths :: (RepoPatch p) => Repository p C(r u t) -> [SubPath] -> IO (Tree -> Tree) restrictSubpaths repo subpaths = do Sealed pending <- read_pending repo let paths = map (fn2fp . sp2fn) subpaths@@ -220,6 +227,7 @@ anchored = map floatPath paths' return $ restrict_paths anchored +restrictBoring :: IO (Tree -> Tree) restrictBoring = do boring <- boring_regexps let boring' (AnchoredPath (Name x:_)) _ | x == BS.pack "_darcs" = False@@ -227,16 +235,19 @@ where p' = anchorPath "" p return $ filter boring' -checkIndex repo = do+readIndex :: (RepoPatch p) => Repository p C(r u t) -> IO Tree+readIndex repo = do+ let getpris = readRecordedAndPending repo+ update = do pris <- getpris >>= expand+ I.updateIndexFrom "_darcs/index" darcsTreeHash pris invalid <- doesFileExist "_darcs/index_invalid" exist <- doesFileExist "_darcs/index"- when (not exist || invalid) $ updateIndex repo- when invalid $ removeFile "_darcs/index_invalid"--updateIndex repo = do- pristine <- readRecordedAndPending repo >>= expand- I.updateIndexFrom "_darcs/index" darcsTreeHash pristine >>= expand- return ()+ if (not exist || invalid)+ then do idx <- update+ when invalid $ removeFile "_darcs/index_invalid"+ return idx+ else I.readOrUpgradeIndex "_darcs/index" darcsTreeHash getpris +invalidateIndex :: t -> IO () invalidateIndex _ = do BS.writeFile "_darcs/index_invalid" BS.empty
src/Darcs/Repository/Cache.hs view
@@ -11,7 +11,7 @@ fetchFileUsingCache, speculateFileUsingCache, writeFileUsingCache, findFileMtimeUsingCache, setFileMtimeUsingCache, peekInCache, repo2cache,- writable, hashedFilePath, allHashedDirs+ writable, isthisrepo, hashedFilePath, allHashedDirs ) where import Control.Monad ( liftM, when, guard )@@ -119,6 +119,10 @@ writable :: CacheLoc -> Bool writable (Cache _ NotWritable _) = False writable (Cache _ Writable _) = True++isthisrepo :: CacheLoc -> Bool+isthisrepo (Cache Repo Writable _) = True+isthisrepo _ = False -- | @hashedFilePath cachelocation subdir hash@ returns the physical filename of -- hash @hash@ in the @subdir@ section of @cachelocation@.
+ tests/hspwd.hs view
@@ -0,0 +1,5 @@+module Main where++import Directory ( getCurrentDirectory )++main = getCurrentDirectory >>= putStr
tests/issue1248.sh view
@@ -17,4 +17,5 @@ darcs check darcs optimize --compress darcs check+cd .. rm -rf temp1