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