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

module Darcs.UI.Commands.Apply
    ( apply, applyCmd
    , getPatchBundle -- used by darcsden
    ) where

import Darcs.Prelude

import System.Exit ( exitSuccess )
import Control.Monad ( unless, when )
import Data.Maybe ( catMaybes )

import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefullyM, info )
import Darcs.UI.Commands
    ( DarcsCommand(..), withStdOpts
    , putInfo
    , amInHashedRepository
    )
import Darcs.UI.Completion ( fileArgs )
import Darcs.UI.Flags
    ( DarcsFlag
    , changesReverse, verbosity, useCache
    , reorder, umask
    , fixUrl
    )
import Darcs.UI.Options ( (^), parseFlags, (?) )
import qualified Darcs.UI.Options.All as O
import Darcs.Util.Path ( toFilePath, AbsolutePath )
import Darcs.Repository
    ( Repository
    , AccessType(..)
    , SealedPatchSet
    , withRepoLock
    , readPatches
    , filterOutConflicts
    )
import Darcs.Patch.Set ( PatchSet, Origin )
import Darcs.Patch ( RepoPatch )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Info ( PatchInfo, displayPatchInfo )
import Darcs.Patch.Witnesses.Ordered
    ( Fork(..), (:>)(..)
    , mapFL, nullFL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )
import Darcs.Util.ByteString ( linesPS, unlinesPS, gzReadStdin )
import qualified Data.ByteString as B (ByteString, null, init)
import qualified Data.ByteString.Char8 as BC (last)

import Darcs.Util.HTTP ( Cachable(Uncachable) )
import Darcs.Util.File ( gzFetchFilePS )
import Darcs.UI.External
    ( verifyPS
    )
import Darcs.UI.Email ( readEmail )
import Darcs.Patch.Depends ( findCommon )
import Darcs.UI.ApplyPatches ( PatchApplier(..), StandardPatchApplier(..), PatchProxy )
import Darcs.UI.SelectChanges
    ( WhichChanges(..)
    , runSelection
    , selectionConfig
    )
import qualified Darcs.UI.SelectChanges as S
import Darcs.Patch.Bundle ( interpretBundle, parseBundle )
import Darcs.Util.Printer
    ( Doc, vcat, text
    , renderString
    , ($$)
    , vsep
    , formatWords
    )
import Darcs.Util.Tree( Tree )

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

applyHelp :: Doc
applyHelp :: Doc
applyHelp = [Doc] -> Doc
vsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ([String] -> Doc) -> [[String]] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map [String] -> Doc
formatWords
  [ [ String
"The `darcs apply` command takes a patch bundle and attempts to insert"
    , String
"it into the current repository.  In addition to invoking it directly"
    , String
"on bundles created by `darcs send`, it is used internally by `darcs"
    , String
"push` on the remote end of an SSH connection."
    ]
  , [ String
"If no file is supplied, the bundle is read from standard input."
    ]
  , [ String
"If given an email instead of a patch bundle, Darcs will look for the"
    , String
"bundle as a MIME attachment to that email.  Currently this will fail"
    , String
"if the MIME boundary is rewritten, such as in Courier and Mail.app."
    ]
  , [ String
"If gpg(1) is installed, you can use `--verify pubring.gpg` to reject"
    , String
"bundles that aren't signed by a key in `pubring.gpg`."
    ]
  , [ String
"If `--test` is supplied and a test is defined (see `darcs setpref`), the"
    , String
"bundle will be rejected if the test fails after applying it."
    ]
  , [ String
"Unlike most Darcs commands, `darcs apply` defaults to `--all`.  Use the"
    , String
"`--interactive` option to pick which patches to apply from a bundle."
    ]
  , [ String
"A patch bundle may introduce unresolved conflicts with existing"
    , String
"patches or with the working tree.  By default, Darcs will refuse to"
    , String
"apply conflicting patches (`--no-allow-conflicts`)."
    ]
  , [ String
"The `--mark-conflicts` option instructs Darcs to allow conflicts and"
    , String
"try to add conflict markup in your working tree. Note that this may"
    , String
"(partly) fail, because some conflicts cannot be marked, such as e.g."
    , String
"conflicts between two adds of the same file. In this case Darcs will"
    , String
"warn you and display the conflicting changes instead. When Darcs"
    , String
"detects conflicts with unrecorded changes, it will give you an extra"
    , String
"warning and prompts you to confirm that you want to continue. This is"
    , String
"because your original unrecorded changes cannot be automatically"
    , String
"restored by Darcs."
    ]
  , [ String
"Note that conflict markup is something Darcs adds to your working tree"
    , String
"files. Nevertheless, you can always re-construct it using"
    , String
"`darcs mark-conflicts`."
    ]
  , [ String
"The `--external-merge` option lets you resolve conflicts"
    , String
"using an external merge tool.  In the option, `%a` is replaced with"
    , String
"the common ancestor (merge base), `%1` with the first version, `%2`"
    , String
"with the second version, and `%o` with the path where your resolved"
    , String
"content should go.  For example, to use the xxdiff visual merge tool"
    , String
"you'd specify: `--external-merge='xxdiff -m -O -M %o %1 %a %2'`"
    ]
  , [ String
"The `--allow-conflicts` option allows conflicts but does not add"
    , String
"conflict markup. This is useful when you want to treat a repository as"
    , String
"just a bunch of patches, such as using `darcs pull --union` to download"
    , String
"all of your co-workers' patches before going offline. Again, conflict"
    , String
"markup can be added at any time later on using `darcs mark-conflicts`."
    ]
  , [ String
"For more information on conflicts in Darcs and how to resolve them,"
    , String
"see the help on `darcs mark-conflicts`."
    ]
  ]

stdindefault :: a -> [String] -> IO [String]
stdindefault :: forall a. a -> [String] -> IO [String]
stdindefault a
_ [] = [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String
"-"]
stdindefault a
_ [String]
x = [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
x

apply :: DarcsCommand
apply :: DarcsCommand
apply = DarcsCommand
    { commandProgramName :: String
commandProgramName = String
"darcs"
    , commandName :: String
commandName = String
"apply"
    , commandHelp :: Doc
commandHelp = Doc
applyHelp
    , commandDescription :: String
commandDescription = String
applyDescription
    , commandExtraArgs :: Int
commandExtraArgs = Int
1
    , commandExtraArgHelp :: [String]
commandExtraArgHelp = [String
"<PATCHFILE>"]
    , commandCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
commandCommand = StandardPatchApplier
-> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
forall pa.
PatchApplier pa =>
pa
-> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
applyCmd StandardPatchApplier
StandardPatchApplier
    , commandPrereq :: [DarcsFlag] -> IO (Either String ())
commandPrereq = [DarcsFlag] -> IO (Either String ())
amInHashedRepository
    , commandCompleteArgs :: (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
commandCompleteArgs = (AbsolutePath, AbsolutePath)
-> [DarcsFlag] -> [String] -> IO [String]
fileArgs
    , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
commandArgdefaults = (AbsolutePath -> [String] -> IO [String])
-> [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]
forall a b. a -> b -> a
const AbsolutePath -> [String] -> IO [String]
forall a. a -> [String] -> IO [String]
stdindefault
    , commandOptions :: CommandOptions
commandOptions = CommandOptions
applyOpts
    }
  where
    applyBasicOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Verify
   -> Reorder
   -> Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
applyBasicOpts
      = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Reorder
   -> Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
  Verify
PrimDarcsOption Verify
O.verify
      PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (Reorder
   -> Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
  Verify
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe Bool
      -> DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
     (Reorder
      -> Maybe Bool
      -> DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe Bool
      -> DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
     (Verify
      -> Reorder
      -> Maybe Bool
      -> DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
  (Reorder
   -> Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
PrimDarcsOption Reorder
O.reorder
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
  (Verify
   -> Reorder
   -> Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
     (Maybe Bool
      -> DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
     (Verify
      -> Reorder
      -> Maybe Bool
      -> DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
  (Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
PrimDarcsOption (Maybe Bool)
O.interactive
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
  (Verify
   -> Reorder
   -> Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     ([MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
     (DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     ([MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
     (Verify
      -> Reorder
      -> Maybe Bool
      -> DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  ([MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
  (DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
forall a. DarcsOption a (DryRun -> XmlOutput -> a)
O.dryRunXml
      OptSpec
  DarcsOptDescr
  DarcsFlag
  ([MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
  (Verify
   -> Reorder
   -> Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe AllowConflicts
      -> TestChanges -> Maybe String -> DiffAlgorithm -> a)
     ([MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe AllowConflicts
      -> TestChanges -> Maybe String -> DiffAlgorithm -> a)
     (Verify
      -> Reorder
      -> Maybe Bool
      -> DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe AllowConflicts
   -> TestChanges -> Maybe String -> DiffAlgorithm -> a)
  ([MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
MatchOption
O.matchSeveral
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe AllowConflicts
   -> TestChanges -> Maybe String -> DiffAlgorithm -> a)
  (Verify
   -> Reorder
   -> Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (TestChanges -> Maybe String -> DiffAlgorithm -> a)
     (Maybe AllowConflicts
      -> TestChanges -> Maybe String -> DiffAlgorithm -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (TestChanges -> Maybe String -> DiffAlgorithm -> a)
     (Verify
      -> Reorder
      -> Maybe Bool
      -> DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (TestChanges -> Maybe String -> DiffAlgorithm -> a)
  (Maybe AllowConflicts
   -> TestChanges -> Maybe String -> DiffAlgorithm -> a)
PrimDarcsOption (Maybe AllowConflicts)
O.conflictsNo
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (TestChanges -> Maybe String -> DiffAlgorithm -> a)
  (Verify
   -> Reorder
   -> Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> DiffAlgorithm -> a)
     (TestChanges -> Maybe String -> DiffAlgorithm -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Maybe String -> DiffAlgorithm -> a)
     (Verify
      -> Reorder
      -> Maybe Bool
      -> DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> DiffAlgorithm -> a)
  (TestChanges -> Maybe String -> DiffAlgorithm -> a)
PrimDarcsOption TestChanges
O.testChanges
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe String -> DiffAlgorithm -> a)
  (Verify
   -> Reorder
   -> Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DiffAlgorithm -> a)
     (Maybe String -> DiffAlgorithm -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (DiffAlgorithm -> a)
     (Verify
      -> Reorder
      -> Maybe Bool
      -> DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (DiffAlgorithm -> a)
  (Maybe String -> DiffAlgorithm -> a)
PrimDarcsOption (Maybe String)
O.repoDir
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (DiffAlgorithm -> a)
  (Verify
   -> Reorder
   -> Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (DiffAlgorithm -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (Verify
      -> Reorder
      -> Maybe Bool
      -> DryRun
      -> XmlOutput
      -> [MatchFlag]
      -> Maybe AllowConflicts
      -> TestChanges
      -> Maybe String
      -> DiffAlgorithm
      -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (DiffAlgorithm -> a)
PrimDarcsOption DiffAlgorithm
O.diffAlgorithm
    applyAdvancedOpts :: OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (SetScriptsExecutable -> UMask -> Bool -> WantGuiPause -> a)
applyAdvancedOpts
      = PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (UMask -> Bool -> WantGuiPause -> a)
  SetScriptsExecutable
PrimDarcsOption SetScriptsExecutable
O.setScriptsExecutable
      PrimOptSpec
  DarcsOptDescr
  DarcsFlag
  (UMask -> Bool -> WantGuiPause -> a)
  SetScriptsExecutable
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Bool -> WantGuiPause -> a)
     (UMask -> Bool -> WantGuiPause -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (Bool -> WantGuiPause -> a)
     (SetScriptsExecutable -> UMask -> Bool -> WantGuiPause -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool -> WantGuiPause -> a)
  (UMask -> Bool -> WantGuiPause -> a)
PrimDarcsOption UMask
O.umask
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (Bool -> WantGuiPause -> a)
  (SetScriptsExecutable -> UMask -> Bool -> WantGuiPause -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (WantGuiPause -> a)
     (Bool -> WantGuiPause -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     (WantGuiPause -> a)
     (SetScriptsExecutable -> UMask -> Bool -> WantGuiPause -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec
  DarcsOptDescr
  DarcsFlag
  (WantGuiPause -> a)
  (Bool -> WantGuiPause -> a)
PrimDarcsOption Bool
O.changesReverse
      OptSpec
  DarcsOptDescr
  DarcsFlag
  (WantGuiPause -> a)
  (SetScriptsExecutable -> UMask -> Bool -> WantGuiPause -> a)
-> OptSpec DarcsOptDescr DarcsFlag a (WantGuiPause -> a)
-> OptSpec
     DarcsOptDescr
     DarcsFlag
     a
     (SetScriptsExecutable -> UMask -> Bool -> WantGuiPause -> a)
forall (d :: * -> *) f b c a.
OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c
^ OptSpec DarcsOptDescr DarcsFlag a (WantGuiPause -> a)
PrimDarcsOption WantGuiPause
O.pauseForGui
    applyOpts :: CommandOptions
applyOpts = OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> UMask
   -> Bool
   -> WantGuiPause
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Verify
   -> Reorder
   -> Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> UMask
   -> Bool
   -> WantGuiPause
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (Verify
   -> Reorder
   -> Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> a)
applyBasicOpts OptSpec
  DarcsOptDescr
  DarcsFlag
  (Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> UMask
   -> Bool
   -> WantGuiPause
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
  (Verify
   -> Reorder
   -> Maybe Bool
   -> DryRun
   -> XmlOutput
   -> [MatchFlag]
   -> Maybe AllowConflicts
   -> TestChanges
   -> Maybe String
   -> DiffAlgorithm
   -> Maybe StdCmdAction
   -> Verbosity
   -> SetScriptsExecutable
   -> UMask
   -> Bool
   -> WantGuiPause
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     (SetScriptsExecutable
      -> UMask
      -> Bool
      -> WantGuiPause
      -> UseCache
      -> UseIndex
      -> HooksConfig
      -> Bool
      -> Bool
      -> [DarcsFlag])
-> CommandOptions
forall b c.
DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c
-> DarcsOption
     (UseCache
      -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
     b
-> CommandOptions
`withStdOpts` DarcsOption
  (UseCache
   -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag])
  (SetScriptsExecutable
   -> UMask
   -> Bool
   -> WantGuiPause
   -> UseCache
   -> UseIndex
   -> HooksConfig
   -> Bool
   -> Bool
   -> [DarcsFlag])
forall {a}.
OptSpec
  DarcsOptDescr
  DarcsFlag
  a
  (SetScriptsExecutable -> UMask -> Bool -> WantGuiPause -> a)
applyAdvancedOpts

applyCmd :: PatchApplier pa
         => pa
         -> (AbsolutePath, AbsolutePath)
         -> [DarcsFlag]
         -> [String]
         -> IO ()
applyCmd :: forall pa.
PatchApplier pa =>
pa
-> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()
applyCmd pa
patchApplier (AbsolutePath
_,AbsolutePath
orig) [DarcsFlag]
opts [String]
args =
  UseCache -> UMask -> RepoJob 'RW () -> IO ()
forall a. UseCache -> UMask -> RepoJob 'RW a -> IO a
withRepoLock (PrimOptSpec DarcsOptDescr DarcsFlag a UseCache
PrimDarcsOption UseCache
useCache PrimDarcsOption UseCache -> [DarcsFlag] -> UseCache
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (PrimOptSpec DarcsOptDescr DarcsFlag a UMask
PrimDarcsOption UMask
umask PrimDarcsOption UMask -> [DarcsFlag] -> UMask
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) (RepoJob 'RW () -> IO ()) -> RepoJob 'RW () -> IO ()
forall a b. (a -> b) -> a -> b
$
  pa
-> (forall (p :: * -> * -> *) wR wU.
    (RepoPatch p, ApplyState p ~ Tree) =>
    PatchProxy p -> Repository 'RW p wU wR -> IO ())
-> RepoJob 'RW ()
forall pa.
PatchApplier pa =>
pa
-> (forall (p :: * -> * -> *) wR wU.
    (RepoPatch p, ApplyState p ~ Tree) =>
    PatchProxy p -> Repository 'RW p wU wR -> IO ())
-> RepoJob 'RW ()
repoJob pa
patchApplier ((forall (p :: * -> * -> *) wR wU.
  (RepoPatch p, ApplyState p ~ Tree) =>
  PatchProxy p -> Repository 'RW p wU wR -> IO ())
 -> RepoJob 'RW ())
-> (forall (p :: * -> * -> *) wR wU.
    (RepoPatch p, ApplyState p ~ Tree) =>
    PatchProxy p -> Repository 'RW p wU wR -> IO ())
-> RepoJob 'RW ()
forall a b. (a -> b) -> a -> b
$ \PatchProxy p
patchProxy Repository 'RW p wU wR
repository -> do
    ByteString
bundle <- [String] -> IO ByteString
readBundle [String]
args
    pa
-> PatchProxy p
-> [DarcsFlag]
-> ByteString
-> Repository 'RW p wU wR
-> IO ()
forall pa (p :: * -> * -> *) wR wU.
(PatchApplier pa, RepoPatch p, ApplyState p ~ Tree) =>
pa
-> PatchProxy p
-> [DarcsFlag]
-> ByteString
-> Repository 'RW p wU wR
-> IO ()
applyCmdCommon pa
patchApplier PatchProxy p
patchProxy [DarcsFlag]
opts ByteString
bundle Repository 'RW p wU wR
repository
  where
    readBundle :: [String] -> IO ByteString
readBundle [String
"-"] = do
      -- For users who try out 'darcs apply' without any arguments.
      -- FIXME apparently some magic behind the scenes causes an empty argument
      -- list to be converted to a single "-". This is quite obscure and should
      -- be removed.
      [DarcsFlag] -> Doc -> IO ()
putInfo [DarcsFlag]
opts (Doc -> IO ()) -> Doc -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Doc
text String
"reading patch bundle from stdin..."
      IO ByteString
gzReadStdin
    readBundle [String
""] = String -> IO ByteString
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Empty filename argument given to apply!"
    readBundle [String
unfixed_filename] = do
      String
patchesfile <- AbsolutePath -> String -> IO String
fixUrl AbsolutePath
orig String
unfixed_filename
      String -> Cachable -> IO ByteString
gzFetchFilePS (String -> String
forall a. FilePathLike a => a -> String
toFilePath String
patchesfile) Cachable
Uncachable
    readBundle [String]
_ = String -> IO ByteString
forall a. HasCallStack => String -> a
error String
"impossible case"

applyCmdCommon
    :: forall pa p wR wU
     . (PatchApplier pa, RepoPatch p, ApplyState p ~ Tree)
    => pa
    -> PatchProxy p
    -> [DarcsFlag]
    -> B.ByteString
    -> Repository 'RW p wU wR
    -> IO ()
applyCmdCommon :: forall pa (p :: * -> * -> *) wR wU.
(PatchApplier pa, RepoPatch p, ApplyState p ~ Tree) =>
pa
-> PatchProxy p
-> [DarcsFlag]
-> ByteString
-> Repository 'RW p wU wR
-> IO ()
applyCmdCommon pa
patchApplier PatchProxy p
patchProxy [DarcsFlag]
opts ByteString
bundle Repository 'RW p wU wR
repository = do
  PatchSet p Origin wR
us <- Repository 'RW p wU wR -> IO (PatchSet p Origin wR)
forall (p :: * -> * -> *) (rt :: AccessType) wU wR.
RepoPatch p =>
Repository rt p wU wR -> IO (PatchSet p Origin wR)
readPatches Repository 'RW p wU wR
repository
  Sealed PatchSet p Origin wX
them <- (String -> IO (Sealed (PatchSet p Origin)))
-> (Sealed (PatchSet p Origin) -> IO (Sealed (PatchSet p Origin)))
-> Either String (Sealed (PatchSet p Origin))
-> IO (Sealed (PatchSet p Origin))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO (Sealed (PatchSet p Origin))
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail Sealed (PatchSet p Origin) -> IO (Sealed (PatchSet p Origin))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Sealed (PatchSet p Origin))
 -> IO (Sealed (PatchSet p Origin)))
-> IO (Either String (Sealed (PatchSet p Origin)))
-> IO (Sealed (PatchSet p Origin))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [DarcsFlag]
-> PatchSet p Origin wR
-> ByteString
-> IO (Either String (Sealed (PatchSet p Origin)))
forall (p :: * -> * -> *) wR.
RepoPatch p =>
[DarcsFlag]
-> PatchSet p Origin wR
-> ByteString
-> IO (Either String (SealedPatchSet p Origin))
getPatchBundle [DarcsFlag]
opts PatchSet p Origin wR
us ByteString
bundle
  Fork PatchSet p Origin wU
common FL (PatchInfoAnd p) wU wR
us' FL (PatchInfoAnd p) wU wX
them' <- Fork
  (PatchSet p)
  (FL (PatchInfoAnd p))
  (FL (PatchInfoAnd p))
  Origin
  wR
  wX
-> IO
     (Fork
        (PatchSet p)
        (FL (PatchInfoAnd p))
        (FL (PatchInfoAnd p))
        Origin
        wR
        wX)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Fork
   (PatchSet p)
   (FL (PatchInfoAnd p))
   (FL (PatchInfoAnd p))
   Origin
   wR
   wX
 -> IO
      (Fork
         (PatchSet p)
         (FL (PatchInfoAnd p))
         (FL (PatchInfoAnd p))
         Origin
         wR
         wX))
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wX
-> IO
     (Fork
        (PatchSet p)
        (FL (PatchInfoAnd p))
        (FL (PatchInfoAnd p))
        Origin
        wR
        wX)
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR
-> PatchSet p Origin wX
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wX
forall (p :: * -> * -> *) wX wY.
Commute p =>
PatchSet p Origin wX
-> PatchSet p Origin wY
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wX
     wY
findCommon PatchSet p Origin wR
us PatchSet p Origin wX
them

  -- all patches in them' need to be available; check that
  let check :: PatchInfoAnd p wX wY -> Maybe PatchInfo
      check :: forall wX wY. PatchInfoAnd p wX wY -> Maybe PatchInfo
check PatchInfoAnd p wX wY
p = case PatchInfoAnd p wX wY -> Maybe (Named p wX wY)
forall (p :: * -> * -> *) wA wB.
PatchInfoAndG p wA wB -> Maybe (p wA wB)
hopefullyM PatchInfoAnd p wX wY
p of
        Maybe (Named p wX wY)
Nothing -> PatchInfo -> Maybe PatchInfo
forall a. a -> Maybe a
Just (PatchInfoAnd p wX wY -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info PatchInfoAnd p wX wY
p)
        Just Named p wX wY
_ -> Maybe PatchInfo
forall a. Maybe a
Nothing
      bad :: [PatchInfo]
bad = [Maybe PatchInfo] -> [PatchInfo]
forall a. [Maybe a] -> [a]
catMaybes ((forall wX wY. PatchInfoAnd p wX wY -> Maybe PatchInfo)
-> FL (PatchInfoAnd p) wU wX -> [Maybe PatchInfo]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL PatchInfoAnd p wW wZ -> Maybe PatchInfo
forall wX wY. PatchInfoAnd p wX wY -> Maybe PatchInfo
check FL (PatchInfoAnd p) wU wX
them')
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([PatchInfo] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PatchInfo]
bad) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    Doc -> String
renderString (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$
      ([Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (PatchInfo -> Doc) -> [PatchInfo] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PatchInfo -> Doc
displayPatchInfo [PatchInfo]
bad) Doc -> Doc -> Doc
$$ String -> Doc
text String
"" Doc -> Doc -> Doc
$$
      String -> Doc
text String
"Cannot apply this bundle. We are missing the above patches."

  (Bool
hadConflicts, Sealed FL (PatchInfoAnd p) wU wX
their_ps)
    <- if PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe AllowConflicts)
PrimDarcsOption (Maybe AllowConflicts)
O.conflictsNo PrimDarcsOption (Maybe AllowConflicts)
-> [DarcsFlag] -> Maybe AllowConflicts
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts Maybe AllowConflicts -> Maybe AllowConflicts -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe AllowConflicts
forall a. Maybe a
Nothing -- skip conflicts
        then Repository 'RW p wU wR
-> UseIndex
-> FL (PatchInfoAnd p) wU wR
-> FL (PatchInfoAnd p) wU wX
-> IO (Bool, Sealed (FL (PatchInfoAnd p) wU))
forall (p :: * -> * -> *) (rt :: AccessType) wU wR wX wZ.
(RepoPatch p, ApplyState p ~ Tree) =>
Repository rt p wU wR
-> UseIndex
-> FL (PatchInfoAnd p) wX wR
-> FL (PatchInfoAnd p) wX wZ
-> IO (Bool, Sealed (FL (PatchInfoAnd p) wX))
filterOutConflicts Repository 'RW p wU wR
repository (PrimOptSpec DarcsOptDescr DarcsFlag a UseIndex
PrimDarcsOption UseIndex
O.useIndex PrimDarcsOption UseIndex -> [DarcsFlag] -> UseIndex
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts) FL (PatchInfoAnd p) wU wR
us' FL (PatchInfoAnd p) wU wX
them'
        else (Bool, Sealed (FL (PatchInfoAnd p) wU))
-> IO (Bool, Sealed (FL (PatchInfoAnd p) wU))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, FL (PatchInfoAnd p) wU wX -> Sealed (FL (PatchInfoAnd p) wU)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL (PatchInfoAnd p) wU wX
them')
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hadConflicts (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Skipping some patches which would cause conflicts."
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FL (PatchInfoAnd p) wU wX -> Bool
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> Bool
nullFL FL (PatchInfoAnd p) wU wX
their_ps) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       do if Bool
hadConflicts
           then String -> IO ()
putStrLn (String
"All new patches of the bundle cause conflicts.  " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                          String
"Nothing to do.") IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitSuccess
           else String -> IO ()
putStrLn (String
"All these patches have already been applied.  " String -> String -> String
forall a. [a] -> [a] -> [a]
++
                          String
"Nothing to do.") IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PrimOptSpec DarcsOptDescr DarcsFlag a Reorder
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) IO ()
forall a. IO a
exitSuccess
          
  let direction :: WhichChanges
direction = if PrimOptSpec DarcsOptDescr DarcsFlag a Bool
PrimDarcsOption Bool
changesReverse PrimDarcsOption Bool -> [DarcsFlag] -> Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
opts then WhichChanges
FirstReversed else WhichChanges
First
      selection_config :: SelectionConfig (PatchInfoAnd p)
selection_config = WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter (PatchInfoAnd p))
-> Maybe [AnchoredPath]
-> SelectionConfig (PatchInfoAnd p)
forall (p :: * -> * -> *).
Matchable p =>
WhichChanges
-> String
-> PatchSelectionOptions
-> Maybe (Splitter p)
-> Maybe [AnchoredPath]
-> SelectionConfig p
selectionConfig WhichChanges
direction String
"apply" ([DarcsFlag] -> PatchSelectionOptions
patchSelOpts [DarcsFlag]
opts) Maybe (Splitter (PatchInfoAnd p))
forall a. Maybe a
Nothing Maybe [AnchoredPath]
forall a. Maybe a
Nothing
  (FL (PatchInfoAnd p) wU wZ
to_be_applied :> FL (PatchInfoAnd p) wZ wX
_) <- FL (PatchInfoAnd p) wU wX
-> SelectionConfig (PatchInfoAnd p)
-> IO ((:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wU wX)
forall (p :: * -> * -> *) wX wY.
(MatchableRP p, ShowPatch p, ShowContextPatch p,
 ApplyState p ~ Tree, ApplyState p ~ ApplyState (PrimOf p)) =>
FL p wX wY -> SelectionConfig p -> IO ((:>) (FL p) (FL p) wX wY)
runSelection FL (PatchInfoAnd p) wU wX
their_ps SelectionConfig (PatchInfoAnd p)
selection_config
  pa
-> PatchProxy p
-> String
-> [DarcsFlag]
-> Repository 'RW p wU wR
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wZ
-> IO ()
forall pa (p :: * -> * -> *) wR wU wZ.
(PatchApplier pa, RepoPatch p, ApplyState p ~ Tree) =>
pa
-> PatchProxy p
-> String
-> [DarcsFlag]
-> Repository 'RW p wU wR
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wZ
-> IO ()
forall (p :: * -> * -> *) wR wU wZ.
(RepoPatch p, ApplyState p ~ Tree) =>
pa
-> PatchProxy p
-> String
-> [DarcsFlag]
-> Repository 'RW p wU wR
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wZ
-> IO ()
applyPatches pa
patchApplier PatchProxy p
patchProxy String
"apply" [DarcsFlag]
opts Repository 'RW p wU wR
repository (PatchSet p Origin wU
-> FL (PatchInfoAnd p) wU wR
-> FL (PatchInfoAnd p) wU wZ
-> Fork
     (PatchSet p)
     (FL (PatchInfoAnd p))
     (FL (PatchInfoAnd p))
     Origin
     wR
     wZ
forall (common :: * -> * -> *) (left :: * -> * -> *)
       (right :: * -> * -> *) wA wX wY wU.
common wA wU
-> left wU wX -> right wU wY -> Fork common left right wA wX wY
Fork PatchSet p Origin wU
common FL (PatchInfoAnd p) wU wR
us' FL (PatchInfoAnd p) wU wZ
to_be_applied)

getPatchBundle :: RepoPatch p
               => [DarcsFlag]
               -> PatchSet p Origin wR
               -> B.ByteString
               -> IO (Either String (SealedPatchSet p Origin))
getPatchBundle :: forall (p :: * -> * -> *) wR.
RepoPatch p =>
[DarcsFlag]
-> PatchSet p Origin wR
-> ByteString
-> IO (Either String (SealedPatchSet p Origin))
getPatchBundle [DarcsFlag]
opts PatchSet p Origin wR
us ByteString
fps = do
    let opt_verify :: Verify
opt_verify = PrimDarcsOption Verify -> [DarcsFlag] -> Verify
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimOptSpec DarcsOptDescr DarcsFlag a Verify
PrimDarcsOption Verify
O.verify [DarcsFlag]
opts
    Maybe ByteString
mps <- Verify -> ByteString -> IO (Maybe ByteString)
verifyPS Verify
opt_verify (ByteString -> IO (Maybe ByteString))
-> ByteString -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
readEmail ByteString
fps
    Maybe ByteString
mops <- Verify -> ByteString -> IO (Maybe ByteString)
verifyPS Verify
opt_verify ByteString
fps
    case (Maybe ByteString
mps, Maybe ByteString
mops) of
      (Maybe ByteString
Nothing, Maybe ByteString
Nothing) ->
          Either String (SealedPatchSet p Origin)
-> IO (Either String (SealedPatchSet p Origin))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (SealedPatchSet p Origin)
 -> IO (Either String (SealedPatchSet p Origin)))
-> Either String (SealedPatchSet p Origin)
-> IO (Either String (SealedPatchSet p Origin))
forall a b. (a -> b) -> a -> b
$ String -> Either String (SealedPatchSet p Origin)
forall a b. a -> Either a b
Left String
"Patch bundle not properly signed, or gpg failed."
      (Just ByteString
bundle, Maybe ByteString
Nothing) -> Either String (SealedPatchSet p Origin)
-> IO (Either String (SealedPatchSet p Origin))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (SealedPatchSet p Origin)
 -> IO (Either String (SealedPatchSet p Origin)))
-> Either String (SealedPatchSet p Origin)
-> IO (Either String (SealedPatchSet p Origin))
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR
-> ByteString -> Either String (SealedPatchSet p Origin)
forall (p :: * -> * -> *) wR.
RepoPatch p =>
PatchSet p Origin wR
-> ByteString -> Either String (SealedPatchSet p Origin)
parseAndInterpretBundle PatchSet p Origin wR
us ByteString
bundle
      (Maybe ByteString
Nothing, Just ByteString
bundle) -> Either String (SealedPatchSet p Origin)
-> IO (Either String (SealedPatchSet p Origin))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (SealedPatchSet p Origin)
 -> IO (Either String (SealedPatchSet p Origin)))
-> Either String (SealedPatchSet p Origin)
-> IO (Either String (SealedPatchSet p Origin))
forall a b. (a -> b) -> a -> b
$ PatchSet p Origin wR
-> ByteString -> Either String (SealedPatchSet p Origin)
forall (p :: * -> * -> *) wR.
RepoPatch p =>
PatchSet p Origin wR
-> ByteString -> Either String (SealedPatchSet p Origin)
parseAndInterpretBundle PatchSet p Origin wR
us ByteString
bundle
      -- 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 ByteString
ps1, Just ByteString
ps2) -> case ByteString -> Either String (SealedPatchSet p Origin)
careful_scan_bundle ByteString
ps1 of
                              Left String
_ -> Either String (SealedPatchSet p Origin)
-> IO (Either String (SealedPatchSet p Origin))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (SealedPatchSet p Origin)
 -> IO (Either String (SealedPatchSet p Origin)))
-> Either String (SealedPatchSet p Origin)
-> IO (Either String (SealedPatchSet p Origin))
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String (SealedPatchSet p Origin)
careful_scan_bundle ByteString
ps2
                              Right SealedPatchSet p Origin
x -> Either String (SealedPatchSet p Origin)
-> IO (Either String (SealedPatchSet p Origin))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (SealedPatchSet p Origin)
 -> IO (Either String (SealedPatchSet p Origin)))
-> Either String (SealedPatchSet p Origin)
-> IO (Either String (SealedPatchSet p Origin))
forall a b. (a -> b) -> a -> b
$ SealedPatchSet p Origin -> Either String (SealedPatchSet p Origin)
forall a b. b -> Either a b
Right SealedPatchSet p Origin
x
          where careful_scan_bundle :: ByteString -> Either String (SealedPatchSet p Origin)
careful_scan_bundle ByteString
bundle =
                    case PatchSet p Origin wR
-> ByteString -> Either String (SealedPatchSet p Origin)
forall (p :: * -> * -> *) wR.
RepoPatch p =>
PatchSet p Origin wR
-> ByteString -> Either String (SealedPatchSet p Origin)
parseAndInterpretBundle PatchSet p Origin wR
us ByteString
bundle of
                    Left String
e -> case PatchSet p Origin wR
-> ByteString -> Either String (SealedPatchSet p Origin)
forall (p :: * -> * -> *) wR.
RepoPatch p =>
PatchSet p Origin wR
-> ByteString -> Either String (SealedPatchSet p Origin)
parseAndInterpretBundle PatchSet p Origin wR
us (ByteString -> Either String (SealedPatchSet p Origin))
-> ByteString -> Either String (SealedPatchSet p Origin)
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
stripCrPS ByteString
bundle of
                              Right SealedPatchSet p Origin
x -> SealedPatchSet p Origin -> Either String (SealedPatchSet p Origin)
forall a b. b -> Either a b
Right SealedPatchSet p Origin
x
                              Either String (SealedPatchSet p Origin)
_ -> String -> Either String (SealedPatchSet p Origin)
forall a b. a -> Either a b
Left String
e
                    Either String (SealedPatchSet p Origin)
x -> Either String (SealedPatchSet p Origin)
x
                stripCrPS :: B.ByteString -> B.ByteString
                stripCrPS :: ByteString -> ByteString
stripCrPS ByteString
bundle = [ByteString] -> ByteString
unlinesPS ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
stripline ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
linesPS ByteString
bundle
                stripline :: ByteString -> ByteString
stripline ByteString
p | ByteString -> Bool
B.null ByteString
p = ByteString
p
                            | ByteString -> Char
BC.last ByteString
p Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\r' = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
B.init ByteString
p
                            | Bool
otherwise = ByteString
p

parseAndInterpretBundle :: RepoPatch p
                        => PatchSet p Origin wR
                        -> B.ByteString
                        -> Either String (SealedPatchSet p Origin)
parseAndInterpretBundle :: forall (p :: * -> * -> *) wR.
RepoPatch p =>
PatchSet p Origin wR
-> ByteString -> Either String (SealedPatchSet p Origin)
parseAndInterpretBundle PatchSet p Origin wR
us ByteString
content = do
    Sealed Bundle p Any wX
bundle <- ByteString -> Either String (Sealed (Bundle p Any))
forall (p :: * -> * -> *) wX.
RepoPatch p =>
ByteString -> Either String (Sealed (Bundle p wX))
parseBundle ByteString
content
    PatchSet p Origin wX -> SealedPatchSet p Origin
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (PatchSet p Origin wX -> SealedPatchSet p Origin)
-> Either String (PatchSet p Origin wX)
-> Either String (SealedPatchSet p Origin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PatchSet p Origin wR
-> Bundle p Any wX -> Either String (PatchSet p Origin wX)
forall (p :: * -> * -> *) wT wA wB.
Commute p =>
PatchSet p Origin wT
-> Bundle p wA wB -> Either String (PatchSet p Origin wB)
interpretBundle PatchSet p Origin wR
us Bundle p Any wX
bundle

patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions
patchSelOpts :: [DarcsFlag] -> PatchSelectionOptions
patchSelOpts [DarcsFlag]
flags = S.PatchSelectionOptions
    { verbosity :: Verbosity
S.verbosity = PrimOptSpec DarcsOptDescr DarcsFlag a Verbosity
PrimDarcsOption Verbosity
verbosity PrimDarcsOption Verbosity -> [DarcsFlag] -> Verbosity
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
? [DarcsFlag]
flags
    , matchFlags :: [MatchFlag]
S.matchFlags = MatchOption -> [DarcsFlag] -> [MatchFlag]
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimOptSpec DarcsOptDescr DarcsFlag a [MatchFlag]
MatchOption
O.matchSeveral [DarcsFlag]
flags
    , interactive :: Bool
S.interactive = [DarcsFlag] -> Bool
maybeIsInteractive [DarcsFlag]
flags
    , selectDeps :: SelectDeps
S.selectDeps = SelectDeps
O.PromptDeps -- option not supported, use default
    , withSummary :: WithSummary
S.withSummary = WithSummary
O.NoSummary -- option not supported, use default
    }

maybeIsInteractive :: [DarcsFlag] -> Bool
maybeIsInteractive :: [DarcsFlag] -> Bool
maybeIsInteractive = Bool -> (Bool -> Bool) -> Maybe Bool -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Bool -> Bool
forall a. a -> a
id (Maybe Bool -> Bool)
-> ([DarcsFlag] -> Maybe Bool) -> [DarcsFlag] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PrimDarcsOption (Maybe Bool) -> [DarcsFlag] -> Maybe Bool
forall (d :: * -> *) f v.
(forall a. PrimOptSpec d f a v) -> [f] -> v
parseFlags PrimOptSpec DarcsOptDescr DarcsFlag a (Maybe Bool)
PrimDarcsOption (Maybe Bool)
O.interactive