diff --git a/README b/README --- a/README +++ b/README @@ -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 ======= diff --git a/darcs-beta.cabal b/darcs-beta.cabal --- a/darcs-beta.cabal +++ b/darcs-beta.cabal @@ -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 , @@ -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: diff --git a/release/distributed-context b/release/distributed-context --- a/release/distributed-context +++ b/release/distributed-context @@ -1,1 +1,1 @@ -Just "\nContext:\n\n[TAG 2.2.98.1\nPetr Rockai **20090623155657\n Ignore-this: b388b0221526b2609dec75bb733bfc4c\n] \n" +Just "\nContext:\n\n[TAG 2.2.98.2\nPetr Rockai **20090709104304\n Ignore-this: d9832c9f7b7c2c78ae83fda2524162ca\n] \n" diff --git a/src/ByteStringUtils.hs b/src/ByteStringUtils.hs --- a/src/ByteStringUtils.hs +++ b/src/ByteStringUtils.hs @@ -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 diff --git a/src/Darcs/Arguments.lhs b/src/Darcs/Arguments.lhs --- a/src/Darcs/Arguments.lhs +++ b/src/Darcs/Arguments.lhs @@ -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} diff --git a/src/Darcs/Commands/GZCRCs.lhs b/src/Darcs/Commands/GZCRCs.lhs --- a/src/Darcs/Commands/GZCRCs.lhs +++ b/src/Darcs/Commands/GZCRCs.lhs @@ -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 "") diff --git a/src/Darcs/Commands/ShowIndex.lhs b/src/Darcs/Commands/ShowIndex.lhs --- a/src/Darcs/Commands/ShowIndex.lhs +++ b/src/Darcs/Commands/ShowIndex.lhs @@ -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} diff --git a/src/Darcs/Flags.hs b/src/Darcs/Flags.hs --- a/src/Darcs/Flags.hs +++ b/src/Darcs/Flags.hs @@ -87,7 +87,7 @@ | HTTPPipelining | NoHTTPPipelining | NoCache | AllowUnrelatedRepos - | Check | Repair + | Check | Repair | JustThisRepo | NullFlag deriving ( Eq, Show ) diff --git a/src/Darcs/Global.hs b/src/Darcs/Global.hs --- a/src/Darcs/Global.hs +++ b/src/Darcs/Global.hs @@ -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 diff --git a/src/Darcs/Gorsvet.hs b/src/Darcs/Gorsvet.hs --- a/src/Darcs/Gorsvet.hs +++ b/src/Darcs/Gorsvet.hs @@ -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 diff --git a/src/Darcs/Repository/Cache.hs b/src/Darcs/Repository/Cache.hs --- a/src/Darcs/Repository/Cache.hs +++ b/src/Darcs/Repository/Cache.hs @@ -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@. diff --git a/tests/hspwd.hs b/tests/hspwd.hs new file mode 100644 --- /dev/null +++ b/tests/hspwd.hs @@ -0,0 +1,5 @@ +module Main where + +import Directory ( getCurrentDirectory ) + +main = getCurrentDirectory >>= putStr diff --git a/tests/issue1248.sh b/tests/issue1248.sh --- a/tests/issue1248.sh +++ b/tests/issue1248.sh @@ -17,4 +17,5 @@ darcs check darcs optimize --compress darcs check +cd .. rm -rf temp1