% 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')
        -- refuse to add boring files recursively:
        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"
        }

    -- |FIXME: this documentation makes *no* sense to me, and the
    -- ramifications of using this option are not clear. --twb, 2008
    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}