module Darcs.Commands.Send ( send ) where
import System.Exit ( exitWith, ExitCode( ExitSuccess ) )
#ifndef HAVE_MAPI
import System.Exit ( ExitCode( ExitFailure ) )
#endif
import System.IO.Error ( ioeGetErrorString )
import System.IO ( hClose )
import Control.Monad ( when, unless, forM_ )
import Storage.Hashed.Tree ( Tree )
import Data.List ( intercalate, isPrefixOf, stripPrefix )
import Data.Maybe ( isNothing, fromMaybe )
import Darcs.Commands ( DarcsCommand(..), putInfo, putVerbose )
import Darcs.Arguments ( DarcsFlag( EditDescription, LogFile,
Target, Context,
DryRun, Quiet
),
fixUrl, setEnvDarcsPatches,
getCc, getAuthor, workingRepoDir,
editDescription, logfile, rmlogfile,
sign, getSubject, depsSel, getInReplyTo,
matchSeveral, setDefault, outputAutoName,
output, ccSend, subject, target, author, sendmailCmd,
inReplyTo, remoteRepo, networkOptions,
allInteractive, getSendmailCmd,
printDryRunMessageAndExit,
summary, allowUnrelatedRepos,
fromOpt, dryRun, sendToContext, getOutput,
changesReverse, charset, getCharset,
)
import Darcs.Flags ( willRemoveLogFile, doReverse )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, patchDesc )
import Darcs.Repository ( PatchSet, Repository,
amInHashedRepository, identifyRepositoryFor, withRepoReadLock, RepoJob(..),
readRepo, readRecorded, prefsUrl, checkUnrelatedRepos )
#ifdef GADT_WITNESSES
import Darcs.Patch.Set ( Origin )
#endif
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch ( RepoPatch, description, applyToTree, invert )
import Darcs.Witnesses.Unsafe ( unsafeCoerceP )
import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), (:>)(..),
mapFL, mapFL_FL, lengthFL, nullFL )
import Darcs.Patch.Bundle ( makeBundleN, scanContext, patchFilename )
import Darcs.Repository.Prefs ( defaultrepo, setDefaultrepo, getPreflist )
import Darcs.External ( signString, sendEmailDoc, fetchFilePS, Cachable(..), generateEmail
#ifndef HAVE_MAPI
, haveSendmail
#endif
)
import ByteStringUtils ( mmapFilePS, isAscii )
import qualified Data.ByteString.Char8 as BC (unpack)
import Darcs.Lock ( withOpenTemp, writeDocBinFile, readDocBinFile, worldReadableTemp, removeFileMayNotExist )
import Darcs.SelectChanges ( selectChanges, WhichChanges(..), selectionContext, runSelection )
import Darcs.Patch.Depends ( findCommonWithThem )
import Darcs.Utils ( askUser, promptYorn, catchall, editFile, formatPath, getSystemEncoding, isUTF8Locale )
import Data.Text.Encoding ( decodeUtf8' )
import Progress ( debugMessage )
import Darcs.Email ( makeEmail )
import Printer ( Doc, vsep, vcat, text, ($$), (<+>), (<>), putDoc, renderPS )
import Darcs.RepoPath ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd,
getCurrentDirectory, useAbsoluteOrStd )
import URL.HTTP ( postUrl )
#include "impossible.h"
#include "gadts.h"
sendDescription :: String
sendDescription =
"Send by email a bundle of one or more patches."
sendHelp :: String
sendHelp =
"Send is used to prepare a bundle of patches that can be applied to a target\n"++
"repository. Send accepts the URL of the repository as an argument. When\n"++
"called without an argument, send will use the most recent repository that\n"++
"was either pushed to, pulled from or sent to. By default, the patch bundle\n"++
"is sent by email, although you may save it to a file.\n"
send :: DarcsCommand
send = DarcsCommand {commandProgramName = "darcs",
commandName = "send",
commandHelp = sendHelp,
commandDescription = sendDescription,
commandExtraArgs = 1,
commandExtraArgHelp = ["[REPOSITORY]"],
commandCommand = sendCmd,
commandPrereq = amInHashedRepository,
commandGetArgPossibilities = getPreflist "repos",
commandArgdefaults = defaultrepo,
commandAdvancedOptions = [logfile, rmlogfile,
remoteRepo,
sendToContext, changesReverse] ++
networkOptions,
commandBasicOptions = [matchSeveral, depsSel,
allInteractive,
fromOpt, author,
target,ccSend,subject, inReplyTo, charset,
output,outputAutoName,sign]
++dryRun++[summary,
editDescription,
setDefault False,
workingRepoDir,
sendmailCmd,
allowUnrelatedRepos]}
sendCmd :: [DarcsFlag] -> [String] -> IO ()
sendCmd input_opts [""] = sendCmd input_opts []
sendCmd input_opts [unfixedrepodir] = withRepoReadLock input_opts $ RepoJob $
\(repository :: Repository p C(r u r)) -> do
context_ps <- the_context input_opts
case context_ps of
Just them -> do
wtds <- decideOnBehavior input_opts (Nothing :: Maybe (Repository p C(r u r)))
sendToThem repository input_opts wtds "CONTEXT" them
Nothing -> do
repodir <- fixUrl input_opts unfixedrepodir
here <- getCurrentDirectory
when (repodir == toFilePath here) $
fail "Can't send to current repository! Did you mean send --context?"
old_default <- getPreflist "defaultrepo"
when (old_default == [repodir] && Quiet `notElem` input_opts) $
putStrLn $ "Creating patch to "++formatPath repodir++"..."
repo <- identifyRepositoryFor repository repodir
them <- readRepo repo
setDefaultrepo repodir input_opts
wtds <- decideOnBehavior input_opts (Just repo)
sendToThem repository input_opts wtds repodir them
where the_context [] = return Nothing
the_context (Context foo:_)
= (Just . scanContext )`fmap` mmapFilePS (toFilePath foo)
the_context (_:fs) = the_context fs
sendCmd _ _ = impossible
sendToThem :: (RepoPatch p, ApplyState p ~ Tree)
=> Repository p C(r u t) -> [DarcsFlag] -> [WhatToDo] -> String
-> PatchSet p C(Origin x) -> IO ()
sendToThem repo opts wtds their_name them = do
#ifndef HAVE_MAPI
sendmail <- haveSendmail
sm_cmd <- getSendmailCmd opts
when (isNothing (getOutput opts "") && DryRun `notElem` opts &&
not sendmail && sm_cmd == "") $ do
putInfo opts $ text "No working sendmail instance on your machine!"
exitWith $ ExitFailure 1
#endif
us <- readRepo repo
common :> us' <- return $ findCommonWithThem us them
checkUnrelatedRepos opts us them
(case us' of
NilFL -> do putInfo opts $ text "No recorded local changes to send!"
exitWith ExitSuccess
_ -> putVerbose opts $ text "We have the following patches to send:"
$$ vcat (mapFL description us')) :: IO ()
pristine <- readRecorded repo
let context = selectionContext "send" opts Nothing Nothing
selector = if doReverse opts
then selectChanges FirstReversed
else selectChanges First
(to_be_sent :> _) <- runSelection (selector us') context
printDryRunMessageAndExit "send" opts to_be_sent
when (nullFL to_be_sent) $ do
putInfo opts $ text "You don't want to send any patches, and that's fine with me!"
exitWith ExitSuccess
setEnvDarcsPatches to_be_sent
bundle <- prepareBundle opts common pristine (us':\/:to_be_sent)
let make_fname (tb:>:_) = patchFilename $ patchDesc tb
make_fname _ = impossible
fname = make_fname to_be_sent
outname = getOutput opts 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 p C(x y z). (RepoPatch p, ApplyState p ~ Tree)
=> [DarcsFlag] -> PatchSet p C(Origin z)
-> Tree IO -> (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) C(x y)
-> IO Doc
prepareBundle opts common pristine (us' :\/: to_be_sent) = do
pristine' <- applyToTree (invert $ mapFL_FL hopefully us') pristine
unsig_bundle <- makeBundleN (Just pristine') (unsafeCoerceP common) (mapFL_FL hopefully to_be_sent)
signString opts unsig_bundle
sendBundle :: forall p C(x y) . (RepoPatch p, ApplyState p ~ Tree)
=> [DarcsFlag] -> FL (PatchInfoAnd p) C(x y)
-> Doc -> String -> [WhatToDo] -> String -> IO ()
sendBundle opts to_be_sent bundle fname wtds their_name=
let
auto_subject :: forall pp C(a b) . FL (PatchInfoAnd pp) C(a b) -> 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 (n3) st ++ "..."
in do
thetargets <- getTargets wtds
from <- getAuthor opts
let thesubject = fromMaybe (auto_subject to_be_sent) $ getSubject opts
(mailcontents, mailfile, mailcharset) <- getDescription opts their_name to_be_sent
let warnMailBody = let msg = "Email body left in " in
case mailfile of
Just mf -> putStrLn $ msg++mf++"."
Nothing -> return ()
warnCharset msg = do
confirmed <- promptYorn $ "Warning: " ++ msg ++ " Send anyway?"
unless confirmed $ do
putStrLn "Aborted. You can specify charset with the --charset option."
warnMailBody
exitWith ExitSuccess
thecharset <- case getCharset opts of
providedCset@(Just _) -> return providedCset
Nothing ->
case mailcharset of
Nothing -> do
warnCharset "darcs could not guess the charset of your mail."
return mailcharset
Just "utf-8" -> do
encoding <- getSystemEncoding
debugMessage $ "Current locale encoding: " ++ encoding
unless (isUTF8Locale encoding) $
warnCharset "your mail is valid UTF-8 but your locale differs."
return mailcharset
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 . text $ ("Successfully sent patch bundle to: "
++ to
++ ccs (getCc opts) ++"."))
`catch` \e -> do warnMailBody
fail $ ioeGetErrorString e
ccs [] = []
ccs cs = " and cc'ed " ++ cs
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 . text $ "Posting patch to " ++ url
postUrl url (BC.unpack nbody) "message/rfc822")
`catch` const 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 (getFileopt opts) || willRemoveLogFile opts) $
removeFileMayNotExist mailfile
cleanup _ Nothing = return ()
writeBundleToFile :: forall p C(x y) . (RepoPatch p, ApplyState p ~ Tree)
=> [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> 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)
putStrLn $ "Wrote patch to " ++ toFilePath a ++ "."
putstd = putDoc (d $$ bundle)
useAbsoluteOrStd putabs putstd fname
let to = generateEmailToString wtds
unless (null to) $
putInfo opts . text $ "The usual recipent for this bundle is: " ++ to
cleanup opts f
data WhatToDo
= Post String
| SendMail String
decideOnBehavior :: RepoPatch p => [DarcsFlag] -> Maybe (Repository p C(r u t)) -> 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
#ifdef HAVE_HTTP
check_post the_remote_repo =
do p <- ((readPost . BC.unpack) `fmap`
fetchFilePS (prefsUrl 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
#else
check_post = who_to_email
#endif
who_to_email the_remote_repo =
do email <- (BC.unpack `fmap`
fetchFilePS (prefsUrl the_remote_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
in if DryRun `elem` opts
then putInfo opts . text $ "Patch bundle would be sent to: "++unwords (map pn emails)
else when (null the_targets && isNothing (getOutput opts "")) $
putInfo opts . text $ "Patch bundle will be sent to: "++unwords (map pn emails)
getTargets :: [WhatToDo] -> IO [WhatToDo]
getTargets [] = fmap ((:[]) . SendMail) $ askUser "What is the target email address? "
getTargets wtds = return wtds
collectTargets :: [DarcsFlag] -> [WhatToDo]
collectTargets flags = [ f t | Target t <- flags ] where
f url | "http:" `isPrefixOf` url = Post url
f em = SendMail em
getDescription :: (RepoPatch p, ApplyState p ~ Tree)
=> [DarcsFlag] -> String -> FL (PatchInfoAnd p) C(x y) -> IO (Doc, Maybe String, Maybe String)
getDescription opts their_name patches =
case get_filename of
Just f -> do file <- f
when (EditDescription `elem` opts) $ do
when (isNothing $ getFileopt opts) $
writeDocBinFile file patchdesc
debugMessage $ "About to edit file " ++ file
(_, changed) <- editFile file
unless changed $ do
confirmed <- promptYorn "File content did not change. Continue anyway?"
unless confirmed $ do putStrLn "Aborted."
exitWith ExitSuccess
return ()
doc <- readDocBinFile file
return (doc, Just file, tryGetCharset doc)
Nothing -> return (patchdesc, Nothing, tryGetCharset patchdesc)
where patchdesc = text (if lengthFL patches == 1
then "1 patch"
else show (lengthFL patches) ++ " patches")
<+> text "for repository" <+> text their_name <> text ":"
$$ text ""
$$ vsep (mapFL description patches)
get_filename = case getFileopt opts of
Just f -> Just $ return $ toFilePath f
Nothing -> if EditDescription `elem` opts
then Just tempfile
else Nothing
tempfile = worldReadableTemp "darcs-temp-mail"
tryGetCharset content = let body = renderPS content in
if isAscii body
then Just "us-ascii"
else either (const Nothing)
(const $ Just "utf-8")
(decodeUtf8' body)
getFileopt :: [DarcsFlag] -> Maybe AbsolutePath
getFileopt (LogFile f:_) = Just f
getFileopt (_:flags) = getFileopt flags
getFileopt [] = Nothing