-- 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
    ( Bundle(..)
    , makeBundle
    , parseBundle
    , interpretBundle
    , readContextFile
    , minContext
    ) where

import Darcs.Prelude

import Control.Applicative ( many, (<|>) )
import Control.Monad ( (<=<) )

import qualified Data.ByteString as B
    ( ByteString
    , breakSubstring
    , concat
    , drop
    , isPrefixOf
    , null
    , splitAt
    )
import qualified Data.ByteString.Char8 as BC
    ( break
    , dropWhile
    , pack
    )

import Darcs.Patch.Apply ( ApplyState, ObjectIdOfPatch )
import Darcs.Patch.ApplyMonad ( ApplyMonadTrans )
import Darcs.Patch.Bracketed ( Bracketed, unBracketedFL )
import Darcs.Patch.Commute ( Commute, commuteFL )
import Darcs.Patch.Depends ( contextPatches, splitOnTag )
import Darcs.Patch.Format ( PatchListFormat )
import Darcs.Patch.Info
    ( PatchInfo
    , displayPatchInfo
    , piTag
    , readPatchInfo
    , showPatchInfo
    )
import Darcs.Patch.Named ( Named, fmapFL_Named )
import Darcs.Patch.Object ( ObjectId )
import Darcs.Patch.PatchInfoAnd
    ( PatchInfoAnd
    , info
    , n2pia
    , patchInfoAndPatch
    , unavailable
    )
import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL )
import Darcs.Patch.Read ( readPatch' )
import Darcs.Patch.RepoPatch ( RepoPatch )
import Darcs.Patch.Show ( showPatch, showPatchWithContext )
import Darcs.Patch.Set
    ( PatchSet(..)
    , SealedPatchSet
    , Origin
    , appendPSFL
    )
import Darcs.Patch.Show ( ShowPatchBasic, ShowPatchFor(ForStorage) )
import Darcs.Patch.Witnesses.Ordered
    ( (:>)(..)
    , FL(..)
    , RL(..)
    , mapFL
    , mapFL_FL
    , mapRL
    , reverseFL
    )
import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal )
import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd, unsafeCoercePStart )

import Darcs.Util.ByteString
    ( dropSpace
    , mmapFilePS
    , betweenLinesPS
    )
import Darcs.Util.Hash ( sha1PS, sha1Show )
import Darcs.Util.Parser
    ( Parser
    , lexString
    , lexWord
    , optional
    , parse
    )
import Darcs.Util.Printer
    ( Doc
    , ($$)
    , newline
    , packedString
    , renderPS
    , renderString
    , text
    , vcat
    , vsep
    )


-- | A 'Bundle' is a context together with some patches. The context
-- consists of unavailable patches.
data Bundle p wX wY where
  Bundle :: (FL (PatchInfoAnd p) :> FL (PatchInfoAnd p)) wX wY
         -> Bundle p wX wY

-- | Interpret a 'Bundle' in the context of a 'PatchSet'. This means we
-- match up a possible tag in the context of the 'Bundle'. This fails if
-- the tag couldn't be found.
interpretBundle :: Commute p
                => PatchSet p Origin wT
                -> Bundle p wA wB
                -> Either String (PatchSet p Origin wB)
interpretBundle :: 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 wT
ref (Bundle (FL (PatchInfoAnd p) wA wZ
context :> FL (PatchInfoAnd p) wZ wB
patches)) =
  (PatchSet p Origin wZ
 -> FL (PatchInfoAnd p) wZ wB -> PatchSet p Origin wB)
-> FL (PatchInfoAnd p) wZ wB
-> PatchSet p Origin wZ
-> PatchSet p Origin wB
forall a b c. (a -> b -> c) -> b -> a -> c
flip PatchSet p Origin wZ
-> FL (PatchInfoAnd p) wZ wB -> PatchSet p Origin wB
forall (p :: * -> * -> *) wStart wX wY.
PatchSet p wStart wX
-> FL (PatchInfoAnd p) wX wY -> PatchSet p wStart wY
appendPSFL FL (PatchInfoAnd p) wZ wB
patches (PatchSet p Origin wZ -> PatchSet p Origin wB)
-> Either String (PatchSet p Origin wZ)
-> Either String (PatchSet p Origin wB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PatchSet p Origin wT
-> FL (PatchInfoAnd p) wA wZ
-> Either String (PatchSet p Origin wZ)
forall (p :: * -> * -> *) wT wA wB.
Commute p =>
PatchSet p Origin wT
-> FL (PatchInfoAnd p) wA wB
-> Either String (PatchSet p Origin wB)
interpretContext PatchSet p Origin wT
ref FL (PatchInfoAnd p) wA wZ
context

-- | Create a b16 encoded SHA1 of a given a FL of named patches. This allows us
-- to ensure that the patches in a received bundle have not been modified in
-- transit.
hashBundle :: (PatchListFormat p, ShowPatchBasic p) => FL (Named p) wX wY
           -> B.ByteString
hashBundle :: forall (p :: * -> * -> *) wX wY.
(PatchListFormat p, ShowPatchBasic p) =>
FL (Named p) wX wY -> ByteString
hashBundle FL (Named p) wX wY
to_be_sent =
    SHA1 -> ByteString
sha1Show (SHA1 -> ByteString) -> SHA1 -> ByteString
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. Named p wW wZ -> Doc) -> FL (Named p) wX wY -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL (ShowPatchFor -> Named p wW wZ -> Doc
forall wX wY. ShowPatchFor -> Named p wX wY -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
ForStorage) FL (Named p) wX wY
to_be_sent) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
newline

makeBundle
  :: (RepoPatch p, ApplyMonadTrans (ApplyState p) IO, ObjectId (ObjectIdOfPatch p))
  => Maybe (ApplyState p IO)
  -> PatchSet p wStart wX
  -> FL (Named p) wX wY
  -> IO Doc
makeBundle :: forall (p :: * -> * -> *) wStart wX wY.
(RepoPatch p, ApplyMonadTrans (ApplyState p) IO,
 ObjectId (ObjectIdOfPatch p)) =>
Maybe (ApplyState p IO)
-> PatchSet p wStart wX -> FL (Named p) wX wY -> IO Doc
makeBundle Maybe (ApplyState p IO)
mstate PatchSet p wStart wX
repo FL (Named p) wX wY
to_be_sent
  | PatchSet p wStart wZ
_ :> RL (PatchInfoAnd p) wZ wX
context <- PatchSet p wStart wX
-> (:>) (PatchSet p) (RL (PatchInfoAnd p)) wStart wX
forall (p :: * -> * -> *) wX wY.
PatchSet p wX wY -> (:>) (PatchSet p) (RL (PatchInfoAnd p)) wX wY
contextPatches PatchSet p wStart wX
repo =
    RL (PatchInfoAnd p) wZ wX -> Doc -> Doc
forall {p :: * -> * -> *} {wX} {wY}.
RL (PatchInfoAndG p) wX wY -> Doc -> Doc
format RL (PatchInfoAnd p) wZ wX
context (Doc -> Doc) -> IO Doc -> IO Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      case Maybe (ApplyState p IO)
mstate of
        Just ApplyState p IO
state -> ShowPatchFor
-> ApplyState (FL (Named p)) IO -> FL (Named p) wX wY -> IO Doc
forall (p :: * -> * -> *) (m :: * -> *) wX wY.
(ApplyMonadTrans (ApplyState p) m, ShowContextPatch p) =>
ShowPatchFor -> ApplyState p m -> p wX wY -> m Doc
showPatchWithContext ShowPatchFor
ForStorage ApplyState p IO
ApplyState (FL (Named p)) IO
state FL (Named p) wX wY
to_be_sent
        Maybe (ApplyState p IO)
Nothing -> Doc -> IO Doc
forall a. a -> IO a
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. Named p wW wZ -> Doc) -> FL (Named p) wX wY -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> FL a wX wY -> [b]
mapFL (ShowPatchFor -> Named p wW wZ -> Doc
forall wX wY. ShowPatchFor -> Named p wX wY -> Doc
forall (p :: * -> * -> *) wX wY.
ShowPatchBasic p =>
ShowPatchFor -> p wX wY -> Doc
showPatch ShowPatchFor
ForStorage) FL (Named p) wX wY
to_be_sent)
  where
    format :: RL (PatchInfoAndG p) wX wY -> Doc -> Doc
format RL (PatchInfoAndG p) wX wY
context Doc
patches =
      String -> Doc
text String
""
      Doc -> Doc -> Doc
$$ String -> Doc
text String
"New patches:"
      Doc -> Doc -> Doc
$$ String -> Doc
text String
""
      Doc -> Doc -> Doc
$$ Doc
patches
      Doc -> Doc -> Doc
$$ String -> Doc
text String
""
      Doc -> Doc -> Doc
$$ String -> Doc
text String
"Context:"
      Doc -> Doc -> Doc
$$ String -> Doc
text String
""
      Doc -> Doc -> Doc
$$ [Doc] -> Doc
vcat ((forall wW wZ. PatchInfoAndG p wW wZ -> Doc)
-> RL (PatchInfoAndG p) wX wY -> [Doc]
forall (a :: * -> * -> *) b wX wY.
(forall wW wZ. a wW wZ -> b) -> RL a wX wY -> [b]
mapRL (ShowPatchFor -> PatchInfo -> Doc
showPatchInfo ShowPatchFor
ForStorage (PatchInfo -> Doc)
-> (PatchInfoAndG p wW wZ -> PatchInfo)
-> PatchInfoAndG p wW wZ
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAndG p wW wZ -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info) RL (PatchInfoAndG p) wX wY
context)
      Doc -> Doc -> Doc
$$ String -> Doc
text String
"Patch bundle hash:"
      Doc -> Doc -> Doc
$$ ByteString -> Doc
packedString (FL (Named p) wX wY -> ByteString
forall (p :: * -> * -> *) wX wY.
(PatchListFormat p, ShowPatchBasic p) =>
FL (Named p) wX wY -> ByteString
hashBundle FL (Named p) wX wY
to_be_sent)
      Doc -> Doc -> Doc
$$ String -> Doc
text String
""

hashFailureMessage :: String
hashFailureMessage :: String
hashFailureMessage =
  String
"Patch bundle failed hash!\n\
  \This probably means that the patch has been corrupted by a mailer.\n\
  \The most likely culprit is CRLF newlines."

parseBundle :: RepoPatch p
            => B.ByteString -> Either String (Sealed (Bundle p wX))
parseBundle :: forall (p :: * -> * -> *) wX.
RepoPatch p =>
ByteString -> Either String (Sealed (Bundle p wX))
parseBundle =
    ((Sealed (Bundle p wX), ByteString) -> Sealed (Bundle p wX))
-> Either String (Sealed (Bundle p wX), ByteString)
-> Either String (Sealed (Bundle p wX))
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Sealed (Bundle p wX), ByteString) -> Sealed (Bundle p wX)
forall a b. (a, b) -> a
fst (Either String (Sealed (Bundle p wX), ByteString)
 -> Either String (Sealed (Bundle p wX)))
-> (ByteString -> Either String (Sealed (Bundle p wX), ByteString))
-> ByteString
-> Either String (Sealed (Bundle p wX))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (Sealed (Bundle p wX))
-> ByteString -> Either String (Sealed (Bundle p wX), ByteString)
forall a. Parser a -> ByteString -> Either String (a, ByteString)
parse Parser (Sealed (Bundle p wX))
forall (p :: * -> * -> *) wX.
RepoPatch p =>
Parser (Sealed (Bundle p wX))
pUnsignedBundle (ByteString -> Either String (Sealed (Bundle p wX), ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> Either String (Sealed (Bundle p wX), ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
dropInitialTrash (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
decodeGpgClearsigned
  where
    dropInitialTrash :: ByteString -> ByteString
dropInitialTrash ByteString
s =
      case (Char -> Bool) -> ByteString -> (ByteString, ByteString)
BC.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') (ByteString -> ByteString
dropSpace ByteString
s) of
        (ByteString
line,ByteString
rest)
          | ByteString
contextName ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
line Bool -> Bool -> Bool
|| ByteString
patchesName ByteString -> ByteString -> Bool
`B.isPrefixOf` ByteString
line -> ByteString
s
          | ByteString -> Bool
B.null ByteString
rest -> ByteString
rest
          | Bool
otherwise -> ByteString -> ByteString
dropInitialTrash ByteString
rest

pUnsignedBundle :: forall p wX. RepoPatch p => Parser (Sealed (Bundle p wX))
pUnsignedBundle :: forall (p :: * -> * -> *) wX.
RepoPatch p =>
Parser (Sealed (Bundle p wX))
pUnsignedBundle = Parser ByteString (Sealed (Bundle p wX))
forall {wX}. Parser ByteString (Sealed (Bundle p wX))
pContextThenPatches Parser ByteString (Sealed (Bundle p wX))
-> Parser ByteString (Sealed (Bundle p wX))
-> Parser ByteString (Sealed (Bundle p wX))
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString (Sealed (Bundle p wX))
forall {wX}. Parser ByteString (Sealed (Bundle p wX))
pPatchesThenContext
  where
    packBundle :: [PatchInfo]
-> FL (Named (Bracketed p)) wZ wX -> Sealed (Bundle p wX)
packBundle [PatchInfo]
context FL (Named (Bracketed p)) wZ wX
patches =
      Bundle p wX wX -> Sealed (Bundle p wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (Bundle p wX wX -> Sealed (Bundle p wX))
-> Bundle p wX wX -> Sealed (Bundle p wX)
forall a b. (a -> b) -> a -> b
$ (:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wX
-> Bundle p wX wX
forall (p :: * -> * -> *) wX wY.
(:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wY
-> Bundle p wX wY
Bundle ((:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wX
 -> Bundle p wX wX)
-> (:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wX
-> Bundle p wX wX
forall a b. (a -> b) -> a -> b
$ ([PatchInfo] -> FL (PatchInfoAnd p) wX wZ
forall (p :: * -> * -> *) wX wY.
[PatchInfo] -> FL (PatchInfoAnd p) wX wY
unavailablePatchesFL ([PatchInfo] -> [PatchInfo]
forall a. [a] -> [a]
reverse [PatchInfo]
context)) FL (PatchInfoAnd p) wX wZ
-> FL (PatchInfoAnd p) wZ wX
-> (:>) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wX
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:>
        ((forall wW wY. Named (Bracketed p) wW wY -> PatchInfoAnd p wW wY)
-> FL (Named (Bracketed p)) wZ wX -> FL (PatchInfoAnd p) wZ 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 (Named p wW wY -> PatchInfoAndG (Named p) wW wY
forall (p :: * -> * -> *) wX wY.
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG p wX wY
n2pia (Named p wW wY -> PatchInfoAndG (Named p) wW wY)
-> (Named (Bracketed p) wW wY -> Named p wW wY)
-> Named (Bracketed p) wW wY
-> PatchInfoAndG (Named p) wW wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FL (Bracketed p) wW wY -> FL p wW wY)
-> Named (Bracketed p) wW wY -> Named p wW wY
forall (p :: * -> * -> *) wA wB (q :: * -> * -> *) wC wD.
(FL p wA wB -> FL q wC wD) -> Named p wA wB -> Named q wC wD
fmapFL_Named FL (Bracketed p) wW wY -> FL p wW wY
forall (p :: * -> * -> *) wX wY. BracketedFL p wX wY -> FL p wX wY
unBracketedFL) FL (Named (Bracketed p)) wZ wX
patches)
    -- Is this a legacy format?
    pContextThenPatches :: Parser ByteString (Sealed (Bundle p wX))
pContextThenPatches = do
      [PatchInfo]
context <- Parser [PatchInfo]
pContext
      Sealed FL (Named (Bracketed p)) Any wX
patches <- Parser (Sealed (FL (Named (Bracketed p)) Any))
forall (p :: * -> * -> *) wX.
RepoPatch p =>
Parser (Sealed (FL (Named (Bracketed p)) wX))
pPatches
      Sealed (Bundle p wX) -> Parser ByteString (Sealed (Bundle p wX))
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (Bundle p wX) -> Parser ByteString (Sealed (Bundle p wX)))
-> Sealed (Bundle p wX) -> Parser ByteString (Sealed (Bundle p wX))
forall a b. (a -> b) -> a -> b
$ [PatchInfo]
-> FL (Named (Bracketed p)) Any wX -> Sealed (Bundle p wX)
forall {p :: * -> * -> *} {wZ} {wX} {wX}.
[PatchInfo]
-> FL (Named (Bracketed p)) wZ wX -> Sealed (Bundle p wX)
packBundle [PatchInfo]
context FL (Named (Bracketed p)) Any wX
patches
    pPatchesThenContext :: Parser ByteString (Sealed (Bundle p wX))
pPatchesThenContext = do
      Sealed FL (Named (Bracketed p)) Any wX
patches <- Parser (Sealed (FL (Named (Bracketed p)) Any))
forall (p :: * -> * -> *) wX.
RepoPatch p =>
Parser (Sealed (FL (Named (Bracketed p)) wX))
pPatches
      [PatchInfo]
context <- Parser [PatchInfo]
pContext
      Maybe ByteString
mBundleHash <- Parser ByteString ByteString
-> Parser ByteString (Maybe ByteString)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ByteString ByteString
pBundleHash
      case Maybe ByteString
mBundleHash of
        Just ByteString
bundleHash -> do
          let realHash :: ByteString
realHash = FL (Named (Bracketed p)) Any wX -> ByteString
forall (p :: * -> * -> *) wX wY.
(PatchListFormat p, ShowPatchBasic p) =>
FL (Named p) wX wY -> ByteString
hashBundle FL (Named (Bracketed p)) Any wX
patches
          if ByteString
realHash ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
bundleHash
            then Sealed (Bundle p wX) -> Parser ByteString (Sealed (Bundle p wX))
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (Bundle p wX) -> Parser ByteString (Sealed (Bundle p wX)))
-> Sealed (Bundle p wX) -> Parser ByteString (Sealed (Bundle p wX))
forall a b. (a -> b) -> a -> b
$ [PatchInfo]
-> FL (Named (Bracketed p)) Any wX -> Sealed (Bundle p wX)
forall {p :: * -> * -> *} {wZ} {wX} {wX}.
[PatchInfo]
-> FL (Named (Bracketed p)) wZ wX -> Sealed (Bundle p wX)
packBundle [PatchInfo]
context FL (Named (Bracketed p)) Any wX
patches
            else String -> Parser ByteString (Sealed (Bundle p wX))
forall a. String -> Parser ByteString a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
hashFailureMessage
        Maybe ByteString
Nothing -> Sealed (Bundle p wX) -> Parser ByteString (Sealed (Bundle p wX))
forall a. a -> Parser ByteString a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (Bundle p wX) -> Parser ByteString (Sealed (Bundle p wX)))
-> Sealed (Bundle p wX) -> Parser ByteString (Sealed (Bundle p wX))
forall a b. (a -> b) -> a -> b
$ [PatchInfo]
-> FL (Named (Bracketed p)) Any wX -> Sealed (Bundle p wX)
forall {p :: * -> * -> *} {wZ} {wX} {wX}.
[PatchInfo]
-> FL (Named (Bracketed p)) wZ wX -> Sealed (Bundle p wX)
packBundle [PatchInfo]
context FL (Named (Bracketed p)) Any wX
patches

pBundleHash :: Parser B.ByteString
pBundleHash :: Parser ByteString ByteString
pBundleHash = ByteString -> Parser ()
lexString ByteString
bundleHashName Parser ()
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString ByteString
lexWord

bundleHashName :: B.ByteString
bundleHashName :: ByteString
bundleHashName = String -> ByteString
BC.pack String
"Patch bundle hash:"

unavailablePatchesFL :: [PatchInfo] -> FL (PatchInfoAnd p) wX wY
unavailablePatchesFL :: forall (p :: * -> * -> *) wX wY.
[PatchInfo] -> FL (PatchInfoAnd p) wX wY
unavailablePatchesFL = (PatchInfo
 -> FL (PatchInfoAnd p) wX wY -> FL (PatchInfoAnd p) wX wY)
-> FL (PatchInfoAnd p) wX wY
-> [PatchInfo]
-> FL (PatchInfoAnd p) wX wY
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (PatchInfoAnd p wX wX
-> FL (PatchInfoAnd p) wX wY -> FL (PatchInfoAnd p) wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
(:>:) (PatchInfoAnd p wX wX
 -> FL (PatchInfoAnd p) wX wY -> FL (PatchInfoAnd p) wX wY)
-> (PatchInfo -> PatchInfoAnd p wX wX)
-> PatchInfo
-> FL (PatchInfoAnd p) wX wY
-> FL (PatchInfoAnd p) wX wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> PatchInfoAnd p wX wX
forall {p :: * -> * -> *} {wA} {wB}.
PatchInfo -> PatchInfoAndG p wA wB
piUnavailable) (FL (PatchInfoAnd p) wX wX -> FL (PatchInfoAnd p) wX wY
forall (a :: * -> * -> *) wX wY1 wY2. a wX wY1 -> a wX wY2
unsafeCoercePEnd FL (PatchInfoAnd p) wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
  where
    piUnavailable :: PatchInfo -> PatchInfoAndG p wA wB
piUnavailable PatchInfo
i = PatchInfo -> Hopefully p wA wB -> PatchInfoAndG p wA wB
forall (p :: * -> * -> *) wA wB.
PatchInfo -> Hopefully p wA wB -> PatchInfoAndG p wA wB
patchInfoAndPatch PatchInfo
i (Hopefully p wA wB -> PatchInfoAndG p wA wB)
-> (String -> Hopefully p wA wB) -> String -> PatchInfoAndG p wA wB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Hopefully p wA wB
forall (a :: * -> * -> *) wX wY. String -> Hopefully a wX wY
unavailable (String -> PatchInfoAndG p wA wB)
-> String -> PatchInfoAndG p wA wB
forall a b. (a -> b) -> a -> b
$
      String
"Patch not stored in patch bundle:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Doc -> String
renderString (PatchInfo -> Doc
displayPatchInfo PatchInfo
i)

pContext :: Parser [PatchInfo]
pContext :: Parser [PatchInfo]
pContext = ByteString -> Parser ()
lexString ByteString
contextName Parser () -> Parser [PatchInfo] -> Parser [PatchInfo]
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString PatchInfo -> Parser [PatchInfo]
forall a. Parser ByteString a -> Parser ByteString [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ByteString PatchInfo
readPatchInfo

contextName :: B.ByteString
contextName :: ByteString
contextName = String -> ByteString
BC.pack String
"Context:"

pPatches :: RepoPatch p => Parser (Sealed (FL (Named (Bracketed p)) wX))
pPatches :: forall (p :: * -> * -> *) wX.
RepoPatch p =>
Parser (Sealed (FL (Named (Bracketed p)) wX))
pPatches = ByteString -> Parser ()
lexString ByteString
patchesName Parser ()
-> Parser ByteString (Sealed (FL (Named (Bracketed p)) wX))
-> Parser ByteString (Sealed (FL (Named (Bracketed p)) wX))
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString (Sealed (FL (Named (Bracketed p)) wX))
forall wX. Parser (Sealed (FL (Named (Bracketed p)) wX))
forall (p :: * -> * -> *) wX. ReadPatch p => Parser (Sealed (p wX))
readPatch'

patchesName :: B.ByteString
patchesName :: ByteString
patchesName = String -> ByteString
BC.pack String
"New patches:"

readContextFile :: Commute p
                => PatchSet p Origin wX
                -> FilePath
                -> IO (SealedPatchSet p Origin)
readContextFile :: forall (p :: * -> * -> *) wX.
Commute p =>
PatchSet p Origin wX -> String -> IO (SealedPatchSet p Origin)
readContextFile PatchSet p Origin wX
ref = (PatchSet p Origin Any -> SealedPatchSet p Origin)
-> IO (PatchSet p Origin Any) -> IO (SealedPatchSet p Origin)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PatchSet p Origin Any -> SealedPatchSet p Origin
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (IO (PatchSet p Origin Any) -> IO (SealedPatchSet p Origin))
-> (String -> IO (PatchSet p Origin Any))
-> String
-> IO (SealedPatchSet p Origin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> IO (PatchSet p Origin Any)
forall {wB}. ByteString -> IO (PatchSet p Origin wB)
parseAndInterpret (ByteString -> IO (PatchSet p Origin Any))
-> (String -> IO ByteString)
-> String
-> IO (PatchSet p Origin Any)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< String -> IO ByteString
mmapFilePS)
  where
    parseAndInterpret :: ByteString -> IO (PatchSet p Origin wB)
parseAndInterpret =
      (String -> IO (PatchSet p Origin wB))
-> (PatchSet p Origin wB -> IO (PatchSet p Origin wB))
-> Either String (PatchSet p Origin wB)
-> IO (PatchSet p Origin wB)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO (PatchSet p Origin wB)
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail PatchSet p Origin wB -> IO (PatchSet p Origin wB)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (PatchSet p Origin wB) -> IO (PatchSet p Origin wB))
-> (ByteString -> Either String (PatchSet p Origin wB))
-> ByteString
-> IO (PatchSet p Origin wB)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PatchSet p Origin wX
-> FL (PatchInfoAnd p) Any wB
-> Either String (PatchSet p Origin wB)
forall (p :: * -> * -> *) wT wA wB.
Commute p =>
PatchSet p Origin wT
-> FL (PatchInfoAnd p) wA wB
-> Either String (PatchSet p Origin wB)
interpretContext PatchSet p Origin wX
ref (FL (PatchInfoAnd p) Any wB
 -> Either String (PatchSet p Origin wB))
-> (ByteString -> Either String (FL (PatchInfoAnd p) Any wB))
-> ByteString
-> Either String (PatchSet p Origin wB)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteString -> Either String (FL (PatchInfoAnd p) Any wB)
forall (p :: * -> * -> *) wX wY.
ByteString -> Either String (FL (PatchInfoAnd p) wX wY)
parseContextFile)

-- | Interpret a context file in the context of a 'PatchSet'. This means we
-- match up a possible tag. This fails if the tag couldn't be found.
interpretContext :: Commute p
                 => PatchSet p Origin wT
                 -> FL (PatchInfoAnd p) wA wB
                 -> Either String (PatchSet p Origin wB)
interpretContext :: forall (p :: * -> * -> *) wT wA wB.
Commute p =>
PatchSet p Origin wT
-> FL (PatchInfoAnd p) wA wB
-> Either String (PatchSet p Origin wB)
interpretContext PatchSet p Origin wT
ref FL (PatchInfoAnd p) wA wB
context =
  case FL (PatchInfoAnd p) wA wB
context of
    PatchInfoAnd p wA wY
tag :>: FL (PatchInfoAnd p) wY wB
rest
      | Just String
tagname <- PatchInfo -> Maybe String
piTag (PatchInfoAnd p wA wY -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info PatchInfoAnd p wA wY
tag) ->
        case PatchInfo -> PatchSet p Origin wT -> Maybe (PatchSet p Origin wT)
forall (p :: * -> * -> *) wStart wX.
Commute p =>
PatchInfo -> PatchSet p wStart wX -> Maybe (PatchSet p wStart wX)
splitOnTag (PatchInfoAnd p wA wY -> PatchInfo
forall (p :: * -> * -> *) wA wB. PatchInfoAndG p wA wB -> PatchInfo
info PatchInfoAnd p wA wY
tag) PatchSet p Origin wT
ref of
          Maybe (PatchSet p Origin wT)
Nothing ->
            String -> Either String (PatchSet p Origin wB)
forall a b. a -> Either a b
Left (String -> Either String (PatchSet p Origin wB))
-> String -> Either String (PatchSet p Origin wB)
forall a b. (a -> b) -> a -> b
$ String
"Cannot find tag " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tagname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from context in our repo"
          Just (PatchSet RL (Tagged p) Origin wX
ts RL (PatchInfoAnd p) wX wT
_) ->
            PatchSet p Origin wB -> Either String (PatchSet p Origin wB)
forall a b. b -> Either a b
Right (PatchSet p Origin wB -> Either String (PatchSet p Origin wB))
-> PatchSet p Origin wB -> Either String (PatchSet p Origin wB)
forall a b. (a -> b) -> a -> b
$ RL (Tagged p) Origin wX
-> RL (PatchInfoAnd p) wX wB -> PatchSet p Origin wB
forall (p :: * -> * -> *) wX wY.
RL (Tagged p) Origin wX
-> RL (PatchInfoAnd p) wX wY -> PatchSet p Origin wY
PatchSet RL (Tagged p) Origin wX
ts (RL (PatchInfoAnd p) wY wB -> RL (PatchInfoAnd p) wX wB
forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart (FL (PatchInfoAnd p) wY wB -> RL (PatchInfoAnd p) wY wB
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd p) wY wB
rest))
    FL (PatchInfoAnd p) wA wB
_ -> PatchSet p Origin wB -> Either String (PatchSet p Origin wB)
forall a b. b -> Either a b
Right (PatchSet p Origin wB -> Either String (PatchSet p Origin wB))
-> PatchSet p Origin wB -> Either String (PatchSet p Origin wB)
forall a b. (a -> b) -> a -> b
$ RL (Tagged p) Origin Origin
-> RL (PatchInfoAnd p) Origin wB -> PatchSet p Origin wB
forall (p :: * -> * -> *) wX wY.
RL (Tagged p) Origin wX
-> RL (PatchInfoAnd p) wX wY -> PatchSet p Origin wY
PatchSet RL (Tagged p) Origin Origin
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL (RL (PatchInfoAnd p) wA wB -> RL (PatchInfoAnd p) Origin wB
forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart (FL (PatchInfoAnd p) wA wB -> RL (PatchInfoAnd p) wA wB
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd p) wA wB
context))

parseContextFile :: B.ByteString
                 -> Either String (FL (PatchInfoAnd p) wX wY)
parseContextFile :: forall (p :: * -> * -> *) wX wY.
ByteString -> Either String (FL (PatchInfoAnd p) wX wY)
parseContextFile =
    ((FL (PatchInfoAnd p) wX wY, ByteString)
 -> FL (PatchInfoAnd p) wX wY)
-> Either String (FL (PatchInfoAnd p) wX wY, ByteString)
-> Either String (FL (PatchInfoAnd p) wX wY)
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FL (PatchInfoAnd p) wX wY, ByteString)
-> FL (PatchInfoAnd p) wX wY
forall a b. (a, b) -> a
fst (Either String (FL (PatchInfoAnd p) wX wY, ByteString)
 -> Either String (FL (PatchInfoAnd p) wX wY))
-> (ByteString
    -> Either String (FL (PatchInfoAnd p) wX wY, ByteString))
-> ByteString
-> Either String (FL (PatchInfoAnd p) wX wY)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (FL (PatchInfoAnd p) wX wY)
-> ByteString
-> Either String (FL (PatchInfoAnd p) wX wY, ByteString)
forall a. Parser a -> ByteString -> Either String (a, ByteString)
parse Parser (FL (PatchInfoAnd p) wX wY)
forall {p :: * -> * -> *} {wX} {wY}.
Parser ByteString (FL (PatchInfoAnd p) wX wY)
pUnsignedContext (ByteString
 -> Either String (FL (PatchInfoAnd p) wX wY, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> Either String (FL (PatchInfoAnd p) wX wY, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
decodeGpgClearsigned
  where
    pUnsignedContext :: Parser ByteString (FL (PatchInfoAnd p) wX wY)
pUnsignedContext = [PatchInfo] -> FL (PatchInfoAnd p) wX wY
forall (p :: * -> * -> *) wX wY.
[PatchInfo] -> FL (PatchInfoAnd p) wX wY
unavailablePatchesFL ([PatchInfo] -> FL (PatchInfoAnd p) wX wY)
-> ([PatchInfo] -> [PatchInfo])
-> [PatchInfo]
-> FL (PatchInfoAnd p) wX wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PatchInfo] -> [PatchInfo]
forall a. [a] -> [a]
reverse ([PatchInfo] -> FL (PatchInfoAnd p) wX wY)
-> Parser [PatchInfo]
-> Parser ByteString (FL (PatchInfoAnd p) wX wY)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser [PatchInfo]
pContext

-- | Minimize the context of an 'FL' of patches to be packed into a bundle.
minContext :: (RepoPatch p)
           => PatchSet p wStart wB -- context to be minimized
           -> FL (PatchInfoAnd p) wB wC
           -> Sealed ((PatchSet p :> FL (PatchInfoAnd p)) wStart)
minContext :: forall (p :: * -> * -> *) wStart wB wC.
RepoPatch p =>
PatchSet p wStart wB
-> FL (PatchInfoAnd p) wB wC
-> Sealed ((:>) (PatchSet p) (FL (PatchInfoAnd p)) wStart)
minContext (PatchSet RL (Tagged p) Origin wX
behindTag RL (PatchInfoAnd p) wX wB
topCommon) FL (PatchInfoAnd p) wB wC
to_be_sent =
  case CommuteFn (PatchInfoAnd p) (FL (PatchInfoAnd p))
-> (:>) (RL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wC
-> (:>)
     (RL (PatchInfoAnd p))
     (FL (PatchInfoAnd p) :> RL (PatchInfoAnd p))
     wX
     wC
forall (p :: * -> * -> *) (q :: * -> * -> *) wX wY.
Commute p =>
CommuteFn p q
-> (:>) (RL p) q wX wY -> (:>) (RL p) (q :> RL p) wX wY
genCommuteWhatWeCanRL (:>) (PatchInfoAnd p) (FL (PatchInfoAnd p)) wX wY
-> Maybe ((:>) (FL (PatchInfoAnd p)) (PatchInfoAnd p) wX wY)
CommuteFn (PatchInfoAnd p) (FL (PatchInfoAnd p))
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> Maybe ((:>) (FL p) p wX wY)
commuteFL (RL (PatchInfoAnd p) wX wB
topCommon RL (PatchInfoAnd p) wX wB
-> FL (PatchInfoAnd p) wB wC
-> (:>) (RL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) wX wC
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PatchInfoAnd p) wB wC
to_be_sent) of
    (RL (PatchInfoAnd p) wX wZ
c :> FL (PatchInfoAnd p) wZ wZ
to_be_sent' :> RL (PatchInfoAnd p) wZ wC
_) -> (:>) (PatchSet p) (FL (PatchInfoAnd p)) wStart wZ
-> Sealed ((:>) (PatchSet p) (FL (PatchInfoAnd p)) wStart)
forall (a :: * -> *) wX. a wX -> Sealed a
seal (RL (Tagged p) Origin wX
-> RL (PatchInfoAnd p) wX wZ -> PatchSet p Origin wZ
forall (p :: * -> * -> *) wX wY.
RL (Tagged p) Origin wX
-> RL (PatchInfoAnd p) wX wY -> PatchSet p Origin wY
PatchSet RL (Tagged p) Origin wX
behindTag RL (PatchInfoAnd p) wX wZ
c PatchSet p wStart wZ
-> FL (PatchInfoAnd p) wZ wZ
-> (:>) (PatchSet p) (FL (PatchInfoAnd p)) wStart wZ
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PatchInfoAnd p) wZ wZ
to_be_sent') 

-- TODO shouldn't we verify the signature? That is, pipe the input through
-- "gpg --verify -o-"? This would also let gpg handle their own mangling.

-- | Decode gpg clearsigned file content.
decodeGpgClearsigned :: B.ByteString -> B.ByteString
decodeGpgClearsigned :: ByteString -> ByteString
decodeGpgClearsigned ByteString
input =
  case ByteString -> ByteString -> ByteString -> Maybe ByteString
betweenLinesPS ByteString
startSignedName ByteString
endSignedName ByteString
input of
    Maybe ByteString
Nothing -> ByteString
input
    Just ByteString
signed -> ByteString -> ByteString
removeGpgDashes (ByteString -> ByteString
dropHashType ByteString
signed)
  where
    -- Note that B.concat is optimized to avoid unnecessary work, in particular
    -- concatenating slices that were originally adjacent involves no extra
    -- copying, and allocation of the result buffer is done only once.
    removeGpgDashes :: ByteString -> ByteString
removeGpgDashes = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
splitGpgDashes
    splitGpgDashes :: ByteString -> [ByteString]
splitGpgDashes ByteString
s =
      case ByteString -> ByteString -> (ByteString, ByteString)
B.breakSubstring ByteString
newline_dashes ByteString
s of
        (ByteString
before, ByteString
rest)
          | ByteString -> Bool
B.null ByteString
rest -> [ByteString
s]
          | (ByteString
keep, ByteString
after) <- Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
2 ByteString
rest ->
              ByteString
before ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString
keep ByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
: ByteString -> [ByteString]
splitGpgDashes (Int -> ByteString -> ByteString
B.drop Int
2 ByteString
after)
    newline_dashes :: ByteString
newline_dashes = String -> ByteString
BC.pack String
"\n- -"
    dropHashType :: ByteString -> ByteString
dropHashType ByteString
s =
      case ByteString -> ByteString -> (ByteString, ByteString)
B.breakSubstring ByteString
hashTypeName ByteString
s of
        (ByteString
_, ByteString
rest)
          | ByteString -> Bool
B.null ByteString
rest -> ByteString
s
          | Bool
otherwise -> ByteString -> ByteString
dropSpace (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ByteString -> ByteString
BC.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') ByteString
rest
    hashTypeName :: ByteString
hashTypeName = String -> ByteString
BC.pack String
"Hash:"
    startSignedName :: ByteString
startSignedName = String -> ByteString
BC.pack String
"-----BEGIN PGP SIGNED MESSAGE-----"
    endSignedName :: ByteString
endSignedName = String -> ByteString
BC.pack String
"-----BEGIN PGP SIGNATURE-----"