%  Copyright (C) 2003-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; if not, write to the Free Software Foundation,
%  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
\section{darcs apply}
\begin{code}
module Apply ( apply ) where
import System ( ExitCode(..), exitWith )
import Prelude hiding ( catch )
import IO ( hPutStr, hClose, stdout, stderr )
import Control.Exception ( catch, throw, Exception( ExitException ), block )
import Monad ( when, unless, liftM )
import List ( elem )
import Maybe ( catMaybes )
import DarcsUtils ( withCurrentDirectory )

import DarcsCommands ( DarcsCommand(..) )
import DarcsArguments ( DarcsFlag( Reply, Test, NoTest, AnyOrder,
                                   Gui, Interactive, All,
                                   NoResolve, Verbose, HappyForwarding
                                 ),
                        get_cc, want_external_merge, working_repo_dir,
                        notest, no_resolve_conflicts, nocompress,
                        ignoretimes, verbose, use_external_merge,
                        reply, verify, list_files,
                        all_gui_interactive,
                        leave_test_dir, happy_forwarding,
                      )
import qualified DarcsArguments ( cc )
import Repository ( PatchSet,
                    add_to_inventory, get_unrecorded, slurp_recorded,
                    slurp_pending, read_repo, is_repo, am_in_repo,
                    write_pending, sift_for_pending, sync_repo,
                    read_pending,
                  )
import Patch ( patch2patchinfo, invert,
               join_patches, unjoin_patches, apply_to_slurpy,
             )
import PatchInfo ( human_friendly )
import SlurpDirectory ( wait_a_moment, slurp_write_dirty, co_slurp, )
import FastPackedString ( readFilePS )
import External ( sendEmail, resendEmail, verifyPS )
import Lock ( withLock, withOpenTemp, withStdoutTemp, readBinFile )
import Pull ( merge_with_us_and_pending, save_patches )
import Depends ( get_common_and_uncommon )
import Resolution ( standard_resolution, no_resolution, external_resolution )
import SelectChanges ( with_selected_changes )
import Test ( test_slurpy )
import PatchBundle ( scan_bundle )
import DarcsUtils ( putStrLnError )
#include "impossible.h"
\end{code}
\begin{code}
apply_description :: String
apply_description =
 "Apply patches to a repo.\n"
\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}
stdin_magic :: String
stdin_magic = "magic darcs standard input"
stdindefault :: [String] -> IO [String]
stdindefault [] = return [stdin_magic]
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 = am_in_repo,
                      command_get_arg_possibilities = list_files,
                      command_argdefaults = stdindefault,
                      command_darcsoptions = [verify, reply,
                                              DarcsArguments.cc,
                                              use_external_merge,
                                              verbose, ignoretimes,
                                              nocompress,
                                              all_gui_interactive,
                                              no_resolve_conflicts,
                                              notest, happy_forwarding,
                                              leave_test_dir,
                                              working_repo_dir]}
\end{code}
\begin{code}
apply_cmd :: [DarcsFlag] -> [String] -> IO ()
apply_cmd opts [patchesfile] = withLock "./_darcs/lock" $
 with_patches_file patchesfile $ \pf -> do
  am_verbose <- return $ Verbose `elem` opts
  from_whom <- get_from pf
  aminrepo <- is_repo "."
  unless aminrepo $ fail "Aaack, I'm not in a repo!"
  us <- read_repo "."
  maybe_them <- get_patch_bundle opts pf
  them <- case maybe_them of
          Just t -> return t
          Nothing -> do m <- readBinFile pf
                        forwarded <- consider_forwarding opts m
                        if forwarded
                          then exitWith ExitSuccess
                          else fail "Bad signature on patch (or gpg failure)!"
  (_, us', them') <- return $ get_common_and_uncommon (us, them)
  s <- slurp_recorded "."
  with_selected_changes "apply" fixed_opts s
                            (map fromJustTheirPatch $ reverse $ head them') $
                            \ (_,to_be_applied) -> do
   when (to_be_applied == []) $
        do putStr "You don't want to apply any patches, so I'm exiting!\n"
           exitWith ExitSuccess
   redirect_output opts from_whom $ do
    when am_verbose $ putStrLn "We have the following extra patches:"
    when am_verbose $ putStr $ unlines $ map (human_friendly.fst) $ head us'
    when am_verbose $ putStrLn "Will apply the following patches:"
    when am_verbose $ putStr $ unlines $
         map (human_friendly.fromJust.patch2patchinfo) $ to_be_applied
    (us_patch, work_patch) <- merge_with_us_and_pending opts
                              (map fromJustOurPatch $ reverse $ head us',
                               to_be_applied)
    recorded <- slurp_recorded "."
    recorded_with_pending <- slurp_pending "."
    working <- co_slurp recorded_with_pending "."
    pw_resolved <-
       if NoResolve `elem` opts
       then join_patches `liftM` no_resolution work_patch
       else case want_external_merge opts of
            Nothing -> join_patches `liftM` standard_resolution work_patch
            Just c -> do pend <- get_unrecorded (AnyOrder:opts)
                         join_patches `liftM` external_resolution c working
                              (join_patches $ (++catMaybes [pend]) $
                               map (fromJust.snd) $ reverse $ head us')
                              (join_patches $ map (fromJust.snd) $ reverse $ head them')
                              work_patch
    when am_verbose $ putStrLn "Applying patches to the local directories..."
    case apply_to_slurpy us_patch recorded of
        Nothing -> fail "Error applying patch to recorded!"
        Just rec' ->
            case apply_to_slurpy pw_resolved working of
            Nothing -> fail "Error applying patch to working dir."
            Just work' -> do
                when (not (NoTest `elem` opts) && Test `elem` opts) $
                  do recb <- slurp_recorded "."
                     testproblem <- test_slurpy opts $
                                    fromJust $ apply_to_slurpy us_patch recb
                     when (testproblem /= ExitSuccess) $ do
                          putStrLnError "Error in test..."
                          exitWith $ ExitFailure 1
                save_patches opts $ unjoin_patches us_patch
                mp <- read_pending
                block $ do
                  withCurrentDirectory "_darcs/current" $
                    do  slurp_write_dirty rec'
                        wait_a_moment -- so work will be more recent than rec
                        return ()
                  sequence $ map (add_to_inventory ".".fromJust.patch2patchinfo)
                           to_be_applied
                  slurp_write_dirty work'
                  when (mp /= Nothing) $
                       write_pending $ sift_for_pending $
                       join_patches [invert us_patch, fromJust mp, pw_resolved]
                sync_repo
                putStrLn "Finished applying..."
                exitWith ExitSuccess
     where fixed_opts = if Gui `elem` opts || Interactive `elem` opts
                        then opts
                        else All : opts
           fromJustTheirPatch (pinfo, Nothing)
               = error $ "Cannot apply this patch bundle, since we're missing:\n"
                 ++ human_friendly pinfo
           fromJustTheirPatch (_, Just p) = p
           fromJustOurPatch (pinfo, Nothing)
               = error $ "Cannot apply this patch bundle, this is a \"-" ++
                         "-partial repository\n" ++
                         "We don't have the following patch:\n" ++
                         human_friendly pinfo
           fromJustOurPatch (_, Just p) = p
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.\footnote{One caveat: don't name your patch file ``magic darcs
standard input'', or darcs will read from standard input instead!}  This
allows you to use apply with a pipe from your email program, for example.

\begin{code}
with_patches_file :: String -> (FilePath -> IO a) -> IO a
with_patches_file s c
    | s == stdin_magic = withOpenTemp $ \(h,fn) -> do
                         pc <- getContents
                         hPutStr h pc
                         hClose h
                         c fn
    | otherwise = c s
\end{code}

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 :: [DarcsFlag] -> FilePath -> IO (Maybe PatchSet)
get_patch_bundle opts f = do
    fps <- readFilePS f
    mps <- verifyPS opts fps
    return $ scan_bundle `liftM` mps
\end{code}

If you give the \verb!--reply FROM! option to 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 an 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.

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: For some reason mutt seems to set the umask
such that patches created with the above macro are not world-readable.  I'm
not sure why this is, but use it with care.

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

If you provide the \verb!--interactive! or \verb!--gui! 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 interactive or gui which might be set in your
``defaults'' file.

\begin{code}
get_from :: FilePath -> IO String
get_from pf = (readFrom.lines) `liftM` readBinFile pf
    where readFrom [] = ""
          readFrom (('F':'r':'o':'m':':':f):_) = f
          readFrom (_:ls) = readFrom ls

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 body <- sanitizeFile tempf
                   sendEmail f to "Patch applied" [] body
                   throwIO e
              sendit tempf (ExitException _) =
                do body <- sanitizeFile tempf
                   sendEmail f to "Patch failed!" cc body
                   throwIO $ ExitException ExitSuccess
              sendit tempf e =
                do body <- sanitizeFile tempf
                   sendEmail f to "Darcs error applying patch!" cc $
                             body ++ "\n\nCaught exception:\n"++
                             show e++"\n"
                   throwIO $ ExitException ExitSuccess
  ro (_:fs) = ro fs

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

sanitizeFile :: FilePath -> IO String
sanitizeFile f = sanitize `liftM` 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}

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 repo by applying patches automatically as they are recieved via
email, you will also want to use the \verb!--no-resolve-conflicts! option,
which will keep the local and recorded versions in sync on the repo.

\begin{code}
forwarding_message :: String
forwarding_message =
    "The following patch was either unsigned, or signed by a non-allowed\n"++
    "key, or there was a gpg failure.\n"

consider_forwarding :: [DarcsFlag] -> String -> IO Bool
consider_forwarding opts m = cf opts (get_cc opts)
    where cf [] _ = return False
          cf (Reply t:_) cc =
              case break is_from (lines m) of
              (m1, f:m2) ->
                  let m_lines = forwarding_message:m1 ++ m2
                      m' = unlines m_lines
                      f' = drop 5 f in do
                      if HappyForwarding `elem` opts
                         then resendEmail t m
                         else sendEmail f' t "A forwarded darcs patch" cc m'
                      return True
              _ -> return False -- Don't forward emails lacking headers!
          cf (_:fs) cc = cf fs cc
          is_from l = take 5 l == "From:"
\end{code}

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 send 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.