Implement a variant of clonePaths that handles non-existing files
[darcs-mirror-ipatch.git] / Common.hs
1 {-# LANGUAGE Rank2Types #-}
2 module Common where
3
4 import Control.Applicative ( (<$>) )
5 import Control.Monad (when)
6 import System.Posix.Files ( getSymbolicLinkStatus, isRegularFile, isDirectory )
7 import System.Directory ( createDirectoryIfMissing, doesFileExist, removeFile )
8 import System.FilePath.Posix ( (</>), takeDirectory, normalise )
9
10 import Darcs.Arguments ( DarcsFlag(LookForAdds) )
11 import Darcs.Repository
12     ( createRepository,
13       applyToWorking,
14       finalizeRepositoryChanges,
15       tentativelyAddPatch,
16       withGutsOf,
17       withRepoLock,
18       invalidateIndex,
19       unrecordedChanges )
20 import Darcs.Flags ( Compression(..) )
21 import Darcs.RepoPath ( AbsolutePath, FilePathLike(..) )
22 import Darcs.External ( cloneFile )
23 import Darcs.Lock ( withTempDir )
24 import Darcs.Patch ( invert, fromPrims, namepatch )
25 import Darcs.Global ( debugMessage )
26 import Darcs.Hopefully ( n2pia )
27 import Darcs.Utils ( clarifyErrors )
28
29 import DiffFile ( applyDiff )
30
31 clonePathWithDeletion :: FilePath -> FilePath -> FilePath -> IO ()
32 clonePathWithDeletion source dest path = do
33     let source' = source </> path
34         dest' = dest </> path
35     ex <- doesFileExist source'
36     if ex
37      then do
38         fs <- getSymbolicLinkStatus source'
39         if isDirectory fs
40          then do
41             createDirectoryIfMissing True dest'
42          else
43             if isRegularFile fs
44              then do
45                 createDirectoryIfMissing True (dest </> takeDirectory path)
46                 cloneFile source' dest'
47              else
48                 fail ("clonePathWithDeletion: Bad file " ++ source')
49      else do
50         exT <- doesFileExist dest'
51         when exT $ removeFile dest'
52    `catch` fail ("clonePathWithDeletion: Bad file " ++ source </> path)
53
54 clonePathsWithDeletion source dest = mapM_ (clonePathWithDeletion source dest)
55
56
57 withTempRepository :: String -> (AbsolutePath -> IO a) -> IO a
58 withTempRepository name job =
59     withTempDir ("ipatch-repo-" ++ name) $ \rdir -> do
60         debugMessage $ "Creating temporary repository in directory " ++ show rdir
61         createRepository []
62         job rdir
63
64 initializeBaseState rdir sdir files = do
65     debugMessage $ "Copying " ++ show (length files) ++ " files to temporary repository."  
66     clonePathsWithDeletion sdir (toFilePath rdir) files
67     -- Create a patch from the newly added files
68     debugMessage $ "Creating initial check  in patch"
69     withRepoLock [LookForAdds] $ \repo -> do
70         init_ps <- unrecordedChanges [LookForAdds] repo [] -- Correct flags?
71         init_patch <- n2pia <$> namepatch "NODATE" "Initial state" "NOAUTHOR" [] (fromPrims init_ps)
72         tentativelyAddPatch repo [] init_patch
73         invalidateIndex repo
74         withGutsOf repo (finalizeRepositoryChanges repo)
75             `clarifyErrors` "Failed to apply inital patch"
76         return init_ps
77
78
79 diffToPrims diff = do
80     debugMessage $ "Applying the user provided diff"
81     -- Now apply the patch
82     applyDiff diff
83
84     debugMessage $ "Creating a patch from the user changes"
85     withRepoLock [LookForAdds] $ \repo -> do
86         -- Create another patch from the changed files
87         patch_ps <- unrecordedChanges [LookForAdds] repo []
88         -- patch_patch <- n2pia <$> namepatch date "Patch effect" author [] (fromPrims patch_ps)
89         -- tentativelyAddPatch repo [] patch_patch
90         -- Now we obliterate the patch, undoing its effects
91         applyToWorking repo [] (invert patch_ps) `catch` \e ->
92             fail ("Couldn't undo diff effect in working dir.\n" ++ show e)
93         return patch_ps
94       
95 stdindefault :: a -> [String] -> IO [String]
96 stdindefault _ [] = return ["-"]
97 stdindefault _ x = return x