File: ApplyPatches.hs

package info (click to toggle)
darcs 2.12.4-2
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 5,748 kB
  • sloc: haskell: 42,936; sh: 11,086; ansic: 837; perl: 129; makefile: 8
file content (184 lines) | stat: -rw-r--r-- 7,766 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
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 Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )
import Darcs.Util.SignalHandler ( withSignalsBlocked )
import Darcs.UI.Commands
    ( putVerbose
    , putInfo
    , printDryRunMessageAndExit
    , setEnvDarcsPatches
    )
import Darcs.UI.CommandsAux ( checkPaths )
import Darcs.UI.Flags
    ( DarcsFlag, verbosity, compression, reorder, allowConflicts, externalMerge
    , wantGuiPause, diffingOpts, setScriptsExecutable, isInteractive, testChanges
    , hasXmlOutput, getReply, getCc, getSendmailCmd, hasSummary, dryRun
    )
import qualified Darcs.UI.Options.All as O
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, PrimOf )
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, ApplyState (PrimOf 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 (PrimOf p) ~ Tree, 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 _opts f = RepoJob (f PatchProxy)
    applyPatches StandardPatchApplier PatchProxy = standardApplyPatches

standardApplyPatches
           :: forall rt p wR wU wT wX wZ
            . (IsRepoType rt, RepoPatch p, ApplyState (PrimOf p) ~ Tree, 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 cmdName opts from_whom repository us' to_be_applied = do
   printDryRunMessageAndExit cmdName
      (verbosity opts)
      (hasSummary O.NoSummary opts)
      (dryRun opts)
      (hasXmlOutput opts)
      (isInteractive True opts)
      to_be_applied
   when (nullFL to_be_applied && reorder opts == O.NoReorder) $ do 
           putStrLn $ "You don't want to " ++ cmdName ++ " any patches, so I'm exiting!"
           exitSuccess
   checkPaths opts to_be_applied
   redirectOutput opts from_whom $ do
    unless (nullFL to_be_applied) $ do
        putVerbose opts $ text $ "Will " ++ cmdName ++ " the following patches:"
        putVerbose opts . vcat $ mapFL description to_be_applied
        setEnvDarcsPatches to_be_applied
    Sealed pw <- tentativelyMergePatches repository cmdName
                         (allowConflicts opts) YesUpdateWorking
                         (externalMerge opts) (wantGuiPause opts)
                         (compression opts) (verbosity opts)
                         (reorder opts) (diffingOpts opts)
                         us' to_be_applied
    invalidateIndex repository
    testTentativeAndMaybeExit repository
         (verbosity opts)
         (testChanges opts)
         (setScriptsExecutable opts)
         (isInteractive True opts)
         "those patches do not pass the tests." (cmdName ++ " them") Nothing
    withSignalsBlocked $ do finalizeRepositoryChanges repository YesUpdateWorking (compression opts)
                            _ <- applyToWorking repository (verbosity opts) pw `catch` \(e :: SomeException) ->
                                fail ("Error applying patch to working dir:\n" ++ show e)
                            when (setScriptsExecutable opts == O.YesSetScriptsExecutable) $
                              setScriptsExecutablePatches pw
                            return ()
    case (nullFL to_be_applied, reorder opts == O.Reorder) of
                (True,True)  -> putInfo opts $ text $ "Nothing to " ++ cmdName ++ ", finished reordering."
                (False,True) -> putInfo opts $ text $ "Finished " ++ cmdName ++ "ing and reordering."
                _            -> putInfo opts $ text $ "Finished " ++ cmdName ++ "ing."

redirectOutput :: [DarcsFlag] -> String -> IO () -> IO ()
redirectOutput opts to doit = case getReply opts of
    Nothing -> doit
    Just from -> withStdoutTemp $ \tempf -> doitAndCleanup `catch` sendit tempf 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 = doit >> hClose stdout >> hClose stderr
    sendit :: FilePath -> String -> SomeException -> IO a
    sendit tempf from e | Just ExitSuccess <- fromException e =
      do sendSanitizedEmail opts from to "Patch applied" cc tempf
         throwIO e
    sendit tempf from e | Just (_ :: ExitCode) <- fromException e =
      do sendSanitizedEmail opts from to "Patch failed!" cc tempf
         throwIO ExitSuccess
    sendit tempf from e =
      do sendSanitizedEmail opts from to "Darcs error applying patch!" cc $
                   tempf ++ "\n\nCaught exception:\n"++
                   show e++"\n"
         throwIO ExitSuccess
    cc = getCc 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 opts from to subject cc mailtext =
    do scmd <- getSendmailCmd opts
       body <- sanitizeFile mailtext
       sendEmail from 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