% Copyright (C) 20022004 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 021101301, USA.
\subsection{darcs add}
\begin{code}
module Darcs.Commands.Add ( add ) where
import Data.List ( (\\), nub)
import Darcs.Commands
import Darcs.Arguments (noskip_boring, allow_problematic_filenames,
fancy_move_add,
recursive, working_repo_dir, dry_run_noxml, umask_option,
list_files, list_unregistered_files,
DarcsFlag (AllowCaseOnly, AllowWindowsReserved, Boring, Recursive,
Verbose, Quiet, FancyMoveAdd, DryRun),
fixSubPaths,
)
import Darcs.Utils ( withCurrentDirectory, nubsort )
import IsoDate ( getIsoDateTime )
import Darcs.Repository ( amInRepository, withRepoLock, ($-),
slurp_pending, add_to_pending )
import Darcs.Patch ( Prim, apply_to_slurpy, addfile, adddir, move )
import Darcs.Ordered ( FL(..), unsafeFL, concatFL, nullFL )
import Darcs.SlurpDirectory ( Slurpy, slurp_has_anycase, slurp_has,
isFileReallySymlink, doesDirectoryReallyExist,
doesFileReallyExist, slurp_hasdir,
)
import Darcs.Patch.FileName ( fp2fn )
import Darcs.RepoPath ( toFilePath )
import Control.Monad ( when )
import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter )
import Data.Maybe ( maybeToList )
import System.FilePath.Posix ( takeDirectory, (</>) )
import System.IO ( hPutStrLn, stderr )
import qualified System.FilePath.Windows as WindowsFilePath
add_description :: String
add_description = "Add one or more new files or directories."
\end{code}
\options{add}
\haskell{add_help}
\begin{code}
add_help :: String
add_help =
"Generally a repository contains both files that should be version\n" ++
"controlled (such as source code) and files that Darcs should ignore\n" ++
"(such as executables compiled from the source code). The `darcs add'\n" ++
"command is used to tell Darcs which files to version control.\n" ++
"\n" ++
"When an existing project is first imported into a Darcs repository, it\n" ++
"is common to run `darcs add -r *' or `darcs record -l' to add all\n" ++
"initial source files into darcs.\n"++
"\n" ++
"Adding symbolic links (symlinks) is not supported.\n\n"
add :: DarcsCommand
add = DarcsCommand {command_name = "add",
command_help = add_help ++ add_help' ++ add_help'',
command_description = add_description,
command_extra_args = 1,
command_extra_arg_help = ["<FILE or DIRECTORY> ..."],
command_command = add_cmd,
command_prereq = amInRepository,
command_get_arg_possibilities = list_unregistered_files,
command_argdefaults = nodefaults,
command_advanced_options = [umask_option],
command_basic_options =
[noskip_boring, allow_problematic_filenames,
recursive "add contents of subdirectories",
fancy_move_add,
working_repo_dir, dry_run_noxml]}
add_help' :: String
add_help' =
"Darcs will ignore all files and folders that look `boring'. The\n" ++
"--boring option overrides this behaviour.\n" ++
"\n" ++
"Darcs will not add file if another file in the same folder has the\n" ++
"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\n"
add_cmd :: [DarcsFlag] -> [String] -> IO ()
add_cmd opts args = withRepoLock opts $- \repository ->
do cur <- slurp_pending repository
origfiles <- map toFilePath `fmap` fixSubPaths opts args
parlist <- get_parents cur origfiles
flist' <- if Recursive `elem` opts
then expand_dirs origfiles
else return origfiles
let flist = nubsort (parlist ++ flist')
nboring <- if Boring `elem` opts
then return $ darcsdir_filter
else boring_file_filter
let putInfoLn = if Quiet `elem` opts then \_ -> return () else putStrLn
sequence_ $ map (putInfoLn . ((msg_skipping msgs ++ " boring file ")++)) $
flist \\ nboring flist
date <- getIsoDateTime
ps <- addp msgs opts date cur $ nboring flist
when (nullFL ps && not (null args)) $ do
fail "No files were added"
when (not gotDryRun) $ add_to_pending repository ps
where
gotDryRun = DryRun `elem` opts
msgs | gotDryRun = dryRunMessages
| otherwise = normalMessages
addp :: AddMessages -> [DarcsFlag] -> String -> Slurpy -> [FilePath] -> IO (FL Prim)
addp msgs opts date cur0 files = do
(ps, dups) <-
foldr
(\f rest cur accPS accDups -> do
(cur', mp, mdup) <- addp' cur f
rest cur' (maybeToList mp ++ accPS) (maybeToList mdup ++ accDups))
(\_ ps dups -> return (reverse ps, dups))
files
cur0 [] []
let uniq_dups = nub dups
caseMsg =
if gotAllowCaseOnly then ":"
else ";\nnote that to ensure portability we don't allow\n" ++
"files that differ only in case. Use --case-ok to override this:"
when (not (null dups)) $ do
dupMsg <-
case uniq_dups of
[f] ->
do
isDir <- doesDirectoryReallyExist f
if isDir
then return $
"The following directory "++msg_is msgs++" already in the repository"
else return $
"The following file "++msg_is msgs++" already in the repository"
fs ->
do
areDirs <- mapM doesDirectoryReallyExist fs
if and areDirs
then return $
"The following directories "++msg_are msgs++" already in the repository"
else
(if or areDirs
then return $
"The following files and directories " ++
msg_are msgs ++ " already in the repository"
else return $
"The following files " ++ msg_are msgs ++ " already in the repository")
putInfo $ dupMsg ++ caseMsg
mapM_ putInfo uniq_dups
return $ concatFL $ unsafeFL ps
where
addp' :: Slurpy -> FilePath -> IO (Slurpy, Maybe (FL Prim), Maybe FilePath)
addp' cur f =
if already_has
then do return (cur, Nothing, Just f)
else do
if is_badfilename
then do putInfo $ "The filename " ++ f ++ " is invalid under Windows.\nUse --reserved-ok to allow it."
return add_failure
else do
isdir <- doesDirectoryReallyExist f
if isdir
then trypatch $ myadddir f
else do isfile <- doesFileReallyExist f
if isfile
then trypatch $ myaddfile f
else do islink <- isFileReallySymlink f
if islink then
putInfo $ "Sorry, file " ++ f ++ " is a symbolic link, which is unsupported by darcs."
else putInfo $ "File "++ f ++" does not exist!"
return add_failure
where already_has = if gotAllowCaseOnly
then slurp_has f cur
else slurp_has_anycase f cur
is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f)
add_failure = (cur, Nothing, Nothing)
trypatch p =
case apply_to_slurpy p cur of
Nothing -> do putInfo $ msg_skipping msgs ++ " '" ++ f ++ "' ... " ++ parent_error
return (cur, Nothing, Nothing)
Just s' -> do putVerbose $ msg_adding msgs++" '"++f++"'"
return (s', Just p, Nothing)
parentdir = takeDirectory f
have_parentdir = slurp_hasdir (fp2fn parentdir) cur
parent_error = if have_parentdir
then ""
else "couldn't add parent directory '"++parentdir++
"' to repository."
myadddir d = if gotFancyMoveAdd
then adddir (d++"-"++date) :>:
move (d++"-"++date) d :>: NilFL
else adddir d :>: NilFL
myaddfile d = if gotFancyMoveAdd
then addfile (d++"-"++date) :>:
move (d++"-"++date) d :>: NilFL
else addfile d :>: NilFL
putVerbose = if Verbose `elem` opts || DryRun `elem` opts
then putStrLn
else \_ -> return ()
putInfo = if Quiet `elem` opts then \_ -> return () else hPutStrLn stderr
gotFancyMoveAdd = FancyMoveAdd `elem` opts
gotAllowCaseOnly = AllowCaseOnly `elem` opts
gotAllowWindowsReserved = AllowWindowsReserved `elem` opts
data AddMessages =
AddMessages
{ msg_skipping :: String
, msg_adding :: String
, msg_is :: String
, msg_are :: String
}
normalMessages, dryRunMessages :: AddMessages
normalMessages =
AddMessages
{ msg_skipping = "Skipping"
, msg_adding = "Adding"
, msg_is = "is"
, msg_are = "are"
}
dryRunMessages =
AddMessages
{ msg_skipping = "Would skip"
, msg_adding = "Would add"
, msg_is = "would be"
, msg_are = "would be"
}
add_help'' :: String
add_help'' =
"The --date-trick option allows you to enable an experimental trick to\n" ++
"make add conflicts, in which two users each add a file or directory\n" ++
"with the same name, less problematic. While this trick is completely\n" ++
"safe, it is not clear to what extent it is beneficial.\n"
expand_dirs :: [FilePath] -> IO [FilePath]
expand_dirs fs = concat `fmap` mapM expand_one fs
expand_one :: FilePath -> IO [FilePath]
expand_one "" = list_files
expand_one f = do
isdir <- doesDirectoryReallyExist f
if not isdir then return [f]
else do fs <- withCurrentDirectory f list_files
return $ f: map (f </>) fs
get_parents :: Slurpy -> [FilePath] -> IO [FilePath]
get_parents cur fs =
concat `fmap` mapM (get_parent cur) fs
get_parent :: Slurpy -> FilePath -> IO [FilePath]
get_parent cur f =
if slurp_hasdir (fp2fn parentdir) cur
then return []
else do grandparents <- get_parent cur parentdir
return (grandparents ++ [parentdir])
where parentdir = takeDirectory f
\end{code}