src/Darcs/Commands/Add.lhs

   1 %  Copyright (C) 2002-2004 David Roundy
   2 %
   3 %  This program is free software; you can redistribute it and/or modify
   4 %  it under the terms of the GNU General Public License as published by
   5 %  the Free Software Foundation; either version 2, or (at your option)
   6 %  any later version.
   7 %
   8 %  This program is distributed in the hope that it will be useful,
   9 %  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 %  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 %  GNU General Public License for more details.
  12 %
  13 %  You should have received a copy of the GNU General Public License
  14 %  along with this program; see the file COPYING.  If not, write to
  15 %  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  16 %  Boston, MA 02110-1301, USA.
  17
  18 \subsection{darcs add}
  19 \begin{code}
  20 module Darcs.Commands.Add ( add ) where
  21
  22 import Data.List ( (\\), nub)
  23
  24 import Darcs.Commands
  25 import Darcs.Arguments (noskip_boring, allow_problematic_filenames,
  26                        fancy_move_add,
  27                        recursive, working_repo_dir, dry_run_noxml, umask_option,
  28                        list_files, list_unregistered_files,
  29                         DarcsFlag (AllowCaseOnly, AllowWindowsReserved, Boring, Recursive,
  30                                    Verbose, Quiet, FancyMoveAdd, DryRun),
  31                         fixSubPaths,
  32                       )
  33 import Darcs.Utils ( withCurrentDirectory, nubsort )
  34 import IsoDate ( getIsoDateTime )
  35 import Darcs.Repository ( amInRepository, withRepoLock, ($-),
  36                     slurp_pending, add_to_pending )
  37 import Darcs.Patch ( Prim, apply_to_slurpy, addfile, adddir, move )
  38 import Darcs.Ordered ( FL(..), unsafeFL, concatFL, nullFL )
  39 import Darcs.SlurpDirectory ( Slurpy, slurp_has_anycase, slurp_has,
  40                         isFileReallySymlink, doesDirectoryReallyExist,
  41                         doesFileReallyExist, slurp_hasdir,
  42                       )
  43 import Darcs.Patch.FileName ( fp2fn )
  44 import Darcs.FilePathUtils ( (///) )
  45 import Darcs.RepoPath ( toFilePath )
  46 import Control.Monad ( when )
  47 import Darcs.Repository.Prefs ( darcsdir_filter, boring_file_filter )
  48 import Data.Maybe ( maybeToList )
  49 import System.IO ( hPutStrLn, stderr )
  50 import qualified System.FilePath.Windows as WindowsFilePath
  51 \end{code}
  52
  53 \begin{code}
  54 add_description :: String
  55 add_description =
  56  "Add one or more new files or directories."
  57 \end{code}
  58
  59 \options{add}
  60
  61 \haskell{add_help}
  62
  63 \begin{code}
  64 add_help :: String
  65 add_help =
  66  "Add needs to be called whenever you add a new file or directory to your\n"++
  67  "project.  Of course, it also needs to be called when you first create the\n"++
  68  "project, to let darcs know which files should be kept track of.\n"
  69 \end{code}
  70
  71 \begin{code}
  72 add :: DarcsCommand
  73 add = DarcsCommand {command_name = "add",
  74                     command_help = add_help,
  75                     command_description = add_description,
  76                     command_extra_args = -1,
  77                     command_extra_arg_help = ["<FILE or DIRECTORY> ..."],
  78                     command_command = add_cmd,
  79                     command_prereq = amInRepository,
  80                     command_get_arg_possibilities = list_unregistered_files,
  81                     command_argdefaults = nodefaults,
  82                     command_advanced_options = [umask_option],
  83                     command_basic_options =
  84                     [noskip_boring, allow_problematic_filenames,
  85                      recursive "add contents of subdirectories",
  86                      fancy_move_add,
  87                      working_repo_dir, dry_run_noxml]}
  88 \end{code}
  89
  90 Darcs will refuse to add a file or directory that differs from an existing
  91 one only in case.  This is because the HFS+ file system used on MacOS
  92 treats such files as being one and the same.
  93
  94 You can not add symbolic links to darcs.
  95 If you try to do that, darcs will refuse and print an error message.
  96 Perhaps you want to make symbolic links \emph{to} the files in darcs instead?
  97
  98 \begin{options}
  99 --boring
 100 \end{options}
 101
 102 By default darcs will ignore all files that match any of the boring patterns.
 103 If you want to add such a file anyway you must use the \verb!--boring! option.
 104
 105 \begin{code}
 106 add_cmd :: [DarcsFlag] -> [String] -> IO ()
 107 add_cmd opts args = withRepoLock opts $- \repository ->
 108  do cur <- slurp_pending repository
 109     origfiles <- map toFilePath `fmap` fixSubPaths opts args
 110     parlist <- get_parents cur origfiles
 111     flist' <- if Recursive `elem` opts
 112               then expand_dirs origfiles
 113               else return origfiles
 114     let flist = nubsort (parlist ++ flist')
 115     -- refuse to add boring files recursively:
 116     nboring <- if Boring `elem` opts
 117                then return $ darcsdir_filter
 118                else boring_file_filter
 119     let putInfoLn = if Quiet `elem` opts then \_ -> return () else putStrLn
 120     sequence_ $ map (putInfoLn . ((msg_skipping msgs ++ " boring file ")++)) $
 121               flist \\ nboring flist
 122     date <- getIsoDateTime
 123     ps <- addp msgs opts date cur $ nboring flist
 124     when (nullFL ps && not (null args)) $ do
 125         fail "No files were added"
 126     when (not gotDryRun) $ add_to_pending repository ps
 127   where
 128     gotDryRun = DryRun `elem` opts
 129     msgs | gotDryRun = dryRunMessages
 130          | otherwise = normalMessages
 131
 132 addp :: AddMessages -> [DarcsFlag] -> String -> Slurpy -> [FilePath] -> IO (FL Prim)
 133 addp msgs opts date cur0 files = do
 134     (ps, dups) <-
 135         foldr
 136             (\f rest cur accPS accDups -> do
 137                 (cur', mp, mdup) <- addp' cur f
 138                 rest cur' (maybeToList mp ++ accPS) (maybeToList mdup ++ accDups))
 139             (\_ ps dups -> return (reverse ps, dups))
 140             files
 141             cur0 [] []
 142     let uniq_dups = nub dups
 143         caseMsg =
 144             if gotAllowCaseOnly then ":"
 145                 else ";\nnote that to ensure portability we don't allow\n" ++
 146                      "files that differ only in case. Use --case-ok to override this:"
 147     when (not (null dups)) $ do
 148        dupMsg <-
 149          case uniq_dups of
 150          [f] ->
 151            do
 152            isDir <- doesDirectoryReallyExist f
 153            if isDir
 154                then return $
 155                  "The following directory "++msg_is msgs++" already in the repository"
 156                else return $
 157                  "The following file "++msg_is msgs++" already in the repository"
 158          fs   ->
 159            do
 160            areDirs <- mapM doesDirectoryReallyExist fs
 161            if and areDirs
 162                then return $
 163                  "The following directories "++msg_are msgs++" already in the repository"
 164                else
 165                  (if or areDirs
 166                       then return $
 167                         "The following files and directories " ++
 168                         msg_are msgs ++ " already in the repository"
 169                       else return $
 170                         "The following files " ++ msg_are msgs ++ " already in the repository")
 171        putInfo $ dupMsg ++ caseMsg
 172        mapM_ putInfo uniq_dups
 173     return $ concatFL $ unsafeFL ps
 174  where
 175   addp' :: Slurpy -> FilePath -> IO (Slurpy, Maybe (FL Prim), Maybe FilePath)
 176   addp' cur f =
 177     if already_has
 178     then do return (cur, Nothing, Just f)
 179     else do
 180     if is_badfilename
 181        then do putInfo $ "The filename " ++ f ++ " is invalid under Windows.\nUse --reserved-ok to allow it."
 182                return add_failure
 183        else do
 184       isdir <- doesDirectoryReallyExist f
 185       if isdir
 186          then trypatch $ myadddir f
 187          else do isfile <- doesFileReallyExist f
 188                  if isfile
 189                     then trypatch $ myaddfile f
 190                     else do islink <- isFileReallySymlink f
 191                             if islink then
 192                                putInfo $ "Sorry, file " ++ f ++ " is a symbolic link, which is unsupported by darcs."
 193                                else putInfo $ "File "++ f ++" does not exist!"
 194                             return add_failure
 195       where already_has = if gotAllowCaseOnly
 196                           then slurp_has f cur
 197                           else slurp_has_anycase f cur
 198             is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f)
 199             add_failure = (cur, Nothing, Nothing)
 200             trypatch p =
 201                 case apply_to_slurpy p cur of
 202                 Nothing -> do putInfo $ msg_skipping msgs ++ " '" ++ f ++ "' ... " ++ parent_error
 203                               return (cur, Nothing, Nothing)
 204                 Just s' -> do putVerbose $ msg_adding msgs++" '"++f++"'"
 205                               return (s', Just p, Nothing)
 206             parentdir = get_parentdir f
 207             have_parentdir = slurp_hasdir (fp2fn parentdir) cur
 208             parent_error = if have_parentdir
 209                            then ""
 210                            else "couldn't add parent directory '"++parentdir++
 211                                 "' to repository."
 212             myadddir d = if gotFancyMoveAdd
 213                          then adddir (d++"-"++date) :>:
 214                               move (d++"-"++date) d :>: NilFL
 215                          else adddir d :>: NilFL
 216             myaddfile d = if gotFancyMoveAdd
 217                           then addfile (d++"-"++date) :>:
 218                                move (d++"-"++date) d :>: NilFL
 219                           else addfile d :>: NilFL
 220   putVerbose = if Verbose `elem` opts || DryRun `elem` opts
 221                then putStrLn
 222                else \_ -> return ()
 223   putInfo = if Quiet `elem` opts then \_ -> return () else hPutStrLn stderr
 224   gotFancyMoveAdd = FancyMoveAdd `elem` opts
 225   gotAllowCaseOnly = AllowCaseOnly `elem` opts
 226   gotAllowWindowsReserved = AllowWindowsReserved `elem` opts
 227
 228 data AddMessages =
 229     AddMessages
 230     { msg_skipping  :: String
 231     , msg_adding    :: String
 232     , msg_is        :: String
 233     , msg_are       :: String
 234     }
 235
 236 normalMessages, dryRunMessages :: AddMessages
 237 normalMessages =
 238     AddMessages
 239     { msg_skipping  = "Skipping"
 240     , msg_adding    = "Adding"
 241     , msg_is        = "is"
 242     , msg_are       = "are"
 243     }
 244 dryRunMessages =
 245     AddMessages
 246     { msg_skipping  = "Would skip"
 247     , msg_adding    = "Would add"
 248     , msg_is        = "would be"
 249     , msg_are       = "would be"
 250     }
 251 \end{code}
 252
 253 \begin{options}
 254 --date-trick
 255 \end{options}
 256
 257 The \verb!--date-trick! option allows you to enable an experimental trick
 258 to make add conflicts, in which two users each add a file or directory with
 259 the same name, less problematic.  While this trick is completely safe, it
 260 is not clear to what extent it is beneficial.
 261
 262 \begin{code}
 263 expand_dirs :: [FilePath] -> IO [FilePath]
 264 expand_dirs fs = concat `fmap` mapM expand_one fs
 265 expand_one :: FilePath -> IO [FilePath]
 266 expand_one "" = list_files
 267 expand_one f = do
 268   isdir <- doesDirectoryReallyExist f
 269   if not isdir then return [f]
 270      else do fs <- withCurrentDirectory f list_files
 271              return $ f: map ((///) f) fs
 272
 273 get_parents :: Slurpy -> [FilePath] -> IO [FilePath]
 274 get_parents cur fs =
 275   concat `fmap` mapM (get_parent cur) fs
 276 get_parent :: Slurpy -> FilePath -> IO [FilePath]
 277 get_parent cur f =
 278   if slurp_hasdir (fp2fn parentdir) cur
 279   then return []
 280   else do grandparents <- get_parent cur parentdir
 281           return (grandparents ++ [parentdir])
 282     where parentdir = get_parentdir f
 283
 284 get_parentdir :: FilePath -> FilePath
 285 get_parentdir f = reverse $ drop 1 $ dropWhile (/='/') $ reverse f
 286
 287 \end{code}
 288