-- Copyright (C) 2002-2004,2007 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.Patch.Bundle
    ( makeBundleN
    , scanBundle
    , contextPatches
    , scanContextFile
    , patchFilename
    , minContext
    ) where

import Prelude ()
import Darcs.Prelude

import Data.Char ( isAlpha, toLower, isDigit, isSpace )
import qualified Data.ByteString as B ( ByteString, length, null, drop,
                                        isPrefixOf )
import qualified Data.ByteString.Char8 as BC ( unpack, break, pack )

import Darcs.Util.Tree( Tree )
import Darcs.Util.Tree.Monad( virtualTreeIO )

import Darcs.Patch ( RepoPatch, showPatch, showContextPatch,
                     readPatchPartial )
import Darcs.Patch.Apply( ApplyState )
import Darcs.Patch.Bracketed ( Bracketed, unBracketedFL )
import Darcs.Patch.Bracketed.Instances ()
import Darcs.Patch.Commute( commute )
import Darcs.Patch.Depends ( slightlyOptimizePatchset )
import Darcs.Patch.Format ( PatchListFormat )
import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo,
                          displayPatchInfo, isTag )
import Darcs.Patch.Named.Wrapped ( WrappedNamed )
import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, piap, fmapFLPIAP, info,
                                  patchInfoAndPatch, unavailable, hopefully,
                                  generaliseRepoTypePIAP
                                )
import Darcs.Patch.ReadMonads ( parseStrictly )
import Darcs.Patch.RepoType ( RepoType(..), RebaseType(..) )
import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin )
import Darcs.Patch.Show ( ShowPatchBasic, ShowPatchFor(ForStorage) )
import Darcs.Patch.Witnesses.Ordered
    ( RL(..), FL(..), (:>)(..), reverseFL, (+<+),
    mapFL, mapFL_FL, mapRL )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )

import Darcs.Util.ByteString
    ( mmapFilePS, linesPS, unlinesPS, dropSpace, substrPS, decodeLocale )
import Darcs.Util.Hash ( sha1PS )
import Darcs.Util.Printer ( Doc, renderPS, newline, text, ($$),
                 vcat, vsep, renderString )

-- |hashBundle creates a SHA1 string of a given a FL of named patches. This
-- allows us to ensure that the patches in a received patchBundle have not been
-- modified in transit.
hashBundle :: (PatchListFormat p, ShowPatchBasic p) => FL (WrappedNamed rt p) wX wY
           -> String
hashBundle :: FL (WrappedNamed rt p) wX wY -> String
hashBundle to_be_sent :: FL (WrappedNamed rt p) wX wY
to_be_sent =
    SHA1 -> String
forall a. Show a => a -> String
show (SHA1 -> String) -> SHA1 -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> SHA1
sha1PS (ByteString -> SHA1) -> ByteString -> SHA1
forall a b. (a -> b) -> a -> b
$ Doc -> ByteString
renderPS (Doc -> ByteString) -> Doc -> ByteString
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ((forall wW wZ. WrappedNamed rt p wW wZ -> Doc)
-> FL (WrappedNamed rt p) wX wY -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL (ShowPatchFor -> WrappedNamed rt p wW wZ -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
ForStorage) FL (WrappedNamed rt p) wX wY
to_be_sent) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
newline

makeBundleN :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO)
            -> PatchSet rt p wStart wX -> FL (WrappedNamed rt p) wX wY -> IO Doc
makeBundleN :: Maybe (Tree IO)
-> PatchSet rt p wStart wX
-> FL (WrappedNamed rt p) wX wY
-> IO Doc
makeBundleN the_s :: Maybe (Tree IO)
the_s (PatchSet (_ :<: Tagged t :: PatchInfoAnd rt p wY wX
t _ _) ps :: RL (PatchInfoAnd rt p) wX wX
ps) to_be_sent :: FL (WrappedNamed rt p) wX wY
to_be_sent =
    Maybe (Tree IO)
-> RL (PatchInfoAnd rt p) wY wX
-> FL (WrappedNamed rt p) wX wY
-> FL (WrappedNamed rt p) wX wY
-> IO Doc
forall (p :: * -> * -> *) (rt :: RepoType) wStart wX wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Maybe (Tree IO)
-> RL (PatchInfoAnd rt p) wStart wX
-> FL (WrappedNamed rt p) wX wY
-> FL (WrappedNamed rt p) wX wY
-> IO Doc
makeBundle2 Maybe (Tree IO)
the_s ((RL (PatchInfoAnd rt p) wY wY
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL RL (PatchInfoAnd rt p) wY wY
-> PatchInfoAnd rt p wY wX -> RL (PatchInfoAnd rt p) wY wX
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: PatchInfoAnd rt p wY wX
t) RL (PatchInfoAnd rt p) wY wX
-> RL (PatchInfoAnd rt p) wX wX -> RL (PatchInfoAnd rt p) wY wX
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> RL a wY wZ -> RL a wX wZ
+<+ RL (PatchInfoAnd rt p) wX wX
ps) FL (WrappedNamed rt p) wX wY
to_be_sent FL (WrappedNamed rt p) wX wY
to_be_sent
makeBundleN the_s :: Maybe (Tree IO)
the_s (PatchSet NilRL ps :: RL (PatchInfoAnd rt p) wX wX
ps) to_be_sent :: FL (WrappedNamed rt p) wX wY
to_be_sent =
    Maybe (Tree IO)
-> RL (PatchInfoAnd rt p) wX wX
-> FL (WrappedNamed rt p) wX wY
-> FL (WrappedNamed rt p) wX wY
-> IO Doc
forall (p :: * -> * -> *) (rt :: RepoType) wStart wX wY.
(ApplyState p ~ Tree, RepoPatch p) =>
Maybe (Tree IO)
-> RL (PatchInfoAnd rt p) wStart wX
-> FL (WrappedNamed rt p) wX wY
-> FL (WrappedNamed rt p) wX wY
-> IO Doc
makeBundle2 Maybe (Tree IO)
the_s RL (PatchInfoAnd rt p) wX wX
ps FL (WrappedNamed rt p) wX wY
to_be_sent FL (WrappedNamed rt p) wX wY
to_be_sent

-- | In makeBundle2, it is presumed that the two patch sequences are
-- identical, but that they may be lazily generated.  If two different
-- patch sequences are passed, a bundle with a mismatched hash will be
-- generated, which is not the end of the world, but isn't very useful
-- either.
makeBundle2 :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO)
            -> RL (PatchInfoAnd rt p) wStart wX -> FL (WrappedNamed rt p) wX wY
            -> FL (WrappedNamed rt p) wX wY -> IO Doc
makeBundle2 :: Maybe (Tree IO)
-> RL (PatchInfoAnd rt p) wStart wX
-> FL (WrappedNamed rt p) wX wY
-> FL (WrappedNamed rt p) wX wY
-> IO Doc
makeBundle2 the_s :: Maybe (Tree IO)
the_s common' :: RL (PatchInfoAnd rt p) wStart wX
common' to_be_sent :: FL (WrappedNamed rt p) wX wY
to_be_sent to_be_sent2 :: FL (WrappedNamed rt p) wX wY
to_be_sent2 = do
    Doc
patches <- case Maybe (Tree IO)
the_s of
                   Just tree :: Tree IO
tree -> (Doc, Tree IO) -> Doc
forall a b. (a, b) -> a
fst ((Doc, Tree IO) -> Doc) -> IO (Doc, Tree IO) -> IO Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` TreeIO Doc -> Tree IO -> IO (Doc, Tree IO)
forall a. TreeIO a -> Tree IO -> IO (a, Tree IO)
virtualTreeIO (ShowPatchFor -> FL (WrappedNamed rt p) wX wY -> TreeIO Doc
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(ShowContextPatch p, ApplyMonad (ApplyState p) m) =>
ShowPatchFor -> p wX wY -> m Doc
showContextPatch ShowPatchFor
ForStorage FL (WrappedNamed rt p) wX wY
to_be_sent) Tree IO
tree
                   Nothing -> Doc -> IO Doc
forall (m :: * -> *) a. Monad m => a -> m a
return ([Doc] -> Doc
vsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (forall wW wZ. WrappedNamed rt p wW wZ -> Doc)
-> FL (WrappedNamed rt p) wX wY -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL (ShowPatchFor -> WrappedNamed rt p wW wZ -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
ForStorage) FL (WrappedNamed rt p) wX wY
to_be_sent)
    Doc -> IO Doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc -> IO Doc) -> Doc -> IO Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
format Doc
patches
  where
    format :: Doc -> Doc
format the_new :: Doc
the_new = String -> Doc
text ""
                     Doc -> Doc -> Doc
$$ String -> Doc
text "New patches:"
                     Doc -> Doc -> Doc
$$ String -> Doc
text ""
                     Doc -> Doc -> Doc
$$ Doc
the_new
                     Doc -> Doc -> Doc
$$ String -> Doc
text ""
                     Doc -> Doc -> Doc
$$ String -> Doc
text "Context:"
                     Doc -> Doc -> Doc
$$ String -> Doc
text ""
                     Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((PatchInfo -> Doc) -> [PatchInfo] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (ShowPatchFor -> PatchInfo -> Doc
showPatchInfo ShowPatchFor
ForStorage) [PatchInfo]
common)
                     Doc -> Doc -> Doc
$$ String -> Doc
text "Patch bundle hash:"
                     Doc -> Doc -> Doc
$$ String -> Doc
text (FL (WrappedNamed rt p) wX wY -> String
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
(PatchListFormat p, ShowPatchBasic p) =>
FL (WrappedNamed rt p) wX wY -> String
hashBundle FL (WrappedNamed rt p) wX wY
to_be_sent2)
                     Doc -> Doc -> Doc
$$ String -> Doc
text ""
    common :: [PatchInfo]
common = (forall wW wZ. PatchInfoAnd rt p wW wZ -> PatchInfo)
-> RL (PatchInfoAnd rt p) wStart wX -> [PatchInfo]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL forall wW wZ. PatchInfoAnd rt p wW wZ -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> PatchInfo
info RL (PatchInfoAnd rt p) wStart wX
common'

parseBundle :: forall rt p. RepoPatch p => B.ByteString
            -> Either String
                      (Sealed ((PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin))
parseBundle :: ByteString
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
parseBundle input :: ByteString
input | ByteString -> Bool
B.null ByteString
input = String
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall a b. a -> Either a b
Left "Bad patch bundle!"
parseBundle input :: ByteString
input = case ByteString -> (String, ByteString)
sillyLex ByteString
input of
    ("New patches:", rest :: ByteString
rest) -> case ByteString
-> (Sealed
      (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) Any),
    ByteString)
forall (p :: * -> * -> *) wX.
RepoPatch p =>
ByteString
-> (Sealed
      (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX),
    ByteString)
getPatches ByteString
rest of
        (Sealed bracketedPatches :: FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) Any wX
bracketedPatches, rest' :: ByteString
rest') -> case ByteString -> (String, ByteString)
sillyLex ByteString
rest' of
            ("Context:", rest'' :: ByteString
rest'') -> case ByteString -> ([PatchInfo], ByteString)
getContext ByteString
rest'' of
                (cont :: [PatchInfo]
cont, maybe_hash :: ByteString
maybe_hash) ->
                    let sealedCtxAndPs :: Either
  a (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
sealedCtxAndPs = [PatchInfo]
-> FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) Any wX
-> Either
     a (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall wX wY a.
[PatchInfo]
-> FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY
-> Either
     a (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
sealCtxAndPs [PatchInfo]
cont FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) Any wX
bracketedPatches in
                    case ByteString -> ByteString -> Maybe Int
substrPS (String -> ByteString
BC.pack "Patch bundle hash:") ByteString
maybe_hash of
                        Just n :: Int
n ->
                            let hPs :: FL (WrappedNamed ('RepoType 'NoRebase) (Bracketed p)) Any wX
hPs = (forall wW wY.
 PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p) wW wY
 -> WrappedNamed ('RepoType 'NoRebase) (Bracketed p) wW wY)
-> FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) Any wX
-> FL (WrappedNamed ('RepoType 'NoRebase) (Bracketed p)) Any wX
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL forall wW wY.
PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p) wW wY
-> WrappedNamed ('RepoType 'NoRebase) (Bracketed p) wW wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAnd rt p wA wB -> WrappedNamed rt p wA wB
hopefully FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) Any wX
bracketedPatches
                                realHash :: String
realHash = FL (WrappedNamed ('RepoType 'NoRebase) (Bracketed p)) Any wX
-> String
forall (p :: * -> * -> *) (rt :: RepoType) wX wY.
(PatchListFormat p, ShowPatchBasic p) =>
FL (WrappedNamed rt p) wX wY -> String
hashBundle FL (WrappedNamed ('RepoType 'NoRebase) (Bracketed p)) Any wX
hPs
                                getHash :: ByteString -> String
getHash = (String, ByteString) -> String
forall a b. (a, b) -> a
fst ((String, ByteString) -> String)
-> (ByteString -> (String, ByteString)) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> (String, ByteString)
sillyLex (ByteString -> (String, ByteString))
-> (ByteString -> ByteString) -> ByteString -> (String, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, ByteString) -> ByteString
forall a b. (a, b) -> b
snd ((String, ByteString) -> ByteString)
-> (ByteString -> (String, ByteString)) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> (String, ByteString)
sillyLex
                                bundleHash :: String
bundleHash = ByteString -> String
getHash (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.drop Int
n ByteString
maybe_hash in
                            if String
realHash String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
bundleHash
                                then Either
  String
  (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall a.
Either
  a (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
sealedCtxAndPs
                                else String
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall a b. a -> Either a b
Left String
hashFailureMessage
                        Nothing -> Either
  String
  (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall a.
Either
  a (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
sealedCtxAndPs
            (a :: String
a, r :: ByteString
r) -> String
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall a b. a -> Either a b
Left (String
 -> Either
      String
      (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)))
-> String
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall a b. (a -> b) -> a -> b
$ "Malformed patch bundle: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a
                             String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' is not 'Context:'\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ByteString -> String
BC.unpack ByteString
r
    ("Context:", rest :: ByteString
rest) -> case ByteString -> ([PatchInfo], ByteString)
getContext ByteString
rest of
        (cont :: [PatchInfo]
cont, rest' :: ByteString
rest') -> case ByteString -> (String, ByteString)
sillyLex ByteString
rest' of
            ("New patches:", rest'' :: ByteString
rest'') -> case ByteString
-> (Sealed
      (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) Any),
    ByteString)
forall (p :: * -> * -> *) wX.
RepoPatch p =>
ByteString
-> (Sealed
      (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX),
    ByteString)
getPatches ByteString
rest'' of
                (Sealed bracketedPatches :: FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) Any wX
bracketedPatches, _) ->
                    Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall a b. b -> Either a b
Right (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
 -> Either
      String
      (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)))
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall a b. (a -> b) -> a -> b
$ [PatchInfo]
-> FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) Any wX
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
forall wX wY.
[PatchInfo]
-> FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
sealContextWithPatches [PatchInfo]
cont FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) Any wX
bracketedPatches
            (a :: String
a, _) -> String
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall a b. a -> Either a b
Left (String
 -> Either
      String
      (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)))
-> String
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall a b. (a -> b) -> a -> b
$ "Malformed patch bundle: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a
                             String -> String -> String
forall a. [a] -> [a] -> [a]
++ "' is not 'New patches:'"
    ("-----BEGIN PGP SIGNED MESSAGE-----",rest :: ByteString
rest) ->
        ByteString
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall (rt :: RepoType) (p :: * -> * -> *).
RepoPatch p =>
ByteString
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
parseBundle (ByteString
 -> Either
      String
      (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)))
-> ByteString
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
filterGpgDashes ByteString
rest
    (_, rest :: ByteString
rest) -> ByteString
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall (rt :: RepoType) (p :: * -> * -> *).
RepoPatch p =>
ByteString
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
parseBundle ByteString
rest
  where
    hashFailureMessage :: String
hashFailureMessage = "Patch bundle failed hash!\n"
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ "This probably means that the patch has been "
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ "corrupted by a mailer.\n"
                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ "The most likely culprit is CRLF newlines."

    sealCtxAndPs :: [PatchInfo]
-> FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY
-> Either
     a (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
sealCtxAndPs ctx :: [PatchInfo]
ctx ps :: FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY
ps = Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
-> Either
     a (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall a b. b -> Either a b
Right (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
 -> Either
      a (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)))
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
-> Either
     a (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall a b. (a -> b) -> a -> b
$ [PatchInfo]
-> FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
forall wX wY.
[PatchInfo]
-> FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
sealContextWithPatches [PatchInfo]
ctx FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY
ps

    sealContextWithPatches :: [PatchInfo]
                           -> FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY
                           -> Sealed
                                  ((PatchSet rt p :> FL (PatchInfoAnd rt p)) Origin)
    sealContextWithPatches :: [PatchInfo]
-> FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
sealContextWithPatches context :: [PatchInfo]
context bracketedPatches :: FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY
bracketedPatches =
        let -- witness to fmapFLPIAP that the bundle won't contain stash/rebase patches
            -- TODO use EmptyCase with GHC 7.8+
            notRebasing :: p -> a
notRebasing _
              = String -> a
forall a. HasCallStack => String -> a
error "internal error: unreachable case (Darcs.Patch.Bundle.parseBundle.notRebasing)"
            patches :: FL (PatchInfoAnd rt p) wX wY
patches = (forall wW wY.
 PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p) wW wY
 -> PatchInfoAnd rt p wW wY)
-> FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY
-> FL (PatchInfoAnd rt p) wX wY
forall (a :: * -> * -> *) (b :: * -> * -> *) wX wZ.
(forall wW wY. a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ
mapFL_FL (PatchInfoAnd ('RepoType 'NoRebase) p wW wY
-> PatchInfoAnd rt p wW wY
forall (p :: * -> * -> *) wA wB (rt :: RepoType).
PatchInfoAnd ('RepoType 'NoRebase) p wA wB
-> PatchInfoAnd rt p wA wB
generaliseRepoTypePIAP (PatchInfoAnd ('RepoType 'NoRebase) p wW wY
 -> PatchInfoAnd rt p wW wY)
-> (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p) wW wY
    -> PatchInfoAnd ('RepoType 'NoRebase) p wW wY)
-> PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p) wW wY
-> PatchInfoAnd rt p wW wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FL (Bracketed p) wW wY -> FL p wW wY)
-> ((RebaseTypeOf ('RepoType 'NoRebase) :~~: 'IsRebase)
    -> Bracketed p :~: p)
-> PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p) wW wY
-> PatchInfoAnd ('RepoType 'NoRebase) p wW wY
forall (p :: * -> * -> *) wX wY (q :: * -> * -> *)
       (rt :: RepoType).
(FL p wX wY -> FL q wX wY)
-> ((RebaseTypeOf rt :~~: 'IsRebase) -> p :~: q)
-> PatchInfoAnd rt p wX wY
-> PatchInfoAnd rt q wX wY
fmapFLPIAP FL (Bracketed p) wW wY -> FL p wW wY
forall (p :: * -> * -> *) wX wY. BracketedFL p wX wY -> FL p wX wY
unBracketedFL (RebaseTypeOf ('RepoType 'NoRebase) :~~: 'IsRebase)
-> Bracketed p :~: p
forall p a. p -> a
notRebasing)
                               FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wY
bracketedPatches
        in
        case [PatchInfo] -> [PatchInfo]
forall a. [a] -> [a]
reverse [PatchInfo]
context of
            (x :: PatchInfo
x : ry :: [PatchInfo]
ry) | PatchInfo -> Bool
isTag PatchInfo
x ->
                  let ps :: RL (PatchInfoAnd rt p) wX wY
ps = [PatchInfo] -> RL (PatchInfoAnd rt p) wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
[PatchInfo] -> RL (PatchInfoAnd rt p) wX wY
unavailablePatches ([PatchInfo] -> [PatchInfo]
forall a. [a] -> [a]
reverse [PatchInfo]
ry)
                      t :: Tagged rt p wY wZ
t = PatchInfoAnd rt p wY wZ
-> Maybe String
-> RL (PatchInfoAnd rt p) wY wY
-> Tagged rt p wY wZ
forall (rt :: RepoType) (p :: * -> * -> *) wY wZ wX.
PatchInfoAnd rt p wY wZ
-> Maybe String
-> RL (PatchInfoAnd rt p) wX wY
-> Tagged rt p wX wZ
Tagged (PatchInfo -> PatchInfoAnd rt p wY wZ
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
PatchInfo -> PatchInfoAnd rt p wX wY
piUnavailable PatchInfo
x) Maybe String
forall a. Maybe a
Nothing RL (PatchInfoAnd rt p) wY wY
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL in
                  (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wY
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wY
 -> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wY
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
forall a b. (a -> b) -> a -> b
$ RL (Tagged rt p) Origin Any
-> RL (PatchInfoAnd rt p) Any wX -> PatchSet rt p Origin wX
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX wY.
RL (Tagged rt p) wStart wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wStart wY
PatchSet (RL (Tagged rt p) Origin Origin
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL RL (Tagged rt p) Origin Origin
-> Tagged rt p Origin Any -> RL (Tagged rt p) Origin Any
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: Tagged rt p Origin Any
forall (rt :: RepoType) (p :: * -> * -> *) wY wZ. Tagged rt p wY wZ
t) RL (PatchInfoAnd rt p) Any wX
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
RL (PatchInfoAnd rt p) wX wY
ps PatchSet rt p Origin wX
-> FL (PatchInfoAnd rt p) wX wY
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PatchInfoAnd rt p) wX wY
forall (rt :: RepoType). FL (PatchInfoAnd rt p) wX wY
patches
            _ -> let ps :: PatchSet rt p wX wY
ps = RL (Tagged rt p) wX wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX wY.
RL (Tagged rt p) wStart wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wStart wY
PatchSet RL (Tagged rt p) wX wX
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL ([PatchInfo] -> RL (PatchInfoAnd rt p) wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
[PatchInfo] -> RL (PatchInfoAnd rt p) wX wY
unavailablePatches [PatchInfo]
context) in
                 (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wY
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wY
 -> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wY
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
forall a b. (a -> b) -> a -> b
$ PatchSet rt p Origin wX
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
PatchSet rt p wX wY
ps PatchSet rt p Origin wX
-> FL (PatchInfoAnd rt p) wX wY
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wY
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PatchInfoAnd rt p) wX wY
forall (rt :: RepoType). FL (PatchInfoAnd rt p) wX wY
patches
                 -- The above NilRLs aren't quite right, because ther *are*
                 -- earlier patches, but we can't set this to undefined
                 -- because there are situations where we look at the rest.
                 -- :{

scanBundle :: forall rt p . RepoPatch p => B.ByteString
           -> Either String (SealedPatchSet rt p Origin)
scanBundle :: ByteString -> Either String (SealedPatchSet rt p Origin)
scanBundle bundle :: ByteString
bundle = do
  Sealed (PatchSet tagged :: RL (Tagged rt p) Origin wX
tagged recent :: RL (PatchInfoAnd rt p) wX wZ
recent :> ps :: FL (PatchInfoAnd rt p) wZ wX
ps) <- ByteString
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
forall (rt :: RepoType) (p :: * -> * -> *).
RepoPatch p =>
ByteString
-> Either
     String
     (Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin))
parseBundle ByteString
bundle
  SealedPatchSet rt p Origin
-> Either String (SealedPatchSet rt p Origin)
forall (m :: * -> *) a. Monad m => a -> m a
return (SealedPatchSet rt p Origin
 -> Either String (SealedPatchSet rt p Origin))
-> (PatchSet rt p Origin wX -> SealedPatchSet rt p Origin)
-> PatchSet rt p Origin wX
-> Either String (SealedPatchSet rt p Origin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchSet rt p Origin wX -> SealedPatchSet rt p Origin
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (PatchSet rt p Origin wX
 -> Either String (SealedPatchSet rt p Origin))
-> PatchSet rt p Origin wX
-> Either String (SealedPatchSet rt p Origin)
forall a b. (a -> b) -> a -> b
$ RL (Tagged rt p) Origin wX
-> RL (PatchInfoAnd rt p) wX wX -> PatchSet rt p Origin wX
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX wY.
RL (Tagged rt p) wStart wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wStart wY
PatchSet RL (Tagged rt p) Origin wX
tagged (RL (PatchInfoAnd rt p) wX wZ
recent RL (PatchInfoAnd rt p) wX wZ
-> RL (PatchInfoAnd rt p) wZ wX -> RL (PatchInfoAnd rt p) wX wX
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> RL a wY wZ -> RL a wX wZ
+<+ FL (PatchInfoAnd rt p) wZ wX -> RL (PatchInfoAnd rt p) wZ wX
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd rt p) wZ wX
ps)

-- |filterGpgDashes unescapes a clearsigned patch, which will have had any
-- lines starting with dashes escaped with a leading "- ".
filterGpgDashes :: B.ByteString -> B.ByteString
filterGpgDashes :: ByteString -> ByteString
filterGpgDashes ps :: ByteString
ps =
    [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
drop_dashes ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$
    (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> ByteString
BC.pack "-----END PGP SIGNED MESSAGE-----") ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$
    (ByteString -> Bool) -> [ByteString] -> [ByteString]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile ByteString -> Bool
not_context_or_newpatches ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
linesPS ByteString
ps
  where
    drop_dashes :: ByteString -> ByteString
drop_dashes x :: ByteString
x
        | ByteString -> Int
B.length ByteString
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 2 = ByteString
x
        | String -> ByteString
BC.pack "- " ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
x = Int -> ByteString -> ByteString
B.drop 2 ByteString
x
        | Bool
otherwise = ByteString
x

    not_context_or_newpatches :: ByteString -> Bool
not_context_or_newpatches s :: ByteString
s = (ByteString
s ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> ByteString
BC.pack "Context:") Bool -> Bool -> Bool
&&
                                  (ByteString
s ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> ByteString
BC.pack "New patches:")

-- |unavailablePatches converts a list of PatchInfos into a RL of PatchInfoAnd
-- Unavailable patches. This is used to represent the Context of a patchBundle.
unavailablePatches :: [PatchInfo] -> RL (PatchInfoAnd rt p) wX wY
unavailablePatches :: [PatchInfo] -> RL (PatchInfoAnd rt p) wX wY
unavailablePatches = (PatchInfo
 -> RL (PatchInfoAnd rt p) wX wY -> RL (PatchInfoAnd rt p) wX wY)
-> RL (PatchInfoAnd rt p) wX wY
-> [PatchInfo]
-> RL (PatchInfoAnd rt p) wX wY
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((RL (PatchInfoAnd rt p) wX wY
 -> PatchInfoAnd rt p wY wY -> RL (PatchInfoAnd rt p) wX wY)
-> PatchInfoAnd rt p wY wY
-> RL (PatchInfoAnd rt p) wX wY
-> RL (PatchInfoAnd rt p) wX wY
forall a b c. (a -> b -> c) -> b -> a -> c
flip RL (PatchInfoAnd rt p) wX wY
-> PatchInfoAnd rt p wY wY -> RL (PatchInfoAnd rt p) wX wY
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
(:<:) (PatchInfoAnd rt p wY wY
 -> RL (PatchInfoAnd rt p) wX wY -> RL (PatchInfoAnd rt p) wX wY)
-> (PatchInfo -> PatchInfoAnd rt p wY wY)
-> PatchInfo
-> RL (PatchInfoAnd rt p) wX wY
-> RL (PatchInfoAnd rt p) wX wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> PatchInfoAnd rt p wY wY
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
PatchInfo -> PatchInfoAnd rt p wX wY
piUnavailable) (RL (PatchInfoAnd rt p) Any Any -> RL (PatchInfoAnd rt p) wX wY
forall (a :: * -> * -> *) wX wY wB wC. a wX wY -> a wB wC
unsafeCoerceP RL (PatchInfoAnd rt p) Any Any
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL)

-- |piUnavailable returns an Unavailable within a PatchInfoAnd given a
-- PatchInfo.
piUnavailable :: PatchInfo -> PatchInfoAnd rt p wX wY
piUnavailable :: PatchInfo -> PatchInfoAnd rt p wX wY
piUnavailable i :: PatchInfo
i = PatchInfo
-> Hopefully (WrappedNamed rt p) wX wY -> PatchInfoAnd rt p wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfo
-> Hopefully (WrappedNamed rt p) wA wB -> PatchInfoAnd rt p wA wB
patchInfoAndPatch PatchInfo
i (Hopefully (WrappedNamed rt p) wX wY -> PatchInfoAnd rt p wX wY)
-> (String -> Hopefully (WrappedNamed rt p) wX wY)
-> String
-> PatchInfoAnd rt p wX wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Hopefully (WrappedNamed rt p) wX wY
forall (a :: * -> * -> *) wX wY. String -> Hopefully a wX wY
unavailable (String -> PatchInfoAnd rt p wX wY)
-> String -> PatchInfoAnd rt p wX wY
forall a b. (a -> b) -> a -> b
$
    "Patch not stored in patch bundle:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
renderString (PatchInfo -> Doc
displayPatchInfo PatchInfo
i)

-- |getContext parses a context list, returning a tuple containing the list,
-- and remaining ByteString input.
getContext :: B.ByteString -> ([PatchInfo],B.ByteString)
getContext :: ByteString -> ([PatchInfo], ByteString)
getContext ps :: ByteString
ps = case SM PatchInfo -> ByteString -> Maybe (PatchInfo, ByteString)
forall a. SM a -> ByteString -> Maybe (a, ByteString)
parseStrictly SM PatchInfo
forall (m :: * -> *). ParserM m => m PatchInfo
readPatchInfo ByteString
ps of
    Just (pinfo :: PatchInfo
pinfo, r' :: ByteString
r') -> case ByteString -> ([PatchInfo], ByteString)
getContext ByteString
r' of
        (pis :: [PatchInfo]
pis, r'' :: ByteString
r'') -> (PatchInfo
pinfo PatchInfo -> [PatchInfo] -> [PatchInfo]
forall a. a -> [a] -> [a]
: [PatchInfo]
pis, ByteString
r'')
    Nothing -> ([], ByteString
ps)

-- |(-:-) is used to build up a Sealed FL of patches and tuple it, along with
-- any unconsumed input.
(-:-) :: a wX wY -> (Sealed (FL a wY), b) -> (Sealed (FL a wX), b)
p :: a wX wY
p -:- :: a wX wY -> (Sealed (FL a wY), b) -> (Sealed (FL a wX), b)
-:- (Sealed ps :: FL a wY wX
ps, r :: b
r) = (FL a wX wX -> Sealed (FL a wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (a wX wY
p a wX wY -> FL a wY wX -> FL a wX wX
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL a wY wX
ps), b
r)

-- |getPatches attempts to parse a sequence of patches from a ByteString,
-- returning the FL of as many patches-with-info as were successfully parsed,
-- along with any unconsumed input.
getPatches :: RepoPatch p => B.ByteString
           -> (Sealed (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX), B.ByteString)
getPatches :: ByteString
-> (Sealed
      (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX),
    ByteString)
getPatches ps :: ByteString
ps = case SM PatchInfo -> ByteString -> Maybe (PatchInfo, ByteString)
forall a. SM a -> ByteString -> Maybe (a, ByteString)
parseStrictly SM PatchInfo
forall (m :: * -> *). ParserM m => m PatchInfo
readPatchInfo ByteString
ps of
    Nothing -> (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wX
-> Sealed
     (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL, ByteString
ps)
    Just (pinfo :: PatchInfo
pinfo, _) -> case ByteString
-> Maybe
     (Sealed (WrappedNamed ('RepoType 'NoRebase) (Bracketed p) wX),
      ByteString)
forall (p :: * -> * -> *) wX.
ReadPatch p =>
ByteString -> Maybe (Sealed (p wX), ByteString)
readPatchPartial ByteString
ps of
        Nothing -> (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wX
-> Sealed
     (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL, ByteString
ps)
        Just (Sealed p :: WrappedNamed ('RepoType 'NoRebase) (Bracketed p) wX wX
p, r :: ByteString
r) -> (PatchInfo
pinfo PatchInfo
-> WrappedNamed ('RepoType 'NoRebase) (Bracketed p) wX wX
-> PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p) wX wX
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfo -> WrappedNamed rt p wA wB -> PatchInfoAnd rt p wA wB
`piap` WrappedNamed ('RepoType 'NoRebase) (Bracketed p) wX wX
p) PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p) wX wX
-> (Sealed
      (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX),
    ByteString)
-> (Sealed
      (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX),
    ByteString)
forall (a :: * -> * -> *) wX wY b.
a wX wY -> (Sealed (FL a wY), b) -> (Sealed (FL a wX), b)
-:- ByteString
-> (Sealed
      (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX),
    ByteString)
forall (p :: * -> * -> *) wX.
RepoPatch p =>
ByteString
-> (Sealed
      (FL (PatchInfoAnd ('RepoType 'NoRebase) (Bracketed p)) wX),
    ByteString)
getPatches ByteString
r

-- |sillyLex takes a ByteString and breaks it upon the first newline, having
-- removed any leading spaces. The before-newline part is unpacked to a String,
-- and tupled up with the remaining ByteString.
sillyLex :: B.ByteString -> (String, B.ByteString)
sillyLex :: ByteString -> (String, ByteString)
sillyLex ps :: ByteString
ps = (ByteString -> String
decodeLocale ByteString
a, ByteString
b)
  where
    (a :: ByteString
a, b :: ByteString
b) = (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BC.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n') (ByteString -> ByteString
dropSpace ByteString
ps)

contextPatches :: PatchSet rt p Origin wX
               -> (PatchSet rt p :> RL (PatchInfoAnd rt p)) Origin wX
contextPatches :: PatchSet rt p Origin wX
-> (:>) (PatchSet rt p) (RL (PatchInfoAnd rt p)) Origin wX
contextPatches set :: PatchSet rt p Origin wX
set = case PatchSet rt p Origin wX -> PatchSet rt p Origin wX
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX.
PatchSet rt p wStart wX -> PatchSet rt p wStart wX
slightlyOptimizePatchset PatchSet rt p Origin wX
set of
    PatchSet (ts :: RL (Tagged rt p) Origin wY
ts :<: Tagged t :: PatchInfoAnd rt p wY wX
t _ ps' :: RL (PatchInfoAnd rt p) wY wY
ps') ps :: RL (PatchInfoAnd rt p) wX wX
ps ->
        RL (Tagged rt p) Origin wY
-> RL (PatchInfoAnd rt p) wY wY -> PatchSet rt p Origin wY
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX wY.
RL (Tagged rt p) wStart wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wStart wY
PatchSet RL (Tagged rt p) Origin wY
ts RL (PatchInfoAnd rt p) wY wY
ps' PatchSet rt p Origin wY
-> RL (PatchInfoAnd rt p) wY wX
-> (:>) (PatchSet rt p) (RL (PatchInfoAnd rt p)) Origin wX
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> ((RL (PatchInfoAnd rt p) wY wY
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL RL (PatchInfoAnd rt p) wY wY
-> PatchInfoAnd rt p wY wX -> RL (PatchInfoAnd rt p) wY wX
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: PatchInfoAnd rt p wY wX
t) RL (PatchInfoAnd rt p) wY wX
-> RL (PatchInfoAnd rt p) wX wX -> RL (PatchInfoAnd rt p) wY wX
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> RL a wY wZ -> RL a wX wZ
+<+ RL (PatchInfoAnd rt p) wX wX
ps)
    PatchSet NilRL ps :: RL (PatchInfoAnd rt p) wX wX
ps -> RL (Tagged rt p) wX wX
-> RL (PatchInfoAnd rt p) wX wX -> PatchSet rt p wX wX
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX wY.
RL (Tagged rt p) wStart wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wStart wY
PatchSet RL (Tagged rt p) wX wX
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL RL (PatchInfoAnd rt p) wX wX
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL PatchSet rt p wX wX
-> RL (PatchInfoAnd rt p) wX wX
-> (:>) (PatchSet rt p) (RL (PatchInfoAnd rt p)) wX wX
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> RL (PatchInfoAnd rt p) wX wX
ps

-- |'scanContextFile' scans the context in the file of the given name.
scanContextFile :: FilePath -> IO (PatchSet rt p Origin wX)
scanContextFile :: String -> IO (PatchSet rt p Origin wX)
scanContextFile filename :: String
filename = ByteString -> PatchSet rt p Origin wX
forall (rt :: RepoType) (p :: * -> * -> *) wX.
ByteString -> PatchSet rt p Origin wX
scanContext (ByteString -> PatchSet rt p Origin wX)
-> IO ByteString -> IO (PatchSet rt p Origin wX)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO ByteString
mmapFilePS String
filename
  where
    -- are the type witnesses sensible?
    scanContext :: B.ByteString -> PatchSet rt p Origin wX
    scanContext :: ByteString -> PatchSet rt p Origin wX
scanContext input :: ByteString
input
        | ByteString -> Bool
B.null ByteString
input = String -> PatchSet rt p Origin wX
forall a. HasCallStack => String -> a
error "Bad context!"
        | Bool
otherwise = case ByteString -> (String, ByteString)
sillyLex ByteString
input of
            ("Context:",rest :: ByteString
rest) -> case ByteString -> ([PatchInfo], ByteString)
getContext ByteString
rest of
                (cont :: [PatchInfo]
cont@(_ : _), _) | PatchInfo -> Bool
isTag ([PatchInfo] -> PatchInfo
forall a. [a] -> a
last [PatchInfo]
cont) ->
                    let ps :: RL (PatchInfoAnd rt p) wX wY
ps = [PatchInfo] -> RL (PatchInfoAnd rt p) wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
[PatchInfo] -> RL (PatchInfoAnd rt p) wX wY
unavailablePatches ([PatchInfo] -> RL (PatchInfoAnd rt p) wX wY)
-> [PatchInfo] -> RL (PatchInfoAnd rt p) wX wY
forall a b. (a -> b) -> a -> b
$ [PatchInfo] -> [PatchInfo]
forall a. [a] -> [a]
init [PatchInfo]
cont
                        t :: Tagged rt p wY wZ
t = PatchInfoAnd rt p wY wZ
-> Maybe String
-> RL (PatchInfoAnd rt p) wY wY
-> Tagged rt p wY wZ
forall (rt :: RepoType) (p :: * -> * -> *) wY wZ wX.
PatchInfoAnd rt p wY wZ
-> Maybe String
-> RL (PatchInfoAnd rt p) wX wY
-> Tagged rt p wX wZ
Tagged (PatchInfo -> PatchInfoAnd rt p wY wZ
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
PatchInfo -> PatchInfoAnd rt p wX wY
piUnavailable (PatchInfo -> PatchInfoAnd rt p wY wZ)
-> PatchInfo -> PatchInfoAnd rt p wY wZ
forall a b. (a -> b) -> a -> b
$ [PatchInfo] -> PatchInfo
forall a. [a] -> a
last [PatchInfo]
cont) Maybe String
forall a. Maybe a
Nothing RL (PatchInfoAnd rt p) wY wY
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL in
                    RL (Tagged rt p) Origin Any
-> RL (PatchInfoAnd rt p) Any wX -> PatchSet rt p Origin wX
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX wY.
RL (Tagged rt p) wStart wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wStart wY
PatchSet (RL (Tagged rt p) Origin Origin
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL RL (Tagged rt p) Origin Origin
-> Tagged rt p Origin Any -> RL (Tagged rt p) Origin Any
forall (a :: * -> * -> *) wX wY wZ.
RL a wX wY -> a wY wZ -> RL a wX wZ
:<: Tagged rt p Origin Any
forall (rt :: RepoType) (p :: * -> * -> *) wY wZ. Tagged rt p wY wZ
t) RL (PatchInfoAnd rt p) Any wX
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
RL (PatchInfoAnd rt p) wX wY
ps
                (cont :: [PatchInfo]
cont, _) -> RL (Tagged rt p) Origin Origin
-> RL (PatchInfoAnd rt p) Origin wX -> PatchSet rt p Origin wX
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX wY.
RL (Tagged rt p) wStart wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wStart wY
PatchSet RL (Tagged rt p) Origin Origin
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL ([PatchInfo] -> RL (PatchInfoAnd rt p) Origin wX
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
[PatchInfo] -> RL (PatchInfoAnd rt p) wX wY
unavailablePatches [PatchInfo]
cont)
            ("-----BEGIN PGP SIGNED MESSAGE-----",rest :: ByteString
rest) ->
                ByteString -> PatchSet rt p Origin wX
forall (rt :: RepoType) (p :: * -> * -> *) wX.
ByteString -> PatchSet rt p Origin wX
scanContext (ByteString -> PatchSet rt p Origin wX)
-> ByteString -> PatchSet rt p Origin wX
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
filterGpgDashes ByteString
rest
            (_, rest :: ByteString
rest) -> ByteString -> PatchSet rt p Origin wX
forall (rt :: RepoType) (p :: * -> * -> *) wX.
ByteString -> PatchSet rt p Origin wX
scanContext ByteString
rest

-- | Minimize the context of a bundle to be sent, taking into account
--   the patches selected to be sent 
minContext :: (RepoPatch p)
          => PatchSet rt p wStart wB
          -> FL (PatchInfoAnd rt p) wB wC
          -> Sealed ((PatchSet rt p :> FL (PatchInfoAnd rt p)) wStart)
minContext :: PatchSet rt p wStart wB
-> FL (PatchInfoAnd rt p) wB wC
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) wStart)
minContext (PatchSet behindTag :: RL (Tagged rt p) wStart wX
behindTag topCommon :: RL (PatchInfoAnd rt p) wX wB
topCommon) to_be_sent :: FL (PatchInfoAnd rt p) wB wC
to_be_sent =
  case RL (PatchInfoAnd rt p) wX wB
-> FL (PatchInfoAnd rt p) wB wB
-> FL (PatchInfoAnd rt p) wB wC
-> Sealed
     ((:>) (RL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX)
forall (p :: * -> * -> *) (rt :: RepoType) wA wB wC wD.
RepoPatch p =>
RL (PatchInfoAnd rt p) wA wB
-> FL (PatchInfoAnd rt p) wB wC
-> FL (PatchInfoAnd rt p) wC wD
-> Sealed
     ((:>) (RL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wA)
go RL (PatchInfoAnd rt p) wX wB
topCommon FL (PatchInfoAnd rt p) wB wB
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL FL (PatchInfoAnd rt p) wB wC
to_be_sent of
    Sealed (c :: RL (PatchInfoAnd rt p) wX wZ
c :> to_be_sent' :: FL (PatchInfoAnd rt p) wZ wX
to_be_sent') -> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) wStart wX
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) wStart)
forall (a :: * -> *) wX. a wX -> Sealed a
seal (RL (Tagged rt p) wStart wX
-> RL (PatchInfoAnd rt p) wX wZ -> PatchSet rt p wStart wZ
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX wY.
RL (Tagged rt p) wStart wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wStart wY
PatchSet RL (Tagged rt p) wStart wX
behindTag RL (PatchInfoAnd rt p) wX wZ
c PatchSet rt p wStart wZ
-> FL (PatchInfoAnd rt p) wZ wX
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) wStart wX
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PatchInfoAnd rt p) wZ wX
to_be_sent') 
  where
    go :: (RepoPatch p)
       => RL (PatchInfoAnd rt p) wA wB -- context we attempt to minimize
       -> FL (PatchInfoAnd rt p) wB wC -- patches we cannot remove from context
       -> FL (PatchInfoAnd rt p) wC wD -- patches to be included in the bundle
       -> Sealed (( RL (PatchInfoAnd rt p) :> FL (PatchInfoAnd rt p) ) wA )
    go :: RL (PatchInfoAnd rt p) wA wB
-> FL (PatchInfoAnd rt p) wB wC
-> FL (PatchInfoAnd rt p) wC wD
-> Sealed
     ((:>) (RL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wA)
go NilRL necessary :: FL (PatchInfoAnd rt p) wB wC
necessary to_be_sent' :: FL (PatchInfoAnd rt p) wC wD
to_be_sent' = (:>) (RL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wB wD
-> Sealed
     ((:>) (RL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wB)
forall (a :: * -> *) wX. a wX -> Sealed a
seal (FL (PatchInfoAnd rt p) wB wC -> RL (PatchInfoAnd rt p) wB wC
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd rt p) wB wC
necessary RL (PatchInfoAnd rt p) wB wC
-> FL (PatchInfoAnd rt p) wC wD
-> (:>) (RL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wB wD
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PatchInfoAnd rt p) wC wD
to_be_sent')
    go (rest :: RL (PatchInfoAnd rt p) wA wY
rest :<: candidate :: PatchInfoAnd rt p wY wB
candidate) necessary :: FL (PatchInfoAnd rt p) wB wC
necessary to_be_sent' :: FL (PatchInfoAnd rt p) wC wD
to_be_sent' =
      let fl1 :: FL (PatchInfoAnd rt p) wY wB
fl1 = (PatchInfoAnd rt p wY wB
candidate PatchInfoAnd rt p wY wB
-> FL (PatchInfoAnd rt p) wB wB -> FL (PatchInfoAnd rt p) wY wB
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchInfoAnd rt p) wB wB
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL) in
      case (:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wY wC
-> Maybe
     ((:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wY wC)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (FL (PatchInfoAnd rt p) wY wB
fl1 FL (PatchInfoAnd rt p) wY wB
-> FL (PatchInfoAnd rt p) wB wC
-> (:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wY wC
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PatchInfoAnd rt p) wB wC
necessary) of
        Nothing                   -> RL (PatchInfoAnd rt p) wA wY
-> FL (PatchInfoAnd rt p) wY wC
-> FL (PatchInfoAnd rt p) wC wD
-> Sealed
     ((:>) (RL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wA)
forall (p :: * -> * -> *) (rt :: RepoType) wA wB wC wD.
RepoPatch p =>
RL (PatchInfoAnd rt p) wA wB
-> FL (PatchInfoAnd rt p) wB wC
-> FL (PatchInfoAnd rt p) wC wD
-> Sealed
     ((:>) (RL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wA)
go RL (PatchInfoAnd rt p) wA wY
rest (PatchInfoAnd rt p wY wB
candidate PatchInfoAnd rt p wY wB
-> FL (PatchInfoAnd rt p) wB wC -> FL (PatchInfoAnd rt p) wY wC
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchInfoAnd rt p) wB wC
necessary) FL (PatchInfoAnd rt p) wC wD
to_be_sent'
        Just (necessary' :: FL (PatchInfoAnd rt p) wY wZ
necessary' :> fl1' :: FL (PatchInfoAnd rt p) wZ wC
fl1') ->
            case (:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wD
-> Maybe
     ((:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wD)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p p wX wY -> Maybe ((:>) p p wX wY)
commute (FL (PatchInfoAnd rt p) wZ wC
fl1' FL (PatchInfoAnd rt p) wZ wC
-> FL (PatchInfoAnd rt p) wC wD
-> (:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wZ wD
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PatchInfoAnd rt p) wC wD
to_be_sent') of
                Nothing                  -> RL (PatchInfoAnd rt p) wA wY
-> FL (PatchInfoAnd rt p) wY wC
-> FL (PatchInfoAnd rt p) wC wD
-> Sealed
     ((:>) (RL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wA)
forall (p :: * -> * -> *) (rt :: RepoType) wA wB wC wD.
RepoPatch p =>
RL (PatchInfoAnd rt p) wA wB
-> FL (PatchInfoAnd rt p) wB wC
-> FL (PatchInfoAnd rt p) wC wD
-> Sealed
     ((:>) (RL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wA)
go RL (PatchInfoAnd rt p) wA wY
rest (PatchInfoAnd rt p wY wB
candidate PatchInfoAnd rt p wY wB
-> FL (PatchInfoAnd rt p) wB wC -> FL (PatchInfoAnd rt p) wY wC
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
:>: FL (PatchInfoAnd rt p) wB wC
necessary) FL (PatchInfoAnd rt p) wC wD
to_be_sent'
                Just (to_be_sent'' :: FL (PatchInfoAnd rt p) wZ wZ
to_be_sent'' :> _) -> -- commutation work, we can drop the patch
                  RL (PatchInfoAnd rt p) wA wY
-> FL (PatchInfoAnd rt p) wY wZ
-> FL (PatchInfoAnd rt p) wZ wZ
-> Sealed
     ((:>) (RL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wA)
forall (p :: * -> * -> *) (rt :: RepoType) wA wB wC wD.
RepoPatch p =>
RL (PatchInfoAnd rt p) wA wB
-> FL (PatchInfoAnd rt p) wB wC
-> FL (PatchInfoAnd rt p) wC wD
-> Sealed
     ((:>) (RL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wA)
go RL (PatchInfoAnd rt p) wA wY
rest FL (PatchInfoAnd rt p) wY wZ
necessary' FL (PatchInfoAnd rt p) wZ wZ
to_be_sent''

-- |patchFilename maps a patch description string to a safe (lowercased, spaces
-- removed and ascii-only characters) patch filename.
patchFilename :: String -> String
patchFilename :: String -> String
patchFilename the_summary :: String
the_summary = String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ ".dpatch"
  where
    name :: String
name = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
safeFileChar String
the_summary
    safeFileChar :: Char -> Char
safeFileChar c :: Char
c | Char -> Bool
isAlpha Char
c = Char -> Char
toLower Char
c
                   | Char -> Bool
isDigit Char
c = Char
c
                   | Char -> Bool
isSpace Char
c = '-'
    safeFileChar _ = '_'