module Darcs.UI.Commands.Add
(
add
, expandDirs
) where
import Prelude ()
import Darcs.Prelude
#include "impossible.h"
import Prelude hiding ( (^) )
import Control.Exception ( catch, IOException )
import Control.Monad ( when, unless, liftM )
import Data.List ( (\\), nub )
import Data.List.Ordered ( nubSort )
import Data.Maybe ( isNothing, maybeToList )
import Darcs.Util.Printer ( text )
import Darcs.Util.Tree ( Tree, findTree, expand )
import Darcs.Util.Path ( floatPath, anchorPath, parents,
SubPath, toFilePath, simpleSubPath, toPath, AbsolutePath )
import System.FilePath.Posix ( takeDirectory, (</>) )
import System.Posix.Files ( isRegularFile, isDirectory, isSymbolicLink )
import System.Directory ( getPermissions, readable )
import qualified System.FilePath.Windows as WindowsFilePath
import Darcs.UI.Commands
( DarcsCommand(..), withStdOpts, putInfo, putWarning, putVerboseWarning
, nodefaults, amInHashedRepository)
import Darcs.UI.Flags
( DarcsFlag
, includeBoring, doAllowCaseOnly, doAllowWindowsReserved, useCache, dryRun, umask
, fixSubPaths, verbosity )
import Darcs.UI.Options
( DarcsOption
, (^), odesc, ocheck, onormalise, defaultFlags, parseFlags )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.Commands.Util.Tree ( treeHas, treeHasDir, treeHasAnycase )
import Darcs.Repository.Flags ( UpdateWorking(..) )
import Darcs.Patch ( Patchy, PrimPatch, applyToTree, addfile, adddir )
import Darcs.Patch.Apply ( ApplyState )
import Darcs.Repository.State ( readRecordedAndPending, updateIndex )
import Darcs.Repository
( withRepoLock
, RepoJob(..)
, addToPending
, listFiles
, listUnregisteredFiles
)
import Darcs.Repository.Prefs ( darcsdirFilter, boringFileFilter )
import Darcs.Util.File ( getFileStatus, withCurrentDirectory )
import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), nullFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )
addDescription :: String
addDescription = "Add new files to version control."
addHelp :: String
addHelp =
"Generally the working tree 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"
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"
addBasicOpts :: DarcsOption a
(O.IncludeBoring -> Bool -> Bool -> Bool -> Maybe String -> O.DryRun -> a)
addBasicOpts = O.includeBoring
^ O.allowProblematicFilenames
^ O.recursive
^ O.workingRepoDir
^ O.dryRun
addAdvancedOpts :: DarcsOption a (O.UMask -> a)
addAdvancedOpts = O.umask
addOpts :: DarcsOption a
(O.IncludeBoring
-> Bool
-> Bool
-> Bool
-> Maybe String
-> O.DryRun
-> Maybe O.StdCmdAction
-> Bool
-> Bool
-> O.Verbosity
-> Bool
-> O.UMask
-> O.UseCache
-> Maybe String
-> Bool
-> Maybe String
-> Bool
-> a)
addOpts = withStdOpts addBasicOpts addAdvancedOpts
add :: DarcsCommand [DarcsFlag]
add = DarcsCommand
{ commandProgramName = "darcs"
, commandName = "add"
, commandHelp = addHelp ++ addHelp'
, commandDescription = addDescription
, commandExtraArgs = 1
, commandExtraArgHelp = [ "<FILE or DIRECTORY> ..." ]
, commandCommand = addCmd
, commandPrereq = amInHashedRepository
, commandGetArgPossibilities = listUnregisteredFiles False
, commandArgdefaults = nodefaults
, commandAdvancedOptions = odesc addAdvancedOpts
, commandBasicOptions = odesc addBasicOpts
, commandDefaults = defaultFlags addOpts
, commandCheckOptions = ocheck addOpts
, commandParseOptions = onormalise addOpts
}
addCmd :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag]
-> [String]
-> IO ()
addCmd paths opts args
| null args = putStrLn $ "Nothing specified, nothing added." ++
"Maybe you wanted to say `darcs add --recursive .'?"
| otherwise = do
fs <- fixSubPaths paths args
case fs of
[] -> fail "No valid arguments were given"
_ -> addFiles opts fs
addFiles :: [DarcsFlag]
-> [SubPath]
-> IO ()
addFiles opts origfiles = withRepoLock (dryRun opts) (useCache opts) YesUpdateWorking (umask opts) $ RepoJob $ \repository -> do
cur <- expand =<< readRecordedAndPending repository
let parlist = getParents cur (map toFilePath origfiles)
flist' <- if parseFlags O.recursive opts
then expandDirs (includeBoring opts) origfiles
else return origfiles
let flist = nubSort (parlist ++ toFilePath `map` flist')
nboring <- if includeBoring opts
then return darcsdirFilter
else boringFileFilter
mapM_ (putWarning opts . text . ((msgSkipping msgs ++ " boring file ")++)) $
flist \\ nboring flist
Sealed ps <- fmap unFreeLeft $ addp msgs opts cur $ nboring flist
when (nullFL ps && not (null origfiles) && notQuiet) $
fail "No files were added"
unless gotDryRun $
do addToPending repository YesUpdateWorking ps
updateIndex repository
where
gotDryRun = dryRun opts == O.YesDryRun
msgs | gotDryRun = dryRunMessages
| otherwise = normalMessages
notQuiet = verbosity opts /= O.Quiet
addp :: forall prim . (Patchy prim, PrimPatch prim, ApplyState prim ~ Tree)
=> AddMessages
-> [DarcsFlag]
-> Tree IO
-> [FilePath]
-> IO (FreeLeft (FL prim))
addp msgs opts cur0 files = do
(ps, dups) <-
foldr
(\f rest cur accPS accDups -> do
addResult <- addp' cur f
case addResult of
(_, Nothing, Nothing) -> return ([], [])
(cur', mp, mdup) -> 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 " ++
msgIs msgs ++ " already in the repository"
else return $
"The following file " ++
msgIs msgs ++ " already in the repository"
fs -> do
areDirs <- mapM doesDirectoryReallyExist fs
if and areDirs
then return $
"The following directories " ++
msgAre msgs ++ " already in the repository"
else
(if or areDirs
then return $
"The following files and directories " ++
msgAre msgs ++ " already in the repository"
else return $
"The following files " ++
msgAre msgs ++ " already in the repository")
putWarning opts . text $ "WARNING: Some files were not added because they are already in the repository."
putVerboseWarning opts . text $ dupMsg ++ caseMsg
mapM_ (putVerboseWarning opts . text) uniq_dups
return $ foldr (joinGap (+>+)) (emptyGap NilFL) ps
where
addp' :: Tree IO
-> FilePath
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)
addp' cur f = do
already_has <- (if gotAllowCaseOnly then treeHas else treeHasAnycase) cur f
mstatus <- getFileStatus f
case (already_has, is_badfilename, mstatus) of
(True, _, _) -> return (cur, Nothing, Just f)
(_, True, _) -> do
putWarning opts . text $
"The filename " ++ f ++ " is invalid under Windows.\n" ++
"Use --reserved-ok to allow it."
return add_failure
(_, _, Just s)
| isDirectory s -> trypatch $ freeGap (adddir f :>: NilFL)
| isRegularFile s -> trypatch $ freeGap (addfile f :>: NilFL)
| isSymbolicLink s -> do
putWarning opts . text $
"Sorry, file " ++ f ++
" is a symbolic link, which is unsupported by darcs."
return add_failure
_ -> do
putWarning opts . text $ "File "++ f ++" does not exist!"
return add_failure
where
is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f)
add_failure = (cur, Nothing, Nothing)
trypatch :: FreeLeft (FL prim)
-> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)
trypatch p = do
perms <- getPermissions f
if not $ readable perms
then do
putWarning opts . text $
msgSkipping msgs ++ " '" ++ f ++ "': permission denied "
return (cur, Nothing, Nothing)
else trypatch' p
trypatch' p = do
Sealed p' <- return $ unFreeLeft p
ok <- treeHasDir cur parentdir
if ok
then do
tree <- applyToTree p' cur
putInfo opts . text $
msgAdding msgs ++ " '" ++ f ++ "'"
return (tree, Just p, Nothing)
else do
putWarning opts . text $
msgSkipping msgs ++ " '" ++ f ++
"' ... couldn't add parent directory '" ++
parentdir ++ "' to repository"
return (cur, Nothing, Nothing)
`catch` \(e :: IOException) -> do
putWarning opts . text $
msgSkipping msgs ++ " '" ++ f ++ "' ... " ++ show e
return (cur, Nothing, Nothing)
parentdir = takeDirectory f
gotAllowCaseOnly = doAllowCaseOnly opts
gotAllowWindowsReserved = doAllowWindowsReserved opts
data AddMessages = AddMessages
{
msgSkipping :: String
, msgAdding :: String
, msgIs :: String
, msgAre :: String
}
normalMessages :: AddMessages
normalMessages = AddMessages
{
msgSkipping = "Skipping"
, msgAdding = "Adding"
, msgIs = "is"
, msgAre = "are"
}
dryRunMessages :: AddMessages
dryRunMessages = AddMessages
{
msgSkipping = "Would skip"
, msgAdding = "Would add"
, msgIs = "would be"
, msgAre = "would be"
}
doesDirectoryReallyExist :: FilePath -> IO Bool
doesDirectoryReallyExist f = maybe False isDirectory `fmap` getFileStatus f
expandDirs :: Bool -> [SubPath]
-> IO [SubPath]
expandDirs doIncludeBoring fs =
do
liftM (map (fromJust . simpleSubPath)) $
concat `fmap` mapM (expandOne doIncludeBoring . toPath) fs
expandOne :: Bool -> FilePath
-> IO [FilePath]
expandOne doIncludeBoring "" = listFiles doIncludeBoring
expandOne doIncludeBoring f = do
isdir <- doesDirectoryReallyExist f
if not isdir
then return [f]
else do
fs <- withCurrentDirectory f (listFiles doIncludeBoring)
return $ f: map (f </>) fs
getParents :: Tree IO
-> [FilePath]
-> [FilePath]
getParents cur = map (anchorPath "") . go . map floatPath
where
go fs = filter (isNothing . findTree cur) $ concatMap parents fs