Add.lhs

%  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.

\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
\end{code}

\begin{code}
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 =
 "Add needs to be called whenever you add a new file or directory to your\n"++
 "project.  Of course, it also needs to be called when you first create the\n"++
 "project, to let darcs know which files should be kept track of.\n"
\end{code}

\begin{code}
add :: DarcsCommand
add = DarcsCommand {command_name = "add",
                    command_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]}
\end{code}

Darcs will refuse to add a file or directory that differs from an existing
one only in case.  This is because the HFS+ file system used on MacOS
treats such files as being one and the same.

You can not add symbolic links to darcs.
If you try to do that, darcs will refuse and print an error message.
Perhaps you want to make symbolic links \emph{to} the files in darcs instead?

\begin{options}
--boring
\end{options}

By default darcs will ignore all files that match any of the boring patterns.
If you want to add such a file anyway you must use the \verb!--boring! option.

\begin{code}
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')
    -- refuse to add boring files recursively:
    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"
    }
\end{code}

\begin{options}
--date-trick
\end{options}

The \verb!--date-trick! option allows you to enable an experimental trick
to make add conflicts, in which two users each add a file or directory with
the same name, less problematic.  While this trick is completely safe, it
is not clear to what extent it is beneficial.

\begin{code}
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}