-- 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
    ( RepoPatch
    , ApplyState
    , showPatch
    , showContextPatch
    )
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.PatchInfoAnd
    ( PatchInfoAnd
    , info
    , n2pia
    , patchInfoAndPatch
    , unavailable
    )
import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL )
import Darcs.Patch.Read ( readPatch' )
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
    )
import Darcs.Util.Tree( Tree )
import Darcs.Util.Tree.Monad( virtualTreeIO )


-- | A 'Bundle' is a context together with some patches. The context
-- consists of unavailable patches.
data Bundle rt p wX wY where
  Bundle :: (FL (PatchInfoAnd rt p) :> FL (PatchInfoAnd rt p)) wX wY
         -> Bundle rt 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 rt p Origin wT
                -> Bundle rt p wA wB
                -> Either String (PatchSet rt p Origin wB)
interpretBundle :: PatchSet rt p Origin wT
-> Bundle rt p wA wB -> Either String (PatchSet rt p Origin wB)
interpretBundle PatchSet rt p Origin wT
ref (Bundle (FL (PatchInfoAnd rt p) wA wZ
context :> FL (PatchInfoAnd rt p) wZ wB
patches)) =
  (PatchSet rt p Origin wZ
 -> FL (PatchInfoAnd rt p) wZ wB -> PatchSet rt p Origin wB)
-> FL (PatchInfoAnd rt p) wZ wB
-> PatchSet rt p Origin wZ
-> PatchSet rt p Origin wB
forall a b c. (a -> b -> c) -> b -> a -> c
flip PatchSet rt p Origin wZ
-> FL (PatchInfoAnd rt p) wZ wB -> PatchSet rt p Origin wB
forall (rt :: RepoType) (p :: * -> * -> *) wStart wX wY.
PatchSet rt p wStart wX
-> FL (PatchInfoAnd rt p) wX wY -> PatchSet rt p wStart wY
appendPSFL FL (PatchInfoAnd rt p) wZ wB
patches (PatchSet rt p Origin wZ -> PatchSet rt p Origin wB)
-> Either String (PatchSet rt p Origin wZ)
-> Either String (PatchSet rt p Origin wB)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PatchSet rt p Origin wT
-> FL (PatchInfoAnd rt p) wA wZ
-> Either String (PatchSet rt p Origin wZ)
forall (p :: * -> * -> *) (rt :: RepoType) wT wA wB.
Commute p =>
PatchSet rt p Origin wT
-> FL (PatchInfoAnd rt p) wA wB
-> Either String (PatchSet rt p Origin wB)
interpretContext PatchSet rt p Origin wT
ref FL (PatchInfoAnd rt 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 :: 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 (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 :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO)
           -> PatchSet rt p wStart wX -> FL (Named p) wX wY -> IO Doc
makeBundle :: Maybe (Tree IO)
-> PatchSet rt p wStart wX -> FL (Named p) wX wY -> IO Doc
makeBundle Maybe (Tree IO)
state PatchSet rt p wStart wX
repo FL (Named p) wX wY
to_be_sent
  | PatchSet rt p wStart wZ
_ :> RL (PatchInfoAnd rt p) wZ wX
context <- PatchSet rt p wStart wX
-> (:>) (PatchSet rt p) (RL (PatchInfoAnd rt p)) wStart wX
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
PatchSet rt p wX wY
-> (:>) (PatchSet rt p) (RL (PatchInfoAnd rt p)) wX wY
contextPatches PatchSet rt p wStart wX
repo =
    RL (PatchInfoAnd rt p) wZ wX -> Doc -> Doc
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
RL (PatchInfoAndG rt p) wX wY -> Doc -> Doc
format RL (PatchInfoAnd rt p) wZ wX
context (Doc -> Doc) -> IO Doc -> IO Doc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
      case Maybe (Tree IO)
state of
        Just 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
<$> TreeIO Doc -> Tree IO -> IO (Doc, Tree IO)
forall a. TreeIO a -> Tree IO -> IO (a, Tree IO)
virtualTreeIO (ShowPatchFor -> FL (Named 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 (Named p) wX wY
to_be_sent) Tree IO
tree
        Maybe (Tree IO)
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. 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 (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 rt p) wX wY -> Doc -> Doc
format RL (PatchInfoAndG rt 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 rt p wW wZ -> Doc)
-> RL (PatchInfoAndG rt 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 rt p wW wZ -> PatchInfo)
-> PatchInfoAndG rt p wW wZ
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfoAndG rt p wW wZ -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info) RL (PatchInfoAndG rt 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 rt p wX))
parseBundle :: ByteString -> Either String (Sealed (Bundle rt p wX))
parseBundle =
    ((Sealed (Bundle rt p wX), ByteString) -> Sealed (Bundle rt p wX))
-> Either String (Sealed (Bundle rt p wX), ByteString)
-> Either String (Sealed (Bundle rt p wX))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Sealed (Bundle rt p wX), ByteString) -> Sealed (Bundle rt p wX)
forall a b. (a, b) -> a
fst (Either String (Sealed (Bundle rt p wX), ByteString)
 -> Either String (Sealed (Bundle rt p wX)))
-> (ByteString
    -> Either String (Sealed (Bundle rt p wX), ByteString))
-> ByteString
-> Either String (Sealed (Bundle rt p wX))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (Sealed (Bundle rt p wX))
-> ByteString
-> Either String (Sealed (Bundle rt p wX), ByteString)
forall a. Parser a -> ByteString -> Either String (a, ByteString)
parse Parser (Sealed (Bundle rt p wX))
forall (rt :: RepoType) (p :: * -> * -> *) wX.
RepoPatch p =>
Parser (Sealed (Bundle rt p wX))
pUnsignedBundle (ByteString -> Either String (Sealed (Bundle rt p wX), ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> Either String (Sealed (Bundle rt 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 rt p wX. RepoPatch p => Parser (Sealed (Bundle rt p wX))
pUnsignedBundle :: Parser (Sealed (Bundle rt p wX))
pUnsignedBundle = Parser (Sealed (Bundle rt p wX))
forall (rt :: RepoType) wX.
Parser ByteString (Sealed (Bundle rt p wX))
pContextThenPatches Parser (Sealed (Bundle rt p wX))
-> Parser (Sealed (Bundle rt p wX))
-> Parser (Sealed (Bundle rt p wX))
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser (Sealed (Bundle rt p wX))
forall (rt :: RepoType) wX.
Parser ByteString (Sealed (Bundle rt p wX))
pPatchesThenContext
  where
    packBundle :: [PatchInfo]
-> FL (Named (Bracketed p)) wZ wX -> Sealed (Bundle rt p wX)
packBundle [PatchInfo]
context FL (Named (Bracketed p)) wZ wX
patches =
      Bundle rt p wX wX -> Sealed (Bundle rt p wX)
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (Bundle rt p wX wX -> Sealed (Bundle rt p wX))
-> Bundle rt p wX wX -> Sealed (Bundle rt p wX)
forall a b. (a -> b) -> a -> b
$ (:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wX
-> Bundle rt p wX wX
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
(:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wY
-> Bundle rt p wX wY
Bundle ((:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wX
 -> Bundle rt p wX wX)
-> (:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wX
-> Bundle rt p wX wX
forall a b. (a -> b) -> a -> b
$ ([PatchInfo] -> FL (PatchInfoAnd rt p) wX wZ
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
[PatchInfo] -> FL (PatchInfoAnd rt p) wX wY
unavailablePatchesFL ([PatchInfo] -> [PatchInfo]
forall a. [a] -> [a]
reverse [PatchInfo]
context)) FL (PatchInfoAnd rt p) wX wZ
-> FL (PatchInfoAnd rt p) wZ wX
-> (:>) (FL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt 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 rt p wW wY)
-> FL (Named (Bracketed p)) wZ wX -> FL (PatchInfoAnd rt 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 rt (Named p) wW wY
forall (p :: * -> * -> *) wX wY (rt :: RepoType).
(Ident p, PatchId p ~ PatchInfo) =>
p wX wY -> PatchInfoAndG rt p wX wY
n2pia (Named p wW wY -> PatchInfoAndG rt (Named p) wW wY)
-> (Named (Bracketed p) wW wY -> Named p wW wY)
-> Named (Bracketed p) wW wY
-> PatchInfoAndG rt (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 rt 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 rt p wX)
-> Parser ByteString (Sealed (Bundle rt p wX))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (Bundle rt p wX)
 -> Parser ByteString (Sealed (Bundle rt p wX)))
-> Sealed (Bundle rt p wX)
-> Parser ByteString (Sealed (Bundle rt p wX))
forall a b. (a -> b) -> a -> b
$ [PatchInfo]
-> FL (Named (Bracketed p)) Any wX -> Sealed (Bundle rt p wX)
forall (p :: * -> * -> *) wZ wX (rt :: RepoType) wX.
[PatchInfo]
-> FL (Named (Bracketed p)) wZ wX -> Sealed (Bundle rt p wX)
packBundle [PatchInfo]
context FL (Named (Bracketed p)) Any wX
patches
    pPatchesThenContext :: Parser ByteString (Sealed (Bundle rt 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 rt p wX)
-> Parser ByteString (Sealed (Bundle rt p wX))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (Bundle rt p wX)
 -> Parser ByteString (Sealed (Bundle rt p wX)))
-> Sealed (Bundle rt p wX)
-> Parser ByteString (Sealed (Bundle rt p wX))
forall a b. (a -> b) -> a -> b
$ [PatchInfo]
-> FL (Named (Bracketed p)) Any wX -> Sealed (Bundle rt p wX)
forall (p :: * -> * -> *) wZ wX (rt :: RepoType) wX.
[PatchInfo]
-> FL (Named (Bracketed p)) wZ wX -> Sealed (Bundle rt p wX)
packBundle [PatchInfo]
context FL (Named (Bracketed p)) Any wX
patches
            else String -> Parser ByteString (Sealed (Bundle rt p wX))
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
hashFailureMessage
        Maybe ByteString
Nothing -> Sealed (Bundle rt p wX)
-> Parser ByteString (Sealed (Bundle rt p wX))
forall (m :: * -> *) a. Monad m => a -> m a
return (Sealed (Bundle rt p wX)
 -> Parser ByteString (Sealed (Bundle rt p wX)))
-> Sealed (Bundle rt p wX)
-> Parser ByteString (Sealed (Bundle rt p wX))
forall a b. (a -> b) -> a -> b
$ [PatchInfo]
-> FL (Named (Bracketed p)) Any wX -> Sealed (Bundle rt p wX)
forall (p :: * -> * -> *) wZ wX (rt :: RepoType) wX.
[PatchInfo]
-> FL (Named (Bracketed p)) wZ wX -> Sealed (Bundle rt 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 (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 rt p) wX wY
unavailablePatchesFL :: [PatchInfo] -> FL (PatchInfoAnd rt p) wX wY
unavailablePatchesFL = (PatchInfo
 -> FL (PatchInfoAnd rt p) wX wY -> FL (PatchInfoAnd rt p) wX wY)
-> FL (PatchInfoAnd rt p) wX wY
-> [PatchInfo]
-> FL (PatchInfoAnd rt p) wX wY
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (PatchInfoAndG rt (Named p) wX wX
-> FL (PatchInfoAnd rt p) wX wY -> FL (PatchInfoAnd rt p) wX wY
forall (a :: * -> * -> *) wX wY wZ.
a wX wY -> FL a wY wZ -> FL a wX wZ
(:>:) (PatchInfoAndG rt (Named p) wX wX
 -> FL (PatchInfoAnd rt p) wX wY -> FL (PatchInfoAnd rt p) wX wY)
-> (PatchInfo -> PatchInfoAndG rt (Named p) wX wX)
-> PatchInfo
-> FL (PatchInfoAnd rt p) wX wY
-> FL (PatchInfoAnd rt p) wX wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatchInfo -> PatchInfoAndG rt (Named p) wX wX
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfo -> PatchInfoAndG rt p wA wB
piUnavailable) (FL (PatchInfoAnd rt p) wX wX -> FL (PatchInfoAnd rt p) wX wY
forall (a :: * -> * -> *) wX wY1 wY2. a wX wY1 -> a wX wY2
unsafeCoercePEnd FL (PatchInfoAnd rt p) wX wX
forall (a :: * -> * -> *) wX. FL a wX wX
NilFL)
  where
    piUnavailable :: PatchInfo -> PatchInfoAndG rt p wA wB
piUnavailable PatchInfo
i = PatchInfo -> Hopefully p wA wB -> PatchInfoAndG rt p wA wB
forall (p :: * -> * -> *) wA wB (rt :: RepoType).
PatchInfo -> Hopefully p wA wB -> PatchInfoAndG rt p wA wB
patchInfoAndPatch PatchInfo
i (Hopefully p wA wB -> PatchInfoAndG rt p wA wB)
-> (String -> Hopefully p wA wB)
-> String
-> PatchInfoAndG rt 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 rt p wA wB)
-> String -> PatchInfoAndG rt 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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString PatchInfo -> Parser [PatchInfo]
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 :: Parser (Sealed (FL (Named (Bracketed p)) wX))
pPatches = ByteString -> Parser ()
lexString ByteString
patchesName Parser ()
-> Parser (Sealed (FL (Named (Bracketed p)) wX))
-> Parser (Sealed (FL (Named (Bracketed p)) wX))
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> 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 rt p Origin wX
                -> FilePath
                -> IO (SealedPatchSet rt p Origin)
readContextFile :: PatchSet rt p Origin wX
-> String -> IO (SealedPatchSet rt p Origin)
readContextFile PatchSet rt p Origin wX
ref = (PatchSet rt p Origin Any -> SealedPatchSet rt p Origin)
-> IO (PatchSet rt p Origin Any) -> IO (SealedPatchSet rt p Origin)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PatchSet rt p Origin Any -> SealedPatchSet rt p Origin
forall (a :: * -> *) wX. a wX -> Sealed a
Sealed (IO (PatchSet rt p Origin Any) -> IO (SealedPatchSet rt p Origin))
-> (String -> IO (PatchSet rt p Origin Any))
-> String
-> IO (SealedPatchSet rt p Origin)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> IO (PatchSet rt p Origin Any)
forall wB. ByteString -> IO (PatchSet rt p Origin wB)
parseAndInterpret (ByteString -> IO (PatchSet rt p Origin Any))
-> (String -> IO ByteString)
-> String
-> IO (PatchSet rt 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 rt p Origin wB)
parseAndInterpret =
      (String -> IO (PatchSet rt p Origin wB))
-> (PatchSet rt p Origin wB -> IO (PatchSet rt p Origin wB))
-> Either String (PatchSet rt p Origin wB)
-> IO (PatchSet rt p Origin wB)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> IO (PatchSet rt p Origin wB)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail PatchSet rt p Origin wB -> IO (PatchSet rt p Origin wB)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (PatchSet rt p Origin wB)
 -> IO (PatchSet rt p Origin wB))
-> (ByteString -> Either String (PatchSet rt p Origin wB))
-> ByteString
-> IO (PatchSet rt p Origin wB)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PatchSet rt p Origin wX
-> FL (PatchInfoAnd rt p) Any wB
-> Either String (PatchSet rt p Origin wB)
forall (p :: * -> * -> *) (rt :: RepoType) wT wA wB.
Commute p =>
PatchSet rt p Origin wT
-> FL (PatchInfoAnd rt p) wA wB
-> Either String (PatchSet rt p Origin wB)
interpretContext PatchSet rt p Origin wX
ref (FL (PatchInfoAnd rt p) Any wB
 -> Either String (PatchSet rt p Origin wB))
-> (ByteString -> Either String (FL (PatchInfoAnd rt p) Any wB))
-> ByteString
-> Either String (PatchSet rt p Origin wB)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ByteString -> Either String (FL (PatchInfoAnd rt p) Any wB)
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
ByteString -> Either String (FL (PatchInfoAnd rt 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 rt p Origin wT
                 -> FL (PatchInfoAnd rt p) wA wB
                 -> Either String (PatchSet rt p Origin wB)
interpretContext :: PatchSet rt p Origin wT
-> FL (PatchInfoAnd rt p) wA wB
-> Either String (PatchSet rt p Origin wB)
interpretContext PatchSet rt p Origin wT
ref FL (PatchInfoAnd rt p) wA wB
context =
  case FL (PatchInfoAnd rt p) wA wB
context of
    PatchInfoAnd rt p wA wY
tag :>: FL (PatchInfoAnd rt p) wY wB
rest
      | Just String
tagname <- PatchInfo -> Maybe String
piTag (PatchInfoAnd rt p wA wY -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wA wY
tag) ->
        case PatchInfo
-> PatchSet rt p Origin wT -> Maybe (PatchSet rt p Origin wT)
forall (p :: * -> * -> *) (rt :: RepoType) wStart wX.
Commute p =>
PatchInfo
-> PatchSet rt p wStart wX -> Maybe (PatchSet rt p wStart wX)
splitOnTag (PatchInfoAnd rt p wA wY -> PatchInfo
forall (rt :: RepoType) (p :: * -> * -> *) wA wB.
PatchInfoAndG rt p wA wB -> PatchInfo
info PatchInfoAnd rt p wA wY
tag) PatchSet rt p Origin wT
ref of
          Maybe (PatchSet rt p Origin wT)
Nothing ->
            String -> Either String (PatchSet rt p Origin wB)
forall a b. a -> Either a b
Left (String -> Either String (PatchSet rt p Origin wB))
-> String -> Either String (PatchSet rt 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 rt p) Origin wX
ts RL (PatchInfoAnd rt p) wX wT
_) ->
            PatchSet rt p Origin wB -> Either String (PatchSet rt p Origin wB)
forall a b. b -> Either a b
Right (PatchSet rt p Origin wB
 -> Either String (PatchSet rt p Origin wB))
-> PatchSet rt p Origin wB
-> Either String (PatchSet rt p Origin wB)
forall a b. (a -> b) -> a -> b
$ RL (Tagged rt p) Origin wX
-> RL (PatchInfoAnd rt p) wX wB -> PatchSet rt p Origin wB
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
RL (Tagged rt p) Origin wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p Origin wY
PatchSet RL (Tagged rt p) Origin wX
ts (RL (PatchInfoAnd rt p) wY wB -> RL (PatchInfoAnd rt p) wX wB
forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart (FL (PatchInfoAnd rt p) wY wB -> RL (PatchInfoAnd rt p) wY wB
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd rt p) wY wB
rest))
    FL (PatchInfoAnd rt p) wA wB
_ -> PatchSet rt p Origin wB -> Either String (PatchSet rt p Origin wB)
forall a b. b -> Either a b
Right (PatchSet rt p Origin wB
 -> Either String (PatchSet rt p Origin wB))
-> PatchSet rt p Origin wB
-> Either String (PatchSet rt p Origin wB)
forall a b. (a -> b) -> a -> b
$ RL (Tagged rt p) Origin Origin
-> RL (PatchInfoAnd rt p) Origin wB -> PatchSet rt p Origin wB
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
RL (Tagged rt p) Origin wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p Origin wY
PatchSet RL (Tagged rt p) Origin Origin
forall (a :: * -> * -> *) wX. RL a wX wX
NilRL (RL (PatchInfoAnd rt p) wA wB -> RL (PatchInfoAnd rt p) Origin wB
forall (a :: * -> * -> *) wX1 wY wX2. a wX1 wY -> a wX2 wY
unsafeCoercePStart (FL (PatchInfoAnd rt p) wA wB -> RL (PatchInfoAnd rt p) wA wB
forall (a :: * -> * -> *) wX wZ. FL a wX wZ -> RL a wX wZ
reverseFL FL (PatchInfoAnd rt p) wA wB
context))

parseContextFile :: B.ByteString
                 -> Either String (FL (PatchInfoAnd rt p) wX wY)
parseContextFile :: ByteString -> Either String (FL (PatchInfoAnd rt p) wX wY)
parseContextFile =
    ((FL (PatchInfoAnd rt p) wX wY, ByteString)
 -> FL (PatchInfoAnd rt p) wX wY)
-> Either String (FL (PatchInfoAnd rt p) wX wY, ByteString)
-> Either String (FL (PatchInfoAnd rt p) wX wY)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FL (PatchInfoAnd rt p) wX wY, ByteString)
-> FL (PatchInfoAnd rt p) wX wY
forall a b. (a, b) -> a
fst (Either String (FL (PatchInfoAnd rt p) wX wY, ByteString)
 -> Either String (FL (PatchInfoAnd rt p) wX wY))
-> (ByteString
    -> Either String (FL (PatchInfoAnd rt p) wX wY, ByteString))
-> ByteString
-> Either String (FL (PatchInfoAnd rt p) wX wY)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser (FL (PatchInfoAnd rt p) wX wY)
-> ByteString
-> Either String (FL (PatchInfoAnd rt p) wX wY, ByteString)
forall a. Parser a -> ByteString -> Either String (a, ByteString)
parse Parser (FL (PatchInfoAnd rt p) wX wY)
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
Parser ByteString (FL (PatchInfoAnd rt p) wX wY)
pUnsignedContext (ByteString
 -> Either String (FL (PatchInfoAnd rt p) wX wY, ByteString))
-> (ByteString -> ByteString)
-> ByteString
-> Either String (FL (PatchInfoAnd rt p) wX wY, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
decodeGpgClearsigned
  where
    pUnsignedContext :: Parser ByteString (FL (PatchInfoAnd rt p) wX wY)
pUnsignedContext = [PatchInfo] -> FL (PatchInfoAnd rt p) wX wY
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
[PatchInfo] -> FL (PatchInfoAnd rt p) wX wY
unavailablePatchesFL ([PatchInfo] -> FL (PatchInfoAnd rt p) wX wY)
-> ([PatchInfo] -> [PatchInfo])
-> [PatchInfo]
-> FL (PatchInfoAnd rt p) wX wY
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PatchInfo] -> [PatchInfo]
forall a. [a] -> [a]
reverse ([PatchInfo] -> FL (PatchInfoAnd rt p) wX wY)
-> Parser [PatchInfo]
-> Parser ByteString (FL (PatchInfoAnd rt 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 rt p wStart wB -- context to be minimized
           -> 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 RL (Tagged rt p) Origin wX
behindTag RL (PatchInfoAnd rt p) wX wB
topCommon) FL (PatchInfoAnd rt p) wB wC
to_be_sent =
  case (forall wA wB.
 (:>) (PatchInfoAnd rt p) (FL (PatchInfoAnd rt p)) wA wB
 -> Maybe ((:>) (FL (PatchInfoAnd rt p)) (PatchInfoAnd rt p) wA wB))
-> (:>) (RL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wC
-> (:>)
     (RL (PatchInfoAnd rt p))
     (FL (PatchInfoAnd rt p) :> RL (PatchInfoAnd rt p))
     wX
     wC
forall (p :: * -> * -> *) (q :: * -> * -> *) wX wY.
Commute p =>
(forall wA wB. (:>) p q wA wB -> Maybe ((:>) q p wA wB))
-> (:>) (RL p) q wX wY -> (:>) (RL p) (q :> RL p) wX wY
genCommuteWhatWeCanRL forall wA wB.
(:>) (PatchInfoAnd rt p) (FL (PatchInfoAnd rt p)) wA wB
-> Maybe ((:>) (FL (PatchInfoAnd rt p)) (PatchInfoAnd rt p) wA wB)
forall (p :: * -> * -> *) wX wY.
Commute p =>
(:>) p (FL p) wX wY -> Maybe ((:>) (FL p) p wX wY)
commuteFL (RL (PatchInfoAnd rt p) wX wB
topCommon RL (PatchInfoAnd rt p) wX wB
-> FL (PatchInfoAnd rt p) wB wC
-> (:>) (RL (PatchInfoAnd rt p)) (FL (PatchInfoAnd rt p)) wX wC
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PatchInfoAnd rt p) wB wC
to_be_sent) of
    (RL (PatchInfoAnd rt p) wX wZ
c :> FL (PatchInfoAnd rt p) wZ wZ
to_be_sent' :> RL (PatchInfoAnd rt p) wZ wC
_) -> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wZ
-> Sealed ((:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin)
forall (a :: * -> *) wX. a wX -> Sealed a
seal (RL (Tagged rt p) Origin wX
-> RL (PatchInfoAnd rt p) wX wZ -> PatchSet rt p Origin wZ
forall (rt :: RepoType) (p :: * -> * -> *) wX wY.
RL (Tagged rt p) Origin wX
-> RL (PatchInfoAnd rt p) wX wY -> PatchSet rt p Origin wY
PatchSet RL (Tagged rt p) Origin wX
behindTag RL (PatchInfoAnd rt p) wX wZ
c PatchSet rt p Origin wZ
-> FL (PatchInfoAnd rt p) wZ wZ
-> (:>) (PatchSet rt p) (FL (PatchInfoAnd rt p)) Origin wZ
forall (a1 :: * -> * -> *) (a2 :: * -> * -> *) wX wY wZ.
a1 wX wZ -> a2 wZ wY -> (:>) a1 a2 wX wY
:> FL (PatchInfoAnd rt 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-----"