% Copyright (C) 2002-2004 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.
\darcsCommand{add}
\begin{code}
module Darcs.Commands.Add ( add, expandDirs ) where
import Data.List ( (\\), nub)
import Darcs.Commands(DarcsCommand(..), putVerbose, putWarning, nodefaults)
import Darcs.Arguments (noskipBoring, allowProblematicFilenames,
fancyMoveAdd,
recursive, workingRepoDir, dryRunNoxml, umaskOption,
listFiles, listUnregisteredFiles,
DarcsFlag ( Recursive, FancyMoveAdd, DryRun, Verbose),
fixSubPaths,
)
import Darcs.Flags( includeBoring, doAllowCaseOnly, doAllowWindowsReserved,)
import Darcs.Utils ( withCurrentDirectory, nubsort )
import IsoDate ( getIsoDateTime )
import Darcs.Repository ( amInRepository, withRepoLock, ($-),
slurp_pending, add_to_pending )
import Darcs.Patch ( Prim, applyToSlurpy, addfile, adddir, move )
import Darcs.Witnesses.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 ( SubPath, toFilePath, simpleSubPath, toPath )
import Control.Monad ( when, unless, liftM )
import Darcs.Repository.Prefs ( darcsdirFilter, boringFileFilter )
import Data.Maybe ( maybeToList, fromJust )
import System.FilePath.Posix ( takeDirectory, (</>) )
import qualified System.FilePath.Windows as WindowsFilePath
import Printer( text )
addDescription :: String
addDescription = "Add one or more new files or directories."
addHelp :: String
addHelp =
"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 {commandName = "add",
commandHelp = addHelp ++ addHelp' ++ addHelp'',
commandDescription = addDescription,
commandExtraArgs = 1,
commandExtraArgHelp = ["<FILE or DIRECTORY> ..."],
commandCommand = addCmd,
commandPrereq = amInRepository,
commandGetArgPossibilities = listUnregisteredFiles,
commandArgdefaults = nodefaults,
commandAdvancedOptions = [umaskOption],
commandBasicOptions =
[noskipBoring, allowProblematicFilenames,
recursive "add contents of subdirectories",
fancyMoveAdd,
workingRepoDir, dryRunNoxml]}
addHelp' :: String
addHelp' =
"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"
addCmd :: [DarcsFlag] -> [String] -> IO ()
addCmd opts args = withRepoLock opts $- \repository ->
do cur <- slurp_pending repository
origfiles <- fixSubPaths opts args
when (null origfiles) $
putStrLn "Nothing specified, nothing added." >>
putStrLn "Maybe you wanted to say `darcs add --recursive .'?"
parlist <- getParents cur (map toFilePath origfiles)
flist' <- if Recursive `elem` opts
then expandDirs origfiles
else return origfiles
let flist = nubsort (parlist ++ toFilePath `map` flist')
nboring <- if includeBoring opts
then return darcsdirFilter
else boringFileFilter
let fixedOpts = if DryRun `elem` opts then Verbose:opts else opts
mapM_ (putWarning fixedOpts . text . ((msg_skipping msgs ++ " boring file ")++)) $
flist \\ nboring flist
date <- getIsoDateTime
ps <- addp msgs fixedOpts date cur $ nboring flist
when (nullFL ps && not (null args)) $
fail "No files were added"
unless 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:"
unless (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")
putWarning opts . text $ dupMsg ++ caseMsg
mapM_ (putWarning opts . text) uniq_dups
return $ concatFL $ unsafeFL ps
where
addp' :: Slurpy -> FilePath -> IO (Slurpy, Maybe (FL Prim), Maybe FilePath)
addp' cur f =
if already_has
then return (cur, Nothing, Just f)
else
if is_badfilename
then do putWarning opts . text $
"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
putWarning opts . text $
"Sorry, file " ++ f ++ " is a symbolic link, which is unsupported by darcs."
else putWarning opts . text $ "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 applyToSlurpy p cur of
Nothing -> do putWarning opts . text $ msg_skipping msgs ++ " '" ++ f ++ "' ... " ++ parent_error
return (cur, Nothing, Nothing)
Just s' -> do putVerbose opts . text $ 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
gotFancyMoveAdd = FancyMoveAdd `elem` opts
gotAllowCaseOnly = doAllowCaseOnly opts
gotAllowWindowsReserved = doAllowWindowsReserved 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"
}
addHelp'' :: String
addHelp'' =
"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"
expandDirs :: [SubPath] -> IO [SubPath]
expandDirs fs = liftM (map (fromJust . simpleSubPath)) (concat `fmap` mapM (expandOne . toPath) fs)
expandOne :: FilePath -> IO [FilePath]
expandOne "" = listFiles
expandOne f = do
isdir <- doesDirectoryReallyExist f
if not isdir then return [f]
else do fs <- withCurrentDirectory f listFiles
return $ f: map (f </>) fs
getParents :: Slurpy -> [FilePath] -> IO [FilePath]
getParents cur fs =
concat `fmap` mapM (getParent cur) fs
getParent :: Slurpy -> FilePath -> IO [FilePath]
getParent cur f =
if slurp_hasdir (fp2fn parentdir) cur
then return []
else do grandparents <- getParent cur parentdir
return (grandparents ++ [parentdir])
where parentdir = takeDirectory f
\end{code}