1 % Copyright (C) 2003-2005 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 \darcsCommand{apply} 19 \begin{code} 20 {-# OPTIONS_GHC -cpp #-} 21 {-# LANGUAGE CPP #-} 22 23 module Darcs.Commands.Apply ( apply ) where 24 import System.Exit ( ExitCode(..), exitWith ) 25 import Prelude hiding ( catch ) 26 import System.IO ( hClose, stdin, stdout, stderr ) 27 import Control.Exception ( catch, throw, Exception( ExitException ) ) 28 import Control.Monad ( when ) 29 30 import Darcs.Hopefully ( n2pia, conscientiously, info ) 31 import Darcs.SignalHandler ( withSignalsBlocked ) 32 import Darcs.Commands ( DarcsCommand(..) ) 33 import Darcs.CommandsAux ( check_paths ) 34 import Darcs.Arguments ( DarcsFlag( Reply, Interactive, All, 35 Verbose, HappyForwarding ), 36 definePatches, 37 get_cc, working_repo_dir, 38 notest, nocompress, apply_conflict_options, 39 use_external_merge, 40 ignoretimes, get_sendmail_cmd, 41 reply, verify, list_files, 42 fixFilePathOrStd, umask_option, 43 all_interactive, sendmail_cmd, 44 leave_test_dir, happy_forwarding, 45 dry_run, print_dry_run_message_and_exit, 46 set_scripts_executable, restrict_paths 47 ) 48 import qualified Darcs.Arguments as DarcsArguments ( cc ) 49 import Darcs.RepoPath ( toFilePath, useAbsoluteOrStd ) 50 import Darcs.Repository ( SealedPatchSet, withRepoLock, ($-), amInRepository, 51 tentativelyMergePatches, 52 sync_repo, read_repo, 53 finalizeRepositoryChanges, 54 applyToWorking, 55 ) 56 import Darcs.Patch ( RepoPatch, description ) 57 import Darcs.Patch.Info ( human_friendly ) 58 import Darcs.Ordered ( (:\/:)(..), (:>)(..), unsafeUnRL, 59 mapFL, nullFL, mapFL_FL, mapRL, concatRL, reverseRL ) 60 import Darcs.SlurpDirectory ( wait_a_moment ) 61 62 import ByteStringUtils ( linesPS, unlinesPS ) 63 import qualified Data.ByteString as B (ByteString, null, readFile, hGetContents, init, take, drop) 64 import qualified Data.ByteString.Char8 as BC (unpack, last, pack) 65 66 import Darcs.External ( sendEmail, sendEmailDoc, resendEmail, 67 verifyPS ) 68 import Darcs.Email ( read_email ) 69 import Darcs.Lock ( withStdoutTemp, readBinFile ) 70 import Darcs.Patch.Depends ( get_common_and_uncommon_or_missing ) 71 import Darcs.SelectChanges ( with_selected_changes ) 72 import Darcs.Patch.Bundle ( scan_bundle ) 73 import Darcs.Sealed ( Sealed(Sealed) ) 74 import Printer ( packedString, putDocLn, vcat, text, ($$), errorDoc, empty ) 75 import Darcs.Gorsvet( invalidateIndex ) 76 #include "impossible.h" 77 78 apply_description :: String 79 apply_description = "Apply a patch bundle created by `darcs send'." 80 81 apply_help :: String 82 apply_help = 83 "Apply is used to apply a bundle of patches to this repository.\n"++ 84 "Such a bundle may be created using send.\n" 85 86 stdindefault :: a -> [String] -> IO [String] 87 stdindefault _ [] = return ["-"] 88 stdindefault _ x = return x 89 apply :: DarcsCommand 90 apply = DarcsCommand {command_name = "apply", 91 command_help = apply_help, 92 command_description = apply_description, 93 command_extra_args = 1, 94 command_extra_arg_help = ["<PATCHFILE>"], 95 command_command = apply_cmd, 96 command_prereq = amInRepository, 97 command_get_arg_possibilities = list_files, 98 command_argdefaults = const stdindefault, 99 command_advanced_options = [reply, DarcsArguments.cc, 100 happy_forwarding, 101 sendmail_cmd, 102 ignoretimes, nocompress, 103 set_scripts_executable, umask_option, 104 restrict_paths], 105 command_basic_options = [verify, 106 all_interactive]++dry_run++ 107 [apply_conflict_options, 108 use_external_merge, 109 notest, 110 leave_test_dir, 111 working_repo_dir]} 112 113 apply_cmd :: [DarcsFlag] -> [String] -> IO () 114 apply_cmd _ [""] = fail "Empty filename argument given to apply!" 115 apply_cmd opts [unfixed_patchesfile] = withRepoLock opts $- \repository -> do 116 patchesfile <- fixFilePathOrStd opts unfixed_patchesfile 117 ps <- useAbsoluteOrStd (B.readFile . toFilePath) (B.hGetContents stdin) patchesfile 118 am_verbose <- return $ Verbose `elem` opts 119 let from_whom = get_from ps 120 us <- read_repo repository 121 either_them <- get_patch_bundle opts ps 122 them <- case either_them of 123 Right (Sealed t) -> return t 124 Left er -> do forwarded <- consider_forwarding opts ps 125 if forwarded 126 then exitWith ExitSuccess 127 else fail er 128 (_, us':\/:them') <- case get_common_and_uncommon_or_missing (us, them) of 129 Left pinfo -> 130 if pinfo `elem` mapRL info (concatRL us) 131 then cannotApplyPartialRepo pinfo "" 132 else cannotApplyMissing pinfo 133 Right x -> return x 134 when (null $ unsafeUnRL $ head $ unsafeUnRL them') $ 135 do putStr $ "All these patches have already been applied. " ++ 136 "Nothing to do.\n" 137 exitWith ExitSuccess 138 let their_ps = mapFL_FL (n2pia . conscientiously (text ("We cannot apply this patch " 139 ++"bundle, since we're missing:") $$)) 140 $ reverseRL $ head $ unsafeUnRL them' 141 with_selected_changes "apply" fixed_opts their_ps $ 142 \ (to_be_applied:>_) -> do 143 print_dry_run_message_and_exit "apply" opts to_be_applied 144 when (nullFL to_be_applied) $ 145 do putStrLn "You don't want to apply any patches, so I'm exiting!" 146 exitWith ExitSuccess 147 check_paths opts to_be_applied 148 redirect_output opts from_whom $ do 149 when am_verbose $ putStrLn "We have the following extra patches:" 150 when am_verbose $ putDocLn $ vcat $ mapRL description $ head $ unsafeUnRL us' 151 when am_verbose $ putStrLn "Will apply the following patches:" 152 when am_verbose $ putDocLn $ vcat $ mapFL description to_be_applied 153 definePatches to_be_applied 154 Sealed pw <- tentativelyMergePatches repository "apply" opts 155 (reverseRL $ head $ unsafeUnRL us') to_be_applied 156 invalidateIndex repository 157 withSignalsBlocked $ do finalizeRepositoryChanges repository 158 wait_a_moment -- so work will be more recent than rec 159 applyToWorking repository opts pw `catch` \e -> 160 fail ("Error applying patch to working dir:\n" ++ show e) 161 sync_repo repository 162 putStrLn "Finished applying..." 163 where fixed_opts = if Interactive `elem` opts 164 then opts 165 else All : opts 166 cannotApplyMissing pinfo 167 = errorDoc $ text "Cannot apply this patch bundle, since we're missing:" 168 $$ human_friendly pinfo 169 cannotApplyPartialRepo pinfo e 170 = errorDoc $ text ("Cannot apply this patch bundle, " 171 ++ "this is a \"--partial repository") 172 $$ text "We don't have the following patch:" 173 $$ human_friendly pinfo $$ text e 174 apply_cmd _ _ = impossible 175 \end{code} 176 177 Darcs apply accepts a single argument, which is the name of the patch 178 file to be applied. If you omit this argument, the patch is read from 179 standard input. Darcs also interprets an argument of `\-' to mean it 180 should read the file from standard input. This allows you to use apply 181 with a pipe from your email program, for example. 182 183 \begin{options} 184 --verify 185 \end{options} 186 187 If you specify the \verb!--verify PUBRING! option, darcs will check that 188 the patch was GPG-signed by a key which is in \verb!PUBRING! and will 189 refuse to apply the patch otherwise. 190 191 \begin{code} 192 get_patch_bundle :: RepoPatch p => [DarcsFlag] -> B.ByteString 193 -> IO (Either String (SealedPatchSet p)) 194 get_patch_bundle opts fps = do 195 mps <- verifyPS opts $ read_email fps 196 mops <- verifyPS opts fps 197 case (mps, mops) of 198 (Nothing, Nothing) -> 199 return $ Left "Patch bundle not properly signed, or gpg failed." 200 (Just ps, Nothing) -> return $ scan_bundle ps 201 (Nothing, Just ps) -> return $ scan_bundle ps 202 -- We use careful_scan_bundle only below because in either of the two 203 -- above case we know the patch was signed, so it really shouldn't 204 -- need stripping of CRs. 205 (Just ps1, Just ps2) -> case careful_scan_bundle ps1 of 206 Left _ -> return $ careful_scan_bundle ps2 207 Right x -> return $ Right x 208 where careful_scan_bundle ps = 209 case scan_bundle ps of 210 Left e -> case scan_bundle $ stripCrPS ps of 211 Right x -> Right x 212 _ -> Left e 213 x -> x 214 stripCrPS :: B.ByteString -> B.ByteString 215 stripCrPS ps = unlinesPS $ map stripline $ linesPS ps 216 stripline p | B.null p = p 217 | BC.last p == '\r' = B.init p 218 | otherwise = p 219 \end{code} 220 221 \begin{options} 222 --cc, --reply 223 \end{options} 224 225 If you give the \verb!--reply FROM! option to \verb!darcs apply!, it will send the 226 results of the application to the sender of the patch. This only works if 227 the patch is in the form of email with its headers intact, so that darcs 228 can actually know the origin of the patch. The reply email will indicate 229 whether or not the patch was successfully applied. The \verb!FROM! flag is 230 the email address that will be used as the ``from'' address when replying. 231 If the darcs apply is being done automatically, it is important that this 232 address not be the same as the address at which the patch was received, in 233 order to avoid automatic email loops. 234 235 If you want to also send the apply email to another address (for example, 236 to create something like a ``commits'' mailing list), you can use the 237 \verb!--cc! option to specify additional recipients. Note that the 238 \verb!--cc! option \emph{requires} the \verb!--reply! option, which 239 provides the ``From'' address. 240 241 The \verb!--reply! feature of apply is intended primarily for two uses. 242 When used by itself, it is handy for when you want to apply patches sent to 243 you by other developers so that they will know when their patch has been 244 applied. For example, in my \verb!.muttrc! (the config file for my mailer) 245 I have: 246 \begin{verbatim} 247 macro pager A "<pipe-entry>darcs apply --verbose \ 248 --reply droundy@abridgegame.org --repodir ~/darcs 249 \end{verbatim} 250 which allows me to apply a patch to darcs directly from my mailer, with the 251 originator of that patch being sent a confirmation when the patch is 252 successfully applied. NOTE: In an attempt to make sure no one else 253 can read your email, mutt seems to set the umask 254 such that patches created with the above macro are not world-readable, so 255 use it with care. 256 257 When used in combination with the \verb!--verify! option, the 258 \verb!--reply! option allows for a nice pushable repository. When these 259 two options are used together, any patches that don't pass the verify will 260 be forwarded to the \verb!FROM! address of the \verb!--reply! option. This 261 allows you to set up a repository so that anyone who is authorized can push 262 to it and have it automatically applied, but if a stranger pushes to it, 263 the patch will be forwarded to you. Please (for your own sake!)\ be certain 264 that the \verb!--reply FROM! address is different from the one used to send 265 patches to a pushable repository, since otherwise an unsigned patch will be 266 forwarded to the repository in an infinite loop. 267 268 If you use \verb!darcs apply --verify PUBRING --reply! to create a 269 pushable repository by applying patches automatically as they are received by 270 email, you will also want to use the \verb!--dont-allow-conflicts! option. 271 272 \begin{options} 273 --dont-allow-conflicts 274 \end{options} 275 The \verb!--dont-allow-conflicts! flag causes apply to fail when applying a 276 patch would cause conflicts. This flag is recommended on repositories 277 which will be pushed to or sent to. 278 279 \begin{options} 280 --allow-conflicts 281 \end{options} 282 283 \verb!--allow-conflicts! will allow conflicts, but will keep the local and 284 recorded versions in sync on the repository. This means the conflict will exist 285 in both locations until it is resolved. 286 287 \begin{options} 288 --mark-conflicts 289 \end{options} 290 291 \verb!--mark-conflicts! will add conflict markers to illustrate the the 292 conflict. 293 294 \begin{options} 295 --external-merge 296 \end{options} 297 298 You can use an external interactive merge tool to resolve conflicts with the 299 flag \verb!--external-merge!. For more details see 300 subsection~\ref{resolution}. 301 302 \begin{options} 303 --all, --interactive 304 \end{options} 305 306 If you provide the \verb!--interactive! flag, darcs will 307 ask you for each change in the patch bundle whether or not you wish to 308 apply that change. The opposite is the \verb!--all! flag, which can be 309 used to override an \verb!interactive! which might be set in your 310 ``defaults'' file. 311 312 \begin{options} 313 --sendmail-command 314 \end{options} 315 316 If you want to use a command different from the default one for sending mail, 317 you need to specify a command line with the \verb!--sendmail-command! option. 318 The command line can contain the format specifier \verb!%t! for to 319 and you can add \verb!%<! to the end of the command line if the command 320 expects the complete mail on standard input. For example, the command line for 321 msmtp looks like this: 322 323 \begin{verbatim} 324 msmtp -t %< 325 \end{verbatim} 326 327 328 \begin{code} 329 get_from :: B.ByteString -> String 330 get_from ps = readFrom $ linesPS ps 331 where readFrom [] = "" 332 readFrom (x:xs) 333 | B.take 5 x == from_start = BC.unpack $ B.drop 5 x 334 | otherwise = readFrom xs 335 336 redirect_output :: [DarcsFlag] -> String -> IO a -> IO a 337 redirect_output opts to doit = ro opts 338 where 339 cc = get_cc opts 340 ro [] = doit 341 ro (Reply f:_) = 342 withStdoutTemp $ \tempf-> do {a <- doit; 343 hClose stdout; 344 hClose stderr; 345 return a; 346 } `catch` (sendit tempf) 347 where sendit tempf e@(ExitException ExitSuccess) = 348 do sendSanitizedEmail opts f to "Patch applied" cc tempf 349 throwIO e 350 sendit tempf (ExitException _) = 351 do sendSanitizedEmail opts f to "Patch failed!" cc tempf 352 throwIO $ ExitException ExitSuccess 353 sendit tempf e = 354 do sendSanitizedEmail opts f to "Darcs error applying patch!" cc $ 355 tempf ++ "\n\nCaught exception:\n"++ 356 show e++"\n" 357 throwIO $ ExitException ExitSuccess 358 ro (_:fs) = ro fs 359 360 -- |sendSanitizedEmail sends a sanitized email using the given sendmailcmd 361 -- It takes @DacrsFlag@ options a file with the mail contents, 362 -- To:, Subject:, CC:, and mail body 363 sendSanitizedEmail :: [DarcsFlag] -> String -> String -> String -> String -> String -> IO () 364 sendSanitizedEmail opts file to subject cc mailtext = 365 do scmd <- get_sendmail_cmd opts 366 body <- sanitizeFile mailtext 367 sendEmail file to subject cc scmd body 368 369 -- sanitizeFile is used to clean up the stdout/stderr before sticking it in 370 -- an email. 371 372 sanitizeFile :: FilePath -> IO String 373 sanitizeFile f = sanitize `fmap` readBinFile f 374 where sanitize s = wash $ remove_backspaces "" s 375 wash ('\000':s) = "\\NUL" ++ wash s 376 wash ('\026':s) = "\\EOF" ++ wash s 377 wash (c:cs) = c : wash cs 378 wash [] = [] 379 remove_backspaces rev_sofar "" = reverse rev_sofar 380 remove_backspaces (_:rs) ('\008':s) = remove_backspaces rs s 381 remove_backspaces "" ('\008':s) = remove_backspaces "" s 382 remove_backspaces rs (s:ss) = remove_backspaces (s:rs) ss 383 384 throwIO :: Exception -> IO a 385 throwIO e = return $ throw e 386 387 forwarding_message :: B.ByteString 388 forwarding_message = BC.pack $ 389 "The following patch was either unsigned, or signed by a non-allowed\n"++ 390 "key, or there was a GPG failure.\n" 391 392 consider_forwarding :: [DarcsFlag] -> B.ByteString -> IO Bool 393 consider_forwarding opts m = cf opts (get_cc opts) 394 where cf [] _ = return False 395 cf (Reply t:_) cc = 396 case break is_from (linesPS m) of 397 (m1, f:m2) -> 398 let m_lines = forwarding_message:m1 ++ m2 399 m' = unlinesPS m_lines 400 f' = BC.unpack (B.drop 5 f) in 401 if t == f' || t == init f' 402 then return False -- Refuse possible email loop. 403 else do 404 scmd <- get_sendmail_cmd opts 405 if HappyForwarding `elem` opts 406 then resendEmail t scmd m 407 else sendEmailDoc f' t "A forwarded darcs patch" cc 408 scmd (Just (empty,empty)) 409 (packedString m') 410 return True 411 _ -> return False -- Don't forward emails lacking headers! 412 cf (_:fs) cc = cf fs cc 413 is_from l = B.take 5 l == from_start 414 415 from_start :: B.ByteString 416 from_start = BC.pack "From:" 417 \end{code} 418 419 \begin{options} 420 --no-test, --test 421 \end{options} 422 423 If you specify the \verb!--test! option, apply will run the test (if a test 424 exists) prior to applying the patch. If the test fails, the patch is not 425 applied. In this case, if the \verb!--reply! option was used, the results 426 of the test are sent in the reply email. You can also specify the 427 \verb!--no-test! option, which will override the \verb!--test! option, and 428 prevent the test from being run. This is helpful when setting up a 429 pushable repository, to keep users from running code. 430 431