darcs 2.16.3 → 2.16.4

raw patch · 34 files changed

+748/−417 lines, 34 filesbinary-addedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG +51/−0
• contrib/_darcs.zsh +33/−17
• contrib/darcs_completion +38/−32
• darcs.cabal +3/−3
• harness/Darcs/Test/HashedStorage.hs +2/−2
• release/distributed-context +1/−1
• src/Darcs/Patch/ApplyPatches.hs +0/−22
• src/Darcs/Patch/Index/Monad.hs +10/−14
• src/Darcs/Patch/Index/Types.hs +0/−4
• src/Darcs/Patch/Prim/V1/Apply.hs +18/−1
• src/Darcs/Repository/ApplyPatches.hs +40/−28
• src/Darcs/Repository/Create.hs +18/−11
• src/Darcs/Repository/Hashed.hs +5/−1
• src/Darcs/Repository/Identify.hs +16/−10
• src/Darcs/Repository/PatchIndex.hs +6/−10
• src/Darcs/Repository/Repair.hs +2/−2
• src/Darcs/Repository/State.hs +72/−46
• src/Darcs/UI/Commands/Move.hs +6/−2
• src/Darcs/UI/Commands/ShowIndex.hs +2/−2
• src/Darcs/UI/Commands/Util/Tree.hs +17/−28
• src/Darcs/UI/Options/All.hs +2/−2
• src/Darcs/Util/Index.hs +21/−25
• src/Darcs/Util/Tree/Hashed.hs +2/−2
• src/Darcs/Util/Tree/Monad.hs +161/−150
• tests/broken_move.sh +117/−0
• tests/data/broken_move.tgz binary
• tests/data/rebase-0.0-conflict.tgz binary
• tests/data/rebase-0.0.tgz binary
• tests/data/rebase-0.2.tgz binary
• tests/issue2674-moving-unadded-files.sh +20/−0
• tests/rebase-0.0-compat.sh +54/−0
• tests/rebase-0.2-compat.sh +28/−0
• tests/rmdir.sh +1/−1
• tests/trackdown-bisect.sh +2/−1

@@ -1,3 +1,54 @@+Darcs 2.16.4, 20 May 2021++  This release is mostly to fix http://bugs.darcs.net/issue2674 which can+  lead to repository corruption. This is not quite as bad as it sounds,+  since the broken changes that you could have recorded were consistently+  ignored when applying the patch. This bug has been in darcs for a very+  long time and even our own repos contain (ancient) patches with broken+  move changes, and so far it hasn't caused us any trouble.++  That said, there are certain patch commutations that will erroneously (and+  unexpectedly) fail when such a patch is involved. We therefore recommend+  to upgrade. You may also (after upgrading) run 'darcs check' on your+  repositories to see if you are affected, and 'darcs repair' them if that+  is the case. Fortunately, the broken move changes can be safely eliminated+  from existing patches, and the improved repair command now does exactly+  that.++  Thanks to lemming@henning-thielemann.de for bringing this bug to our+  attention.++  * resolve issue2674: moving unadded files+  * add a check/repair rule for bad move patches+    This drops a move patch with either non-existing source or existing target.++  Also related to issue2674:++  * improve error message when runDefault fails due to an IO error+  * remove catching of exceptions for bad moves in DefaultIO+  * fail in Darcs.Util.Tree.Monad.rename if source does not exist+  * test that we cannot record patches that depend on broken moves++  The rest of the changes are minor bug fixes plus a few dependencies.++  * resolve issue2670: convert "." to absolute path when creating a repo+    This bug was introduced by fix for issue2668.+  * resolve issue2668: createDirectory: permission denied+  * resolve issue2667: darcs init failed with permission denied+  * bugfix: --leave-test-dir should be off by default+  * bash_completion: use '--list-options' before any other option+    This is so to avoid that, e.g.:+    $ darcs record -m <Tab><Tab>+    results in a patch named '--list-options' being recorded.+  * zsh completion: use '--list-options' before any other option+    See the corresponding change in the bash completion for details.+  * zsh completion: improve the get/clone case+    Moving the special case for get/clone down into the catch-all case for the+    current word allows it to complete options and local paths.+  * bugfix: --leave-test-dir should be off by default+  * bugfix in readPendingAndMovesAndUnrecorded+  * print patch application warnings to stderr, not stdout+ Darcs 2.16.3, 22 October 2020    * Fix building with `-f curl` (issue2655)

@@ -4,35 +4,51 @@ ## Originally derived from a version by ## Copyright (C) 2009  Nicolas Pouillard -local -a darcs_options darcs_non_options darcs_arguments+local -a darcs_options darcs_non_options darcs_arguments darcs_list_options  if (($CURRENT == 2)); then   compadd -- $(darcs --commands) else-  case "${words[2]}"; in-    get|clone)-      _urls-      ;;-  esac-  case "${words[$CURRENT]}"; in+  # advanced zsh (array) parameter expansion fu:+  # - ${(f)...} means split into array elements at line endings+  #   instead of white space+  # - ${arr:#pat} drops elements matching pat from arr, whereas+  #   ${(M)arr:#pat} drops non-matching elements+  # - ${arr/pat/repl} replaces pat with repl for all elements of arr+  # - ${arr[(i)val]} is reverse indexing: returns index of first+  #   occurrence of val in arr++  # save current word+  local current_word=$words[$CURRENT]+  # delete it from words+  words[$CURRENT]=()+  # find the index of the first option argument+  local first_opt=${words[(i)-*]}+  # insert --list-options right before the first option argument+  darcs_list_options=($words[1,$(($first_opt - 1))] --list-options $words[$first_opt,-1])+  # debugging help+  #print -l $darcs_list_options > ./debug_darcs_completion+  # execute command line with --list-options inserted and+  # split the result (stdout) at line endings+  darcs_arguments=(${(f)"$($darcs_list_options 2>/dev/null)"})+  case $current_word; in     /*|./*|\~*|../*)       _files       ;;     -*)-      # advanced zsh (array) parameter expansion fu:-      # - ${(f)...} means split into array elements at line endings-      #   instead of white space-      # - ${arr:#pat} drops elements matching pat from arr, whereas-      #   ${(M)arr:#pat} drops non-matching elements-      # - ${arr/pat/repl} replaces pat with repl for all elements of arr-      darcs_arguments=(${(f)"$(words[$CURRENT]=--list-options && $words 2>/dev/null)"})       darcs_options=(${${(M)darcs_arguments:#-*}/;/:})       _describe '' darcs_options       ;;     *)-      darcs_arguments=(${(f)"$(words[$CURRENT]=--list-options && $words 2>/dev/null)"})-      darcs_non_options=(${darcs_arguments:#-*})-      _multi_parts -i -S ' ' / darcs_non_options+      case "${words[2]}"; in+        get|clone)+          _urls+          ;;+        *)+          darcs_non_options=(${darcs_arguments:#-*})+          _multi_parts -i -S ' ' / darcs_non_options+          ;;+      esac       ;;   esac fi

@@ -16,51 +16,57 @@         return 0     fi -    # Store the whole command line substituting the (possibly empty)-    # to-be-completed word with '--list-options'.-    local -a words=("${COMP_WORDS[@]}")-    words[$COMP_CWORD]="--list-options"+    # Top-level options do not accept any further options+    case "${COMP_WORDS[1]}" in+        (-*) COMPREPLY=''; return 0;;+    esac -    # Options are processed from left to right, so avoid to display the help-    # page when trying to complete a command line that includes '--help'. It-    # could be tricked by things like '--repodir --hell', but, come on... you-    # don't deserve a working completion if you name a directory '--hell'.-    for w in "${words[@]}"; do-        case "$w" in-            (--he*) return 0;;+    # Build a new command line copying all the tokens and inserting+    # '--list-options' before the first option (a token starting with '-').+    local -a cmdline+    local i=0+    local m=$(( ${#COMP_WORDS[@]} - 1 ))+    for token in "${COMP_WORDS[@]:0:${m}}"+    do+        case "$token" in+            (-*) cmdline+=("--list-options" "${COMP_WORDS[@]:${i}}");+                 break;;+             (*) cmdline+=("$token");+                 i=$(( $i + 1 ));;         esac     done+    test $i -eq $m && cmdline+=("--list-options")      # So that the following "command-output to array" operation splits only at     # newlines, not at each space, tab or newline.     local IFS=$'\n'-    COMPREPLY=( $( "${words[@]}" 2>/dev/null |\+    COMPREPLY=( $( "${cmdline[@]}" 2>/dev/null |\         command grep "^${cur//./\\.}" | cut -d ';' -f 1) ) -	# Then, we adapt the resulting strings to be reusable by bash. If we don't-	# do this, in the case where we have two repositories named-	# ~/space in there-0.1 and ~/space in there-0.2, the first completion will-	# give us:-	# bash> darcs push ~/space in there-0.-	# ~/space in there-0.1 ~/space in there-0.2-	# and we have introduced two spaces in the command line (if we try to-	# recomplete that, it won't find anything, as it doesn't know anything-	# starting with "there-0.").-	# printf %q will gracefully add the necessary backslashes.-	#-	# Bash also interprets colon as a separator. If we didn't handle it-	# specially, completing http://example.org/repo from http://e would -	# give us:-	# bash> darcs pull http:http://example.org/repo-	# An option would be to require the user to escape : as \: and we-	# would do the same here. Instead, we return only the part after-	# the last colon that is already there, and thus fool bash. The-	# downside is that bash only shows this part to the user.+    # Then, we adapt the resulting strings to be reusable by bash. If we don't+    # do this, in the case where we have two repositories named+    # ~/space in there-0.1 and ~/space in there-0.2, the first completion will+    # give us:+    # bash> darcs push ~/space in there-0.+    # ~/space in there-0.1 ~/space in there-0.2+    # and we have introduced two spaces in the command line (if we try to+    # recomplete that, it won't find anything, as it doesn't know anything+    # starting with "there-0.").+    # printf %q will gracefully add the necessary backslashes.+    #+    # Bash also interprets colon as a separator. If we didn't handle it+    # specially, completing http://example.org/repo from http://e would+    # give us:+    # bash> darcs pull http:http://example.org/repo+    # An option would be to require the user to escape : as \: and we+    # would do the same here. Instead, we return only the part after+    # the last colon that is already there, and thus fool bash. The+    # downside is that bash only shows this part to the user.     local i=${#COMPREPLY[*]}     local colonprefixes=${cur%"${cur##*:}"}     while [ $((--i)) -ge 0 ]; do       COMPREPLY[$i]=`printf %q "${COMPREPLY[$i]}"`-      COMPREPLY[$i]=${COMPREPLY[$i]#"$colonprefixes"} +      COMPREPLY[$i]=${COMPREPLY[$i]#"$colonprefixes"}     done     return 0 }

@@ -1,6 +1,6 @@-Cabal-Version:  2.2+Cabal-Version:  2.4 Name:           darcs-version:        2.16.3+version:        2.16.4 License:        GPL-2.0-or-later License-file:   COPYING Author:         David Roundy <droundy@darcs.net>, <darcs-devel@darcs.net>@@ -117,6 +117,7 @@   manual:      True  flag rts+  description: Support RTS options   default:     False   manual:      True @@ -151,7 +152,6 @@                       Darcs.Patch.Annotate                       Darcs.Patch.Apply                       Darcs.Patch.ApplyMonad-                      Darcs.Patch.ApplyPatches                       Darcs.Patch.Bracketed                       Darcs.Patch.Bundle                       Darcs.Patch.Choices

@@ -149,7 +149,7 @@                exist <- doesFileExist "_darcs/index"                performGC -- required in win32 to trigger file close                when exist $ removeFile "_darcs/index"-               idx <- updateIndex =<< updateIndexFrom "_darcs/index" darcsTreeHash x+               idx <- treeFromIndex =<< updateIndexFrom "_darcs/index" darcsTreeHash x                return (x, idx)           check_index = extractRepoAndRun $             do (pris, idx) <- build_index@@ -280,7 +280,7 @@           check_diffTrees = extractRepoAndRun $                  do Prelude.writeFile "foo_dir/foo_a" "b\n"                     working_plain <- filter nondarcs `fmap` readPlainTree "."-                    working <- updateIndex =<<+                    working <- treeFromIndex =<<                                  updateIndexFrom "_darcs/index" darcsTreeHash working_plain                     pristine <- readDarcsPristine "."                     (working', pristine') <- diffTrees working pristine

@@ -1,1 +1,1 @@-Just "\nContext:\n\n\n[TAG 2.16.3\nBen Franksen <ben.franksen@online.de>**20201022094642\n Ignore-this: bd76d7e31488721e4a5ce7267115e71c3b68d680c155c75c3dd275d9e54933a607d208fab502a143\n] \n"+Just "\nContext:\n\n\n[TAG 2.16.4\nBen Franksen <ben.franksen@online.de>**20210520120106\n Ignore-this: 6ad053de84a2b3fcd9dc62076e0fbbad24d8c25ef4a659a163cadc1832b39686aa41a2b7a12928df\n] \n"

@@ -1,22 +0,0 @@-module Darcs.Patch.ApplyPatches-    ( applyPatches-    ) where--import Darcs.Patch.Info ( displayPatchInfo )-import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info )-import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.MonadProgress ( MonadProgress, ProgressAction(..), runProgressActions)--import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL )-import Darcs.Util.Printer ( text, ($$) )--applyPatches :: (MonadProgress m, ApplyMonad (ApplyState p) m, Apply p)-             => FL (PatchInfoAnd rt p) wX wY -> m ()-applyPatches ps = runProgressActions "Applying patch" (mapFL doApply ps)-  where-    doApply hp = ProgressAction { paAction = apply (hopefully hp)-                                , paMessage = displayPatchInfo (info hp)-                                , paOnError = text "Unapplicable patch:" $$-                                              displayPatchInfo (info hp)-                                }

@@ -71,20 +71,16 @@     mRemoveDirectory = remove     mRename a b = do       fns <- gets fst-      if S.notMember a fns then-         addMod (PInvalid a)  -- works around some old repo inconsistencies-       else-        do -- we have to account for directory moves-           addMod (PRename a b)-           modifyFps (S.delete a)-           addFile b-           forM_ (S.toList fns) $ \fn ->-             when (a `isPrefix` fn && a /= fn) $ do-               modifyFps (S.delete fn)-               let newfn = movedirfilename a b fn-               addFile newfn-               addMod (PRename fn newfn)-+      -- we have to account for directory moves+      addMod (PRename a b)+      modifyFps (S.delete a)+      addFile b+      forM_ (S.toList fns) $ \fn ->+        when (a `isPrefix` fn && a /= fn) $ do+          modifyFps (S.delete fn)+          let newfn = movedirfilename a b fn+          addFile newfn+          addMod (PRename fn newfn)     mModifyFilePS f _ = addMod (PTouch f)  -- ---------------------------------------------------------------------

@@ -56,10 +56,6 @@   | PRename a             a   | PRemove a-  | PInvalid a-    -- ^ This is an invalid patch-    --   e.g. there is a patch 'Move Autoconf.lhs Autoconf.lhs.in'-    --   where there is no Autoconf.lhs in the darcs repo   | PDuplicateTouch a     -- ^ this is used for duplicate patches that don't     --   have any effect, but we still want to keep

@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE MultiWayIf #-} module Darcs.Patch.Prim.V1.Apply () where  import Darcs.Prelude@@ -105,7 +106,23 @@                            FP f (Binary x new) :>: NilFL                           )              else return Nothing-    applyAndTryToFixFL p = do apply p; return Nothing+    applyAndTryToFixFL p@(Move old new) =+        do old_is_file <- mDoesFileExist old+           old_is_dir <- mDoesDirectoryExist old+           new_is_file <- mDoesFileExist new+           new_is_dir <- mDoesDirectoryExist new+           if | not (old_is_file || old_is_dir) ->+                  return $+                     Just ("WARNING: Dropping move patch with non-existing source "++ap2fp old,+                           unsafeCoercePStart NilFL+                          )+              | new_is_file || new_is_dir ->+                  return $+                     Just ("WARNING: Dropping move patch with existing target "++ap2fp old,+                           unsafeCoercePStart NilFL+                          )+              | otherwise -> apply p >> return Nothing+    applyAndTryToFixFL p = apply p >> return Nothing  instance PrimApply Prim where     applyPrimFL NilFL = return ()

@@ -25,35 +25,49 @@     , DefaultIO, runDefault     ) where -import Control.Exception ( catch, SomeException, IOException )+import Control.Exception ( IOException, SomeException, catch )+import Control.Monad ( unless )+import qualified Data.ByteString as B ( empty, null, readFile ) import Data.Char ( toLower ) import Data.List ( isSuffixOf )-import System.IO ( stderr )-import System.IO.Error ( isDoesNotExistError, isPermissionError )-import Control.Monad ( unless, mplus )-import System.Directory ( createDirectory,-                          removeDirectory, removeFile,-                          renameFile, renameDirectory,-                          doesDirectoryExist, doesFileExist-                        )+import System.Directory+    ( createDirectory+    , doesDirectoryExist+    , doesFileExist+    , removeDirectory+    , removeFile+    , renamePath+    )+import System.IO ( hPutStrLn, stderr )+import System.IO.Error ( catchIOError, isDoesNotExistError, isPermissionError )  import Darcs.Prelude -import Darcs.Patch.ApplyMonad( ApplyMonad(..), ApplyMonadTree(..) )-import Darcs.Patch.ApplyPatches ( applyPatches )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) )+import Darcs.Patch.Info ( displayPatchInfo ) import Darcs.Patch.MonadProgress ( MonadProgress(..), ProgressAction(..) )-import Darcs.Repository.Prefs( changePrefval )-import Darcs.Util.Lock ( writeAtomicFilePS )-+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info )+import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL )+import Darcs.Repository.Prefs ( changePrefval ) import Darcs.Util.Exception ( prettyException )-import Darcs.Util.Progress ( beginTedious, endTedious, tediousSize, finishedOneIO )-import Darcs.Util.Printer ( hPutDocLn, renderString ) import Darcs.Util.External ( backupByCopying, backupByRenaming )+import Darcs.Util.Lock ( writeAtomicFilePS ) import Darcs.Util.Path ( AnchoredPath, anchorPath )-import qualified Data.ByteString as B (empty, null, readFile)--import Darcs.Util.Tree( Tree )+import Darcs.Util.Printer ( hPutDocLn, renderString )+import Darcs.Util.Printer ( text, ($$) )+import Darcs.Util.Progress ( beginTedious, endTedious, finishedOneIO, tediousSize )+import Darcs.Util.Tree ( Tree ) +applyPatches :: (MonadProgress m, ApplyMonad (ApplyState p) m, Apply p)+             => FL (PatchInfoAnd rt p) wX wY -> m ()+applyPatches ps = runProgressActions "Applying patch" (mapFL doApply ps)+  where+    doApply hp = ProgressAction { paAction = apply (hopefully hp)+                                , paMessage = displayPatchInfo (info hp)+                                , paOnError = text "Unapplicable patch:" $$+                                              displayPatchInfo (info hp)+                                }  ap2fp :: AnchoredPath -> FilePath ap2fp = anchorPath ""@@ -95,13 +109,7 @@                             fail $ "Cannot remove non-empty file "++fp                        removeFile fp     mRemoveDirectory = DefaultIO . removeDirectory . ap2fp-    mRename a b = DefaultIO $-                  catch-                  (renameDirectory x y `mplus` renameFile x y)-                  -- We need to catch does not exist errors, since older-                  -- versions of darcs allowed users to rename nonexistent-                  -- files.  :(-                  (\e -> unless (isDoesNotExistError e) $ ioError e)+    mRename a b = DefaultIO $ renamePath x y       where x = ap2fp a             y = ap2fp b @@ -114,7 +122,7 @@     deriving (Functor, Applicative, Monad)  instance TolerantMonad TolerantIO where-    warning io = TIO $ io `catch` \e -> putStrLn $ "Warning: " ++ prettyException e+    warning io = TIO $ io `catch` \e -> hPutStrLn stderr $ "Warning: " ++ prettyException e     runIO (TIO io) = io     runTM = TIO @@ -140,7 +148,11 @@ -- | The default mode of applying patches: fail if the directory is not -- as we expect runDefault :: DefaultIO a -> IO a-runDefault = runDefaultIO+runDefault action =+  catchIOError (runDefaultIO action) $ \e ->+    fail $ "Cannot apply some patch:\n"++show e+++      "\nYou may want to run 'darcs check' to find out if there are broken"+++      "\npatches in your repo, and perhaps 'darcs repair' to fix them."  instance TolerantMonad m => ApplyMonad Tree (TolerantWrapper m) where     type ApplyMonadBase (TolerantWrapper m) = IO

@@ -76,6 +76,7 @@     ( writeBinFile     , writeDocBinFile     )+import Darcs.Util.Path ( ioAbsoluteOrRemote, toPath ) import Darcs.Util.Tree( Tree, emptyTree ) import Darcs.Util.Tree.Hashed( writeDarcsHashed, darcsAddMissingHashes ) @@ -112,30 +113,34 @@ createRepository patchfmt withWorkingDir withPatchIndex useCache = do   rfmt <- createRepositoryFiles patchfmt withWorkingDir   cache <- getCaches useCache here+  rdir <- toPath <$> ioAbsoluteOrRemote here   repo@(EmptyRepository r) <- case patchfmt of-    PatchFormat1 -> return $ EmptyRepository $ mkRepoV1 rfmt cache-    PatchFormat2 -> return $ EmptyRepository $ mkRepoV2 rfmt cache-    PatchFormat3 -> return $ EmptyRepository $ mkRepoV3 rfmt cache+    PatchFormat1 -> return $ EmptyRepository $ mkRepoV1 rdir rfmt cache+    PatchFormat2 -> return $ EmptyRepository $ mkRepoV2 rdir rfmt cache+    PatchFormat3 -> return $ EmptyRepository $ mkRepoV3 rdir rfmt cache   maybeCreatePatchIndex withPatchIndex r   return repo  mkRepoV1-  :: RepoFormat+  :: FilePath+  -> RepoFormat   -> Cache   -> Repository ('RepoType 'NoRebase) (RepoPatchV1 V1.Prim) Origin Origin Origin-mkRepoV1 repofmt cache = mkRepo here repofmt HashedPristine cache+mkRepoV1 rdir repofmt cache = mkRepo rdir repofmt HashedPristine cache  mkRepoV2-  :: RepoFormat+  :: FilePath+  -> RepoFormat   -> Cache   -> Repository ('RepoType 'NoRebase) (RepoPatchV2 V2.Prim) Origin Origin Origin-mkRepoV2 repofmt cache = mkRepo here repofmt HashedPristine cache+mkRepoV2 rdir repofmt cache = mkRepo rdir repofmt HashedPristine cache  mkRepoV3-  :: RepoFormat+  :: FilePath+  -> RepoFormat   -> Cache   -> Repository ('RepoType 'NoRebase) (RepoPatchV3 V2.Prim) Origin Origin Origin-mkRepoV3 repofmt cache = mkRepo here repofmt HashedPristine cache+mkRepoV3 rdir repofmt cache = mkRepo rdir repofmt HashedPristine cache  createRepositoryV1   :: WithWorkingDir -> WithPatchIndex -> UseCache@@ -143,7 +148,8 @@ createRepositoryV1 withWorkingDir withPatchIndex useCache = do   rfmt <- createRepositoryFiles PatchFormat1 withWorkingDir   cache <- getCaches useCache here-  let repo = mkRepoV1 rfmt cache+  rdir <- toPath <$> ioAbsoluteOrRemote here+  let repo = mkRepoV1 rdir rfmt cache   maybeCreatePatchIndex withPatchIndex repo   return repo @@ -153,7 +159,8 @@ createRepositoryV2 withWorkingDir withPatchIndex useCache = do   rfmt <- createRepositoryFiles PatchFormat2 withWorkingDir   cache <- getCaches useCache here-  let repo = mkRepoV2 rfmt cache+  rdir <- toPath <$> ioAbsoluteOrRemote here+  let repo = mkRepoV2 rdir rfmt cache   maybeCreatePatchIndex withPatchIndex repo   return repo 

@@ -626,7 +626,11 @@             let r' = unsafeCoerceR r             debugMessage "Done finalizing changes..."             ps <- readRepo r'-            doesPatchIndexExist (repoLocation r') >>= (`when` createOrUpdatePatchIndexDisk r' ps)+            pi_exists <- doesPatchIndexExist (repoLocation r')+            when pi_exists $+              createOrUpdatePatchIndexDisk r' ps+              `catchIOError` \e ->+                hPutStrLn stderr $ "Cannot create or update patch index: "++ show e             updateIndex r'             return r'     | otherwise = fail Old.oldRepoFailMsg

@@ -33,6 +33,7 @@                         , listDirectory                         ) import System.FilePath.Posix ( (</>) )+import System.IO ( hPutStrLn, stderr ) import System.IO.Error ( catchIOError ) import Data.Maybe ( fromMaybe ) @@ -164,7 +165,7 @@  -- | hunt upwards for the darcs repository -- This keeps changing up one parent directory, testing at each--- step if the current directory is a repository or not.  $+-- step if the current directory is a repository or not. -- The result is: --   Nothing, if no repository found --   Just (Left errorMessage), if bad repository found@@ -172,19 +173,24 @@ -- WARNING this changes the current directory for good if matchFn succeeds seekRepo :: IO (Maybe (Either String ())) seekRepo = getCurrentDirectory >>= helper where-   helper startpwd = do+  helper startpwd = do     status <- maybeIdentifyRepository YesUseCache "."     case status of       GoodRepository _ -> return . Just $ Right ()-      BadRepository e  -> return . Just $ Left e+      BadRepository e -> return . Just $ Left e       NonRepository _ ->-            do cd <- toFilePath `fmap` getCurrentDirectory-               setCurrentDirectory ".."-               cd' <- toFilePath `fmap` getCurrentDirectory-               if cd' /= cd-                  then helper startpwd-                  else do setCurrentDirectory startpwd-                          return Nothing+        catchIOError+          (do cd <- toFilePath `fmap` getCurrentDirectory+              setCurrentDirectory ".."+              cd' <- toFilePath `fmap` getCurrentDirectory+              if cd' /= cd+                then helper startpwd+                else do+                  setCurrentDirectory startpwd+                  return Nothing)+          (\e -> do+             hPutStrLn stderr ("Warning: " ++ show e)+             return Nothing)  -- The performGC in this function is a workaround for a library/GHC bug, -- http://hackage.haskell.org/trac/ghc/ticket/2924 -- (doesn't seem to be a

@@ -180,7 +180,6 @@          insertTouch fid pid          stopFidSpan fn pid          stopFpSpan fid pid-       go (_, PInvalid _) = return () -- just ignore invalid changes        go (pid, PDuplicateTouch fn) = do          fidm <- gets fidspans          case M.lookup fn fidm of@@ -323,14 +322,11 @@                                      PRemove f -> [f]; _ -> []}             touched_all = listTouchedFiles p             touched_effect = concatMap touched pmods_effect-            touched_invalid = [ f | (PInvalid f) <- pmods_effect]             -- listTouchedFiles returns all files that touched by these             --  patches, even if they have no effect, e.g. by duplicate patches             pmods_dup = map PDuplicateTouch . S.elems                             $ S.difference (S.fromList touched_all)-                                           (S.fromList touched_invalid-                                            `S.union`-                                            S.fromList touched_effect)+                                           (S.fromList touched_effect)  -- | return set of current filenames in patch index fpSpans2fileNames :: FilePathSpans -> Set AnchoredPath@@ -388,7 +384,7 @@     let newpatches = drop len_common $ mapFL seal2 flpatches         newpmods = patches2patchMods newpatches filenames     inv_hash <- getInventoryHash repodir-    storePatchIndex repodir cdir inv_hash (applyPatchMods newpmods pindex')+    storePatchIndex cdir inv_hash (applyPatchMods newpmods pindex')   where     -- return uncommon suffixes and length of common prefix of as and bs     uncommon = uncommon' 0@@ -403,7 +399,7 @@                      -> [(PatchId, [PatchMod AnchoredPath])] -> IO () createPatchIndexFrom repo pmods = do     inv_hash <- getInventoryHash repodir-    storePatchIndex repodir cdir inv_hash (applyPatchMods pmods emptyPatchIndex)+    storePatchIndex cdir inv_hash (applyPatchMods pmods emptyPatchIndex)   where repodir = repoLocation repo         cdir = repodir </> indexDir         emptyPatchIndex = PatchIndex [] M.empty M.empty M.empty@@ -518,10 +514,10 @@     else return False  -- | Stores patch-index on disk.-storePatchIndex :: FilePath -> FilePath -> String -> PatchIndex -> IO ()-storePatchIndex repodir cdir inv_hash (PatchIndex pids fidspans fpspans infom) = do+storePatchIndex :: FilePath -> String -> PatchIndex -> IO ()+storePatchIndex cdir inv_hash (PatchIndex pids fidspans fpspans infom) = do   createDirectory cdir `catch` \(_ :: IOError) -> return ()-  tmpdir <- withPermDir repodir $ \dir -> do+  tmpdir <- withPermDir cdir $ \dir -> do               debugMessage "About to create patch index..."               let tmpdir = toFilePath dir               storeRepoState (tmpdir </> repoStateFile) inv_hash

@@ -76,7 +76,7 @@ import Darcs.Util.Tree.Monad( TreeIO ) import Darcs.Util.Tree.Hashed( darcsUpdateHashes, hashedTreeIO ) import Darcs.Util.Tree.Plain( readPlainTree )-import Darcs.Util.Index( updateIndex )+import Darcs.Util.Index( treeFromIndex )  import qualified Data.ByteString.Char8 as BC @@ -243,7 +243,7 @@   -> Bool   -> IO Bool checkIndex repo quiet = do-  index <- updateIndex =<< readIndex repo+  index <- treeFromIndex =<< readIndex repo   pristine <- expand =<< readRecordedAndPending repo   working <- expand =<< restrict pristine <$> readPlainTree "."   working_hashed <- darcsUpdateHashes working

@@ -39,7 +39,7 @@  import Darcs.Prelude -import Control.Monad ( when, foldM, forM )+import Control.Monad ( when, foldM, forM, void ) import Control.Monad.State ( StateT, runStateT, get, put, liftIO ) import Control.Exception ( catch, IOException ) import Data.Maybe ( isJust )@@ -47,13 +47,8 @@ import Data.List ( sortBy, union, delete ) import Text.Regex( matchRegex ) -import System.Directory( removeFile, doesFileExist, doesDirectoryExist, renameFile )-import System.FilePath-    ( (</>)-#if mingw32_HOST_OS-    , (<.>)-#endif-    )+import System.Directory( doesFileExist, doesDirectoryExist, renameFile )+import System.FilePath ( (<.>), (</>) ) import System.IO ( hPutStrLn, stderr ) import System.IO.Error ( catchIOError ) @@ -100,6 +95,8 @@     , indexInvalidPath     ) +import Darcs.Util.File ( removeFileMayNotExist )+import Darcs.Util.Global ( debugMessage ) import Darcs.Util.Path     ( AnchoredPath     , anchorPath@@ -115,7 +112,13 @@ import qualified Darcs.Util.Tree.Plain as PlainTree ( readPlainTree ) import Darcs.Util.Tree.Hashed     ( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize )-import qualified Darcs.Util.Index as I+import Darcs.Util.Index+    ( Index+    , indexFormatValid+    , openIndex+    , treeFromIndex+    , updateIndexFrom+    ) import qualified Darcs.Util.Tree as Tree import Darcs.Util.Index ( listFileIDs, getFileID ) @@ -245,14 +248,18 @@   IsEq <- return $ workDirLessRepoWitness r   return (NilFL :> NilFL) readPendingAndWorking (useidx, scan, diffalg) lfm lfr repo mbpaths = do+  debugMessage "readPendingAndWorking: start"   (pending_tree, working_tree, (pending :> moves)) <-     readPendingAndMovesAndUnrecorded repo useidx scan lfm mbpaths+  debugMessage "readPendingAndWorking: after readPendingAndMovesAndUnrecorded"   (pending_tree_with_replaces, Sealed replaces) <-     getReplaces lfr diffalg repo pending_tree working_tree+  debugMessage "readPendingAndWorking: after getReplaces"   ft <- filetypeFunction   wrapped_diff <- treeDiff diffalg ft pending_tree_with_replaces working_tree   case unFreeLeft wrapped_diff of     Sealed diff -> do+      debugMessage "readPendingAndWorking: done"       return $ unsafeCoercePEnd $ pending :> (moves +>+ replaces +>+ diff)  readPendingAndMovesAndUnrecorded@@ -267,17 +274,28 @@         , (FL (PrimOf p) :> FL (PrimOf p)) wR wU -- pending :> moves         ) readPendingAndMovesAndUnrecorded repo useidx scan lfm mbpaths = do+  debugMessage "readPendingAndMovesAndUnrecorded: start"   (pending_tree, Sealed pending) <- readPending repo   moves <- getMoves lfm repo mbpaths-  let pending' = pending +>+ moves-  relevant <- maybeRestrictSubpaths pending' repo mbpaths-  pending_tree' <-+  -- we want to include any user specified paths before and after pending+  -- and detected moves+  relevant <- maybeRestrictSubpaths (pending +>+ moves) repo mbpaths+  pending_tree_with_moves <-     applyTreeFilter relevant <$> applyToTree moves pending_tree+  debugMessage "readPendingAndMovesAndUnrecorded: before readIndexOrPlainTree"+  -- the moves are detected i.e. they are already applied in the working tree;+  -- also note that we have to use the amended pending tree to restrict the+  -- working tree in case we don't use the index (here and below)+  index <- readIndexOrPlainTree repo useidx relevant pending_tree_with_moves+  debugMessage "readPendingAndMovesAndUnrecorded: before filteredWorking"+  -- TODO this conditional looks wrong; so if we do have detected moves,+  -- then we cannot use the index to read the working state? Why not?   let useidx' = if nullFL moves then useidx else IgnoreIndex-  index <--    applyToTree moves =<< readIndexOrPlainTree repo useidx relevant pending_tree-  working_tree <- filteredWorking repo useidx' scan relevant index pending_tree'-  return (pending_tree', working_tree, unsafeCoercePEnd (pending :> moves))+  working_tree <-+    filteredWorking repo useidx' scan relevant index pending_tree_with_moves+  debugMessage "readPendingAndMovesAndUnrecorded: done"+  return+    (pending_tree_with_moves, working_tree, unsafeCoercePEnd (pending :> moves))  -- | @filteredWorking useidx scan relevant index pending_tree@ reads the -- working tree and filters it according to options and @relevant@ file paths.@@ -389,7 +407,7 @@ #if TEST_INDEX readIndexOrPlainTree repo useidx treeFilter pending_tree = do   indexTree <--    I.updateIndex =<< applyTreeFilter treeFilter <$> readIndex repo+    treeFromIndex =<< applyTreeFilter treeFilter <$> readIndex repo   plainTree <- do     guide <- expand pending_tree     expand =<< applyTreeFilter treeFilter . restrict guide <$> readPlainTree repo@@ -400,7 +418,7 @@       IgnoreIndex -> plainTree #else readIndexOrPlainTree repo UseIndex treeFilter pending_tree =-  (I.updateIndex =<< applyTreeFilter treeFilter <$> readIndex repo)+  (treeFromIndex =<< applyTreeFilter treeFilter <$> readIndex repo)     `catchIOError` \e -> do       hPutStrLn stderr ("Warning, cannot access the index:\n" ++ show e)       readIndexOrPlainTree repo IgnoreIndex treeFilter pending_tree@@ -455,48 +473,56 @@        return (pristine, seal NilFL)  -- | Mark the existing index as invalid. This has to be called whenever the--- listing of pristine changes and will cause darcs to update the index next--- time it tries to read it. (NB. This is about files added and removed from+-- listing of pristine+pending changes and will cause darcs to update the index.+-- This will happen either when we call updateIndex in finalizeRepositoryChanges+-- or else when we try to read the index the next time.+-- (NB. This is about files added and removed from -- pristine: changes to file content in either pristine or working are handled -- transparently by the index reading code.) invalidateIndex :: t -> IO () invalidateIndex _ = B.writeFile indexInvalidPath B.empty  readIndex :: (RepoPatch p, ApplyState p ~ Tree)-          => Repository rt p wR wU wR -> IO I.Index+          => Repository rt p wR wU wR -> IO Index readIndex repo = do-  (invalid, exists, formatValid) <- checkIndex-  if not exists || invalid || not formatValid-     then do pris <- readRecordedAndPending repo-             idx <- I.updateIndexFrom indexPath darcsTreeHash pris-             when invalid $ removeFile indexInvalidPath-             return idx-     else I.readIndex indexPath darcsTreeHash+  okay <- checkIndex+  if not okay+    then internalUpdateIndex repo+    else openIndex indexPath darcsTreeHash +-- | Update the index so that it matches pristine+pending. If the index does+-- not exist or is invalid, create a new one. Returns the updated index.+internalUpdateIndex :: (RepoPatch p, ApplyState p ~ Tree)+            => Repository rt p wR wU wR -> IO Index+internalUpdateIndex repo = do+  pris <- readRecordedAndPending repo+  idx <- updateIndexFrom indexPath darcsTreeHash pris+  removeFileMayNotExist indexInvalidPath+  return idx++-- | Update the index so that it matches pristine+pending. If the index does+-- not exist or is invalid, create a new one. updateIndex :: (RepoPatch p, ApplyState p ~ Tree)             => Repository rt p wR wU wR -> IO () updateIndex repo = do-  (invalid, _, _) <- checkIndex-  pris <- readRecordedAndPending repo-  _ <- I.updateIndexFrom indexPath darcsTreeHash pris-  when invalid $ removeFile indexInvalidPath+  -- call checkIndex to throw away the index if it is invalid;+  -- this can happen if we are called with --ignore-times+  -- TODO make this impossible i.e. honor UseIndex here+  void checkIndex+  void $ internalUpdateIndex repo -checkIndex :: IO (Bool, Bool, Bool)+-- | Check if we have a valid index. This means that the index file exists, is+-- readable, and can be mmapped, /and/ that indexInvalidPath does /not/ exist.+-- We do not yet remove indexInvalidPath in case updating the index fails.+checkIndex :: IO Bool checkIndex = do   invalid <- doesFileExist $ indexInvalidPath-  exists <- doesFileExist indexPath-  formatValid <- if exists-                     then I.indexFormatValid indexPath-                     else return True-  when (exists && not formatValid) $ do--- TODO this conditional logic (rename or delete) is mirrored in--- Darcs.Util.Index.updateIndexFrom and should be refactored-#if mingw32_HOST_OS-    renameFile indexPath (indexPath <.> "old")-#else-    removeFile indexPath-#endif-  return (invalid, exists, formatValid)+  formatValid <- indexFormatValid indexPath+  exist <- doesFileExist indexPath+  -- this fails with a permission (access denied) error on windows+  -- if we use removeFileMayNotExist instead of renameFile+  when (exist && not formatValid) $ renameFile indexPath (indexPath <.> "old")+  return (not invalid && formatValid)  -- |Remove any patches (+dependencies) from a sequence that -- conflict with the recorded or unrecorded changes in a repo

@@ -202,8 +202,12 @@  moveFilesToDir :: [DarcsFlag] -> [AnchoredPath] -> AnchoredPath -> IO () moveFilesToDir opts froms to =-  withRepoAndState opts $ \(repo, work, cur, _) ->-    moveToDir repo opts cur work froms to+  withRepoAndState opts $ \(repo, work, cur, _) -> do+    froms_exist <- and <$> forM froms (treeHas cur)+    if froms_exist then+      moveToDir repo opts cur work froms to+    else+      fail "Some of the paths you want to move aren't know to darcs. Use `darcs add` to add them first."  withRepoAndState :: [DarcsFlag]                  -> (forall rt p wR wU .

@@ -38,7 +38,7 @@  import Darcs.Util.Hash( encodeBase16, Hash( NoHash ) ) import Darcs.Util.Tree( list, expand, itemHash, Tree, TreeItem( SubTree ) )-import Darcs.Util.Index( updateIndex, listFileIDs )+import Darcs.Util.Index( treeFromIndex, listFileIDs ) import Darcs.Util.Path( anchorPath, AbsolutePath, floatPath ) import Darcs.Util.Printer ( Doc, text ) @@ -98,7 +98,7 @@ showIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () showIndexCmd _ opts _ = withRepository (useCache ? opts) $ RepoJob $ \repo ->   do index <- readIndex repo-     index_tree <- updateIndex index+     index_tree <- treeFromIndex index      fileids <- (M.fromList . map (\((a,_),b) -> (anchorPath "" a,b))) <$> listFileIDs index      dump opts (Just fileids) index_tree 

@@ -26,41 +26,30 @@  import Darcs.Prelude -import Control.Monad ( forM )-import Control.Monad.State.Strict( gets )-import Data.Maybe ( fromMaybe )+import Data.List ( find ) +import Darcs.Util.Path ( AnchoredPath(..), eqAnycase )+import Darcs.Util.Tree ( Tree, TreeItem(..), listImmediate ) import qualified Darcs.Util.Tree.Monad as TM-    ( TreeMonad, withDirectory, fileExists, directoryExists-    , virtualTreeMonad, currentDirectory, exists, tree )-import Darcs.Util.Tree ( Tree, listImmediate, findTree )--import Darcs.Util.Path-    ( AnchoredPath(..), eqAnycase )+    ( directoryExists+    , exists+    , fileExists+    , virtualTreeMonad+    )  treeHasAnycase :: Monad m                => Tree m                -> AnchoredPath                -> m Bool-treeHasAnycase tree path =-    fst `fmap` TM.virtualTreeMonad (existsAnycase path) tree---existsAnycase :: Monad m-              => AnchoredPath-              -> TM.TreeMonad m Bool-existsAnycase (AnchoredPath []) = return True-existsAnycase (AnchoredPath (x:xs)) = do-     wd <- TM.currentDirectory-     tree <- fromMaybe (error "invalid path passed to existsAnycase") <$>-             gets (flip findTree wd . TM.tree)-     let subs = [ AnchoredPath [n] | (n, _) <- listImmediate tree,-                                          eqAnycase n x ]-     or `fmap` forM subs (\path -> do-       file <- TM.fileExists path-       if file then return True-               else TM.withDirectory path (existsAnycase $ AnchoredPath xs))-+treeHasAnycase tree (AnchoredPath names) = go names (SubTree tree)+  where+    go [] _ = return True+    go ns (Stub mkTree _) = mkTree >>= go ns . SubTree+    go _ (File _) = return False+    go (n:ns) (SubTree t) =+      case find (eqAnycase n . fst) (listImmediate t) of+        Nothing -> return False+        Just (_,i) -> go ns i  treeHas :: Monad m => Tree m -> AnchoredPath -> m Bool treeHas tree path = fst `fmap` TM.virtualTreeMonad (TM.exists path) tree

@@ -839,7 +839,7 @@  testChanges :: PrimDarcsOption TestChanges testChanges = imap (Iso fw bw) $ runTest ^ leaveTestDir where-  fw k NoTestChanges = k NoRunTest {- undefined -} YesLeaveTestDir+  fw k NoTestChanges = k NoRunTest NoLeaveTestDir   fw k (YesTestChanges ltd) = k YesRunTest ltd   bw k NoRunTest _ = k NoTestChanges   bw k YesRunTest ltd = k (YesTestChanges ltd)@@ -850,7 +850,7 @@   , RawNoArg [] ["no-test"] F.NoTest NoRunTest "don't run the test script" ]  leaveTestDir :: PrimDarcsOption LeaveTestDir-leaveTestDir = withDefault YesLeaveTestDir+leaveTestDir = withDefault NoLeaveTestDir   [ RawNoArg [] ["leave-test-directory"]     F.LeaveTestDir YesLeaveTestDir "don't remove the test directory"   , RawNoArg [] ["remove-test-directory"]

@@ -70,7 +70,7 @@ -- index, so we can efficiently skip reading the whole subtree starting at a -- given directory (by just seeking aux bytes forward). The lines are -- pre-ordered with respect to directory structure -- the directory comes first--- and after it come all its items. Cf. 'readIndex''.+-- and after it come all its items. Cf. 'openIndex''. -- -- For files, the aux field holds a timestamp. --@@ -93,10 +93,10 @@ -- paths.  module Darcs.Util.Index-    ( readIndex+    ( openIndex     , updateIndexFrom     , indexFormatValid-    , updateIndex+    , treeFromIndex     , listFileIDs     , Index     , filter@@ -146,12 +146,8 @@ import System.IO ( hPutStrLn, stderr ) import System.IO.MMap( mmapFileForeignPtr, Mode(..) ) import System.Directory( doesFileExist, getCurrentDirectory, doesDirectoryExist )-#if mingw32_HOST_OS import System.Directory( renameFile ) import System.FilePath( (<.>) )-#else-import System.Directory( removeFile )-#endif  #ifdef WIN32 import System.Win32.File@@ -187,7 +183,7 @@ -- used by git...) It turns out that it's hard to efficiently read a flat index -- with our internal data structures -- we need to turn the flat index into a -- recursive Tree object, which is rather expensive... As a bonus, we can also--- efficiently implement subtree queries this way (cf. 'readIndex').+-- efficiently implement subtree queries this way (cf. 'openIndex'). data Item = Item { iBase :: !(Ptr ())                  , iHashAndDescriptor :: !B.ByteString                  } deriving Show@@ -575,18 +571,18 @@ -- * Reading and writing 'Tree's from/to the index  -- | Read an index and build up a 'Tree' object from it, referring to current--- working directory. The initial Index object returned by readIndex is not+-- working directory. The initial Index object returned by openIndex is not -- directly useful. However, you can use 'Tree.filter' on it. Either way, to -- obtain the actual Tree object, call update. -- -- The usual use pattern is this: ----- > do (idx, update) <- readIndex+-- > do (idx, update) <- openIndex -- >    tree <- update =<< filter predicate idx -- -- The resulting tree will be fully expanded.-readIndex :: FilePath -> (Tree IO -> Hash) -> IO Index-readIndex indexpath ht = do+openIndex :: FilePath -> (Tree IO -> Hash) -> IO Index+openIndex indexpath ht = do   (mmap_ptr, mmap_size) <- mmapIndex indexpath 0   base <- getCurrentDirectory   return $ if mmap_size == 0 then EmptyIndex@@ -638,32 +634,32 @@ -- does not exist in a plain form in current working directory). updateIndexFrom :: FilePath -> (Tree IO -> Hash) -> Tree IO -> IO Index updateIndexFrom indexpath hashtree' ref =-    do old_idx <- updateIndex =<< readIndex indexpath hashtree'+    do old_tree <- treeFromIndex =<< openIndex indexpath hashtree'        reference <- expand ref        let len_root = itemAllocSize anchoredRoot            len = len_root + sum [ itemAllocSize p | (p, _) <- list reference ]        exist <- doesFileExist indexpath--- TODO this conditional logic (rename or delete) is mirrored in--- Darcs.Repository.State.checkIndex and should be refactored-#if mingw32_HOST_OS+       -- Note that the file is still open via the mmaped pointer in+       -- the open index, and we /are/ going to write the index using+       -- that pointer. If we could rely on posix semantics,+       -- we would just delete the file. However, on windows this+       -- would fail, so instead we rename it.        when exist $ renameFile indexpath (indexpath <.> "old")-#else-       when exist $ removeFile indexpath -- to avoid clobbering oldidx-#endif        (mmap_ptr, _) <- mmapIndex indexpath len-       formatIndex mmap_ptr old_idx reference-       readIndex indexpath hashtree'+       formatIndex mmap_ptr old_tree reference+       openIndex indexpath hashtree' -updateIndex :: Index -> IO (Tree IO)-updateIndex EmptyIndex = return emptyTree-updateIndex index =+-- | Read the index, starting with the root, to create a 'Tree'.+treeFromIndex :: Index -> IO (Tree IO)+treeFromIndex EmptyIndex = return emptyTree+treeFromIndex index =     do let initial = State { start = size_header                            , dirlength = 0                            , path = anchoredRoot }        res <- readItem index initial        case treeitem res of          Just (SubTree tree) -> return $ filter (predicate index) tree-         _ -> fail "Unexpected failure in updateIndex!"+         _ -> fail "Unexpected failure in treeFromIndex!"  -- | Check that a given file is an index file with a format we can handle. You -- should remove and re-create the index whenever this is not true.

@@ -63,7 +63,7 @@     , updateSubtrees     , updateTree     )-import Darcs.Util.Tree.Monad (TreeIO, initialState, runTreeMonad)+import Darcs.Util.Tree.Monad (TreeIO, runTreeMonad)  --------------------------------------------------------------------- -- Utilities for coping with the darcs directory format.@@ -237,7 +237,7 @@              -> FilePath -- ^ directory              -> IO (a, Tree IO) hashedTreeIO action t dir =-    runTreeMonad action $ initialState t darcsHash updateItem+    runTreeMonad action t darcsHash updateItem     where updateItem _ (File b) = File <$> updateFile b           updateItem _ (SubTree s) = SubTree <$> updateSub s           updateItem _ x = return x

@@ -2,7 +2,7 @@ -- --  BSD3 --- | An experimental monadic interface to Tree mutation. The main idea is to+-- | A monadic interface to Tree mutation. The main idea is to -- simulate IO-ish manipulation of real filesystem (that's the state part of -- the monad), and to keep memory usage down by reasonably often dumping the -- intermediate data to disk and forgetting it. The monad interface itself is@@ -10,14 +10,27 @@ -- provides just 'virtualTreeIO' that never writes any changes, but may trigger -- filesystem reads as appropriate. module Darcs.Util.Tree.Monad-    ( virtualTreeIO, virtualTreeMonad-    , readFile, writeFile, createDirectory, rename, copy, unlink-    , fileExists, directoryExists, exists, withDirectory-    , currentDirectory-    , tree, TreeState, TreeMonad, TreeIO, runTreeMonad-    , initialState, replaceItem+    ( -- * 'TreeMonad'+      TreeMonad+    , TreeState(tree)+    , runTreeMonad+    , virtualTreeMonad+      -- * Specializing to 'IO'+    , TreeIO+    , virtualTreeIO+      -- * Read actions+    , readFile+    , exists+    , directoryExists+    , fileExists+      -- * Write actions+    , writeFile+    , createDirectory+    , unlink+    , rename+    , copy+      -- * Other actions     , findM, findFileM, findTreeM-    , TreeRO, TreeRW     ) where  import Darcs.Prelude hiding ( readFile, writeFile )@@ -35,112 +48,96 @@ import Control.Monad.RWS.Strict import qualified Data.Map as M +-- | Keep track of the size and age of changes to the tree. type Changed = M.Map AnchoredPath (Int64, Int64) -- size, age --- | Internal state of the 'TreeIO' monad. Keeps track of the current Tree--- content, unsync'd changes and a current working directory (of the monad).-data TreeState m = TreeState { tree :: !(Tree m)-                             , changed :: !Changed-                             , changesize :: !Int64-                             , maxage :: !Int64-                             , updateHash :: TreeItem m -> m Hash-                             , update :: AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m) }+-- | Internal state of the 'TreeMonad'. Keeps track of the current 'Tree'+-- content and unsync'd changes.+data TreeState m = TreeState+  { tree :: !(Tree m)+  , changed :: !Changed+  , changesize :: !Int64+  , maxage :: !Int64+  } --- | A 'TreeIO' monad. A sort of like IO but it keeps a 'TreeState' around as well,--- which is a sort of virtual filesystem. Depending on how you obtained your--- 'TreeIO', the actions in your virtual filesystem get somehow reflected in the--- actual real filesystem. For 'virtualTreeIO', nothing happens in real--- filesystem, however with 'plainTreeIO', the plain tree will be updated every--- now and then, and with 'hashedTreeIO' a darcs-style hashed tree will get--- updated.-type TreeMonad m = RWST AnchoredPath () (TreeState m) m-type TreeIO = TreeMonad IO+data TreeEnv m = TreeEnv+  { updateHash :: TreeItem m -> m Hash+  , update :: AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m)+  } -class Monad m => TreeRO m where-    currentDirectory :: m AnchoredPath-    withDirectory :: AnchoredPath -> m a -> m a-    expandTo :: AnchoredPath -> m AnchoredPath-    -- | Grab content of a file in the current Tree at the given path.-    readFile :: AnchoredPath -> m BL.ByteString-    -- | Check for existence of a node (file or directory, doesn't matter).-    exists :: AnchoredPath -> m Bool-    -- | Check for existence of a directory.-    directoryExists ::AnchoredPath -> m Bool-    -- | Check for existence of a file.-    fileExists :: AnchoredPath -> m Bool+-- | A monad transformer that adds state of type 'TreeState' and an environment+-- of type 'AnchoredPath' (for the current directory).+type TreeMonad m = RWST (TreeEnv m) () (TreeState m) m -class TreeRO m => TreeRW m where-    -- | Change content of a file at a given path. The change will be-    -- eventually flushed to disk, but might be buffered for some time.-    writeFile :: AnchoredPath -> BL.ByteString -> m ()-    createDirectory :: AnchoredPath -> m ()-    unlink :: AnchoredPath -> m ()-    rename :: AnchoredPath -> AnchoredPath -> m ()-    copy   :: AnchoredPath -> AnchoredPath -> m ()+-- | 'TreeMonad' specialized to 'IO'+type TreeIO = TreeMonad IO -initialState :: Tree m-             -> (TreeItem m -> m Hash)-             -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))-             -> TreeState m-initialState t uh u = TreeState { tree = t-                                , changed = M.empty-                                , changesize = 0-                                , updateHash = uh-                                , maxage = 0-                                , update = u }+initialEnv :: (TreeItem m -> m Hash)+           -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))+           -> TreeEnv m+initialEnv uh u = TreeEnv {updateHash = uh, update = u} -flush :: (Monad m) => TreeMonad m ()+initialState :: Tree m -> TreeState m+initialState t =+  TreeState {tree = t, changed = M.empty, changesize = 0, maxage = 0}++flush :: Monad m => TreeMonad m () flush = do changed' <- map fst . M.toList <$> gets changed            dirs' <- gets tree >>= \t -> return [ path | (path, SubTree _) <- list t ]            modify $ \st -> st { changed = M.empty, changesize = 0 }            forM_ (changed' ++ dirs' ++ [AnchoredPath []]) flushItem -runTreeMonad' :: (Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m)-runTreeMonad' action initial = do-  (out, final, _) <- runRWST action (AnchoredPath []) initial+runTreeMonad' :: Monad m => TreeMonad m a -> TreeEnv m -> TreeState m -> m (a, Tree m)+runTreeMonad' action initEnv initState = do+  (out, final, _) <- runRWST action initEnv initState   return (out, tree final) -runTreeMonad :: (Monad m) => TreeMonad m a -> TreeState m -> m (a, Tree m)-runTreeMonad action initial = do+runTreeMonad :: Monad m+             => TreeMonad m a+             -> Tree m+             -> (TreeItem m -> m Hash)+             -> (AnchoredPath -> TreeItem m -> TreeMonad m (TreeItem m))+             -> m (a, Tree m)+runTreeMonad action t uh u = do   let action' = do x <- action                    flush                    return x-  runTreeMonad' action' initial+  runTreeMonad' action' (initialEnv uh u) (initialState t) --- | Run a TreeIO action without storing any changes. This is useful for--- running monadic tree mutations for obtaining the resulting Tree (as opposed+-- | Run a 'TreeMonad' action without storing any changes. This is useful for+-- running monadic tree mutations for obtaining the resulting 'Tree' (as opposed -- to their effect of writing a modified tree to disk). The actions can do both -- read and write -- reads are passed through to the actual filesystem, but the--- writes are held in memory in a form of modified Tree.-virtualTreeMonad :: (Monad m) => TreeMonad m a -> Tree m -> m (a, Tree m)+-- writes are held in memory in the form of a modified 'Tree'.+virtualTreeMonad :: Monad m => TreeMonad m a -> Tree m -> m (a, Tree m) virtualTreeMonad action t =-  runTreeMonad' action $ initialState t (\_ -> return NoHash) (\_ x -> return x)+  runTreeMonad action t (\_ -> return NoHash) (\_ x -> return x) +-- | 'virtualTreeMonad' specialized to 'IO' virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO) virtualTreeIO = virtualTreeMonad  -- | Modifies an item in the current Tree. This action keeps an account of the -- modified data, in changed and changesize, for subsequent flush -- operations. Any modifications (as in "modifyTree") are allowed.-modifyItem :: (Monad m)+modifyItem :: Monad m             => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m () modifyItem path item = do-  path' <- (`catPaths` path) `fmap` currentDirectory   age <- gets maxage   changed' <- gets changed-  let getsize (Just (File b)) = lift (BL.length `fmap` readBlob b)+  let getsize (Just (File b)) = lift (BL.length <$> readBlob b)       getsize _ = return 0   size <- getsize item-  let change = case M.lookup path' changed' of+  let change = case M.lookup path changed' of         Nothing -> size         Just (oldsize, _) -> size - oldsize -  modify $ \st -> st { tree = modifyTree (tree st) path' item-                     , changed = M.insert path' (size, age) (changed st)+  modify $ \st -> st { tree = modifyTree (tree st) path item+                     , changed = M.insert path (size, age) (changed st)                      , maxage = age + 1                      , changesize = changesize st + change } -renameChanged :: (Monad m)+renameChanged :: Monad m               => AnchoredPath -> AnchoredPath -> TreeMonad m () renameChanged from to = modify $ \st -> st {changed = rename' $ changed st}   where@@ -156,38 +153,37 @@ -- 'sync' implementation for a particular storage format. The presumed use-case -- is that an existing in-memory Blob is replaced with a one referring to an -- on-disk file.-replaceItem :: (Monad m)+replaceItem :: Monad m             => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m () replaceItem path item = do-  path' <- (`catPaths` path) `fmap` currentDirectory-  modify $ \st -> st { tree = modifyTree (tree st) path' item }+  modify $ \st -> st { tree = modifyTree (tree st) path item } -flushItem :: forall m. (Monad m) => AnchoredPath -> TreeMonad m ()+flushItem :: forall m. Monad m => AnchoredPath -> TreeMonad m () flushItem path =   do current <- gets tree      case find current path of        Nothing -> return () -- vanished, do nothing        Just x -> do y <- fixHash x-                    new <- gets update >>= ($ y) . ($ path)+                    new <- asks update >>= ($ y) . ($ path)                     replaceItem path (Just new)     where fixHash :: TreeItem m -> TreeMonad m (TreeItem m)           fixHash f@(File (Blob con NoHash)) = do-            hash <- gets updateHash >>= \x -> lift $ x f+            hash <- asks updateHash >>= \x -> lift $ x f             return $ File $ Blob con hash           fixHash (SubTree s) | treeHash s == NoHash =-            gets updateHash >>= \f -> SubTree <$> lift (addMissingHashes f s)+            asks updateHash >>= \f -> SubTree <$> lift (addMissingHashes f s)           fixHash x = return x   -- | If buffers are becoming large, sync, otherwise do nothing.-flushSome :: (Monad m) => TreeMonad m ()+flushSome :: Monad m => TreeMonad m () flushSome = do x <- gets changesize                when (x > megs 100) $ do                  remaining <- go =<< sortBy age . M.toList <$> gets changed                  modify $ \s -> s { changed = M.fromList remaining }   where go [] = return []         go ((path, (size, _)):chs) = do-          x <- (\s -> s - size) <$> gets changesize+          x <- subtract size <$> gets changesize           flushItem path           modify $ \s -> s { changesize = x }           if  x > megs 50  then go chs@@ -195,90 +191,105 @@         megs = (* (1024 * 1024))         age (_, (_, a)) (_, (_, b)) = compare a b -instance (Monad m) => TreeRO (TreeMonad m) where-    expandTo p =-        do t <- gets tree-           p' <- (`catPaths` p) `fmap` ask-           t' <- lift $ expandPath t p'-           modify $ \st -> st { tree = t' }-           return p'+-- read only actions -    fileExists p =-        do p' <- expandTo p-           (isJust . (`findFile` p')) `fmap` gets tree+expandTo :: Monad m => AnchoredPath -> TreeMonad m ()+expandTo p =+    do t <- gets tree+       t' <- lift $ expandPath t p+       modify $ \st -> st { tree = t' } -    directoryExists p =-        do p' <- expandTo p-           (isJust . (`findTree` p')) `fmap` gets tree+-- | Check for existence of a file.+fileExists :: Monad m => AnchoredPath -> TreeMonad m Bool+fileExists p =+    do expandTo p+       (isJust . (`findFile` p)) <$> gets tree -    exists p =-        do p' <- expandTo p-           (isJust . (`find` p')) `fmap` gets tree+-- | Check for existence of a directory.+directoryExists :: Monad m => AnchoredPath -> TreeMonad m Bool+directoryExists p =+    do expandTo p+       (isJust . (`findTree` p)) <$> gets tree -    readFile p =-        do p' <- expandTo p-           t <- gets tree-           let f = findFile t p'-           case f of-             Nothing -> throw $ userError $ "No such file " ++ show p'-             Just x -> lift (readBlob x)+-- | Check for existence of a node (file or directory, doesn't matter).+exists :: Monad m => AnchoredPath -> TreeMonad m Bool+exists p =+    do expandTo p+       isJust . (`find` p) <$> gets tree -    currentDirectory = ask-    withDirectory dir act = do-      dir' <- expandTo dir-      local (const dir') act+-- | Grab content of a file in the current Tree at the given path.+readFile :: Monad m => AnchoredPath -> TreeMonad m BL.ByteString+readFile p =+    do expandTo p+       t <- gets tree+       let f = findFile t p+       case f of+         Nothing -> throw $ userError $ "No such file " ++ displayPath p+         Just x -> lift (readBlob x) -instance (Monad m) => TreeRW (TreeMonad m) where-    writeFile p con =-        do _ <- expandTo p-           modifyItem p (Just blob)-           flushSome-        where blob = File $ Blob (return con) hash-              hash = NoHash -- we would like to say "sha256 con" here, but due-                            -- to strictness of Hash in Blob, this would often-                            -- lead to unnecessary computation which would then-                            -- be discarded anyway; we rely on the sync-                            -- implementation to fix up any NoHash occurrences+-- | Change content of a file at a given path. The change will be+-- eventually flushed to disk, but might be buffered for some time.+writeFile :: Monad m => AnchoredPath -> BL.ByteString -> TreeMonad m ()+writeFile p con =+    do expandTo p+       modifyItem p (Just blob)+       flushSome+    where blob = File $ Blob (return con) hash+          hash = NoHash -- we would like to say "sha256 con" here, but due+                        -- to strictness of Hash in Blob, this would often+                        -- lead to unnecessary computation which would then+                        -- be discarded anyway; we rely on the sync+                        -- implementation to fix up any NoHash occurrences -    createDirectory p =-        do _ <- expandTo p-           modifyItem p $ Just $ SubTree emptyTree+-- | Create a directory.+createDirectory :: Monad m => AnchoredPath -> TreeMonad m ()+createDirectory p =+    do expandTo p+       modifyItem p $ Just $ SubTree emptyTree -    unlink p =-        do _ <- expandTo p-           modifyItem p Nothing+-- | Remove the item at a path.+unlink :: Monad m => AnchoredPath -> TreeMonad m ()+unlink p =+    do expandTo p+       modifyItem p Nothing -    rename from to =-        do from' <- expandTo from-           to' <- expandTo to-           tr <- gets tree-           let item = find tr from'-               found_to = find tr to'-           unless (isNothing found_to) $-                  throw $ userError $ "Error renaming: destination " ++ show to ++ " exists."-           unless (isNothing item) $ do-                  modifyItem from Nothing-                  modifyItem to item-                  renameChanged from to+-- | Rename the item at a path.+rename :: Monad m => AnchoredPath -> AnchoredPath -> TreeMonad m ()+rename from to =+    do expandTo from+       expandTo to+       tr <- gets tree+       let item = find tr from+           found_to = find tr to+       unless (isNothing found_to) $+              throw $ userError $ "Error renaming: destination " ++ displayPath to ++ " exists."+       if isJust item then do+              modifyItem from Nothing+              modifyItem to item+              renameChanged from to+       else+        throw $ userError $ "Error renaming: source " ++ displayPath from ++ " does not exist." -    copy from to =-        do from' <- expandTo from-           _ <- expandTo to-           tr <- gets tree-           let item = find tr from'-           unless (isNothing item) $ modifyItem to item+-- | Copy an item from some path to another path.+copy :: Monad m => AnchoredPath -> AnchoredPath -> TreeMonad m ()+copy from to =+    do expandTo from+       expandTo to+       tr <- gets tree+       let item = find tr from+       unless (isNothing item) $ modifyItem to item -findM' :: forall m a . (Monad m)+findM' :: forall m a . Monad m        => (Tree m -> AnchoredPath -> a) -> Tree m -> AnchoredPath -> m a findM' what t path = fst <$> virtualTreeMonad (look path) t   where look :: AnchoredPath -> TreeMonad m a-        look = expandTo >=> \p' -> flip what p' <$> gets tree+        look p = expandTo p >> flip what p <$> gets tree -findM :: (Monad m) => Tree m -> AnchoredPath -> m (Maybe (TreeItem m))+findM :: Monad m => Tree m -> AnchoredPath -> m (Maybe (TreeItem m)) findM = findM' find -findTreeM :: (Monad m) => Tree m -> AnchoredPath -> m (Maybe (Tree m))+findTreeM :: Monad m => Tree m -> AnchoredPath -> m (Maybe (Tree m)) findTreeM = findM' findTree -findFileM :: (Monad m) => Tree m -> AnchoredPath -> m (Maybe (Blob m))+findFileM :: Monad m => Tree m -> AnchoredPath -> m (Maybe (Blob m)) findFileM = findM' findFile

@@ -0,0 +1,117 @@+#!/usr/bin/env bash+# This tests that even if broken move patches (caused by issue2674)+# are present in a repo, we can safely eliminate them because no further+# patches can depend on the target of the move. In fact, applying such a+# bad move is a no-op.++. lib++# We could create three different archives for darcs-1, darcs-2, and darcs-3+# but since this problem concerns only the Prim.V1 layer this seems excessive.+only-format darcs-2++# Script to create the test repo. It is no longer used now that issue2674 has+# been fixed and we use the tar ball. Its only remaining purpose is to+# document what patches the broken_move repository consists of.+cat >create_broken_moves.sh <<EOF+  #!/usr/bin/env bash+  . lib++  rm -rf broken_move+  darcs init broken_move+  cd broken_move++  mkdir d1+  darcs record -l d1 -am 'add d1'++  touch f1 f2+  echo text > f1+  darcs move f1 f2 d1+  darcs record -am 'bad first move'++  # this commutes with the two bad moves+  darcs move d1 d2+  darcs record -am 'move d1 to d2'++  darcs move d2/f1 d2/f2 .+  darcs record -am 'bad second move'++  mkdir d3 d4+  darcs move d3 d4 d2+  darcs record -am 'bad third move'++  cd ..++  tar zcf broken_move.tgz broken_move+EOF++chmod +x create_broken_moves.sh++# if create_broken_moves.sh fails, then issue2674 has been fixed,+# so instead we unpack the repo from an archive instead+if ! ./create_broken_moves.sh; then+  unpack_testdata broken_move+fi++cd broken_move++# test that commutes either work or we can repair+echo y | darcs amend -a -p 'move d1 to d2' -m 'edited move d1 to d2'+if ! (echo y | darcs amend -a -p 'bad second move' -m 'edited bad second move' 2> LOG); then+  grep -i "Error renaming" LOG+  # but then we should be able to repair it+  not darcs check | grep 'Dropping move patch with non-existing source'+  rm -rf ../repaired+  darcs clone . ../repaired+  darcs repair --repodir=../repaired+fi+darcs obliterate -a -p 'move d1 to d2'+if ! (darcs obliterate -a -p 'bad second move' 2>LOG); then+  grep -i "Error renaming" LOG+  # but then we should be able to repair it+  not darcs check | grep 'Dropping move patch with non-existing source'+  rm -rf ../repaired+  darcs clone . ../repaired+  darcs repair --repodir=../repaired+fi+# test that unapplying patches either works or we can repair the repo+rm -rf ../S+if ! (darcs clone . ../S --to-patch 'add d1' 2>LOG); then+  grep -i "Error renaming" LOG+  # but then we should be able to repair it+  not darcs check | grep 'Dropping move patch with non-existing source'+  rm -rf ../repaired+  darcs clone . ../repaired+  darcs repair --repodir=../repaired+fi++# test that we cannot record a change that depends on the target path+# nor the source path (because both are unadded)+echo text > f1+not darcs record f1 -am impossible+echo text > d1/f1+not darcs record d1/f1 -am impossible++# same with a bad move of a directory+touch d1/d3/f+# this will ask us to add d1/d3, too, so we have to say no first+echo ny | darcs record -l d1/d3/f -m impossible >LOG+grep "you don't want to record anything" LOG++cd ..++# make a clone to get a fresh working tree equal to the pristine tree+rm -rf R+darcs clone broken_move R+cd R++# check that only d1 exists in pristine, i.e. the bad moves are ignored+cat <<EOF > log.expected+.+./d1+EOF+# the tr hack is to make the test work on Windows+darcs show files | tr -d $'\r' > log+diff log.expected log >&2++cd ..

binary file changed (absent → 6840 bytes)

binary file changed (absent → 5822 bytes)

binary file changed (absent → 5666 bytes)

binary file changed (absent → 6179 bytes)

@@ -0,0 +1,20 @@+. lib++rm -rf R+darcs init R+cd R+echo added >added.txt+echo unadded >unadded.txt+mkdir newdir+darcs add added.txt newdir/+not darcs mv added.txt unadded.txt newdir/ > LOG+not grep unadded LOG+# i.e. not this:+#Finished moving: ./added.txt ./unadded.txt to: ./newdir+darcs whatsnew -s > LOG+not grep unadded LOG+# i.e. not this:+# A ./newdir/+#  ./unadded.txt -> ./newdir/unadded.txt+# A ./newdir/added.txt+cd ..

@@ -0,0 +1,54 @@+#!/usr/bin/env bash++## Test that we can upgrade rebase format 0.0 repos++. lib++rm -rf R log+unpack_testdata rebase-0.0++cd R+darcs rebase log 2>../log+grep 'Rebase in progress: 1 suspended patch' ../log++darcs rebase unsuspend -a++cat > file.expected << END+v v v v v v v+change 1+=============+change 2+*************+initial content+^ ^ ^ ^ ^ ^ ^+END++diff -u file.expected file++cd ..++# In format 0.0 it is legal to store a suspended patch containing a conflict,+# whereas the plan for future formats is to unwind the conflict.+# So make sure that old repos can be updated successfully.++rm -rf R log+unpack_testdata rebase-0.0-conflict++cd R+darcs rebase log 2>../log+grep 'Rebase in progress: 1 suspended patch' ../log++darcs rebase unsuspend -a+cat > file.expected << END+v v v v v v v+initial content+=============+content A+*************+content B+^ ^ ^ ^ ^ ^ ^+END++diff -u file.expected file++cd ..

@@ -0,0 +1,28 @@+#!/usr/bin/env bash++## Test that we can upgrade rebase format 0.2 repos++. lib++rm -rf R log+unpack_testdata rebase-0.2++cd R+darcs rebase log 2>../log+grep 'Rebase in progress: 1 suspended patch' ../log++darcs rebase unsuspend -a++cat > file.expected << END+v v v v v v v+change 1+=============+change 2+*************+initial content+^ ^ ^ ^ ^ ^ ^+END++diff -u file.expected file++cd ..

@@ -36,7 +36,7 @@ grep foo dirs cd .. -darcs pull -a --repodir=temp2 > pullresult+darcs pull -a --repodir=temp2 2> pullresult cat pullresult grep 'Warning: .ot deleting' pullresult 

@@ -12,7 +12,8 @@     exit 0 fi -ghc -o trackdown-bisect-helper $TESTBIN/trackdown-bisect-helper.hs+cp $TESTBIN/trackdown-bisect-helper.hs .+ghc -o trackdown-bisect-helper trackdown-bisect-helper.hs  function make_repo_with_test {     rm -fr temp1