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 \darcsCommand{send} 19 \begin{code} 20 {-# OPTIONS_GHC -cpp #-} 21 {-# LANGUAGE CPP #-} 22 23 module Darcs.Commands.Send ( send ) where 24 import Data.Char ( isAlpha, isDigit, isSpace, toLower ) 25 import System.Exit ( exitWith, ExitCode( ExitSuccess ) ) 26 import System.IO.Error ( ioeGetErrorString ) 27 import System.IO ( hClose ) 28 import Control.Monad ( when, unless, forM_ ) 29 import Data.Maybe ( isJust, isNothing ) 30 31 import Darcs.Commands ( DarcsCommand(..) ) 32 import Darcs.Arguments ( DarcsFlag( EditDescription, LogFile, RmLogFile, 33 Target, OutputAutoName, Output, Context, 34 DryRun, Verbose, Quiet, Unified 35 ), 36 fixUrl, definePatches, 37 get_cc, get_author, working_repo_dir, 38 edit_description, logfile, rmlogfile, 39 sign, get_subject, deps_sel, get_in_reply_to, 40 match_several, set_default, output_auto_name, 41 output, cc, subject, target, author, sendmail_cmd, 42 in_reply_to, remote_repo, network_options, 43 all_interactive, get_sendmail_cmd, 44 print_dry_run_message_and_exit, 45 summary, allow_unrelated_repos, 46 from_opt, dry_run, send_to_context, 47 ) 48 import Darcs.Hopefully ( PatchInfoAnd, hopefully, info ) 49 import Darcs.Repository ( PatchSet, Repository, 50 amInRepository, identifyRepositoryFor, withRepoReadLock, ($-), 51 read_repo, slurp_recorded, prefsUrl, checkUnrelatedRepos ) 52 import Darcs.Patch ( RepoPatch, description, apply_to_slurpy, invert ) 53 import Darcs.Ordered ( FL(..), RL(..), (:>)(..), (:\/:)(..), unsafeUnRL, 54 mapRL_RL, mapFL, mapRL, reverseRL, mapFL_FL, lengthFL, nullFL ) 55 import Darcs.Patch.Bundle ( make_bundle, scan_context ) 56 import Darcs.Patch.Info ( just_name ) 57 import Darcs.Repository.Prefs ( defaultrepo, set_defaultrepo, get_preflist ) 58 import Darcs.External ( signString, sendEmailDoc, fetchFilePS, Cachable(..), generateEmail ) 59 import ByteStringUtils ( mmapFilePS ) 60 import qualified Data.ByteString.Char8 as BC (unpack) 61 import Darcs.Lock ( withOpenTemp, writeDocBinFile, readDocBinFile, world_readable_temp, removeFileMayNotExist ) 62 import Darcs.SelectChanges ( with_selected_changes ) 63 import Darcs.Patch.Depends ( get_common_and_uncommon ) 64 import Darcs.Utils ( askUser, catchall, edit_file, formatPath ) 65 import Progress ( debugMessage ) 66 import Darcs.Email ( make_email ) 67 import Printer ( Doc, vsep, vcat, text, ($$), putDocLn, putDoc ) 68 import Darcs.RepoPath ( toFilePath, AbsolutePath, AbsolutePathOrStd, 69 getCurrentDirectory, makeAbsoluteOrStd, useAbsoluteOrStd ) 70 import HTTP ( postUrl ) 71 #include "impossible.h" 72 73 send_description :: String 74 send_description = 75 "Send by email a bundle of one or more patches." 76 77 send_help :: String 78 send_help = 79 "Send is used to prepare a bundle of patches that can be applied to a target\n"++ 80 "repository. Send accepts the URL of the repository as an argument. When\n"++ 81 "called without an argument, send will use the most recent repository that\n"++ 82 "was either pushed to, pulled from or sent to. By default, the patch bundle\n"++ 83 "is sent by email, although you may save it to a file.\n" 84 \end{code} 85 86 Do not confuse the \verb!--author! options with the return address 87 that \verb!darcs send! will set for your patch bundle. 88 89 For example, if you have two email addresses A and B: 90 \begin{description} 91 \item If you use 92 \verb!--author A! but your machine is configured to send mail from 93 address B by default, then the return address on your message will be B. 94 95 \item If you use \verb!--from A! and your mail client supports setting the 96 From: address arbitrarily (some non-Unix-like mail clients, especially, 97 may not support this), then the return address will be A; if it does 98 not support this, then the return address will be B. 99 100 \item If you supply neither \verb!--from! nor \verb!--author!, then the return 101 address will be B. 102 \end{description} 103 104 In addition, unless you specify the sendmail command with 105 \verb!--sendmail-command!, darcs sends email using the default email 106 command on your computer. This default command is determined by the 107 \verb!configure! script. Thus, on some non-Unix-like OSes, 108 \verb!--from! is likely to not work at all. 109 110 \begin{code} 111 send :: DarcsCommand 112 send = DarcsCommand {command_name = "send", 113 command_help = send_help, 114 command_description = send_description, 115 command_extra_args = 1, 116 command_extra_arg_help = ["[REPOSITORY]"], 117 command_command = send_cmd, 118 command_prereq = amInRepository, 119 command_get_arg_possibilities = get_preflist "repos", 120 command_argdefaults = defaultrepo, 121 command_advanced_options = [logfile, rmlogfile, 122 remote_repo, 123 send_to_context] ++ 124 network_options, 125 command_basic_options = [match_several, deps_sel, 126 all_interactive, 127 from_opt, author, 128 target,cc,subject, in_reply_to, 129 output,output_auto_name,sign] 130 ++dry_run++[summary, 131 edit_description, 132 set_default, working_repo_dir, 133 sendmail_cmd, 134 allow_unrelated_repos]} 135 136 send_cmd :: [DarcsFlag] -> [String] -> IO () 137 send_cmd input_opts [""] = send_cmd input_opts [] 138 send_cmd input_opts [unfixedrepodir] = withRepoReadLock input_opts $- \repository -> do 139 context_ps <- the_context input_opts 140 case context_ps of 141 Just them -> send_to_them repository input_opts [] "CONTEXT" them 142 Nothing -> do 143 repodir <- fixUrl input_opts unfixedrepodir 144 -- Test to make sure we aren't trying to push to the current repo 145 here <- getCurrentDirectory 146 when (repodir == toFilePath here) $ 147 fail ("Can't send to current repository! Did you mean send -"++"-context?") 148 repo <- identifyRepositoryFor repository repodir 149 them <- read_repo repo 150 old_default <- get_preflist "defaultrepo" 151 set_defaultrepo repodir input_opts 152 when (old_default == [repodir] && not (Quiet `elem` input_opts)) $ 153 putStrLn $ "Creating patch to "++formatPath repodir++"..." 154 wtds <- decide_on_behavior input_opts repo 155 send_to_them repository input_opts wtds repodir them 156 where the_context [] = return Nothing 157 the_context (Context foo:_) 158 = (Just . scan_context )`fmap` mmapFilePS (toFilePath foo) 159 the_context (_:fs) = the_context fs 160 send_cmd _ _ = impossible 161 162 send_to_them :: RepoPatch p => Repository p -> [DarcsFlag] -> [WhatToDo] -> String -> PatchSet p -> IO () 163 send_to_them repo opts wtds their_name them = do 164 let am_verbose = Verbose `elem` opts 165 am_quiet = Quiet `elem` opts 166 putVerbose s = when am_verbose $ putDocLn s 167 putInfo s = when (not am_quiet) $ putStrLn s 168 patch_desc p = just_name $ info p 169 make_fname tbs = patch_filename $ patch_desc $ headFL tbs 170 headFL (x:>:_) = x 171 headFL _ = impossible 172 us <- read_repo repo 173 case get_common_and_uncommon (us, them) of 174 (common, us' :\/: _) -> do 175 checkUnrelatedRepos opts common us them 176 case us' of 177 NilRL:<:NilRL -> do putInfo "No recorded local changes to send!" 178 exitWith ExitSuccess 179 _ -> putVerbose $ text "We have the following patches to send:" 180 $$ (vcat $ mapRL description $ head $ unsafeUnRL us') 181 s <- slurp_recorded repo 182 let our_ps = reverseRL $ head $ unsafeUnRL us' 183 with_selected_changes "send" opts our_ps $ 184 \ (to_be_sent :> _) -> do 185 print_dry_run_message_and_exit "send" opts to_be_sent 186 when (nullFL to_be_sent) $ do 187 putInfo "You don't want to send any patches, and that's fine with me!" 188 exitWith ExitSuccess 189 definePatches to_be_sent 190 bundle <- signString opts $ make_bundle (Unified:opts) 191 (fromJust $ apply_to_slurpy 192 (invert $ 193 mapRL_RL hopefully $ head $ unsafeUnRL us') s) 194 common (mapFL_FL hopefully to_be_sent) 195 let outname = get_output opts (make_fname to_be_sent) 196 case outname of 197 Just fname -> do (d,f) <- get_description opts to_be_sent 198 let putabs a = do writeDocBinFile a (d $$ bundle) 199 putStrLn $ "Wrote patch to " ++ toFilePath a ++ "." 200 putstd = putDoc (d $$ bundle) 201 useAbsoluteOrStd putabs putstd fname 202 cleanup f 203 Nothing -> 204 let 205 auto_subject (p:>:NilFL) = "darcs patch: " ++ trim (patch_desc p) 57 206 auto_subject (p:>:ps) = "darcs patch: " ++ trim (patch_desc p) 43 ++ 207 " (and " ++ show (lengthFL ps) ++ " more)" 208 auto_subject _ = error "Tried to get a name from empty patch list." 209 trim st n = if length st <= n then st 210 else take (n-3) st ++ "..." 211 in do 212 thetargets <- get_targets wtds 213 from <- get_author opts 214 let thesubject = case get_subject opts of 215 Nothing -> auto_subject to_be_sent 216 Just subj -> subj 217 (mailcontents, mailfile) <- get_description opts to_be_sent 218 let body = make_email their_name 219 (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . get_in_reply_to $ opts) 220 (Just mailcontents) 221 bundle 222 (Just $ make_fname to_be_sent) 223 contentAndBundle = Just (mailcontents, bundle) 224 225 sendmail = do 226 sm_cmd <- get_sendmail_cmd opts 227 (sendEmailDoc from (lt [t | SendMail t <- thetargets]) (thesubject) (get_cc opts) 228 sm_cmd contentAndBundle body >> 229 putInfo ("Successfully sent patch bundle to: " 230 ++ lt [ t | SendMail t <- thetargets ] 231 ++ ccs (get_cc opts) ++".")) 232 `catch` \e -> let msg = "Email body left in " in 233 do case mailfile of 234 Just mf -> putStrLn $ msg++mf++"." 235 Nothing -> return () 236 fail $ ioeGetErrorString e 237 ccs [] = [] 238 ccs cs = " and cc'ed " ++ cs 239 240 when (null [ p | Post p <- thetargets]) sendmail 241 nbody <- withOpenTemp $ \ (fh,fn) -> do 242 generateEmail fh from (lt [t | SendMail t <- thetargets]) thesubject (get_cc opts) body 243 hClose fh 244 mmapFilePS fn 245 forM_ [ p | Post p <- thetargets] 246 (\url -> do 247 putInfo $ "Posting patch to " ++ url 248 postUrl url (BC.unpack nbody) "message/rfc822") 249 `catch` const sendmail 250 cleanup mailfile 251 252 where cleanup (Just mailfile) = when (isNothing (get_fileopt opts) || (RmLogFile `elem` opts)) $ 253 removeFileMayNotExist mailfile 254 cleanup Nothing = return () 255 lt [t] = t 256 lt [t,""] = t 257 lt (t:ts) = t++" , "++lt ts 258 lt [] = "" 259 260 safeFileChar :: Char -> Char 261 safeFileChar c | isAlpha c = toLower c 262 | isDigit c = c 263 | isSpace c = '-' 264 safeFileChar _ = '_' 265 266 patch_filename :: String -> String 267 patch_filename the_summary = name ++ ".dpatch" 268 where name = map safeFileChar the_summary 269 \end{code} 270 271 \begin{options} 272 --output, --to, --cc 273 \end{options} 274 275 The \verb!--output!, \verb!--output-auto-name!, and \verb!--to! flags determine 276 what darcs does with the patch bundle after creating it. If you provide an 277 \verb!--output! argument, the patch bundle is saved to that file. If you 278 specify \verb!--output-auto-name!, the patch bundle is saved to a file with an 279 automatically generated name. If you give one or more \verb!--to! arguments, 280 the bundle of patches is sent to those locations. The locations may either be email 281 addresses or urls that the patch should be submitted to via HTTP. 282 283 If you don't provide any of these options, darcs will look at the contents of 284 the \verb!_darcs/prefs/email! file in the target repository (if it exists), and 285 send the patch by email to that address. In this case, you may use the 286 \verb!--cc! option to specify additional recipients without overriding the 287 default repository email address. 288 289 If \texttt{\_darcs/prefs/post} exists in the target repository, darcs will 290 upload to the URL contained in that file, which may either be a 291 \texttt{mailto:} URL, or an \texttt{http://} URL. In the latter case, the 292 patch is posted to that URL. 293 294 If there is no email address associated with the repository, darcs will 295 prompt you for an email address. 296 297 \begin{options} 298 --subject 299 \end{options} 300 301 Use the \verb!--subject! flag to set the subject of the e-mail to be sent. 302 If you don't provide a subject on the command line, darcs will make one up 303 based on names of the patches in the patch bundle. 304 305 \begin{options} 306 --in-reply-to 307 \end{options} 308 309 Use the \verb!--in-reply-to! flag to set the In-Reply-To and References headers 310 of the e-mail to be sent. By default no additional headers are included so e-mail 311 will not be treated as reply by mail readers. 312 313 \begin{code} 314 315 data WhatToDo 316 = Post String -- ^ POST the patch via HTTP 317 | SendMail String -- ^ send patch via email 318 319 320 decide_on_behavior :: RepoPatch p => [DarcsFlag] -> Repository p -> IO [WhatToDo] 321 decide_on_behavior opts the_remote_repo = 322 case the_targets of 323 [] -> 324 if isJust $ get_output opts "" 325 then return [] 326 else 327 do wtds <- check_post 328 unless (null wtds) $ announce_recipients wtds 329 return wtds 330 ts -> do announce_recipients ts 331 return ts 332 where the_targets = collect_targets opts 333 #ifdef HAVE_HTTP 334 -- the ifdef above is to so that darcs only checks the remote 335 -- _darcs/post if we have an implementation of postUrl. See 336 -- our HTTP module for more details 337 check_post = do p <- ((readPost . BC.unpack) `fmap` 338 fetchFilePS (prefsUrl the_remote_repo++"/post") 339 (MaxAge 600)) `catchall` return [] 340 emails <- who_to_email 341 return (p++emails) 342 readPost p = map pp (lines p) where 343 pp ('m':'a':'i':'l':'t':'o':':':s) = SendMail s 344 pp s = Post s 345 #else 346 check_post = who_to_email 347 #endif 348 who_to_email = 349 do email <- (BC.unpack `fmap` 350 fetchFilePS (prefsUrl the_remote_repo++"/email") 351 (MaxAge 600)) 352 `catchall` return "" 353 if '@' `elem` email then return . map SendMail $ lines email 354 else return [] 355 putInfoLn s = unless (Quiet `elem` opts) $ putStrLn s 356 announce_recipients emails = 357 let pn (SendMail s) = s 358 pn (Post p) = p 359 in if DryRun `elem` opts 360 then putInfoLn $ "Patch bundle would be sent to: "++unwords (map pn emails) 361 else when (null the_targets) $ 362 putInfoLn $ "Patch bundle will be sent to: "++unwords (map pn emails) 363 364 get_output :: [DarcsFlag] -> FilePath -> Maybe AbsolutePathOrStd 365 get_output (Output a:_) _ = return a 366 get_output (OutputAutoName a:_) f = return $ makeAbsoluteOrStd a f 367 get_output (_:flags) f = get_output flags f 368 get_output [] _ = Nothing 369 370 get_targets :: [WhatToDo] -> IO [WhatToDo] 371 get_targets [] = do fmap ((:[]) . SendMail) $ askUser "What is the target email address? " 372 get_targets wtds = return wtds 373 374 collect_targets :: [DarcsFlag] -> [WhatToDo] 375 collect_targets flags = [ f t | Target t <- flags ] where 376 f url@('h':'t':'t':'p':':':_) = Post url 377 f em = SendMail em 378 379 380 \end{code} 381 382 \begin{options} 383 --matches, --patches, --tags, --no-deps 384 \end{options} 385 386 The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps! 387 options can be used to select which patches to send, as described in 388 subsection~\ref{selecting}. 389 390 \begin{options} 391 --edit-description 392 \end{options} 393 394 If you want to include a description or explanation along with the bundle 395 of patches, you need to specify the \verb!--edit-description! flag, which 396 will cause darcs to open up an editor with which you can compose a message 397 to go along with your patches. 398 399 \begin{options} 400 --sendmail-command 401 \end{options} 402 403 If you want to use a command different from the default one for sending email, 404 you need to specify a command line with the \verb!--sendmail-command! option. The 405 command line can contain some format specifiers which are replaced by the actual 406 values. Accepted format specifiers are \verb!%s! for subject, \verb!%t! for to, 407 \verb!%c! for cc, \verb!%b! for the body of the mail, \verb!%f! for from, \verb!%a! 408 for the patch bundle and the same specifiers in uppercase for the URL-encoded values. 409 Additionally you can add \verb!%<! to the end of the command line if the command 410 expects the complete email message on standard input. E.g.\ the command lines for evolution 411 and msmtp look like this: 412 413 \begin{verbatim} 414 evolution "mailto:%T?subject=%S&attach=%A&cc=%C&body=%B" 415 msmtp -t %< 416 \end{verbatim} 417 418 \begin{code} 419 get_description :: RepoPatch p => [DarcsFlag] -> FL (PatchInfoAnd p) -> IO (Doc, Maybe String) 420 get_description opts patches = 421 case get_filename of 422 Just f -> do file <- f 423 when (EditDescription `elem` opts) $ do 424 when (isNothing $ get_fileopt opts) $ 425 writeDocBinFile file patchdesc 426 debugMessage $ "About to edit file " ++ file 427 edit_file file 428 return () 429 doc <- readDocBinFile file 430 return (doc, Just file) 431 Nothing -> return (patchdesc, Nothing) 432 where patchdesc = vsep $ mapFL description patches 433 get_filename = case get_fileopt opts of 434 Just f -> Just $ return $ toFilePath f 435 Nothing -> if EditDescription `elem` opts 436 then Just tempfile 437 else Nothing 438 tempfile = world_readable_temp "darcs-temp-mail" 439 440 get_fileopt :: [DarcsFlag] -> Maybe AbsolutePath 441 get_fileopt (LogFile f:_) = Just f 442 get_fileopt (_:flags) = get_fileopt flags 443 get_fileopt [] = Nothing 444 \end{code}