{-# 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 ( PatchInfoAnd, n2pia, conscientiously, info )
import Darcs.SignalHandler ( withSignalsBlocked )
import Darcs.Commands ( DarcsCommand(..), putVerbose )
import Darcs.CommandsAux ( check_paths )
import Darcs.Arguments ( DarcsFlag( Reply, Interactive, All ),
                         definePatches,
                         getCc, workingRepoDir,
                        notest, nocompress, applyConflictOptions,
                        useExternalMerge,
                        ignoretimes, getSendmailCmd,
                        reply, verify, listFiles,
                        fixFilePathOrStd, umaskOption,
                        allInteractive, sendmailCmd,
                        leaveTestDir, happyForwarding, 
                        dryRun, printDryRunMessageAndExit,
                        setScriptsExecutableOption, restrictPaths
                      )
import Darcs.Flags(doHappyForwarding)

import qualified Darcs.Arguments as DarcsArguments ( ccApply )
import Darcs.RepoPath ( toFilePath, useAbsoluteOrStd )
import Darcs.Repository ( Repository, SealedPatchSet, withRepoLock, ($-), amInRepository,
                          tentativelyMergePatches,
                    read_repo,
                    finalizeRepositoryChanges,
                    applyToWorking, invalidateIndex
                  )
import Darcs.Patch ( RepoPatch, description )
import Darcs.Patch.Info ( PatchInfo, human_friendly )
import Darcs.Witnesses.Ordered ( FL, RL, (:\/:)(..), (:>)(..),
                       mapFL, nullFL, mapFL_FL, mapRL, concatRL, reverseRL )
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, filterOutConflicts )
import Darcs.Patch.Bundle ( scan_bundle )
import Darcs.Witnesses.Sealed ( Sealed(Sealed) )
import Printer ( packedString, vcat, text, ($$), errorDoc, empty )

#include "impossible.h"

#include "gadts.h"

applyDescription :: String
applyDescription = "Apply a patch bundle created by `darcs send'."

applyHelp :: String
applyHelp =
 "The `darcs apply' command takes a patch bundle and attempts to insert\n" ++
 "it into the current repository.  In addition to invoking it directly\n" ++
 "on bundles created by `darcs send', it is used internally by `darcs\n" ++
 "push' and `darcs put' on the remote end of an SSH connection.\n" ++
 "\n" ++
 "If no file is supplied, the bundle is read from standard input.\n" ++
 "\n" ++
 "If given an email instead of a patch bundle, Darcs will look for the\n" ++
 "bundle as a MIME attachment to that email.  Currently this will fail\n" ++
 "if the MIME boundary is rewritten, such as in Courier and Mail.app.\n" ++
 "\n" ++
 "If the `--reply noreply@example.net' option is used, and the bundle is\n" ++
 "attached to an email, Darcs will send a report (indicating success or\n" ++
 "failure) to the sender of the bundle (the To field).  The argument to\n" ++
 "noreply is the address the report will appear to originate FROM.\n" ++
 "\n" ++
 "The --cc option will cause the report to be CC'd to another address,\n" ++
 "for example `--cc reports@lists.example.net,admin@lists.example.net'.\n" ++
 "Using --cc without --reply is undefined.\n" ++
 "\n" ++
 "If gpg(1) is installed, you can use `--verify pubring.gpg' to reject\n" ++
 "bundles that aren't signed by a key in pubring.gpg.\n" ++
 "\n" ++
 "If --test is supplied and a test is defined (see `darcs setpref'), the\n" ++
 "bundle will be rejected if the test fails after applying it.  In that\n" ++
 "case, the rejection email from --reply will include the test output.\n"

stdindefault :: a -> [String] -> IO [String]
stdindefault _ [] = return ["-"]
stdindefault _ x = return x
apply :: DarcsCommand
apply = DarcsCommand {commandName = "apply",
                      commandHelp = applyHelp ++ "\n" ++ applyHelp',
                      commandDescription = applyDescription,
                      commandExtraArgs = 1,
                      commandExtraArgHelp = ["<PATCHFILE>"],
                      commandCommand = applyCmd,
                      commandPrereq = amInRepository,
                      commandGetArgPossibilities = listFiles,
                      commandArgdefaults = const stdindefault,
                      commandAdvancedOptions = [reply, DarcsArguments.ccApply,
                                                  happyForwarding,
                                                  sendmailCmd,
                                                  ignoretimes, nocompress,
                                                  setScriptsExecutableOption, umaskOption,
                                                  restrictPaths],
                      commandBasicOptions = [verify,
                                              allInteractive]++dryRun++
                                              [applyConflictOptions,
                                              useExternalMerge,
                                              notest,
                                              leaveTestDir,
                                              workingRepoDir]}

applyCmd :: [DarcsFlag] -> [String] -> IO ()
applyCmd _ [""] = fail "Empty filename argument given to apply!"
applyCmd opts [unfixed_patchesfile] = withRepoLock opts $- \repository -> do
  patchesfile <- fixFilePathOrStd opts unfixed_patchesfile
  ps <- useAbsoluteOrStd (B.readFile . toFilePath) (B.hGetContents stdin) patchesfile
  let from_whom = getFrom ps
  us <- read_repo repository
  either_them <- getPatchBundle opts ps
  Sealed them
     <- case either_them of
          Right t -> return t
          Left er -> do forwarded <- considerForwarding 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
  let their_ps = mapFL_FL (n2pia . conscientiously (text ("We cannot apply this patch "
                                                          ++"bundle, since we're missing:") $$))
                 $ reverseRL them'
  (hadConflicts, Sealed their_ps_filtered) <- filterOutConflicts opts us' repository their_ps
  when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts."
  when (nullFL their_ps_filtered) $
       do putStr $ "All these patches have already been applied.  " ++
                     "Nothing to do.\n"
          exitWith ExitSuccess
  with_selected_changes "apply" fixed_opts Nothing their_ps_filtered $
                            \ (to_be_applied:>_) ->
                                applyItNow opts from_whom repository us' to_be_applied
    where fixed_opts = if Interactive `elem` opts
                         then opts
                         else All : opts
applyCmd _ _ = impossible

applyItNow :: FORALL(p r u t x y z) RepoPatch p =>
             [DarcsFlag] -> String -> Repository p C(r u t)
           -> RL (PatchInfoAnd p) C(x r) -> FL (PatchInfoAnd p) C(x z) -> IO ()
applyItNow opts from_whom repository us' to_be_applied = do
   printDryRunMessageAndExit "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
   redirectOutput opts from_whom $ do
    putVerbose opts $ text "We have the following extra patches:"
    putVerbose opts . vcat $ mapRL description us'
    putVerbose opts $ text "Will apply the following patches:"
    putVerbose opts . vcat $ mapFL description to_be_applied
    definePatches to_be_applied
    Sealed pw <- tentativelyMergePatches repository "apply" opts
                 (reverseRL us') to_be_applied
    invalidateIndex repository
    withSignalsBlocked $ do finalizeRepositoryChanges repository
                            applyToWorking repository opts pw `catch` \e ->
                                fail ("Error applying patch to working dir:\n" ++ show e)
    putStrLn "Finished applying..."

cannotApplyMissing :: PatchInfo -> a
cannotApplyMissing pinfo
    = errorDoc $ text "Cannot apply this patch bundle, since we're missing:"
      $$ human_friendly pinfo

cannotApplyPartialRepo :: PatchInfo -> String -> a
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

getPatchBundle :: RepoPatch p => [DarcsFlag] -> B.ByteString
                 -> IO (Either String (SealedPatchSet p))
getPatchBundle 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

applyHelp' :: String
applyHelp' =
 "A patch bundle may introduce unresolved conflicts with existing\n" ++
 "patches or with the working tree.  By default, Darcs will add conflict\n" ++
 "markers (see `darcs mark-conflicts').\n" ++
 "\n" ++
 "The --allow-conflicts option will skip conflict marking; this is\n" ++
 "useful when you want to treat a repository as just a bunch of patches,\n" ++
 "such as using `darcs pull --union' to download of your co-workers\n" ++
 "patches before going offline.\n" ++
 "\n" ++
 "This can mess up unrecorded changes in the working tree, forcing you\n" ++
 "to resolve the conflict immediately.  To simply reject bundles that\n" ++
 "introduce unresolved conflicts, using the --dont-allow-conflicts\n" ++
 "option.  Making this the default in push-based workflows is strongly\n" ++
 "recommended.\n" ++
 "\n" ++
 "Unlike most Darcs commands, `darcs apply' defaults to --all.  Use the\n" ++
 "--interactive option to pick which patches to apply from a bundle.\n"