module Darcs.UI.ApplyPatches
    ( PatchApplier(..), PatchProxy(..)
    , StandardPatchApplier(..)
    ) where

import Prelude ()
import Darcs.Prelude

import System.Exit ( ExitCode ( ExitSuccess ), exitSuccess )
import System.IO ( hClose, stdout, stderr )
import Control.Exception
                 ( catch, fromException, SomeException, throwIO )
import Control.Monad ( when, unless )
import qualified Data.ByteString.Char8 as BC

import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.UI.Commands
    ( putVerbose
    , putInfo
    , setEnvDarcsPatches
    )
import Darcs.UI.Commands.Util ( printDryRunMessageAndExit )
import Darcs.UI.CommandsAux ( checkPaths )
import Darcs.UI.Flags
    ( DarcsFlag, verbosity, compress, reorder, allowConflicts, externalMerge
    , wantGuiPause, diffingOpts, setScriptsExecutable, isInteractive, testChanges
    , xmlOutput, reply, getCc, getSendmailCmd, dryRun
    )
import qualified Darcs.UI.Options.All as O
import Darcs.UI.Options ( (?) )
import Darcs.UI.Commands.Util ( testTentativeAndMaybeExit )
import Darcs.Repository.Flags ( UpdateWorking(..) )
import Darcs.Repository
    ( Repository
    , tentativelyMergePatches
    , finalizeRepositoryChanges
    , applyToWorking
    , invalidateIndex
    , setScriptsExecutablePatches
    )
import Darcs.Repository.Job ( RepoJob(RepoJob) )
import Darcs.Patch ( RepoPatch, RepoType, IsRepoType, description )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Witnesses.Ordered
    ( FL, mapFL, nullFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )

import Darcs.UI.External ( sendEmail )
import Darcs.Util.Lock ( withStdoutTemp, readBinFile )
import Darcs.Util.Printer ( vcat, text )
import Darcs.Util.Tree( Tree )

import GHC.Exts ( Constraint )

data PatchProxy (p :: * -> * -> *) = PatchProxy

-- |This class is a hack to abstract over pull/apply and rebase pull/apply.
class PatchApplier pa where

    type ApplierRepoTypeConstraint pa (rt :: RepoType) :: Constraint

    repoJob
        :: pa
        -> [DarcsFlag]
        -> (forall rt p wR wU
               . ( IsRepoType rt, ApplierRepoTypeConstraint pa rt
                 , RepoPatch p, ApplyState p ~ Tree
                 )
              => (PatchProxy p -> Repository rt p wR wU wR -> IO ()))
        -> RepoJob ()

    applyPatches
        :: forall rt p wR wU wT wX wZ
         . ( ApplierRepoTypeConstraint pa rt, IsRepoType rt
           , RepoPatch p, ApplyState p ~ Tree
           )
        => pa
        -> PatchProxy p
        -> String
        -> [DarcsFlag]
        -> String
        -> Repository rt p wR wU wT
        -> FL (PatchInfoAnd rt p) wX wT
        -> FL (PatchInfoAnd rt p) wX wZ -> IO ()

data StandardPatchApplier = StandardPatchApplier

instance PatchApplier StandardPatchApplier where
    type ApplierRepoTypeConstraint StandardPatchApplier rt = ()
    repoJob :: StandardPatchApplier
-> [DarcsFlag]
-> (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
    (IsRepoType rt, ApplierRepoTypeConstraint StandardPatchApplier rt,
     RepoPatch p, ApplyState p ~ Tree) =>
    PatchProxy p -> Repository rt p wR wU wR -> IO ())
-> RepoJob ()
repoJob StandardPatchApplier _opts :: [DarcsFlag]
_opts f :: forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, ApplierRepoTypeConstraint StandardPatchApplier rt,
 RepoPatch p, ApplyState p ~ Tree) =>
PatchProxy p -> Repository rt p wR wU wR -> IO ()
f = (forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO ())
-> RepoJob ()
forall a.
(forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
 (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
 Repository rt p wR wU wR -> IO a)
-> RepoJob a
RepoJob (PatchProxy p -> Repository rt p wR wU wR -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU.
(IsRepoType rt, ApplierRepoTypeConstraint StandardPatchApplier rt,
 RepoPatch p, ApplyState p ~ Tree) =>
PatchProxy p -> Repository rt p wR wU wR -> IO ()
f PatchProxy p
forall (p :: * -> * -> *). PatchProxy p
PatchProxy)
    applyPatches :: StandardPatchApplier
-> PatchProxy p
-> String
-> [DarcsFlag]
-> String
-> Repository rt p wR wU wT
-> FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wZ
-> IO ()
applyPatches StandardPatchApplier PatchProxy = String
-> [DarcsFlag]
-> String
-> Repository rt p wR wU wT
-> FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wZ
-> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX wZ.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
String
-> [DarcsFlag]
-> String
-> Repository rt p wR wU wT
-> FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wZ
-> IO ()
standardApplyPatches

standardApplyPatches
           :: forall rt p wR wU wT wX wZ
            . (IsRepoType rt, RepoPatch p, ApplyState p ~ Tree)
           => String -> [DarcsFlag] -> String -> Repository rt p wR wU wT
           -> FL (PatchInfoAnd rt p) wX wT -> FL (PatchInfoAnd rt p) wX wZ -> IO ()
standardApplyPatches :: String
-> [DarcsFlag]
-> String
-> Repository rt p wR wU wT
-> FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wZ
-> IO ()
standardApplyPatches cmdName :: String
cmdName opts :: [DarcsFlag]
opts from_whom :: String
from_whom repository :: Repository rt p wR wU wT
repository us' :: FL (PatchInfoAnd rt p) wX wT
us' to_be_applied :: FL (PatchInfoAnd rt p) wX wZ
to_be_applied = do
   String
-> Verbosity
-> Summary
-> DryRun
-> XmlOutput
-> Bool
-> FL (PatchInfoAnd rt p) wX wZ
-> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
String
-> Verbosity
-> Summary
-> DryRun
-> XmlOutput
-> Bool
-> FL (PatchInfoAnd rt p) wX wY
-> IO ()
printDryRunMessageAndExit String
cmdName
      (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      (PrimDarcsOption Summary
O.summary PrimDarcsOption Summary -> [DarcsFlag] -> Summary
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      (PrimDarcsOption DryRun
dryRun PrimDarcsOption DryRun -> [DarcsFlag] -> DryRun
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      (PrimDarcsOption XmlOutput
xmlOutput PrimDarcsOption XmlOutput -> [DarcsFlag] -> XmlOutput
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
      (Bool -> [DarcsFlag] -> Bool
isInteractive Bool
True [DarcsFlag]
opts)
      FL (PatchInfoAnd rt p) wX wZ
to_be_applied
   Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FL (PatchInfoAnd rt p) wX wZ -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PatchInfoAnd rt p) wX wZ
to_be_applied Bool -> Bool -> Bool
&& PrimDarcsOption Reorder
reorder PrimDarcsOption Reorder -> [DarcsFlag] -> Reorder
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts Reorder -> Reorder -> Bool
forall a. Eq a => a -> a -> Bool
== Reorder
O.NoReorder) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do 
           String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "You don't want to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ " any patches, so I'm exiting!"
           IO ()
forall a. IO a
exitSuccess
   [DarcsFlag] -> FL (PatchInfoAnd rt p) wX wZ -> IO ()
forall (p :: * -> * -> *) wX wY.
PatchInspect p =>
[DarcsFlag] -> FL p wX wY -> IO ()
checkPaths [DarcsFlag]
opts FL (PatchInfoAnd rt p) wX wZ
to_be_applied
   [DarcsFlag] -> String -> IO () -> IO ()
redirectOutput [DarcsFlag]
opts String
from_whom (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (FL (PatchInfoAnd rt p) wX wZ -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PatchInfoAnd rt p) wX wZ
to_be_applied) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        [DarcsFlag] -> Doc -> IO ()
putVerbose [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ "Will " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ " the following patches:"
        [DarcsFlag] -> Doc -> IO ()
putVerbose [DarcsFlag]
opts (Doc -> IO ()) -> ([Doc] -> Doc) -> [Doc] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vcat ([Doc] -> IO ()) -> [Doc] -> IO ()
forall a b. (a -> b) -> a -> b
$ (forall wW wZ. PatchInfoAnd rt p wW wZ -> Doc)
-> FL (PatchInfoAnd rt p) wX wZ -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL forall wW wZ. PatchInfoAnd rt p wW wZ -> Doc
forall (p :: * -> * -> *) wX wY. ShowPatch p => p wX wY -> Doc
description FL (PatchInfoAnd rt p) wX wZ
to_be_applied
        FL (PatchInfoAnd rt p) wX wZ -> IO ()
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
(RepoPatch p, ApplyState p ~ Tree) =>
FL (PatchInfoAnd rt p) wX wY -> IO ()
setEnvDarcsPatches FL (PatchInfoAnd rt p) wX wZ
to_be_applied
    Sealed pw :: FL (PrimOf p) wU wX
pw <- Repository rt p wR wU wT
-> String
-> AllowConflicts
-> UpdateWorking
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wZ
-> IO (Sealed (FL (PrimOf p) wU))
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT wX wY.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT
-> String
-> AllowConflicts
-> UpdateWorking
-> ExternalMerge
-> WantGuiPause
-> Compression
-> Verbosity
-> Reorder
-> (UseIndex, ScanKnown, DiffAlgorithm)
-> FL (PatchInfoAnd rt p) wX wT
-> FL (PatchInfoAnd rt p) wX wY
-> IO (Sealed (FL (PrimOf p) wU))
tentativelyMergePatches Repository rt p wR wU wT
repository String
cmdName
                         ([DarcsFlag] -> AllowConflicts
allowConflicts [DarcsFlag]
opts) UpdateWorking
YesUpdateWorking
                         (PrimDarcsOption ExternalMerge
externalMerge PrimDarcsOption ExternalMerge -> [DarcsFlag] -> ExternalMerge
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) ([DarcsFlag] -> WantGuiPause
wantGuiPause [DarcsFlag]
opts)
                         (PrimDarcsOption Compression
compress PrimDarcsOption Compression -> [DarcsFlag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
                         (PrimDarcsOption Reorder
reorder PrimDarcsOption Reorder -> [DarcsFlag] -> Reorder
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) ([DarcsFlag] -> (UseIndex, ScanKnown, DiffAlgorithm)
diffingOpts [DarcsFlag]
opts)
                         FL (PatchInfoAnd rt p) wX wT
us' FL (PatchInfoAnd rt p) wX wZ
to_be_applied
    Repository rt p wR wU wT -> IO ()
forall t. t -> IO ()
invalidateIndex Repository rt p wR wU wT
repository
    Repository rt p wR wU wT
-> Verbosity
-> TestChanges
-> SetScriptsExecutable
-> Bool
-> String
-> String
-> Maybe String
-> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
Repository rt p wR wU wT
-> Verbosity
-> TestChanges
-> SetScriptsExecutable
-> Bool
-> String
-> String
-> Maybe String
-> IO ()
testTentativeAndMaybeExit Repository rt p wR wU wT
repository
         (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
         (PrimDarcsOption TestChanges
testChanges PrimDarcsOption TestChanges -> [DarcsFlag] -> TestChanges
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
         (PrimDarcsOption SetScriptsExecutable
setScriptsExecutable PrimDarcsOption SetScriptsExecutable
-> [DarcsFlag] -> SetScriptsExecutable
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
         (Bool -> [DarcsFlag] -> Bool
isInteractive Bool
True [DarcsFlag]
opts)
         "those patches do not pass the tests." (String
cmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ " them") Maybe String
forall a. Maybe a
Nothing
    IO () -> IO ()
forall a. IO a -> IO a
withSignalsBlocked (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do Repository rt p wR wU wT -> UpdateWorking -> Compression -> IO ()
forall (rt :: RepoType) (p :: * -> * -> *) wR wU wT.
(IsRepoType rt, RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wR wU wT -> UpdateWorking -> Compression -> IO ()
finalizeRepositoryChanges Repository rt p wR wU wT
repository UpdateWorking
YesUpdateWorking (PrimDarcsOption Compression
compress PrimDarcsOption Compression -> [DarcsFlag] -> Compression
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts)
                            Repository rt p wR wX wT
_ <- Repository rt p wR wU wT
-> Verbosity
-> FL (PrimOf p) wU wX
-> IO (Repository rt p wR wX wT)
forall (p :: * -> * -> *) (rt :: RepoType) wR wU wT wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Repository rt p wR wU wT
-> Verbosity
-> FL (PrimOf p) wU wY
-> IO (Repository rt p wR wY wT)
applyToWorking Repository rt p wR wU wT
repository (PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) FL (PrimOf p) wU wX
pw IO (Repository rt p wR wX wT)
-> (SomeException -> IO (Repository rt p wR wX wT))
-> IO (Repository rt p wR wX wT)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException
e :: SomeException) ->
                                String -> IO (Repository rt p wR wX wT)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("Error applying patch to working dir:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
                            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PrimDarcsOption SetScriptsExecutable
setScriptsExecutable PrimDarcsOption SetScriptsExecutable
-> [DarcsFlag] -> SetScriptsExecutable
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts SetScriptsExecutable -> SetScriptsExecutable -> Bool
forall a. Eq a => a -> a -> Bool
== SetScriptsExecutable
O.YesSetScriptsExecutable) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
                              FL (PrimOf p) wU wX -> IO ()
forall (p :: * -> * -> *) wX wY. PatchInspect p => p wX wY -> IO ()
setScriptsExecutablePatches FL (PrimOf p) wU wX
pw
                            () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    case (FL (PatchInfoAnd rt p) wX wZ -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PatchInfoAnd rt p) wX wZ
to_be_applied, PrimDarcsOption Reorder
reorder PrimDarcsOption Reorder -> [DarcsFlag] -> Reorder
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts Reorder -> Reorder -> Bool
forall a. Eq a => a -> a -> Bool
== Reorder
O.Reorder) of
                (True,True)  -> [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ "Nothing to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", finished reordering."
                (False,True) -> [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ "Finished " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "ing and reordering."
                _            -> [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ "Finished " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cmdName String -> String -> String
forall a. [a] -> [a] -> [a]
++ "ing."

redirectOutput :: [DarcsFlag] -> String -> IO () -> IO ()
redirectOutput :: [DarcsFlag] -> String -> IO () -> IO ()
redirectOutput opts :: [DarcsFlag]
opts to :: String
to doit :: IO ()
doit = case PrimDarcsOption (Maybe String)
reply PrimDarcsOption (Maybe String) -> [DarcsFlag] -> Maybe String
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts of
    Nothing -> IO ()
doit
    Just from :: String
from -> (String -> IO ()) -> IO ()
forall a. (String -> IO a) -> IO a
withStdoutTemp ((String -> IO ()) -> IO ()) -> (String -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \tempf :: String
tempf -> IO ()
doitAndCleanup IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` String -> String -> SomeException -> IO ()
forall a. String -> String -> SomeException -> IO a
sendit String
tempf String
from
  where
    -- TODO: I suggest people writing such code should *at least* put in some comments.
    -- It is unclear how this works and how the intertwined exception handlers make
    -- this do what the author wanted.
    doitAndCleanup :: IO ()
doitAndCleanup = IO ()
doit IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
stdout IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
stderr
    sendit :: FilePath -> String -> SomeException -> IO a
    sendit :: String -> String -> SomeException -> IO a
sendit tempf :: String
tempf from :: String
from e :: SomeException
e | Just ExitSuccess <- SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e =
      do [DarcsFlag]
-> String -> String -> String -> String -> String -> IO ()
sendSanitizedEmail [DarcsFlag]
opts String
from String
to "Patch applied" String
cc String
tempf
         SomeException -> IO a
forall e a. Exception e => e -> IO a
throwIO SomeException
e
    sendit tempf :: String
tempf from :: String
from e :: SomeException
e | Just (ExitCode
_ :: ExitCode) <- SomeException -> Maybe ExitCode
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e =
      do [DarcsFlag]
-> String -> String -> String -> String -> String -> IO ()
sendSanitizedEmail [DarcsFlag]
opts String
from String
to "Patch failed!" String
cc String
tempf
         ExitCode -> IO a
forall e a. Exception e => e -> IO a
throwIO ExitCode
ExitSuccess
    sendit tempf :: String
tempf from :: String
from e :: SomeException
e =
      do [DarcsFlag]
-> String -> String -> String -> String -> String -> IO ()
sendSanitizedEmail [DarcsFlag]
opts String
from String
to "Darcs error applying patch!" String
cc (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                   String
tempf String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\n\nCaught exception:\n"String -> String -> String
forall a. [a] -> [a] -> [a]
++
                   SomeException -> String
forall a. Show a => a -> String
show SomeException
eString -> String -> String
forall a. [a] -> [a] -> [a]
++"\n"
         ExitCode -> IO a
forall e a. Exception e => e -> IO a
throwIO ExitCode
ExitSuccess
    cc :: String
cc = [DarcsFlag] -> String
getCc [DarcsFlag]
opts

-- |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 :: [DarcsFlag]
-> String -> String -> String -> String -> String -> IO ()
sendSanitizedEmail opts :: [DarcsFlag]
opts from :: String
from to :: String
to subject :: String
subject cc :: String
cc mailtext :: String
mailtext =
    do String
scmd <- [DarcsFlag] -> IO String
getSendmailCmd [DarcsFlag]
opts
       String
body <- String -> IO String
sanitizeFile String
mailtext
       String -> String -> String -> String -> String -> String -> IO ()
sendEmail String
from String
to String
subject String
cc String
scmd String
body

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

sanitizeFile :: FilePath -> IO String
sanitizeFile :: String -> IO String
sanitizeFile f :: String
f = String -> String
sanitize (String -> String)
-> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
BC.unpack (ByteString -> String) -> IO ByteString -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
forall p. FilePathLike p => p -> IO ByteString
readBinFile String
f
    where sanitize :: String -> String
sanitize s :: String
s = String -> String
wash (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> String
remove_backspaces "" String
s
          wash :: String -> String
wash ('\000':s :: String
s) = "\\NUL" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
wash String
s
          wash ('\026':s :: String
s) = "\\EOF" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
wash String
s
          wash (c :: Char
c:cs :: String
cs) = Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
wash String
cs
          wash [] = []
          remove_backspaces :: String -> String -> String
remove_backspaces rev_sofar :: String
rev_sofar "" = String -> String
forall a. [a] -> [a]
reverse String
rev_sofar
          remove_backspaces (_:rs :: String
rs) ('\008':s :: String
s) = String -> String -> String
remove_backspaces String
rs String
s
          remove_backspaces "" ('\008':s :: String
s) = String -> String -> String
remove_backspaces "" String
s
          remove_backspaces rs :: String
rs (s :: Char
s:ss :: String
ss) = String -> String -> String
remove_backspaces (Char
sChar -> String -> String
forall a. a -> [a] -> [a]
:String
rs) String
ss