Find git executable at run time

[git-darcs-import.git] / src / Darcs / Commands / Apply.lhs

%  Copyright (C) 2003-2005 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.

\subsection{darcs apply}
\begin{code}
{-# OPTIONS_GHC -cpp #-}
{-# LANGUAGE CPP #-}

module Darcs.Commands.Apply ( apply ) where
import System.Exit ( ExitCode(..), exitWith )
import Prelude hiding ( catch )
import System.IO ( hClose, stdin, stdout, stderr )
import Control.Exception ( catch, throw, Exception( ExitException ) )
import Control.Monad ( when )

import Darcs.Hopefully ( n2pia, conscientiously, info )
import Darcs.SignalHandler ( withSignalsBlocked )
import Darcs.Commands ( DarcsCommand(..) )
import Darcs.CommandsAux ( check_paths )
import Darcs.Arguments ( DarcsFlag( Reply, Interactive, All,
                                    Verbose, HappyForwarding ),
                         definePatches,
                         get_cc, working_repo_dir,
                        notest, nocompress, apply_conflict_options,
                        use_external_merge,
                        ignoretimes, get_sendmail_cmd,
                        reply, verify, list_files,
                        fixFilePathOrStd, umask_option,
                        all_interactive, sendmail_cmd,
                        leave_test_dir, happy_forwarding, 
                        dry_run, print_dry_run_message_and_exit,
                        set_scripts_executable
                      )
import qualified Darcs.Arguments as DarcsArguments ( cc )
import Darcs.RepoPath ( toFilePath, useAbsoluteOrStd )
import Darcs.Repository ( SealedPatchSet, withRepoLock, ($-), amInRepository,
                          tentativelyMergePatches, slurp_recorded,
                    sync_repo, read_repo,
                    finalizeRepositoryChanges,
                    applyToWorking,
                  )
import Darcs.Patch ( RepoPatch, description )
import Darcs.Patch.Info ( human_friendly )
import Darcs.Ordered ( (:\/:)(..), (:>)(..), unsafeUnRL,
                             mapFL, nullFL, mapFL_FL, mapRL, concatRL, reverseRL )
import Darcs.SlurpDirectory ( wait_a_moment )

import ByteStringUtils ( linesPS, unlinesPS )
import qualified Data.ByteString as B (ByteString, null, readFile, hGetContents, init, take, drop)
import qualified Data.ByteString.Char8 as BC (unpack, last, pack)

import Darcs.External ( sendEmail, sendEmailDoc, resendEmail,
                  verifyPS )
import Darcs.Email ( read_email )
import Darcs.Lock ( withStdoutTemp, readBinFile )
import Darcs.Patch.Depends ( get_common_and_uncommon_or_missing )
import Darcs.SelectChanges ( with_selected_changes )
import Darcs.Patch.Bundle ( scan_bundle )
import Darcs.Sealed ( Sealed(Sealed) )
import Printer ( packedString, putDocLn, vcat, text, ($$), errorDoc, empty )
#include "impossible.h"
\end{code}
\begin{code}
apply_description :: String
apply_description =
 "Apply patches (from an email bundle) to the repository."
\end{code}

\options{apply}

\haskell{apply_help}
\begin{code}
apply_help :: String
apply_help =
 "Apply is used to apply a bundle of patches to this repository.\n"++
 "Such a bundle may be created using send.\n"
\end{code}
\begin{code}
stdindefault :: a -> [String] -> IO [String]
stdindefault _ [] = return ["-"]
stdindefault _ x = return x
apply :: DarcsCommand
apply = DarcsCommand {command_name = "apply",
                      command_help = apply_help,
                      command_description = apply_description,
                      command_extra_args = 1,
                      command_extra_arg_help = ["<PATCHFILE>"],
                      command_command = apply_cmd,
                      command_prereq = amInRepository,
                      command_get_arg_possibilities = list_files,
                      command_argdefaults = const stdindefault,
                      command_advanced_options = [reply, DarcsArguments.cc,
                                                  happy_forwarding,
                                                  sendmail_cmd,
                                                  ignoretimes, nocompress,
                                                  set_scripts_executable, umask_option],
                      command_basic_options = [verify,
                                              all_interactive]++dry_run++
                                              [apply_conflict_options,
                                              use_external_merge,
                                              notest,
                                              leave_test_dir,
                                              working_repo_dir]}
\end{code}
\begin{code}
apply_cmd :: [DarcsFlag] -> [String] -> IO ()
apply_cmd _ [""] = fail "Empty filename argument given to apply!"
apply_cmd opts [unfixed_patchesfile] = withRepoLock opts $- \repository -> do
  patchesfile <- fixFilePathOrStd opts unfixed_patchesfile
  ps <- useAbsoluteOrStd (B.readFile . toFilePath) (B.hGetContents stdin) patchesfile
  am_verbose <- return $ Verbose `elem` opts
  let from_whom = get_from ps
  us <- read_repo repository
  either_them <- get_patch_bundle opts ps
  them <- case either_them of
          Right (Sealed t) -> return t
          Left er -> do forwarded <- consider_forwarding opts ps
                        if forwarded
                          then exitWith ExitSuccess
                          else fail er
  (_, us':\/:them') <- case get_common_and_uncommon_or_missing (us, them) of
                         Left pinfo ->
                            if pinfo `elem` mapRL info (concatRL us)
                                then cannotApplyPartialRepo pinfo ""
                                else cannotApplyMissing pinfo
                         Right x -> return x
  when (null $ unsafeUnRL $ head $ unsafeUnRL them') $
       do putStr $ "All these patches have already been applied.  " ++
                     "Nothing to do.\n"
          exitWith ExitSuccess
  s <- slurp_recorded repository
  let their_ps = mapFL_FL (n2pia . conscientiously (text ("We cannot apply this patch "
                                                          ++"bundle, since we're missing:") $$))
                 $ reverseRL $ head $ unsafeUnRL them'
  with_selected_changes "apply" fixed_opts s their_ps $
                            \ (to_be_applied:>_) -> do
   print_dry_run_message_and_exit "apply" opts to_be_applied
   when (nullFL to_be_applied) $
        do putStrLn "You don't want to apply any patches, so I'm exiting!"
           exitWith ExitSuccess
   check_paths opts to_be_applied
   redirect_output opts from_whom $ do
    when am_verbose $ putStrLn "We have the following extra patches:"
    when am_verbose $ putDocLn $ vcat $ mapRL description $ head $ unsafeUnRL us'
    when am_verbose $ putStrLn "Will apply the following patches:"
    when am_verbose $ putDocLn $ vcat $ mapFL description to_be_applied
    definePatches to_be_applied
    Sealed pw <- tentativelyMergePatches repository "apply" opts
                 (reverseRL $ head $ unsafeUnRL us') to_be_applied
    withSignalsBlocked $ do finalizeRepositoryChanges repository
                            wait_a_moment -- so work will be more recent than rec
                            applyToWorking repository opts pw `catch` \e ->
                                fail ("Error applying patch to working dir:\n" ++ show e)
    sync_repo repository
    putStrLn "Finished applying..."
    exitWith ExitSuccess
     where fixed_opts = if Interactive `elem` opts
                        then opts
                        else All : opts
           cannotApplyMissing pinfo
               = errorDoc $ text "Cannot apply this patch bundle, since we're missing:"
                         $$ human_friendly pinfo
           cannotApplyPartialRepo pinfo e
               = errorDoc $ text ("Cannot apply this patch bundle, "
                               ++ "this is a \"--partial repository")
                         $$ text "We don't have the following patch:"
                         $$ human_friendly pinfo $$ text e
apply_cmd _ _ = impossible
\end{code}

Darcs apply accepts a single argument, which is the name of the patch
file to be applied.  If you omit this argument, the patch is read from
standard input.  Darcs also interprets an argument of `\-' to mean it
should read the file from standard input. This allows you to use apply
with a pipe from your email program, for example.

\begin{options}
--verify
\end{options}

If you specify the \verb!--verify PUBRING! option, darcs will check that
the patch was GPG-signed by a key which is in \verb!PUBRING! and will
refuse to apply the patch otherwise.

\begin{code}
get_patch_bundle :: RepoPatch p => [DarcsFlag] -> B.ByteString
                 -> IO (Either String (SealedPatchSet p))
get_patch_bundle opts fps = do
    mps <- verifyPS opts $ read_email fps
    mops <- verifyPS opts fps
    case (mps, mops) of
      (Nothing, Nothing) ->
          return $ Left "Patch bundle not properly signed, or gpg failed."
      (Just ps, Nothing) -> return $ scan_bundle ps
      (Nothing, Just ps) -> return $ scan_bundle ps
      -- We use careful_scan_bundle only below because in either of the two
      -- above case we know the patch was signed, so it really shouldn't
      -- need stripping of CRs.
      (Just ps1, Just ps2) -> case careful_scan_bundle ps1 of
                              Left _ -> return $ careful_scan_bundle ps2
                              Right x -> return $ Right x
          where careful_scan_bundle ps =
                    case scan_bundle ps of
                    Left e -> case scan_bundle $ stripCrPS ps of
                              Right x -> Right x
                              _ -> Left e
                    x -> x
                stripCrPS :: B.ByteString -> B.ByteString
                stripCrPS ps = unlinesPS $ map stripline $ linesPS ps
                stripline p | B.null p = p
                            | BC.last p == '\r' = B.init p
                            | otherwise = p
\end{code}

\begin{options}
--cc, --reply
\end{options}

If you give the \verb!--reply FROM! option to \verb!darcs apply!, it will send the
results of the application to the sender of the patch.  This only works if
the patch is in the form of email with its headers intact, so that darcs
can actually know the origin of the patch.  The reply email will indicate
whether or not the patch was successfully applied.  The \verb!FROM! flag is
the email address that will be used as the ``from'' address when replying.
If the darcs apply is being done automatically, it is important that this
address not be the same as the address at which the patch was received, in
order to avoid automatic email loops.

If you want to also send the apply email to another address (for example,
to create something like a ``commits'' mailing list), you can use the
\verb!--cc! option to specify additional recipients.  Note that the
\verb!--cc! option \emph{requires} the \verb!--reply! option, which
provides the ``From'' address.

The \verb!--reply! feature of apply is intended primarily for two uses.
When used by itself, it is handy for when you want to apply patches sent to
you by other developers so that they will know when their patch has been
applied.  For example, in my \verb!.muttrc! (the config file for my mailer)
I have:
\begin{verbatim}
macro pager A "<pipe-entry>darcs apply --verbose \
        --reply droundy@abridgegame.org --repodir ~/darcs
\end{verbatim}
which allows me to apply a patch to darcs directly from my mailer, with the
originator of that patch being sent a confirmation when the patch is
successfully applied.  NOTE: In an attempt to make sure no one else
can read your email, mutt seems to set the umask
such that patches created with the above macro are not world-readable, so
use it with care.

When used in combination with the \verb!--verify! option, the
\verb!--reply! option allows for a nice pushable repository.  When these
two options are used together, any patches that don't pass the verify will
be forwarded to the \verb!FROM! address of the \verb!--reply! option.  This
allows you to set up a repository so that anyone who is authorized can push
to it and have it automatically applied, but if a stranger pushes to it,
the patch will be forwarded to you.  Please (for your own sake!)\ be certain
that the \verb!--reply FROM! address is different from the one used to send
patches to a pushable repository, since otherwise an unsigned patch will be
forwarded to the repository in an infinite loop.

If you use \verb!darcs apply --verify PUBRING --reply! to create a
pushable repository by applying patches automatically as they are received by
email, you will also want to use the \verb!--dont-allow-conflicts! option.

\begin{options}
--dont-allow-conflicts
\end{options}
The \verb!--dont-allow-conflicts! flag causes apply to fail when applying a
patch would cause conflicts.  This flag is recommended on repositories
which will be pushed to or sent to.

\begin{options}
--allow-conflicts
\end{options}

\verb!--allow-conflicts! will allow conflicts, but will keep the local and
recorded versions in sync on the repository.  This means the conflict will exist
in both locations until it is resolved.

\begin{options}
--mark-conflicts
\end{options}

\verb!--mark-conflicts! will add conflict markers to illustrate the the
conflict.

\begin{options}
--external-merge
\end{options}

You can use an external interactive merge tool to resolve conflicts with the
flag \verb!--external-merge!.  For more details see
subsection~\ref{resolution}.

\begin{options}
--all, --interactive
\end{options}

If you provide the \verb!--interactive! flag, darcs will
ask you for each change in the patch bundle whether or not you wish to
apply that change.  The opposite is the \verb!--all! flag, which can be
used to override an \verb!interactive! which might be set in your
``defaults'' file.

\begin{options}
--sendmail-command
\end{options}

If you want to use a command different from the default one for sending mail,
you need to specify a command line with the \verb!--sendmail-command! option.
The command line can contain the format specifier \verb!%t! for to
and you can add \verb!%<! to the end of the command line if the command
expects the complete mail on standard input. For example, the command line for
msmtp looks like this:

\begin{verbatim}
msmtp -t %<
\end{verbatim}


\begin{code}
get_from :: B.ByteString -> String
get_from ps = readFrom $ linesPS ps
    where readFrom [] = ""
          readFrom (x:xs)
           | B.take 5 x == from_start = BC.unpack $ B.drop 5 x
           | otherwise = readFrom xs

redirect_output :: [DarcsFlag] -> String -> IO a -> IO a
redirect_output opts to doit = ro opts
    where
  cc = get_cc opts
  ro [] = doit
  ro (Reply f:_) =
    withStdoutTemp $ \tempf-> do {a <- doit;
                                  hClose stdout;
                                  hClose stderr;
                                  return a;
                                 } `catch` (sendit tempf)
        where sendit tempf e@(ExitException ExitSuccess) =
                do sendSanitizedEmail opts f to "Patch applied" cc tempf
                   throwIO e
              sendit tempf (ExitException _) =
                do sendSanitizedEmail opts f to "Patch failed!" cc tempf
                   throwIO $ ExitException ExitSuccess
              sendit tempf e =
                do sendSanitizedEmail opts f to "Darcs error applying patch!" cc $
                             tempf ++ "\n\nCaught exception:\n"++
                             show e++"\n"
                   throwIO $ ExitException ExitSuccess
  ro (_:fs) = ro fs

-- |sendSanitizedEmail sends a sanitized email using the given sendmailcmd
-- It takes @DacrsFlag@ options a file with the mail contents,
-- To:, Subject:, CC:, and mail body
sendSanitizedEmail :: [DarcsFlag] -> String -> String -> String -> String -> String -> IO ()
sendSanitizedEmail opts file to subject cc mailtext =
    do scmd <- get_sendmail_cmd opts
       body <- sanitizeFile mailtext
       sendEmail file to subject cc scmd body

-- sanitizeFile is used to clean up the stdout/stderr before sticking it in
-- an email.

sanitizeFile :: FilePath -> IO String
sanitizeFile f = sanitize `fmap` readBinFile f
    where sanitize s = wash $ remove_backspaces "" s
          wash ('\000':s) = "\\NUL" ++ wash s
          wash ('\026':s) = "\\EOF" ++ wash s
          wash (c:cs) = c : wash cs
          wash [] = []
          remove_backspaces rev_sofar "" = reverse rev_sofar
          remove_backspaces (_:rs) ('\008':s) = remove_backspaces rs s
          remove_backspaces "" ('\008':s) = remove_backspaces "" s
          remove_backspaces rs (s:ss) = remove_backspaces (s:rs) ss

throwIO :: Exception -> IO a
throwIO e = return $ throw e
\end{code}

\begin{code}
forwarding_message :: B.ByteString
forwarding_message = BC.pack $
    "The following patch was either unsigned, or signed by a non-allowed\n"++
    "key, or there was a GPG failure.\n"

consider_forwarding :: [DarcsFlag] -> B.ByteString -> IO Bool
consider_forwarding opts m = cf opts (get_cc opts)
    where cf [] _ = return False
          cf (Reply t:_) cc =
              case break is_from (linesPS m) of
              (m1, f:m2) ->
                  let m_lines = forwarding_message:m1 ++ m2
                      m' = unlinesPS m_lines
                      f' = BC.unpack (B.drop 5 f) in
                      if t == f' || t == init f'
                      then return False -- Refuse possible email loop.
                      else do
                        scmd <- get_sendmail_cmd opts
                        if HappyForwarding `elem` opts
                         then resendEmail t scmd m
                         else sendEmailDoc f' t "A forwarded darcs patch" cc
                                           scmd (Just (empty,empty))
                                           (packedString m')
                        return True
              _ -> return False -- Don't forward emails lacking headers!
          cf (_:fs) cc = cf fs cc
          is_from l = B.take 5 l == from_start

from_start :: B.ByteString
from_start = BC.pack "From:"
\end{code}

\begin{options}
--no-test, --test
\end{options}

If you specify the \verb!--test! option, apply will run the test (if a test
exists) prior to applying the patch.  If the test fails, the patch is not
applied.  In this case, if the \verb!--reply! option was used, the results
of the test are sent in the reply email.  You can also specify the
\verb!--no-test! option, which will override the \verb!--test! option, and
prevent the test from being run.  This is helpful when setting up a
pushable repository, to keep users from running code.