1 % Copyright (C) 2002-2004 David Roundy 2 % 3 % This program is free software; you can redistribute it and/or modify 4 % it under the terms of the GNU General Public License as published by 5 % the Free Software Foundation; either version 2, or (at your option) 6 % any later version. 7 % 8 % This program is distributed in the hope that it will be useful, 9 % but WITHOUT ANY WARRANTY; without even the implied warranty of 10 % MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 % GNU General Public License for more details. 12 % 13 % You should have received a copy of the GNU General Public License 14 % along with this program; see the file COPYING. If not, write to 15 % the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16 % Boston, MA 02110-1301, USA. 17 18 \darcsCommand{add} 19 \begin{code} 20 module Darcs.Commands.Add ( add ) where 21 22 import Data.List ( (\\), nub) 23 24 import Darcs.Commands 25 import Darcs.Arguments (noskip_boring, allow_problematic_filenames, 26 fancy_move_add, 27 recursive, working_repo_dir, dry_run_noxml, umask_option, 28 list_files, list_unregistered_files, 29 DarcsFlag (AllowCaseOnly, AllowWindowsReserved, Boring, Recursive, 30 Verbose, Quiet, FancyMoveAdd, DryRun), 31 fixSubPaths, 32 ) 33 import Darcs.Utils ( withCurrentDirectory, nubsort ) 34 import IsoDate ( getIsoDateTime ) 35 import Darcs.Repository ( amInRepository, withRepoLock, ($-), 36 slurp_pending, add_to_pending ) 37 import Darcs.Patch ( Prim, apply_to_slurpy, addfile, adddir, move ) 38 import Darcs.Ordered ( FL(..), unsafeFL, concatFL, nullFL ) 39 import Darcs.SlurpDirectory ( Slurpy, slurp_has_anycase, slurp_has, 40 isFileReallySymlink, doesDirectoryReallyExist, 41 doesFileReallyExist, slurp_hasdir, 42 ) 43 import Darcs.Patch.FileName ( fp2fn ) 44 import Darcs.RepoPath ( toFilePath ) 45 import Control.Monad ( when, unless ) 46 import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter ) 47 import Data.Maybe ( maybeToList ) 48 import System.FilePath.Posix ( takeDirectory, (</>) ) 49 import System.IO ( hPutStrLn, stderr ) 50 import qualified System.FilePath.Windows as WindowsFilePath 51 import Darcs.Gorsvet( invalidateIndex ) 52 53 add_description :: String 54 add_description = "Add one or more new files or directories." 55 56 add_help :: String 57 add_help = 58 "Generally a repository contains both files that should be version\n" ++ 59 "controlled (such as source code) and files that Darcs should ignore\n" ++ 60 "(such as executables compiled from the source code). The `darcs add'\n" ++ 61 "command is used to tell Darcs which files to version control.\n" ++ 62 "\n" ++ 63 "When an existing project is first imported into a Darcs repository, it\n" ++ 64 "is common to run `darcs add -r *' or `darcs record -l' to add all\n" ++ 65 "initial source files into darcs.\n"++ 66 "\n" ++ 67 "Adding symbolic links (symlinks) is not supported.\n\n" 68 69 add :: DarcsCommand 70 add = DarcsCommand {command_name = "add", 71 command_help = add_help ++ add_help' ++ add_help'', 72 command_description = add_description, 73 command_extra_args = -1, 74 command_extra_arg_help = ["<FILE or DIRECTORY> ..."], 75 command_command = add_cmd, 76 command_prereq = amInRepository, 77 command_get_arg_possibilities = list_unregistered_files, 78 command_argdefaults = nodefaults, 79 command_advanced_options = [umask_option], 80 command_basic_options = 81 [noskip_boring, allow_problematic_filenames, 82 recursive "add contents of subdirectories", 83 fancy_move_add, 84 working_repo_dir, dry_run_noxml]} 85 86 add_help' :: String 87 add_help' = 88 "Darcs will ignore all files and folders that look `boring'. The\n" ++ 89 "--boring option overrides this behaviour.\n" ++ 90 "\n" ++ 91 "Darcs will not add file if another file in the same folder has the\n" ++ 92 "same name, except for case. The --case-ok option overrides this\n" ++ 93 "behaviour. Windows and OS X usually use filesystems that do not allow\n" ++ 94 "files a folder to have the same name except for case (for example,\n" ++ 95 "`ReadMe' and `README'). If --case-ok is used, the repository might be\n" ++ 96 "unusable on those systems!\n\n" 97 98 add_cmd :: [DarcsFlag] -> [String] -> IO () 99 add_cmd opts args = withRepoLock opts $- \repository -> 100 do cur <- slurp_pending repository 101 origfiles <- map toFilePath `fmap` fixSubPaths opts args 102 when (null origfiles) $ 103 putStrLn "Nothing specified, nothing added." >> 104 putStrLn "Maybe you wanted to say `darcs add --recursive .'?" 105 parlist <- get_parents cur origfiles 106 flist' <- if Recursive `elem` opts 107 then expand_dirs origfiles 108 else return origfiles 109 let flist = nubsort (parlist ++ flist') 110 -- refuse to add boring files recursively: 111 nboring <- if Boring `elem` opts 112 then return darcsdir_filter 113 else boring_file_filter 114 let putInfoLn = if Quiet `elem` opts then \_ -> return () else putStrLn 115 mapM_ (putInfoLn . ((msg_skipping msgs ++ " boring file ")++)) $ 116 flist \\ nboring flist 117 date <- getIsoDateTime 118 invalidateIndex repository 119 ps <- addp msgs opts date cur $ nboring flist 120 when (nullFL ps && not (null args)) $ 121 fail "No files were added" 122 unless gotDryRun $ add_to_pending repository ps 123 where 124 gotDryRun = DryRun `elem` opts 125 msgs | gotDryRun = dryRunMessages 126 | otherwise = normalMessages 127 128 addp :: AddMessages -> [DarcsFlag] -> String -> Slurpy -> [FilePath] -> IO (FL Prim) 129 addp msgs opts date cur0 files = do 130 (ps, dups) <- 131 foldr 132 (\f rest cur accPS accDups -> do 133 (cur', mp, mdup) <- addp' cur f 134 rest cur' (maybeToList mp ++ accPS) (maybeToList mdup ++ accDups)) 135 (\_ ps dups -> return (reverse ps, dups)) 136 files 137 cur0 [] [] 138 let uniq_dups = nub dups 139 caseMsg = 140 if gotAllowCaseOnly then ":" 141 else ";\nnote that to ensure portability we don't allow\n" ++ 142 "files that differ only in case. Use --case-ok to override this:" 143 unless (null dups) $ do 144 dupMsg <- 145 case uniq_dups of 146 [f] -> 147 do 148 isDir <- doesDirectoryReallyExist f 149 if isDir 150 then return $ 151 "The following directory "++msg_is msgs++" already in the repository" 152 else return $ 153 "The following file "++msg_is msgs++" already in the repository" 154 fs -> 155 do 156 areDirs <- mapM doesDirectoryReallyExist fs 157 if and areDirs 158 then return $ 159 "The following directories "++msg_are msgs++" already in the repository" 160 else 161 (if or areDirs 162 then return $ 163 "The following files and directories " ++ 164 msg_are msgs ++ " already in the repository" 165 else return $ 166 "The following files " ++ msg_are msgs ++ " already in the repository") 167 putInfo $ dupMsg ++ caseMsg 168 mapM_ putInfo uniq_dups 169 return $ concatFL $ unsafeFL ps 170 where 171 addp' :: Slurpy -> FilePath -> IO (Slurpy, Maybe (FL Prim), Maybe FilePath) 172 addp' cur f = 173 if already_has 174 then return (cur, Nothing, Just f) 175 else 176 if is_badfilename 177 then do putInfo $ "The filename " ++ f ++ " is invalid under Windows.\nUse --reserved-ok to allow it." 178 return add_failure 179 else do 180 isdir <- doesDirectoryReallyExist f 181 if isdir 182 then trypatch $ myadddir f 183 else do isfile <- doesFileReallyExist f 184 if isfile 185 then trypatch $ myaddfile f 186 else do islink <- isFileReallySymlink f 187 if islink then 188 putInfo $ "Sorry, file " ++ f ++ " is a symbolic link, which is unsupported by darcs." 189 else putInfo $ "File "++ f ++" does not exist!" 190 return add_failure 191 where already_has = if gotAllowCaseOnly 192 then slurp_has f cur 193 else slurp_has_anycase f cur 194 is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f) 195 add_failure = (cur, Nothing, Nothing) 196 trypatch p = 197 case apply_to_slurpy p cur of 198 Nothing -> do putInfo $ msg_skipping msgs ++ " '" ++ f ++ "' ... " ++ parent_error 199 return (cur, Nothing, Nothing) 200 Just s' -> do putVerbose $ msg_adding msgs++" '"++f++"'" 201 return (s', Just p, Nothing) 202 parentdir = takeDirectory f 203 have_parentdir = slurp_hasdir (fp2fn parentdir) cur 204 parent_error = if have_parentdir 205 then "" 206 else "couldn't add parent directory '"++parentdir++ 207 "' to repository." 208 myadddir d = if gotFancyMoveAdd 209 then adddir (d++"-"++date) :>: 210 move (d++"-"++date) d :>: NilFL 211 else adddir d :>: NilFL 212 myaddfile d = if gotFancyMoveAdd 213 then addfile (d++"-"++date) :>: 214 move (d++"-"++date) d :>: NilFL 215 else addfile d :>: NilFL 216 putVerbose = if Verbose `elem` opts || DryRun `elem` opts 217 then putStrLn 218 else \_ -> return () 219 putInfo = if Quiet `elem` opts then \_ -> return () else hPutStrLn stderr 220 gotFancyMoveAdd = FancyMoveAdd `elem` opts 221 gotAllowCaseOnly = AllowCaseOnly `elem` opts 222 gotAllowWindowsReserved = AllowWindowsReserved `elem` opts 223 224 data AddMessages = 225 AddMessages 226 { msg_skipping :: String 227 , msg_adding :: String 228 , msg_is :: String 229 , msg_are :: String 230 } 231 232 normalMessages, dryRunMessages :: AddMessages 233 normalMessages = 234 AddMessages 235 { msg_skipping = "Skipping" 236 , msg_adding = "Adding" 237 , msg_is = "is" 238 , msg_are = "are" 239 } 240 dryRunMessages = 241 AddMessages 242 { msg_skipping = "Would skip" 243 , msg_adding = "Would add" 244 , msg_is = "would be" 245 , msg_are = "would be" 246 } 247 248 -- |FIXME: this documentation makes *no* sense to me, and the 249 -- ramifications of using this option are not clear. --twb, 2008 250 add_help'' :: String 251 add_help'' = 252 "The --date-trick option allows you to enable an experimental trick to\n" ++ 253 "make add conflicts, in which two users each add a file or directory\n" ++ 254 "with the same name, less problematic. While this trick is completely\n" ++ 255 "safe, it is not clear to what extent it is beneficial.\n" 256 257 expand_dirs :: [FilePath] -> IO [FilePath] 258 expand_dirs fs = concat `fmap` mapM expand_one fs 259 expand_one :: FilePath -> IO [FilePath] 260 expand_one "" = list_files 261 expand_one f = do 262 isdir <- doesDirectoryReallyExist f 263 if not isdir then return [f] 264 else do fs <- withCurrentDirectory f list_files 265 return $ f: map (f </>) fs 266 267 get_parents :: Slurpy -> [FilePath] -> IO [FilePath] 268 get_parents cur fs = 269 concat `fmap` mapM (get_parent cur) fs 270 get_parent :: Slurpy -> FilePath -> IO [FilePath] 271 get_parent cur f = 272 if slurp_hasdir (fp2fn parentdir) cur 273 then return [] 274 else do grandparents <- get_parent cur parentdir 275 return (grandparents ++ [parentdir]) 276 where parentdir = takeDirectory f 277 \end{code} 278