-- 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. {-# LANGUAGE CPP, TypeOperators, OverloadedStrings #-} module Darcs.UI.Commands.Send ( send ) where import Prelude () import Darcs.Prelude import System.Exit ( exitSuccess #ifndef HAVE_MAPI , ExitCode ( ExitFailure ) , exitWith #endif ) import System.IO.Error ( ioeGetErrorString ) import System.IO ( hClose ) import Control.Exception ( catch, IOException ) import Control.Monad ( when, unless, forM_ ) import Darcs.Util.Tree ( Tree ) import Data.List ( intercalate, isPrefixOf ) import Data.List ( stripPrefix ) import Data.Maybe ( isNothing, fromMaybe ) import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts , putInfo , putVerbose , setEnvDarcsPatches , defaultRepo , amInHashedRepository ) import Darcs.UI.Commands.Util ( printDryRunMessageAndExit, checkUnrelatedRepos ) import Darcs.UI.Flags ( DarcsFlag , willRemoveLogFile, changesReverse, dryRun, useCache, remoteRepos, setDefault , fixUrl , getCc , getAuthor , getSubject , getInReplyTo , getSendmailCmd , getOutput , charset , verbosity , isInteractive , author , hasLogfile , selectDeps , minimize , editDescription ) import Darcs.UI.Options ( (^), odesc, ocheck, onormalise , defaultFlags, parseFlags, (?) ) import qualified Darcs.UI.Options.All as O import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, patchDesc ) import Darcs.Repository ( Repository , repoLocation , PatchSet , identifyRepositoryFor , withRepository , RepoJob(..) , readRepo , readRecorded , prefsUrl ) import Darcs.Patch.Set ( Origin ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch ( IsRepoType, RepoPatch, description, applyToTree, invert ) import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), mapFL, mapFL_FL, lengthFL, nullFL ) import Darcs.Patch.Bundle ( minContext, makeBundleN, scanContextFile, patchFilename ) import Darcs.Repository.Prefs ( addRepoSource, getPreflist ) import Darcs.Repository.Flags ( DryRun(..) ) import Darcs.Util.External ( fetchFilePS, Cachable(..) ) import Darcs.UI.External ( signString , sendEmailDoc , generateEmail , editFile , catchall , getSystemEncoding , isUTF8Locale #ifndef HAVE_MAPI , haveSendmail #endif ) import Darcs.Util.ByteString ( mmapFilePS, isAscii ) import qualified Data.ByteString.Char8 as BC (unpack) import Darcs.Util.Lock ( withOpenTemp , writeDocBinFile , readDocBinFile , removeFileMayNotExist ) import Darcs.UI.SelectChanges ( WhichChanges(..) , selectionContext , runSelection ) import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) ) import Darcs.Patch.Depends ( findCommonWithThem ) import Darcs.Util.Prompt ( askUser, promptYorn ) import Data.Text.Encoding ( decodeUtf8' ) import Darcs.Util.Progress ( debugMessage ) import Darcs.UI.Email ( makeEmail ) import Darcs.UI.Completion ( prefArgs ) import Darcs.Util.Printer ( Doc, vsep, text, ($$), (<+>), putDoc, putDocLn , renderPS, vcat ) import Darcs.Util.English ( englishNum, Noun(..) ) import Darcs.Util.Text ( sentence, quote ) import Darcs.Util.Path ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd, getCurrentDirectory, useAbsoluteOrStd, makeAbsoluteOrStd ) import Darcs.Util.Download.HTTP ( postUrl ) import Darcs.Util.Workaround ( renameFile ) import Darcs.Util.Global ( darcsSendMessage, darcsSendMessageFinal ) import Darcs.Util.SignalHandler ( catchInterrupt ) patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions patchSelOpts flags = S.PatchSelectionOptions { S.verbosity = verbosity ? flags , S.matchFlags = parseFlags O.matchSeveral flags , S.interactive = isInteractive True flags , S.selectDeps = selectDeps ? flags , S.summary = O.summary ? flags , S.withContext = O.NoContext } send :: DarcsCommand [DarcsFlag] send = DarcsCommand { commandProgramName = "darcs" , commandName = "send" , commandHelp = cmdHelp , commandDescription = cmdDescription , commandExtraArgs = 1 , commandExtraArgHelp = ["[REPOSITORY]"] , commandCommand = sendCmd , commandPrereq = amInHashedRepository , commandCompleteArgs = prefArgs "repos" , commandArgdefaults = defaultRepo , commandAdvancedOptions = odesc sendAdvancedOpts , commandBasicOptions = odesc sendBasicOpts , commandDefaults = defaultFlags sendOpts , commandCheckOptions = ocheck sendOpts , commandParseOptions = onormalise sendOpts } where sendBasicOpts = O.matchSeveral ^ O.selectDeps ^ O.interactive -- True ^ O.headerFields ^ O.author ^ O.charset ^ O.sendmail ^ O.output ^ O.sign ^ O.dryRunXml ^ O.summary ^ O.editDescription ^ O.setDefault ^ O.repoDir ^ O.minimize ^ O.allowUnrelatedRepos sendAdvancedOpts = O.logfile ^ O.remoteRepos ^ O.sendToContext ^ O.changesReverse ^ O.network sendOpts = sendBasicOpts `withStdOpts` sendAdvancedOpts sendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO () sendCmd fps opts [""] = sendCmd fps opts [] sendCmd (_,o) opts [unfixedrepodir] = withRepository (useCache ? opts) $ RepoJob $ \(repository :: Repository rt p wR wU wR) -> do context_ps <- the_context (O.sendToContext ? opts) case context_ps of Just them -> do wtds <- decideOnBehavior opts (Nothing :: Maybe (Repository rt p wR wU wR)) sendToThem repository opts wtds "CONTEXT" them Nothing -> do repodir <- fixUrl o unfixedrepodir -- Test to make sure we aren't trying to push to the current repo here <- getCurrentDirectory when (repodir == toFilePath here) $ fail cannotSendToSelf old_default <- getPreflist "defaultrepo" when (old_default == [repodir]) $ putInfo opts (creatingPatch repodir) repo <- identifyRepositoryFor repository (useCache ? opts) repodir them <- readRepo repo addRepoSource repodir (dryRun ? opts) (remoteRepos ? opts) (setDefault False opts) wtds <- decideOnBehavior opts (Just repo) sendToThem repository opts wtds repodir them where the_context Nothing = return Nothing the_context (Just foo) = Just `fmap` scanContextFile (toFilePath foo) sendCmd _ _ _ = impossible sendToThem :: (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) => Repository rt p wR wU wT -> [DarcsFlag] -> [WhatToDo] -> String -> PatchSet rt p Origin wX -> IO () sendToThem repo opts wtds their_name them = do #ifndef HAVE_MAPI when (fst (O.sendmail ? opts) && dryRun ? opts == O.NoDryRun) $ do -- If --mail is used, check if the user has sendmail or -- provided a --sendmail-cmd sendmail <- haveSendmail sm_cmd <- getSendmailCmd opts when (not sendmail && sm_cmd == "") $ do putInfo opts noWorkingSendmail exitWith $ ExitFailure 1 #endif us <- readRepo repo common :> us' <- return $ findCommonWithThem us them checkUnrelatedRepos (O.allowUnrelatedRepos ? opts) us them case us' of NilFL -> do putInfo opts nothingSendable exitSuccess _ -> putVerbose opts $ selectionIs (mapFL description us') pristine <- readRecorded repo let direction = if changesReverse ? opts then FirstReversed else First context = selectionContext direction "send" (patchSelOpts opts) Nothing Nothing (to_be_sent :> _) <- runSelection us' context printDryRunMessageAndExit "send" (verbosity ? opts) (O.summary ? opts) (dryRun ? opts) O.NoXml (isInteractive True opts) to_be_sent when (nullFL to_be_sent) $ do putInfo opts selectionIsNull exitSuccess setEnvDarcsPatches to_be_sent let genFullBundle = prepareBundle opts common (Right (pristine, us':\/:to_be_sent)) bundle <- if not (minimize ? opts) then genFullBundle else do putInfo opts "Minimizing context, to send with full context hit ctrl-C..." ( case minContext common to_be_sent of Sealed (common' :> to_be_sent') -> prepareBundle opts common' (Left to_be_sent') ) `catchInterrupt` genFullBundle here <- getCurrentDirectory let make_fname (tb:>:_) = patchFilename $ patchDesc tb make_fname _ = impossible fname = make_fname to_be_sent outname = case getOutput opts fname of Just f -> Just f Nothing | fst (O.sendmail ? opts) -> Nothing | not $ null [ p | Post p <- wtds] -> Nothing | otherwise -> Just (makeAbsoluteOrStd here fname) case outname of Just fname' -> writeBundleToFile opts to_be_sent bundle fname' wtds their_name Nothing -> sendBundle opts to_be_sent bundle fname wtds their_name prepareBundle :: forall rt p wX wY wZ. (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> PatchSet rt p Origin wZ -> Either (FL (PatchInfoAnd rt p) wX wY) (Tree IO, (FL (PatchInfoAnd rt p) :\/: FL (PatchInfoAnd rt p)) wX wY) -> IO Doc prepareBundle opts common e = do unsig_bundle <- case e of (Right (pristine, us' :\/: to_be_sent)) -> do pristine' <- applyToTree (invert $ mapFL_FL hopefully us') pristine makeBundleN (Just pristine') (unsafeCoerceP common) (mapFL_FL hopefully to_be_sent) Left to_be_sent -> makeBundleN Nothing (unsafeCoerceP common) (mapFL_FL hopefully to_be_sent) signString (parseFlags O.sign opts) unsig_bundle sendBundle :: forall rt p wX wY . (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> FL (PatchInfoAnd rt p) wX wY -> Doc -> String -> [WhatToDo] -> String -> IO () sendBundle opts to_be_sent bundle fname wtds their_name= let auto_subject :: forall pp wA wB . FL (PatchInfoAnd rt pp) wA wB -> String auto_subject (p:>:NilFL) = "darcs patch: " ++ trim (patchDesc p) 57 auto_subject (p:>:ps) = "darcs patch: " ++ trim (patchDesc p) 43 ++ " (and " ++ show (lengthFL ps) ++ " more)" auto_subject _ = error "Tried to get a name from empty patch list." trim st n = if length st <= n then st else take (n-3) st ++ "..." in do thetargets <- getTargets wtds from <- getAuthor (author ? opts) False let thesubject = fromMaybe (auto_subject to_be_sent) $ getSubject opts (mailcontents, mailfile, mailcharset) <- getDescription opts their_name to_be_sent let warnMailBody = case mailfile of Just mf -> putDocLn $ emailBackedUp mf Nothing -> return () warnCharset msg = do confirmed <- promptYorn $ promptCharSetWarning msg unless confirmed $ do putDocLn charsetAborted warnMailBody exitSuccess thecharset <- case charset ? opts of -- Always trust provided charset providedCset@(Just _) -> return providedCset Nothing -> case mailcharset of Nothing -> do warnCharset charsetCouldNotGuess return mailcharset Just "utf-8" -> do -- Check the locale encoding for consistency encoding <- getSystemEncoding debugMessage $ currentEncodingIs encoding unless (isUTF8Locale encoding) $ warnCharset charsetUtf8MailDiffLocale return mailcharset -- Trust other cases (us-ascii) Just _ -> return mailcharset let body = makeEmail their_name (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . getInReplyTo $ opts) (Just mailcontents) thecharset bundle (Just fname) contentAndBundle = Just (mailcontents, bundle) sendmail = do sm_cmd <- getSendmailCmd opts let to = generateEmailToString thetargets sendEmailDoc from to thesubject (getCc opts) sm_cmd contentAndBundle body >> putInfo opts (success to (getCc opts)) `catch` \e -> do warnMailBody fail $ ioeGetErrorString e when (null [ p | Post p <- thetargets]) sendmail nbody <- withOpenTemp $ \ (fh,fn) -> do let to = generateEmailToString thetargets generateEmail fh from to thesubject (getCc opts) body hClose fh mmapFilePS fn forM_ [ p | Post p <- thetargets] (\url -> do putInfo opts $ postingPatch url postUrl url (BC.unpack nbody) "message/rfc822") `catch` (\(_ :: IOException) -> sendmail) cleanup opts mailfile generateEmailToString :: [WhatToDo] -> String generateEmailToString = intercalate " , " . filter (/= "") . map extractEmail where extractEmail (SendMail t) = t extractEmail _ = "" cleanup :: (FilePathLike t) => [DarcsFlag] -> Maybe t -> IO () cleanup opts (Just mailfile) = when (isNothing (hasLogfile opts) || willRemoveLogFile opts) $ removeFileMayNotExist mailfile cleanup _ Nothing = return () writeBundleToFile :: forall rt p wX wY . (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> FL (PatchInfoAnd rt p) wX wY -> Doc -> AbsolutePathOrStd -> [WhatToDo] -> String -> IO () writeBundleToFile opts to_be_sent bundle fname wtds their_name = do (d,f,_) <- getDescription opts their_name to_be_sent let putabs a = do writeDocBinFile a (d $$ bundle) putDocLn (wroteBundle a) putstd = putDoc (d $$ bundle) useAbsoluteOrStd putabs putstd fname let to = generateEmailToString wtds unless (null to) $ putInfo opts $ savedButNotSent to cleanup opts f data WhatToDo = Post String -- ^ POST the patch via HTTP | SendMail String -- ^ send patch via email decideOnBehavior :: [DarcsFlag] -> Maybe (Repository rt p wR wU wT) -> IO [WhatToDo] decideOnBehavior opts remote_repo = case the_targets of [] -> do wtds <- case remote_repo of Nothing -> return [] Just r -> check_post r unless (null wtds) $ announce_recipients wtds return wtds ts -> do announce_recipients ts return ts where the_targets = collectTargets opts check_post the_remote_repo = do p <- ((readPost . BC.unpack) `fmap` fetchFilePS (prefsUrl (repoLocation the_remote_repo) ++ "/post") (MaxAge 600)) `catchall` return [] emails <- who_to_email the_remote_repo return (p++emails) readPost = map parseLine . lines where parseLine t = maybe (Post t) SendMail $ stripPrefix "mailto:" t who_to_email repo = do email <- (BC.unpack `fmap` fetchFilePS (prefsUrl (repoLocation repo) ++ "/email") (MaxAge 600)) `catchall` return "" if '@' `elem` email then return . map SendMail $ lines email else return [] announce_recipients emails = let pn (SendMail s) = s pn (Post p) = p msg = willSendTo (dryRun ? opts) (map pn emails) in case dryRun ? opts of O.YesDryRun -> putInfo opts msg O.NoDryRun -> when (null the_targets && isNothing (getOutput opts "")) $ putInfo opts msg getTargets :: [WhatToDo] -> IO [WhatToDo] getTargets [] = fmap ((:[]) . SendMail) $ askUser promptTarget getTargets wtds = return wtds collectTargets :: [DarcsFlag] -> [WhatToDo] collectTargets flags = [ f t | t <- O._to (O.headerFields ? flags) ] where f url | "http:" `isPrefixOf` url = Post url f em = SendMail em getDescription :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> String -> FL (PatchInfoAnd rt p) wX wY -> IO (Doc, Maybe String, Maybe String) getDescription opts their_name patches = case get_filename of Just file -> do when (editDescription ? opts) $ do when (isNothing $ hasLogfile opts) $ writeDocBinFile file patchdesc debugMessage $ aboutToEdit file (_, changed) <- editFile file unless changed $ do confirmed <- promptYorn promptNoDescriptionChange unless confirmed $ do putDocLn aborted exitSuccess return () updatedFile <- updateFilename file doc <- readDocBinFile updatedFile return (doc, Just updatedFile, tryGetCharset doc) Nothing -> return (patchdesc, Nothing, tryGetCharset patchdesc) where patchdesc = text (show len) <+> text (englishNum len (Noun "patch") "") <+> text "for repository" <+> text their_name <> text ":" $$ text "" $$ vsep (mapFL description patches) where len = lengthFL patches updateFilename file = maybe (renameFile file darcsSendMessageFinal >> return darcsSendMessageFinal) (return . toFilePath) $ hasLogfile opts get_filename = case hasLogfile opts of Just f -> Just $ toFilePath f Nothing -> if editDescription ? opts then Just darcsSendMessage else Nothing tryGetCharset content = let body = renderPS content in if isAscii body then Just "us-ascii" else either (const Nothing) (const $ Just "utf-8") (decodeUtf8' body) cmdDescription :: String cmdDescription = "Prepare a bundle of patches to be applied to some target repository." cmdHelp :: String cmdHelp = unlines [ "Send is used to prepare a bundle of patches that can be applied to a target" , "repository. Send accepts the URL of the repository as an argument. When" , "called without an argument, send will use the most recent repository that" , "was either pushed to, pulled from or sent to. By default, the patch bundle" , "is saved to a file, although you may directly send it by mail." , "" , "The `--output`, `--output-auto-name`, and `--to` flags determine" , "what darcs does with the patch bundle after creating it. If you provide an" , "`--output` argument, the patch bundle is saved to that file. If you" , "specify `--output-auto-name`, the patch bundle is saved to a file with an" , "automatically generated name. If you give one or more `--to` arguments," , "the bundle of patches is sent to those locations. The locations may either" , "be email addresses or urls that the patch should be submitted to via HTTP." , "" , "If you provide the `--mail` flag, darcs will look at the contents" , "of the `_darcs/prefs/email` file in the target repository (if it exists)," , "and send the patch by email to that address. In this case, you may use" , "the `--cc` option to specify additional recipients without overriding the" , "default repository email address." , "" , "If `_darcs/prefs/post` exists in the target repository, darcs will" , "upload to the URL contained in that file, which may either be a" , "`mailto:` URL, or an `http://` URL. In the latter case, the" , "patch is posted to that URL." , "" , "If there is no email address associated with the repository, darcs will" , "prompt you for an email address." , "" , "Use the `--subject` flag to set the subject of the e-mail to be sent." , "If you don't provide a subject on the command line, darcs will make one up" , "based on names of the patches in the patch bundle." , "" , "Use the `--in-reply-to` flag to set the In-Reply-To and References headers" , "of the e-mail to be sent. By default no additional headers are included so" , "e-mail will not be treated as reply by mail readers." , "" , "If you want to include a description or explanation along with the bundle" , "of patches, you need to specify the `--edit-description` flag, which" , "will cause darcs to open up an editor with which you can compose a message" , "to go along with your patches." , "" , "If you want to use a command different from the default one for sending" , "email, you need to specify a command line with the `--sendmail-command`" , "option. The command line can contain some format specifiers which are" , "replaced by the actual values. Accepted format specifiers are `%s` for" , "subject, `%t` for to, `%c` for cc, `%b` for the body of the mail, `%f` for" , "from, `%a` for the patch bundle and the same specifiers in uppercase for the" , "URL-encoded values." , "Additionally you can add `%<` to the end of the command line if the command" , "expects the complete email message on standard input. E.g. the command lines" , "for evolution and msmtp look like this:" , "" , " evolution \"mailto:%T?subject=%S&attach=%A&cc=%C&body=%B\"" , " msmtp -t %<" , "" , "Do not confuse the `--author` options with the return address" , "that `darcs send` will set for your patch bundle." , "" , "For example, if you have two email addresses A and B:" , "" , "* If you use `--author A` but your machine is configured to send mail from" , " address B by default, then the return address on your message will be B." , "* If you use `--from A` and your mail client supports setting the" , " From: address arbitrarily (some non-Unix-like mail clients, especially," , " may not support this), then the return address will be A; if it does" , " not support this, then the return address will be B." , "* If you supply neither `--from` nor `--author` then the return" , " address will be B." , "" , "In addition, unless you specify the sendmail command with" , "`--sendmail-command`, darcs sends email using the default email" , "command on your computer. This default command is determined by the" , "`configure` script. Thus, on some non-Unix-like OSes," , "`--from` is likely to not work at all." ] cannotSendToSelf :: String cannotSendToSelf = "Can't send to current repository! Did you mean send --context?" creatingPatch :: String -> Doc creatingPatch repodir = "Creating patch to" <+> text (quote repodir) <> "..." noWorkingSendmail :: Doc noWorkingSendmail = "No working sendmail instance on your machine!" nothingSendable :: Doc nothingSendable = "No recorded local changes to send!" selectionIs :: [Doc] -> Doc selectionIs descs = text "We have the following patches to send:" $$ vcat descs selectionIsNull :: Doc selectionIsNull = text "You don't want to send any patches, and that's fine with me!" emailBackedUp :: String -> Doc emailBackedUp mf = sentence $ "Email body left in" <+> text mf promptCharSetWarning :: String -> String promptCharSetWarning msg = "Warning: " ++ msg ++ " Send anyway?" charsetAborted :: Doc charsetAborted = "Aborted. You can specify charset with the --charset option." charsetCouldNotGuess :: String charsetCouldNotGuess = "darcs could not guess the charset of your mail." currentEncodingIs :: String -> String currentEncodingIs e = "Current locale encoding: " ++ e charsetUtf8MailDiffLocale :: String charsetUtf8MailDiffLocale = "your mail is valid UTF-8 but your locale differs." aborted :: Doc aborted = "Aborted." success :: String -> String -> Doc success to cc = sentence $ "Successfully sent patch bundle to:" <+> text to <+> copies cc where copies "" = "" copies x = "and cc'ed" <+> text x postingPatch :: String -> Doc postingPatch url = "Posting patch to" <+> text url wroteBundle :: FilePathLike a => a -> Doc wroteBundle a = sentence $ "Wrote patch to" <+> text (toFilePath a) savedButNotSent :: String -> Doc savedButNotSent to = text ("The usual recipent for this bundle is: " ++ to) $$ text "To send it automatically, make sure sendmail is working," <+> text "and add 'send mail' to _darcs/prefs/defaults or" <+> text " ~/.darcs/defaults" willSendTo :: DryRun -> [String] -> Doc willSendTo dr addresses = "Patch bundle" <+> will <+> " be sent to:" <+> text (unwords addresses) where will = case dr of { YesDryRun -> "would"; NoDryRun -> "will" } promptTarget :: String promptTarget = "What is the target email address? " aboutToEdit :: FilePath -> String aboutToEdit file = "About to edit file " ++ file promptNoDescriptionChange :: String promptNoDescriptionChange = "File content did not change. Continue anyway?"