File: Move.hs

package info (click to toggle)
darcs 2.12.4-2
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 5,748 kB
  • sloc: haskell: 42,936; sh: 11,086; ansic: 837; perl: 129; makefile: 8
file content (376 lines) | stat: -rw-r--r-- 15,814 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
{-# LANGUAGE RankNTypes #-}
--  Copyright (C) 2002-2003 David Roundy
--
--  This program is free software; you can redistribute it and/or modify
--  it under the terms of the GNU General Public License as published by
--  the Free Software Foundation; either version 2, or (at your option)
--  any later version.
--
--  This program is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
--  GNU General Public License for more details.
--
--  You should have received a copy of the GNU General Public License
--  along with this program; see the file COPYING.  If not, write to
--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
--  Boston, MA 02110-1301, USA.

{-# LANGUAGE CPP #-}

module Darcs.UI.Commands.Move ( move, mv ) where

import Prelude ()
import Darcs.Prelude

import Control.Monad ( when, unless, forM_, forM )
import Data.Maybe ( fromMaybe )
import Darcs.Util.SignalHandler ( withSignalsBlocked )

import Darcs.UI.Commands
    ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, amInHashedRepository )
import Darcs.UI.Flags ( DarcsFlag(Quiet)
    , doAllowCaseOnly, doAllowWindowsReserved, useCache, dryRun, umask
    , maybeFixSubPaths, fixSubPaths )
import Darcs.UI.Options ( DarcsOption, (^), odesc, ocheck, onormalise, defaultFlags )
import qualified Darcs.UI.Options.All as O
import Darcs.Repository.Diff ( treeDiff )
import Darcs.Repository.Flags ( UpdateWorking (..), DiffAlgorithm(..) )
import Darcs.Repository.Prefs ( filetypeFunction )
import System.FilePath.Posix ( (</>), takeFileName )
import System.Directory ( renameDirectory )
import Darcs.Repository.State ( readRecordedAndPending, readRecorded, updateIndex )
import Darcs.Repository
    ( Repository
    , withRepoLock
    , RepoJob(..)
    , addPendingDiffToPending
    , listFiles
    )
import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) )
import Darcs.Patch.Witnesses.Sealed ( emptyGap, freeGap, joinGap, FreeLeft )
import Darcs.Util.Global ( debugMessage )
import qualified Darcs.Patch
import Darcs.Patch ( RepoPatch, PrimPatch, PrimOf )
import Darcs.Patch.Apply( ApplyState )
import Data.List ( nub, sort )
import qualified System.FilePath.Windows as WindowsFilePath

import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase, treeHasFile )
import Darcs.Util.Tree( Tree, modifyTree )
import Darcs.Util.Tree.Plain( readPlainTree )
import Darcs.Util.Path
    ( floatPath
    , fp2fn
    , fn2fp
    , superName
    , SubPath()
    , toFilePath
    , AbsolutePath
    )
import Darcs.Util.Workaround ( renameFile )

moveDescription :: String
moveDescription = "Move or rename files."

moveHelp :: String
moveHelp =
 "Darcs cannot reliably distinguish between a file being deleted and a\n" ++
 "new one added, and a file being moved.  Therefore Darcs always assumes\n" ++
 "the former, and provides the `darcs mv` command to let Darcs know when\n" ++
 "you want the latter.  This command will also move the file in the\n" ++
 "working tree (unlike `darcs remove`), unless it has already been moved.\n" ++
 "\n" ++
 -- Note that this paragraph is very similar to one in ./Add.lhs.
 "Darcs will not rename a file if another file in the same folder has\n" ++
 "the same name, except for case.  The `--case-ok` option overrides this\n" ++
 "behaviour.  Windows and OS X usually use filesystems that do not allow\n" ++
 "files a folder to have the same name except for case (for example,\n" ++
 "`ReadMe` and `README`).  If `--case-ok` is used, the repository might be\n" ++
 "unusable on those systems!\n"

moveBasicOpts :: DarcsOption a (Bool -> Bool -> Maybe String -> a)
moveBasicOpts = O.allowProblematicFilenames ^ O.workingRepoDir

moveAdvancedOpts :: DarcsOption a (O.UMask -> a)
moveAdvancedOpts = O.umask

moveOpts :: DarcsOption a
            (Bool
             -> Bool
             -> Maybe String
             -> Maybe O.StdCmdAction
             -> Bool
             -> Bool
             -> O.Verbosity
             -> Bool
             -> O.UMask
             -> O.UseCache
             -> Maybe String
             -> Bool
             -> Maybe String
             -> Bool
             -> a)
moveOpts = moveBasicOpts `withStdOpts` moveAdvancedOpts

move :: DarcsCommand [DarcsFlag]
move = DarcsCommand
    { commandProgramName = "darcs"
    , commandName = "move"
    , commandHelp = moveHelp
    , commandDescription = moveDescription
    , commandExtraArgs = -1
    , commandExtraArgHelp = ["<SOURCE> ... <DESTINATION>"]
    , commandCommand = moveCmd
    , commandPrereq = amInHashedRepository
    , commandGetArgPossibilities = listFiles False
    , commandArgdefaults = nodefaults
    , commandAdvancedOptions = odesc moveAdvancedOpts
    , commandBasicOptions = odesc moveBasicOpts
    , commandDefaults = defaultFlags moveOpts
    , commandCheckOptions = ocheck moveOpts
    , commandParseOptions = onormalise moveOpts
    }

moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
moveCmd fps opts args
  | length args < 2 =
      fail "The `darcs move' command requires at least two arguments."
  | length args == 2 = do
      -- NOTE: The extra case for two arguments is necessary because
      -- in this case we allow file -> file moves. Whereas with 3 or
      -- more arguments the last one (i.e. the target) must be a directory.
      xs <- maybeFixSubPaths fps args
      case xs of
        [Just from, Just to]
          | from == to -> fail "Cannot rename a file or directory onto itself."
          | toFilePath from == "" -> fail "Cannot move the root of the repository."
          | otherwise -> moveFile opts from to
        _ -> fail "Both source and destination must be valid."
  | otherwise = let (froms, to) = (init args, last args) in do
      x <- head <$> maybeFixSubPaths fps [to]
      case x of
        Nothing -> fail "Invalid destination directory."
        Just to' -> do
          xs <- nub . sort <$> fixSubPaths fps froms
          if to' `elem` xs
            then fail "Cannot rename a file or directory onto itself."
            else case xs of
              [] -> fail "Nothing to move."
              froms' ->
                if or (map (null . toFilePath) froms') then
                  fail "Cannot move the root of the repository."
                else
                  moveFilesToDir opts froms' to'

data FileKind = Dir | File
              deriving (Show, Eq)

data FileStatus =
  Nonexistant
  | Unadded FileKind
  | Shadow FileKind -- ^ known to darcs, but absent in working copy
  | Known FileKind
  deriving Show

fileStatus :: Tree IO -- ^ tree of the working directory
           -> Tree IO -- ^ tree of recorded and pending changes
           -> Tree IO -- ^ tree of recorded changes
           -> FilePath
           -> IO FileStatus
fileStatus work cur recorded fp = do
  existsInCur <- treeHas cur fp
  existsInRec <- treeHas recorded fp
  existsInWork <- treeHas work fp
  case (existsInRec, existsInCur, existsInWork) of
    (_, True, True) -> do
      isDirCur <- treeHasDir cur fp
      isDirWork <- treeHasDir work fp
      unless (isDirCur == isDirWork) . fail $ "don't know what to do with " ++ fp
      return . Known $ if isDirCur then Dir else File

    (_, False, True) -> do
      isDir <- treeHasDir work fp
      if isDir
        then return $ Unadded Dir
        else return $ Unadded File
    (False, False, False) -> return Nonexistant
    (_, _, False) -> do
      isDir <- treeHasDir cur fp
      if isDir
        then return $ Shadow Dir
        else return $ Shadow File

-- | Takes two filenames (as 'Subpath'), and tries to move the first
-- into/onto the second. Needs to guess what that means: renaming or moving
-- into a directory, and whether it is a post-hoc move.
moveFile :: [DarcsFlag] -> SubPath -> SubPath -> IO ()
moveFile opts old new = withRepoAndState opts $ \(repo, work, cur, recorded) -> do
  let old_fp = toFilePath old
      new_fp = toFilePath new
  new_fs <- fileStatus work cur recorded new_fp
  old_fs <- fileStatus work cur recorded old_fp
  let doSimpleMove = simpleMove repo opts cur work old_fp new_fp
  case (old_fs, new_fs) of
    (Nonexistant, _) -> fail $ old_fp ++ " does not exist."
    (Unadded k, _) -> fail $ show k ++ " " ++ old_fp ++ " is unadded."
    (Known _, Nonexistant) -> doSimpleMove
    (Known _, Shadow _) -> doSimpleMove
    (_, Nonexistant) -> fail $ old_fp ++ " is not in the repository."
    (Known _, Known Dir) -> moveToDir repo opts cur work [old_fp] new_fp
    (Known _, Unadded Dir) -> fail $
        new_fp ++ " is not known to darcs; please add it to the repository."
    (Known _, _) -> fail $ new_fp ++ " already exists."
    (Shadow k, Unadded k') | k == k' -> doSimpleMove
    (Shadow File, Known Dir) -> moveToDir repo opts cur work [old_fp] new_fp
    (Shadow Dir, Known Dir) -> doSimpleMove
    (Shadow File, Known File) -> doSimpleMove
    (Shadow k, _) -> fail $
        "cannot move " ++ show k ++ " " ++ old_fp ++ " into " ++ new_fp
        ++ " : " ++ "did you already move it elsewhere?"

moveFilesToDir :: [DarcsFlag] -> [SubPath] -> SubPath -> IO ()
moveFilesToDir opts froms to = withRepoAndState opts $ \(repo, work, cur, _) ->
  moveToDir repo opts cur work (map toFilePath froms) $ toFilePath to

withRepoAndState :: [DarcsFlag]
                 -> (forall rt p wR wU .
                        (ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree, RepoPatch p) =>
                            (Repository rt p wR wU wR, Tree IO, Tree IO, Tree IO)
                                -> IO ())
                 -> IO ()
withRepoAndState opts f =
    withRepoLock dr uc YesUpdateWorking um $ RepoJob $ \repo -> do
        work <- readPlainTree "."
        cur <- readRecordedAndPending repo
        recorded <- readRecorded repo
        f (repo, work, cur, recorded)
  where
    dr = dryRun opts
    uc = useCache opts
    um = umask opts

simpleMove :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
           => Repository rt p wR wU wT
           -> [DarcsFlag] -> Tree IO -> Tree IO -> FilePath -> FilePath
           -> IO ()
simpleMove repository opts cur work old_fp new_fp = do
    doMoves repository opts cur work [(old_fp, new_fp)]
    unless (Quiet `elem` opts) $
        putStrLn $ unwords ["Moved:", old_fp, "to:", new_fp]

moveToDir :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
          => Repository rt p wR wU wT
          -> [DarcsFlag] -> Tree IO -> Tree IO -> [FilePath] -> FilePath
          -> IO ()
moveToDir repository opts cur work moved finaldir = do
    let movetargets = map ((finaldir </>) . takeFileName) moved
        moves = zip moved movetargets
    doMoves repository opts cur work moves
    unless (Quiet `elem` opts) $
      putStrLn $ unwords $ ["Moved:"] ++ moved ++ ["to:", finaldir]

doMoves :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)
          => Repository rt p wR wU wT
          -> [DarcsFlag] -> Tree IO -> Tree IO
          -> [(FilePath, FilePath)] -> IO ()
doMoves repository opts cur work moves = do
  patches <- forM moves $ \(old, new) -> do
        prePatch <- generatePreMovePatches opts cur work (old,new)
        return (prePatch, old, new)
  withSignalsBlocked $ do
    forM_ patches $ \(prePatch, old, new) -> do
      let -- Add any pre patches before the move patch
          pendingDiff = joinGap (+>+)
            (fromMaybe (emptyGap NilFL) prePatch)
            (freeGap $ Darcs.Patch.move old new :>: NilFL)
      addPendingDiffToPending repository YesUpdateWorking pendingDiff
      moveFileOrDir work old new
    updateIndex repository

-- Take the recorded/ working trees and the old and intended new filenames;
-- check if the new path is safe on windows. We potentially need to create
-- extra patches that are required to keep the repository consistent, in order
-- to allow the move patch to be applied.
generatePreMovePatches :: PrimPatch prim => [DarcsFlag] -> Tree IO -> Tree IO
                       -> (FilePath, FilePath)
                       -> IO (Maybe (FreeLeft (FL prim)))
generatePreMovePatches opts cur work (old,new) = do
    -- Only allow Windows-invalid paths if we've been told to do so
    unless newIsOkWindowsPath $ fail newNotOkWindowsPathMsg
    -- Check if the first directory above the new path is in the repo (this
    -- is the new path if itself is a directory), handling the case where
    -- a user moves a file into a directory not known by darcs.
    let dirPath = fn2fp $ superName $ fp2fn new
    haveNewParent <- treeHasDir cur dirPath
    unless haveNewParent $
        fail $ "The target directory " ++ dirPath
                ++ " isn't known in the repository, did you forget to add it?"
    newInRecorded <- hasNew cur
    newInWorking <- hasNew work
    oldInWorking <- treeHas work old
    if oldInWorking -- We need to move the object
        then do
            -- We can't move if the target already exists in working
            when newInWorking $ fail $ alreadyExists "working directory"
            if newInRecorded
                then Just <$> deleteNewFromRepoPatches
                else return Nothing
        else do
          unless (Quiet `elem` opts) $
              putStrLn "Detected post-hoc move."
          -- Post-hoc move - user has moved/deleted the file in working, so
          -- we can hopefully make a move patch to make the repository
          -- consistent.
          -- If we don't have the old or new in working, we're stuck
          unless newInWorking $
              fail $ "Cannot determine post-hoc move target, "
                     ++ "no file/dir named:\n" ++ new
          Just <$> if newInRecorded
                       then deleteNewFromRepoPatches
                       else return $ emptyGap NilFL
  where
    newIsOkWindowsPath =
        doAllowWindowsReserved opts || WindowsFilePath.isValid new

    newNotOkWindowsPathMsg =
        "The filename " ++ new ++ " is not valid under Windows.\n"
        ++ "Use --reserved-ok to allow such filenames."

    -- If we're moving to a file/dir that was recorded, but has been deleted,
    -- we need to add patches to pending that remove the original.
    deleteNewFromRepoPatches = do
        unless (Quiet `elem` opts) $
            putStrLn $ "Existing recorded contents of " ++ new
                       ++ " will be overwritten."
        ftf <- filetypeFunction
        let curNoNew = modifyTree cur (floatPath new) Nothing
        -- Return patches to remove new, so that the move patch
        -- can move onto new
        treeDiff MyersDiff ftf cur curNoNew

    -- Check if the passed tree has the new filepath. The old path is removed
    -- from the tree before checking if the new path is present.
    hasNew s = treeHas_case (modifyTree s (floatPath old) Nothing) new
    treeHas_case = if doAllowCaseOnly opts then treeHas else treeHasAnycase

    alreadyExists inWhat =
        if doAllowCaseOnly opts
            then "A file or dir named "++new++" already exists in "
                  ++ inWhat ++ "."
            else "A file or dir named "++new++" (or perhaps differing "
                 ++ "only in case)\nalready exists in "++ inWhat ++ ".\n"
                 ++ "Use --case-ok to allow files differing only in case."

moveFileOrDir :: Tree IO -> FilePath -> FilePath -> IO ()
moveFileOrDir work old new = do
  has_file <- treeHasFile work old
  has_dir <- treeHasDir work old
  when has_file $ do debugMessage $ unwords ["renameFile",old,new]
                     renameFile old new
  when has_dir $ do debugMessage $ unwords ["renameDirectory",old,new]
                    renameDirectory old new

mv :: DarcsCommand [DarcsFlag]
mv = commandAlias "mv" Nothing move