bytepatch 0.2.1 → 0.3.0

raw patch · 31 files changed

+1274/−778 lines, 31 filesdep +QuickCheckdep +eitherdep +vinyldep ~mtldep ~textPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, either, vinyl

Dependency ranges changed: mtl, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• README.md +23/−20
• app/CLI.hs +66/−0
• app/Config.hs +29/−7
• app/Main.hs +169/−58
• app/Options.hs +0/−39
• bytepatch.cabal +49/−19
• src/BytePatch.hs +133/−0
• src/BytePatch/Core.hs +0/−38
• src/BytePatch/HexByteString.hs +70/−0
• src/BytePatch/JSON.hs +0/−55
• src/BytePatch/Linear/Gen.hs +0/−59
• src/BytePatch/Linear/Patch.hs +0/−146
• src/BytePatch/Pretty.hs +0/−166
• src/BytePatch/Pretty/HexByteString.hs +0/−62
• src/BytePatch/Pretty/PascalText.hs +0/−56
• src/BytePatch/Pretty/PatchRep.hs +0/−29
• src/StreamPatch/Apply.hs +60/−0
• src/StreamPatch/Patch.hs +79/−0
• src/StreamPatch/Patch/Align.hs +59/−0
• src/StreamPatch/Patch/Binary.hs +181/−0
• src/StreamPatch/Patch/Binary/PascalText.hs +48/−0
• src/StreamPatch/Patch/Linearize.hs +58/−0
• src/StreamPatch/Stream.hs +81/−0
• src/Util.hs +19/−0
• test/BytePatch/HexByteStringSpec.hs +23/−0
• test/BytePatch/Pretty/HexByteStringSpec.hs +0/−23
• test/StreamPatch/ApplySpec.hs +48/−0
• test/StreamPatch/Patch/AlignSpec.hs +28/−0
• test/StreamPatch/Patch/LinearizeSpec.hs +19/−0
• test/Util.hs +20/−1

@@ -1,3 +1,15 @@+## 0.3.0 (Unreleased)+Large internal refactoring.++  * Various concepts surrounding stream patching have been decoupled and+    parameterized. Pre-apply patch transformations are modelled as "metadata+    layers" which can be stripped off, and patch application functions require+    that no irrelevant metadata is present.+  * A new CLI inspired by the original tool exposes the useful bits.+  * Internally, the package is split into streampatch and bytepatch. If I could+    be bothered, they would be different packages, streampatch not requiring+    things like Aeson and Megaparsec.+ ## 0.2.1 (2021-12-03)   * large internal refactoring (still more to come!)   * schema refactoring (patch -> edit, offsets -> at)

@@ -1,12 +1,15 @@ # bytepatch-A Haskell library and CLI tool for patching byte-representable data in a-bytestream. Write **patchscripts** (in-place edits to a file) using a convenient-YAML format, and apply them with a safe patching algorithm. You choose how-explicit to be: edits may be written as a simple `(offset, content)` tuple, or-you can provide metadata regarding expected original data, so you know you're-patching the right file.+A Haskell library and CLI tool for patching data in a stream, primarily aimed at+handling byte-representable data. Write **patchscripts** (in-place edits to a+file) using a convenient YAML format, and apply them with a safe patching+algorithm. On the library side, define explicit patches over any type, apply+them to pure/impure streams, and write further patch types and streams to extend+as you desire. -Intended as a general tool for making simple binary editing more manageable.+The executable is intended as a general tool for making simple binary editing+more manageable. The codebase is really a fun investigation into some type-level+Haskell features. Regardless of which you're interested in, I hope you might+find some use from this project!  ## What? If you're modifying binaries, you often end up needing to make edits in a hex@@ -14,13 +17,13 @@ mess up. bytepatch provides a simple, human read-writeable format for defining such edits, and can apply them for you. -bytepatch is intended as a developer tool for writing a *patchscript*. It's not-a binary patch tool like IPS, BPS: these take an input and a result file, and-generate a patch file that can be applied to the input in order to recreate the-result. By itself, the patch file isn't useful, being instructions to the tool-telling how to edit the input file. bytepatch uses a human-readable patch file-format that describes in plain terms the edits to make, so developers can read-and write patches in a structured, useable format.+bytepatch is intended as a developer tool for writing a *static patchscript*.+It's not a binary patch tool like IPS, BPS: these take an input and a result+file, and generate a patch file that can be applied to the input in order to+recreate the result. By itself, the patch file isn't useful, being instructions+to the tool telling how to edit the input file. bytepatch uses a human-readable+patch file format that describes in plain terms the edits to make, so developers+can read and write patches in a structured, useable format.  ## When might I want to use this? You might find bytepatch useful if you want to define edits to be made on binary@@ -34,11 +37,11 @@ gaining much.)*  You can't use bytepatch to make edits that aren't in-place. Edits are located-using a byte offset. Allowing edits to change the length of the segment they+using stream offsets. Allowing edits to change the length of the segment they replace would introduce issues for following edits: do we use the original offset, or do we implicitly shift them so they still write to the "same place"?-It may be possible to design a convenient format with useful behaviour. I'd like-to look into it at some point.+There *is* some support in the library for such edits, however, and it would be+interesting to explore.  ### Original rationale I'm working on some binary files, and need to patch strings, machine code and@@ -48,9 +51,9 @@ others. But if I want to test more stuff, I may have to make those changes again. I'm gonna make a mistake eventually. -Instead, I described my patches in YAML, and wrote a tool to apply them. Now my-changes and my notes are the same file, which can be checked for correctness and-applied automatically.+Instead, I described my patches in YAML and wrote a tool to apply them. Now my+changes and my notes (thanks YAML comments!) are the same file, which can be+checked for correctness and applied automatically.  ## License Provided under the MIT license. Please see `LICENSE` for the full license text.

@@ -0,0 +1,66 @@+module CLI ( parse ) where++import           Config+import           Options.Applicative+import           Control.Monad.IO.Class+import qualified StreamPatch.Patch.Binary as Bin++parse :: MonadIO m => m Config+parse = execParserWithDefaults desc pConfig+  where desc = "Patch bytestrings (TODO)."++pConfig :: Parser Config+pConfig = Config+    <$> strArgument (metavar "PATCHSCRIPT" <> help "Path to patchscript")+    <*> pCStreamPair+    <*> pCPatchFormat+    <*> pPrintBinary++pCStreamPair :: Parser CStreamPair+pCStreamPair = CStreamPair <$> pCSIn <*> pCSOut+  where+    pCSIn    = pFileArg <|> pStdin+    pCSOut   = pFileOpt <|> pure CStreamStd+    pFileArg = CStreamFile <$> strArgument (metavar "FILE" <> help "Input file")+    pFileOpt = CStreamFile <$> strOption (metavar "FILE" <> long "out-file" <> short 'o' <> help "Output file")+    pStdin   = flag' CStreamStd (long "stdin"  <> help "Use stdin")++pCPatchFormat :: Parser CPatchFormat+pCPatchFormat = CPatchFormat <$> pCPatchDataType <*> pCPatchAlign <*> pBinCfg++pCPatchDataType :: Parser CPatchDataType+pCPatchDataType = option (maybeReader mapper) $+       long "type"+    <> short 't'+    <> help "How to interpret & use patch data (binary/text/text-only)"+    <> metavar "PATCH_TYPE"+  where mapper = \case "text-only" -> Just CTextPatch+                       "bin"       -> Just CBinPatch+                       "binary"    -> Just CBinPatch+                       "text"      -> Just CTextBinPatch+                       _           -> Nothing++pCPatchAlign :: Parser CPatchAlign+pCPatchAlign = flag CNoAlignPatch CAlignPatch $+       long "aligned"+    <> help "Parse alignment data"++pBinCfg :: Parser Bin.Cfg+pBinCfg = Bin.Cfg <$> pExactMatch+  where+    pExactMatch = flag True False $+           long "match-exact"+        <> help "Expected binary data must match exactly (rather than be a prefix)"++pPrintBinary :: Parser Bool+pPrintBinary = switch $+       long "print-binary"+    <> help "Force print binary to stdout"++--------------------------------------------------------------------------------++-- | Execute a 'Parser' with decent defaults.+execParserWithDefaults :: MonadIO m => String -> Parser a -> m a+execParserWithDefaults desc p = liftIO $ customExecParser+    (prefs $ showHelpOnError)+    (info (helper <*> p) (progDesc desc))

@@ -1,17 +1,39 @@ module Config where -import qualified BytePatch.Linear.Patch+import           GHC.Generics ( Generic )+import qualified StreamPatch.Patch.Binary as Bin  data Config = Config-  { cfgPatchCfg    :: BytePatch.Linear.Patch.Cfg-  , cfgPatchscript :: FilePath-  , cfgStreamInOut :: CStreamInOut-  } deriving (Eq, Show)+  { cfgPatchscript :: FilePath+  , cfgStreamPair  :: CStreamPair+  , cfgPatchFormat :: CPatchFormat+  , cfgPrintBinary :: Bool+  } deriving (Eq, Show, Generic) +data CStreamPair = CStreamPair+  { cStreamPairIn  :: CStream+  , cStreamPairOut :: CStream+  } deriving (Eq, Show, Generic)+ -- | "Single file" stream. data CStream   = CStreamFile FilePath   | CStreamStd-    deriving (Eq, Show)+    deriving (Eq, Show, Generic) -newtype CStreamInOut = CStreamInOut { unCStreamInOut :: (CStream, CStream) } deriving (Eq, Show)+data CPatchFormat = CPatchFormat+  { cpfDataType :: CPatchDataType+  , cpfAlign    :: CPatchAlign+  , cpfBinCfg   :: Bin.Cfg+  } deriving (Eq, Show, Generic)++data CPatchAlign+  = CAlignPatch     -- ^ Patch has alignment data.+  | CNoAlignPatch   -- ^ Patch does not have alignment data.+    deriving (Eq, Show, Generic)++data CPatchDataType+  = CTextPatch      -- ^ Patch 'Text' over a 'Text' stream.+  | CBinPatch       -- ^ Patch bytestrings over a bytestream.+  | CTextBinPatch   -- ^ Patch 'Text' over a bytestream.+    deriving (Eq, Show, Generic)

@@ -1,79 +1,190 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE AllowAmbiguousTypes #-}  module Main ( main ) where  import           Config-import qualified Options+import qualified CLI -import           BytePatch.Pretty-import           BytePatch.Pretty.PatchRep-import           BytePatch.JSON()-import qualified BytePatch.Linear.Patch     as Linear-import qualified BytePatch.Linear.Gen       as Linear+import           StreamPatch.Patch+import qualified StreamPatch.Patch.Align  as Align+import qualified StreamPatch.Patch.Linearize as Linear+import qualified StreamPatch.Patch.Binary as Bin+import           StreamPatch.Patch.Binary ( BinRep )+import qualified StreamPatch.Apply as Apply+import           BytePatch as BP+import qualified BytePatch.HexByteString as HexBS+import           BytePatch.HexByteString ( HexByteString ) +import qualified System.Exit as System+import           Numeric.Natural+import           Data.Vinyl+import           Data.Vinyl.TypeLevel+import           Data.Functor.Const+import           Data.Either.Combinators ( mapLeft ) import           Control.Monad.IO.Class-import qualified Data.ByteString            as BS-import qualified Data.ByteString.Lazy       as BL-import qualified Data.Yaml                  as Yaml-import           Data.Aeson                 ( FromJSON )+import           Control.Monad.Reader+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Yaml as Yaml+import           Data.Yaml ( FromJSON )+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import           Data.Text ( Text )+import           Optics+import           Data.Generics.Product.Any -import           Data.Text                  ( Text )-import           BytePatch.Pretty.HexByteString+type Bytes = BS.ByteString +data Error+  = ErrorYaml     Yaml.ParseException+  | ErrorAlign    String+  | ErrorBin      String+  | ErrorLinear   String+  | ErrorBinPatch String+  | Error         String+    deriving (Show)+ main :: IO ()-main = Options.parse >>= run+main = CLI.parse >>= runReaderT run -run :: MonadIO m => Config -> m ()-run cfg = do-    return ()-    tryReadPatchscript @HexByteString (cfgPatchscript cfg) >>= \case-      Nothing -> quit "couldn't parse patchscript"-      Just ps ->-        case normalizeSimple ps of-          Nothing -> quit "failed while normalizing patchscript"-          Just p  ->-            case Linear.gen p of-              (_, genErrs@(_:_)) -> quit' "patchscript generation failed" genErrs-              (ps', []) -> do-                bs <- readStream' io-                case Linear.patchPure (cfgPatchCfg cfg) ps' bs of-                  Left patchErr -> quit' "patching failed" patchErr-                  Right bs' -> writeStream' io (BL.toStrict bs')+run :: forall m. (MonadIO m, MonadReader Config m) => m ()+run = readPatchscript >>= processPatchScript >>= writePatched   where-    io = cfgStreamInOut cfg+    readPatchscript = asks cfgPatchscript >>= readStream . CStreamFile -readStream :: MonadIO m => CStream -> m BS.ByteString-readStream stream = liftIO $-    case stream of+    processPatchScript psBs = do+        cpf <- asks cfgPatchFormat+        case cpfDataType cpf of+          CTextPatch    -> processText psBs+          CBinPatch     -> processBin' @HexByteString psBs+          CTextBinPatch -> processBin' @Text          psBs++    processText :: Bytes -> m Bytes+    processText psBs = do+        cpf <- asks cfgPatchFormat+        case processAny @Text psBs (cpfAlign cpf) of+          Left err -> quit err+          Right ps -> patchTextAwkward ps++    processBin' :: forall a. (BinRep a, FromJSON a, Show a) => Bytes -> m Bytes+    processBin' psBs = do+        cpf <- asks cfgPatchFormat+        case processBin @a psBs (cpfAlign cpf) of+          Left err -> quit err+          Right ps -> patchBin ps++    patchBin ps = do+        bsIn <- asks (cStreamPairIn . cfgStreamPair) >>= readStream+        binCfg <- asks $ cpfBinCfg . cfgPatchFormat+        case Apply.runPureFwdBin binCfg ps bsIn of+          Left err -> quit $ ErrorBinPatch (showErrorBin err)+          Right bsOut -> return $ BL.toStrict bsOut++    patchTextAwkward :: [Patch 'FwdSeek '[] Text] -> m Bytes+    patchTextAwkward ps = do+        bsIn <- asks (cStreamPairIn . cfgStreamPair) >>= readStream+        let psStr  = map (fmap Text.unpack) ps+            strIn  = Text.unpack $ Text.decodeUtf8 bsIn+            strOut = Apply.runPureSimpleFwdList psStr strIn+            bsOut  = Text.encodeUtf8 $ Text.pack strOut+        return bsOut++    writePatched bs =+        asks (cStreamPairOut . cfgStreamPair) >>= \case+          CStreamFile fp -> liftIO $ BS.writeFile fp bs+          CStreamStd     -> asks (cpfDataType . cfgPatchFormat) >>= \case+            CTextPatch -> liftIO $ BS.putStr bs+            _          -> asks cfgPrintBinary >>= \case+              True  -> liftIO $ BS.putStr bs+              False -> liftIO $ logWarn $+                     "refusing to print binary to stdout:"+                  <> " write to a file with --out-file FILE"+                  <> " or use --print-binary flag to override"++logWarn :: MonadIO m => String -> m ()+logWarn msg = liftIO $ putStrLn $ "bytepatch: warning: " <> msg++-- | Parses your bytes into some binreppable patch form (aligned or not,+--   depending on flag), converts it to the internal patch form, binreps it, and+--   linearizes. The binrep type is consumed inside the function, making it+--   ambiguous, so you need to pass it a type via @processBin \@Text@.+--+-- Note that we linearize *after* binrepping. This is important -- it means the+-- seeks are byte offsets, not using the pre-binrepped type.+processBin+    :: forall a. (BinRep a, FromJSON a, Show a) => Bytes -> CPatchAlign+    -> Either Error [Patch 'FwdSeek '[Bin.MetaStream] Bytes]+processBin bs = \case+  CAlignPatch   ->     mapLeft ErrorYaml (Yaml.decodeEither' @[Aligned (MultiPatch 'RelSeek a)] bs)+                   >>= mapLeft (ErrorAlign . show) . fmap concat . traverse (wrapAlign (BP.convertBinAlign @'AbsSeek))+                   >>= mapLeft (ErrorBin . showErrorBin) . traverse Bin.patchBinRep+                   >>= mapLeft (ErrorLinear . show) . Linear.linearize+  CNoAlignPatch ->     mapLeft ErrorYaml (Yaml.decodeEither' @[MultiPatch 'AbsSeek a] bs)+                   >>= mapLeft (ErrorBin . showErrorBin) . traverse Bin.patchBinRep . concat . map BP.convertBin+                   >>= mapLeft (ErrorLinear . show) . Linear.linearize++-- | Like 'processBin' but no binrepping. Similarly beautiful and ambiguous.+processAny+    :: forall a. (Show a, FromJSON a, Linear.HasLength a) => Bytes -> CPatchAlign+    -> Either Error [Patch 'FwdSeek '[] a]+processAny bs = \case+  CAlignPatch   ->     mapLeft ErrorYaml (Yaml.decodeEither' @[Aligned (MultiPatch 'RelSeek a)] bs)+                   >>= mapLeft (ErrorAlign . show) . fmap concat . traverse (wrapAlign (BP.convertAlign @'AbsSeek))+                   >>= mapLeft (ErrorLinear . show) . Linear.linearize+  CNoAlignPatch ->     mapLeft ErrorYaml (Yaml.decodeEither' @[MultiPatch 'AbsSeek a] bs)+                   >>= mapLeft (ErrorLinear . show) . Linear.linearize . concat . map BP.convertEmpty++wrapAlign+    :: ( SeekRep s ~ Natural+       , r ~ Const (Align.Meta s)+       , rs ~ RDelete r ss+       , RElem r ss i+       , RSubset rs ss is )+    => (MultiPatch 'RelSeek a -> [Patch 'RelSeek ss a])+    -> Aligned (MultiPatch 'RelSeek a)+    -> Either (Align.Error s) [Patch s rs a]+wrapAlign f = align . over (the @"alignedPatches") (concat . map f)++quit :: MonadIO m => Error -> m a+quit err = do+    liftIO $ putStrLn $ "bytepatch: error: " <> errStr+    liftIO $ System.exitWith $ System.ExitFailure errExitCode+  where+    (errExitCode, errStr) = case err of+      ErrorYaml     e -> (1, "while parsing YAML: " <> show e)+      ErrorAlign    e -> (2, "while aligning: "     <> e)+      ErrorBin      e -> (3, "while converting to binary representation: " <> e)+      ErrorLinear   e -> (4, "while linearizing: " <> e)+      ErrorBinPatch e -> (5, "while applying binaryized patch: " <> e)+      Error         e -> (10, e)++readStream :: MonadIO m => CStream -> m Bytes+readStream s = liftIO $+    case s of       CStreamStd     -> BS.getContents       CStreamFile fp -> BS.readFile fp -readStream' :: MonadIO m => CStreamInOut -> m BS.ByteString-readStream' = readStream . fst . unCStreamInOut+-- stupid but how else do I do this without pluggin HexByteString into Binary+-- guess I just gotta write ACTUAL error handling. ffs+showErrorBin :: Show a => Bin.Error a -> String+showErrorBin = \case+  Bin.ErrorBadBinRep a s -> "ErrorBadBinRep " <> show a <> " " <> s+  Bin.ErrorUnexpectedNonNull bs -> "ErrorUnexpectedNonNull " <> go bs+  Bin.ErrorDidNotMatchExpected bs1 bs2 -> "ErrorDidNotMatchExpected " <> go bs1 <> " " <> go bs2+  Bin.ErrorBinRepTooLong bs n -> "ErrorBinRepTooLong " <> go bs <> " " <> show n+  where go bs = "\"" <> Text.unpack (HexBS.prettyHexByteString bs) <> "\"" -writeStream :: MonadIO m => CStream -> BS.ByteString -> m ()-writeStream stream bs = liftIO $-    case stream of+{-++writeStream :: MonadIO m => Bytes -> CStream -> m ()+writeStream bs s = liftIO $+    case s of       CStreamStd     -> BS.putStr bs       CStreamFile fp -> BS.writeFile fp bs -writeStream' :: MonadIO m => CStreamInOut -> BS.ByteString -> m ()-writeStream' stream = writeStream (snd (unCStreamInOut stream))--quit' :: (MonadIO m, Show a) => String -> a -> m ()-quit' msg a = liftIO $ do-    putStrLn $ "bytepatch: error: " <> msg-    print a--quit :: MonadIO m => String -> m ()-quit = liftIO . putStrLn--tryReadPatchscript :: forall a m. (PatchRep a, FromJSON a, MonadIO m) => FilePath -> m (Maybe [CommonMultiEdits a])-tryReadPatchscript = tryDecodeYaml+tryDecodeYaml+    :: forall a m. (FromJSON a, MonadIO m)+    => FilePath -> m (Either Yaml.ParseException a)+tryDecodeYaml fp = Yaml.decodeEither' <$> liftIO (BS.readFile fp) -tryDecodeYaml :: (FromJSON a, MonadIO m) => FilePath -> m (Maybe a)-tryDecodeYaml fp = do-    bs <- liftIO $ BS.readFile fp-    case Yaml.decodeEither' bs of-      Left  _      -> return Nothing-      Right parsed -> return $ Just parsed+-}

@@ -1,39 +0,0 @@-module Options ( parse ) where--import           Config-import           Options.Applicative-import qualified BytePatch.Linear.Patch as Patch-import           Control.Monad.IO.Class--parse :: MonadIO m => m Config-parse = execParserWithDefaults desc pConfig-  where desc = "Patch bytestrings (TODO)."--pConfig :: Parser Config-pConfig = Config-    <$> pPatchCfg-    <*> strArgument (metavar "PATCHSCRIPT" <> help "Path to patchscript")-    <*> pCStreamInOut--pPatchCfg :: Parser Patch.Cfg-pPatchCfg = Patch.Cfg <$> pAllowRepatch <*> pExpectExact-  where-    pAllowRepatch = switch $ long "allow-repatch" <> help "Override safety checks and only warn if it appears we're repatching a patched file (CURRENTLY NONFUNCTIONAL)"-    pExpectExact = flag True False $ long "expect-exact" <> help "When checking expected bytes, require an exact match (rather than the expected being a prefix of the actual)"--pCStreamInOut :: Parser CStreamInOut-pCStreamInOut = CStreamInOut <$> liftA2 (,) pCSIn pCSOut-  where-    pCSIn    = pFileArg <|> pStdin-    pCSOut   = pFileOpt <|> pure CStreamStd-    pFileArg = CStreamFile <$> strArgument (metavar "FILE" <> help "Input file")-    pFileOpt = CStreamFile <$> strOption (metavar "FILE" <> long "out-file" <> short 'o' <> help "Output file")-    pStdin   = flag' CStreamStd (long "stdin"  <> help "Use stdin")-------------------------------------------------------------------------------------- | Execute a 'Parser' with decent defaults.-execParserWithDefaults :: MonadIO m => String -> Parser a -> m a-execParserWithDefaults desc p = liftIO $ customExecParser-    (prefs $ showHelpOnError)-    (info (helper <*> p) (progDesc desc))

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           bytepatch-version:        0.2.1+version:        0.3.0 synopsis:       Patch byte-representable data in a bytestream. description:    Please see README.md. category:       CLI@@ -17,7 +17,7 @@ license-file:   LICENSE build-type:     Simple tested-with:-    GHC >= 8.6 && < 9.2+    GHC >= 8.10 && < 9.2 extra-source-files:     README.md     CHANGELOG.md@@ -28,14 +28,16 @@  library   exposed-modules:-      BytePatch.Core-      BytePatch.JSON-      BytePatch.Linear.Gen-      BytePatch.Linear.Patch-      BytePatch.Pretty-      BytePatch.Pretty.HexByteString-      BytePatch.Pretty.PascalText-      BytePatch.Pretty.PatchRep+      BytePatch+      BytePatch.HexByteString+      StreamPatch.Apply+      StreamPatch.Patch+      StreamPatch.Patch.Align+      StreamPatch.Patch.Binary+      StreamPatch.Patch.Binary.PascalText+      StreamPatch.Patch.Linearize+      StreamPatch.Stream+      Util   other-modules:       Paths_bytepatch   hs-source-dirs:@@ -60,22 +62,30 @@       KindSignatures       TypeOperators       TypeApplications+      DataKinds+      TypeFamilies+      UndecidableInstances+      StandaloneKindSignatures+      RankNTypes+      ScopedTypeVariables   build-depends:       aeson >=1.5 && <2.1     , base >=4.12 && <4.17     , bytestring >=0.10 && <0.12+    , either >=5.0.1.1 && <5.1     , generic-optics >=2.1 && <2.4     , megaparsec >=9.0 && <9.3-    , mtl ==2.2.*+    , mtl >=2.2.2 && <2.3     , optics >=0.3 && <0.5-    , text ==1.2.*+    , text >=1.2.4.1 && <1.3+    , vinyl   default-language: Haskell2010  executable bytepatch   main-is: Main.hs   other-modules:+      CLI       Config-      Options       Paths_bytepatch   hs-source-dirs:       app@@ -99,18 +109,26 @@       KindSignatures       TypeOperators       TypeApplications+      DataKinds+      TypeFamilies+      UndecidableInstances+      StandaloneKindSignatures+      RankNTypes+      ScopedTypeVariables   ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N   build-depends:       aeson >=1.5 && <2.1     , base >=4.12 && <4.17     , bytepatch     , bytestring >=0.10 && <0.12+    , either >=5.0.1.1 && <5.1     , generic-optics >=2.1 && <2.4     , megaparsec >=9.0 && <9.3-    , mtl ==2.2.*+    , mtl >=2.2.2 && <2.3     , optics >=0.3 && <0.5     , optparse-applicative >=0.16.1 && <0.17-    , text ==1.2.*+    , text >=1.2.4.1 && <1.3+    , vinyl     , yaml >=0.11.7 && <0.12   default-language: Haskell2010 @@ -118,7 +136,10 @@   type: exitcode-stdio-1.0   main-is: Spec.hs   other-modules:-      BytePatch.Pretty.HexByteStringSpec+      BytePatch.HexByteStringSpec+      StreamPatch.ApplySpec+      StreamPatch.Patch.AlignSpec+      StreamPatch.Patch.LinearizeSpec       Util       Paths_bytepatch   hs-source-dirs:@@ -143,17 +164,26 @@       KindSignatures       TypeOperators       TypeApplications+      DataKinds+      TypeFamilies+      UndecidableInstances+      StandaloneKindSignatures+      RankNTypes+      ScopedTypeVariables   build-tool-depends:       hspec-discover:hspec-discover   build-depends:-      aeson >=1.5 && <2.1+      QuickCheck+    , aeson >=1.5 && <2.1     , base >=4.12 && <4.17     , bytepatch     , bytestring >=0.10 && <0.12+    , either >=5.0.1.1 && <5.1     , generic-optics >=2.1 && <2.4     , hspec     , megaparsec >=9.0 && <9.3-    , mtl ==2.2.*+    , mtl >=2.2.2 && <2.3     , optics >=0.3 && <0.5-    , text ==1.2.*+    , text >=1.2.4.1 && <1.3+    , vinyl   default-language: Haskell2010

@@ -0,0 +1,133 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}++module BytePatch where++import           StreamPatch.Patch+import qualified StreamPatch.Patch.Binary as Bin+import qualified StreamPatch.Patch.Align  as Align++import           Numeric.Natural+import           Data.Functor.Const+import           Data.Vinyl+import           Data.Vinyl.TypeLevel+import           Data.Aeson+import           GHC.Generics ( Generic )++data MultiPatch s a = MultiPatch+  { mpData :: a+  , mpAt :: [Seek s a]+  } deriving (Generic)++deriving instance (Eq   a, Eq   (SeekRep s)) => Eq   (MultiPatch s a)+deriving instance (Show a, Show (SeekRep s)) => Show (MultiPatch s a)++data Seek s a = Seek+  { sSeek :: SeekRep s+  , sExpected :: Maybe a+  , sNullTerminates :: Maybe (SeekRep 'FwdSeek)+  , sMaxBytes :: Maybe (SeekRep 'FwdSeek) -- TODO confirm meaning, maybe improve name+  , sAligned :: Maybe Natural+  } deriving (Generic)++deriving instance (Eq   a, Eq   (SeekRep s)) => Eq   (Seek s a)+deriving instance (Show a, Show (SeekRep s)) => Show (Seek s a)++-- TODO write a Text newtype for Haskell-style negated integers -- allowing+-- negative hex integers!+data Aligned p = Aligned+  { alignedAlign   :: SeekRep 'RelSeek+  , alignedPatches :: [p]+  } deriving (Eq, Show, Generic)++--------------------------------------------------------------------------------++jsonCfgCamelDrop :: Int -> Options+jsonCfgCamelDrop x = defaultOptions+  { fieldLabelModifier = camelTo2 '_' . drop x+  , rejectUnknownFields = False }++instance (ToJSON   (SeekRep s), ToJSON   a) => ToJSON   (MultiPatch s a) where+    toJSON     = genericToJSON     $ jsonCfgCamelDrop 2+    toEncoding = genericToEncoding $ jsonCfgCamelDrop 2+instance (FromJSON (SeekRep s), FromJSON a) => FromJSON (MultiPatch s a) where+    parseJSON  = genericParseJSON  $ jsonCfgCamelDrop 2++instance (ToJSON   (SeekRep s), ToJSON   a) => ToJSON   (Seek s a) where+    toJSON     = genericToJSON     $ jsonCfgCamelDrop 1+    toEncoding = genericToEncoding $ jsonCfgCamelDrop 1+instance (FromJSON (SeekRep s), FromJSON a) => FromJSON (Seek s a) where+    parseJSON  = genericParseJSON  $ jsonCfgCamelDrop 1++instance (ToJSON   p) => ToJSON   (Aligned p) where+    toJSON     = genericToJSON     $ jsonCfgCamelDrop 7+    toEncoding = genericToEncoding $ jsonCfgCamelDrop 7+instance (FromJSON p) => FromJSON (Aligned p) where+    parseJSON  = genericParseJSON  $ jsonCfgCamelDrop 7++--------------------------------------------------------------------------------++convert :: (Seek s a -> Rec (Flap a) fs) -> MultiPatch s a -> [Patch s fs a]+convert f p = map go (mpAt p)+  where go s = Patch { patchData = mpData p+                     , patchSeek = sSeek s+                     , patchMeta = FunctorRec $ f s }++-- TODO how to clean up (it's like liftA2 over n instead of 2. like a fold)+-- likely 'ap'!+convertBinAlign+    :: forall s a+    .  SeekRep s ~ Natural+    => MultiPatch 'RelSeek a+    -> [Patch 'RelSeek '[Const (Align.Meta s), Const Bin.Meta, Bin.MetaStream] a]+convertBinAlign p = convert go p+  where go s = cmAlign s <+> cmBin s <+> cmBinStream s++convertBin+    :: forall s a+    .  MultiPatch s a+    -> [Patch s '[Const Bin.Meta, Bin.MetaStream] a]+convertBin p = convert go p+  where go s = cmBin s <+> cmBinStream s++convertAlign+    :: forall s a+    .  SeekRep s ~ Natural+    => MultiPatch 'RelSeek a+    -> [Patch 'RelSeek '[Const (Align.Meta s)] a]+convertAlign p = convert cmAlign p++convertEmpty+    :: forall s a+    .  MultiPatch s a+    -> [Patch s '[] a]+convertEmpty p = convert (const RNil) p++--------------------------------------------------------------------------------++align+    :: forall s a ss rs is i r+    .  ( SeekRep s ~ Natural+       , r ~ Const (Align.Meta s)+       , rs ~ RDelete r ss+       , RElem r ss i+       , RSubset rs ss is )+    => Aligned (Patch 'RelSeek ss a)+    -> Either (Align.Error s) [Patch s rs a]+align (Aligned a ps) = traverse (Align.align a) ps++--------------------------------------------------------------------------------++cmBin :: Seek s a -> Rec (Flap a) '[Const Bin.Meta]+cmBin s = cm $ Const $ Bin.Meta { Bin.mMaxBytes = sMaxBytes s }++cmBinStream :: Seek s a -> Rec (Flap a) '[Bin.MetaStream]+cmBinStream s = cm $ Bin.MetaStream+    { Bin.msNullTerminates = sNullTerminates s+    , Bin.msExpected = sExpected s }++cmAlign :: SeekRep s ~ Natural => Seek 'RelSeek a -> Rec (Flap a) '[Const (Align.Meta s)]+cmAlign s = cm $ Const $ Align.Meta { Align.mExpected = sAligned s }++cm :: f a -> Rec (Flap a) '[f]+cm fa = Flap fa :& RNil

@@ -1,38 +0,0 @@-{-# LANGUAGE DataKinds, TypeFamilies, UndecidableInstances #-}--module BytePatch.Core where--import GHC.Generics ( Generic )-import GHC.Natural--data Patch (s :: SeekKind) a = Patch (SeekRep s) (Edit a)-    deriving (Generic, Functor, Foldable, Traversable)--deriving instance (Eq (SeekRep s), Eq a) => Eq (Patch s a)-deriving instance (Show (SeekRep s), Show a) => Show (Patch s a)--data SeekKind-  = FwdSeek    -- ^ seeks only move cursor forward-  | CursorSeek -- ^ seeks move cursor forward or backward-  | AbsSeek    -- ^ seeks specify an exact offset in stream-    deriving (Eq, Show, Generic)--type family SeekRep (s :: SeekKind) where-    SeekRep 'FwdSeek    = Natural-    SeekRep 'CursorSeek = Integer-    SeekRep 'AbsSeek    = Natural---- | Data to add to a stream.-data Edit a = Edit-  { editData :: a-  , editMeta :: EditMeta a-  } deriving (Eq, Show, Generic, Functor, Foldable, Traversable)---- | Various optional metadata defining expected existing data for an 'Edit'.-data EditMeta a = EditMeta-  { emNullTerminates :: Maybe Int-  -- ^ Stream segment should be null bytes (0x00) only from this index onwards.--  , emExpected       :: Maybe a-  -- ^ Stream segment should be this.-  } deriving (Eq, Show, Generic, Functor, Foldable, Traversable)

@@ -0,0 +1,70 @@+{- |+A 'Data.ByteString.ByteString' newtype wrapper indicating a human-readable+bytestring, to be displayed in hex form (e.g. 00 12 AB FF).+-}++module BytePatch.HexByteString+  ( HexByteString(..)+  , parseHexByteString+  , prettyHexByteString+  ) where++import           StreamPatch.Patch.Binary ( BinRep(..) )++import           Data.Void+import           Text.Megaparsec+import qualified Text.Megaparsec.Char       as MC+import qualified Data.ByteString            as BS+import qualified Data.Char                  as Char+import           Data.Word+import qualified Data.Text                  as Text+import           Data.Text                  ( Text )+import           Data.List                  as List+import           Data.Aeson++type Bytes = BS.ByteString++newtype HexByteString = HexByteString { unHexByteString :: Bytes }+    deriving (Eq)++instance Show HexByteString where+    show = Text.unpack . prettyHexByteString . unHexByteString++instance BinRep HexByteString where+    toBinRep = Right . unHexByteString++instance FromJSON HexByteString where+    parseJSON = withText "hex bytestring" $ \t ->+        case parseMaybe @Void parseHexByteString t of+          Nothing -> fail "failed to parse hex bytestring (TODO)"+          Just t' -> pure (HexByteString t')+instance ToJSON   HexByteString where+    toJSON = String . prettyHexByteString . unHexByteString++-- | A hex bytestring looks like this: @00 01 89 8a   FEff@. You can mix and+-- match capitalization and spacing, but I prefer to space each byte, full caps.+parseHexByteString :: (MonadParsec e s m, Token s ~ Char) => m Bytes+parseHexByteString = BS.pack <$> parseHexByte `sepBy` MC.hspace++-- | Parse a byte formatted as two hex digits e.g. EF. You _must_ provide both+-- nibbles e.g. @0F@, not @F@. They cannot be spaced e.g. @E F@ is invalid.+--+-- Returns a value 0-255, so can fit in any Num type that can store that.+parseHexByte :: (MonadParsec e s m, Token s ~ Char, Num a) => m a+parseHexByte = do+    c1 <- MC.hexDigitChar+    c2 <- MC.hexDigitChar+    return $ 0x10 * fromIntegral (Char.digitToInt c1) + fromIntegral (Char.digitToInt c2)++prettyHexByteString :: Bytes -> Text+prettyHexByteString =+    Text.concat . List.intersperse (Text.singleton ' ') . fmap (f . prettyHexByte) . BS.unpack+  where+    f :: (Char, Char) -> Text+    f (c1, c2) = Text.cons c1 $ Text.singleton c2++prettyHexByte :: Word8 -> (Char, Char)+prettyHexByte w = (prettyNibble h, prettyNibble l)+  where+    (h,l) = fromIntegral w `divMod` 0x10+    prettyNibble = Char.toUpper . Char.intToDigit

@@ -1,55 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE UndecidableInstances #-}---- | Aeson instances for various types.-module BytePatch.JSON where--import           BytePatch.Core-import qualified BytePatch.Pretty               as Pretty-import           BytePatch.Pretty.HexByteString-import           Data.Aeson-import           Text.Megaparsec-import           Data.Void--instance FromJSON HexByteString where-    parseJSON = withText "hex bytestring" $ \t ->-        case parseMaybe @Void parseHexByteString t of-          Nothing -> fail "failed to parse hex bytestring (TODO)"-          Just t' -> pure (HexByteString t')-instance ToJSON   HexByteString where-    toJSON = String . prettyHexByteString . unHexByteString--jsonCfgCamelDrop :: Int -> Options-jsonCfgCamelDrop x = defaultOptions-  { fieldLabelModifier = camelTo2 '_' . drop x-  , rejectUnknownFields = True }--instance ToJSON   a => ToJSON   (Pretty.CommonMultiEdits a) where-    toJSON     = genericToJSON     $ jsonCfgCamelDrop 4-    toEncoding = genericToEncoding $ jsonCfgCamelDrop 4-instance FromJSON a => FromJSON (Pretty.CommonMultiEdits a) where-    parseJSON  = genericParseJSON  $ jsonCfgCamelDrop 4--instance (ToJSON   (SeekRep s), ToJSON   a) => ToJSON   (Pretty.MultiEdit s a) where-    toJSON     = genericToJSON     $ jsonCfgCamelDrop 2-    toEncoding = genericToEncoding $ jsonCfgCamelDrop 2-instance (FromJSON (SeekRep s), FromJSON a) => FromJSON (Pretty.MultiEdit s a) where-    parseJSON  = genericParseJSON  $ jsonCfgCamelDrop 2--instance (ToJSON   (SeekRep s), ToJSON   a) => ToJSON   (Pretty.EditOffset s a) where-    toJSON     = genericToJSON     $ jsonCfgCamelDrop 2-    toEncoding = genericToEncoding $ jsonCfgCamelDrop 2-instance (FromJSON (SeekRep s), FromJSON a) => FromJSON (Pretty.EditOffset s a) where-    parseJSON  = genericParseJSON  $ jsonCfgCamelDrop 2--instance ToJSON   a => ToJSON   (EditMeta a) where-    toJSON     = genericToJSON     $ jsonCfgCamelDrop 2-    toEncoding = genericToEncoding $ jsonCfgCamelDrop 2-instance FromJSON a => FromJSON (EditMeta a) where-    parseJSON  = genericParseJSON  $ jsonCfgCamelDrop 2--instance ToJSON   a => ToJSON   (Edit a) where-    toJSON     = genericToJSON     defaultOptions-    toEncoding = genericToEncoding defaultOptions-instance FromJSON a => FromJSON (Edit a) where-    parseJSON  = genericParseJSON  defaultOptions

@@ -1,59 +0,0 @@-{-# LANGUAGE DataKinds, TypeFamilies, UndecidableInstances #-}--module BytePatch.Linear.Gen (gen, Error(..)) where--import           BytePatch.Core--import qualified Data.ByteString        as BS-import           Control.Monad.State-import qualified Data.List              as List-import           GHC.Natural--type Bytes = BS.ByteString---- | Error encountered during linear patchscript generation.-data Error s a-  = ErrorOverlap (Patch s a) (Patch s a)-  -- ^ Two edits wrote to the same offset.--deriving instance (Eq (SeekRep s), Eq a) => Eq (Error s a)-deriving instance (Show (SeekRep s), Show a) => Show (Error s a)---- | Process a list of patches into a linear patch script.------ Errors are reported, but do not interrupt patch generation. The user could--- discard patchscripts that errored, or perhaps attempt to recover them. This--- is what we do for errors:------   * overlapping edit: later edit is skipped & overlapping edits reported-gen-    :: [Patch 'AbsSeek Bytes]-    -> ([Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes])-gen pList =-    let pList'                 = List.sortBy comparePatchOffsets pList-        (_, script, errors, _) = execState (go pList') (0, [], [], undefined)-        -- I believe the undefined is inaccessible providing the first patch has-        -- a non-negative offset (negative offsets are forbidden)-     in (reverse script, reverse errors)-  where-    comparePatchOffsets (Patch o1 _) (Patch o2 _) = compare o1 o2-    go-        :: (MonadState (Natural, [Patch 'FwdSeek Bytes], [Error 'AbsSeek Bytes], Patch 'AbsSeek Bytes) m)-        => [Patch 'AbsSeek Bytes]-        -> m ()-    go [] = return ()-    go (p@(Patch offset edit) : ps) = do-        (cursor, script, errors, prevPatch) <- get-        case offset `minusNaturalMaybe` cursor of-          -- next offset is behind current cursor: overlapping patches-          -- record error, recover via dropping patch-          Nothing -> do-            let e = ErrorOverlap p prevPatch-            let errors' = e : errors-            put (cursor, script, errors', p)-            go ps-          Just skip -> do-            let dataLen = fromIntegral $ BS.length $ editData edit-            let cursor' = cursor + skip + dataLen-            put (cursor', Patch skip edit : script, errors, p)-            go ps

@@ -1,146 +0,0 @@-{-# LANGUAGE DataKinds, TypeFamilies #-}--{- | Low-level patchscript processing and application.--Patchscripts are applied as a list of @(skip x, write in-place y)@ commands. An-offset-based format is much simpler to use, however. This module processes such-offset patchscripts into a "linear" patchscript, and provides a stream patching-algorithm that can be applied to any forward-seeking byte stream.--Some core types are parameterized over the stream type/patch content. This-enables writing patches in any form (e.g. UTF-8 text), which are then processed-into an applicable patch by transforming edits into a concrete binary-representation (e.g. null-terminated UTF-8 bytestring). See TODO module for-more.--}--module BytePatch.Linear.Patch-  (-  -- * Patch interface-    MonadFwdByteStream(..)-  , Cfg(..)-  , Error(..)--  -- * Prepared patchers-  , patchPure--  -- * General patcher-  , patch--  ) where--import           BytePatch.Core--import           GHC.Natural-import qualified Data.ByteString         as BS-import qualified Data.ByteString.Lazy    as BL-import qualified Data.ByteString.Builder as BB-import           Control.Monad.State-import           Control.Monad.Reader-import           System.IO               ( Handle, SeekMode(..), hSeek )-import           Optics--type Bytes = BS.ByteString---- TODO also require reporting cursor position (for error reporting)-class Monad m => MonadFwdByteStream m where-    -- | Read a number of bytes without advancing the cursor.-    readahead :: Natural -> m Bytes--    -- | Advance cursor without reading.-    advance :: Natural -> m ()--    -- | Insert bytes into the stream at the cursor position, overwriting-    --   existing bytes.-    overwrite :: Bytes -> m ()--instance Monad m => MonadFwdByteStream (StateT (Bytes, BB.Builder) m) where-    readahead n = BS.take (fromIntegral n) <$> gets fst-    advance n = do-        (src, out) <- get-        let (bs, src') = BS.splitAt (fromIntegral n) src-        put (src', out <> BB.byteString bs)-    overwrite bs = do-        (src, out) <- get-        let (_, src') = BS.splitAt (BS.length bs) src-        put (src', out <> BB.byteString bs)--instance MonadIO m => MonadFwdByteStream (ReaderT Handle m) where-    readahead n = do-        hdl <- ask-        bs <- liftIO $ BS.hGet hdl (fromIntegral n)-        liftIO $ hSeek hdl RelativeSeek (- fromIntegral n)-        return bs-    advance n = do-        hdl <- ask-        liftIO $ hSeek hdl RelativeSeek (fromIntegral n)-    overwrite bs = do-        hdl <- ask-        liftIO $ BS.hPut hdl bs---- | Patch time config.-data Cfg = Cfg-  { cfgWarnIfLikelyReprocessing :: Bool-  -- ^ If we determine that we're repatching an already-patched stream, continue-  --   with a warning instead of failing.--  , cfgAllowPartialExpected :: Bool-  -- ^ If enabled, allow partial expected bytes checking. If disabled, then even-  --   if the expected bytes are a prefix of the actual, fail.-  } deriving (Eq, Show)---- | Errors encountered during patch time.-data Error-  = ErrorPatchOverlong-  | ErrorPatchUnexpectedNonnull-  | ErrorPatchDidNotMatchExpected Bytes Bytes-    deriving (Eq, Show)--patch-    :: MonadFwdByteStream m-    => Cfg -> [Patch 'FwdSeek Bytes]-    -> m (Maybe Error)-patch cfg = go-  where-    go [] = return Nothing-    go (Patch n (Edit bs meta):es) = do-        advance n-        bsStream <- readahead $ fromIntegral $ BS.length bs -- TODO catch overlong error--        -- if provided, strip trailing nulls from to-overwrite bytestring-        case tryStripNulls bsStream (emNullTerminates meta) of-          Nothing -> return $ Just ErrorPatchUnexpectedNonnull-          Just bsStream' -> do--            -- if provided, check the to-overwrite bytestring matches expected-            case checkExpected bsStream' (emExpected meta) of-              Just (bsa, bse) -> return $ Just $ ErrorPatchDidNotMatchExpected bsa bse-              Nothing -> overwrite bs >> go es--    tryStripNulls bs = \case-      Nothing        -> Just bs-      Just nullsFrom ->-        let (bs', bsNulls) = BS.splitAt nullsFrom bs-         in if   bsNulls == BS.replicate (BS.length bsNulls) 0x00-            then Just bs'-            else Nothing--    checkExpected bs = \case-      Nothing -> Nothing-      Just bsExpected ->-        case cfgAllowPartialExpected cfg of-          True  -> if   BS.isPrefixOf bs bsExpected-                   then Nothing-                   else Just (bs, bsExpected)-          False -> if   bs == bsExpected-                   then Nothing-                   else Just (bs, bsExpected)---- | Attempt to apply a patchscript to a 'Data.ByteString.ByteString'.-patchPure :: Cfg -> [Patch 'FwdSeek Bytes] -> BS.ByteString -> Either Error BL.ByteString-patchPure cfg ps bs =-    let (mErr, (bsRemaining, bbPatched)) = runState (patch cfg ps) (bs, mempty)-        bbPatched' = bbPatched <> BB.byteString bsRemaining-     in case mErr of-          Just err -> Left err-          Nothing  -> Right $ BB.toLazyByteString bbPatched'

@@ -1,166 +0,0 @@-{-# LANGUAGE DataKinds, TypeFamilies, UndecidableInstances #-}--{-|-Convenience interface to enable defining edits at offsets with some optional-safety checks.--Redefines some types to enable us to easily leverage Aeson's generic JSON schema-deriving. That sadly means we can't use some of the interesting offset plumbing.--TODO I should definitely bite the bullet and use the plumbing now that it's so-cool.--}--module BytePatch.Pretty-  (-  -- * Core types-    CommonMultiEdits(..)-  , MultiEdit(..)-  , EditOffset(..)--  -- * Convenience functions-  , normalizeSimple--  -- * Low-level interface-  , applyBaseOffset-  , listAlgebraConcatEtc-  , normalize-  ) where--import           BytePatch.Core-import           BytePatch.Pretty.PatchRep--import qualified Data.ByteString            as BS-import           Data.Maybe                 ( fromMaybe )-import           GHC.Generics               ( Generic )-import           GHC.Natural--type Bytes = BS.ByteString---- | A list of 'MultiEdit's with some common configuration.-data CommonMultiEdits a = CommonMultiEdits-  { cmesBaseOffset :: Maybe (SeekRep 'CursorSeek)-  -- ^-  -- The base offset from which all offsets are located. An actual offset is-  -- calculated by adding the base offset to an offset. Actual offsets below 0-  -- are invalid, meaning for an offset @o@ with base offset @bo@, the actual-  -- offset is only valid when @o >= bo@. Negative base offsets are allowed.--  , cmesEdits :: [MultiEdit 'CursorSeek a]-  } deriving (Eq, Show, Generic, Functor, Foldable, Traversable)---- | A single edit to be applied at a list of offsets.-data MultiEdit (s :: SeekKind) a = MultiEdit-  { meData :: a              -- ^ The value (e.g. bytes, text) to add.-  , meAt   :: [EditOffset s a] -- ^ Offsets to apply edit at.-  } deriving (Generic, Functor, Foldable, Traversable)--deriving instance (Eq (SeekRep s), Eq a) => Eq (MultiEdit s a)-deriving instance (Show (SeekRep s), Show a) => Show (MultiEdit s a)---- | An edit offset, with metadata to use for preparing and applying the edit.-data EditOffset (s :: SeekKind) a = EditOffset-  { eoOffset    :: SeekRep s-  -- ^ Stream offset for edit.--  , eoAbsOffset :: Maybe (SeekRep 'AbsSeek)-  -- ^ Absolute stream offset for edit. Used for checking against actual offset.--  , eoMaxLength :: Maybe Natural-  -- ^ Maximum number of bytes allowed to write at this offset.--  , eoEditMeta  :: Maybe (EditMeta a)-  -- ^ Optional apply time metadata for the edit at this offset.--  } deriving (Generic, Functor, Foldable, Traversable)--deriving instance (Eq (SeekRep s), Eq a) => Eq (EditOffset s a)-deriving instance (Show (SeekRep s), Show a) => Show (EditOffset s a)---- | Normalize a list of 'CommonMultiEdits's, discarding everything on error.-normalizeSimple :: PatchRep a => [CommonMultiEdits a] -> Maybe [Patch 'AbsSeek Bytes]-normalizeSimple cmess =-    let (p, errs) = listAlgebraConcatEtc . map applyBaseOffset $ cmess-     in case errs of-          _:_ -> Nothing-          []  -> normalize p---- Drops no info, not easy to consume.-applyBaseOffset-    :: CommonMultiEdits a-    -> (Integer, [(MultiEdit 'AbsSeek a, [EditOffset 'CursorSeek a])])-applyBaseOffset cmes =-    (baseOffset, recalculateMultiPatchOffsets baseOffset (cmesEdits cmes))-      where baseOffset = fromMaybe 0 (cmesBaseOffset cmes)---- lmao this sucks. generalisation bad-listAlgebraConcatEtc :: [(a, [(b, [c])])] -> ([b], [(c, a)])-listAlgebraConcatEtc = mconcat . map go-  where-    go (baseOffset, inps) = tuplemconcat (map (go' baseOffset) inps)-    go' x (mp, offs) = (mp, map (\o -> (o, x)) offs)-    tuplemconcat = foldr (\(a, bs) (as, bs') -> (a:as, bs <> bs')) ([], mempty)--recalculateMultiPatchOffsets-    :: Integer-    -> [MultiEdit 'CursorSeek a]-    -> [(MultiEdit 'AbsSeek a, [EditOffset 'CursorSeek a])]-recalculateMultiPatchOffsets baseOffset = map go-  where-    go :: MultiEdit 'CursorSeek a -> (MultiEdit 'AbsSeek a, [EditOffset 'CursorSeek a])-    go me =-        let (osRecalculated, osInvalid) = recalculateOffsets baseOffset (meAt me)-         in (me { meAt = osRecalculated }, osInvalid)--recalculateOffsets-    :: Integer-    -> [EditOffset 'CursorSeek a]-    -> ([EditOffset 'AbsSeek a], [EditOffset 'CursorSeek a])-recalculateOffsets baseOffset = partitionMaybe go-  where-    go o = let actualOffset = baseOffset + eoOffset o-            in case tryIntegerToNatural actualOffset of-                 Nothing -> Nothing-                 Just actualOffset' -> Just $ o { eoOffset = actualOffset' }--tryIntegerToNatural :: Integer -> Maybe Natural-tryIntegerToNatural n | n < 0     = Nothing-                      | otherwise = Just $ naturalFromInteger n--normalize :: PatchRep a => [MultiEdit 'AbsSeek a] -> Maybe [Patch 'AbsSeek Bytes]-normalize xs = concat <$> mapM go xs-  where go (MultiEdit contents os) = mapM (tryMakeSingleReplace contents) os---- TODO now can error with "[expected] content has no valid patch rep"-tryMakeSingleReplace :: PatchRep a => a -> EditOffset 'AbsSeek a -> Maybe (Patch 'AbsSeek Bytes)-tryMakeSingleReplace contents (EditOffset os maos mMaxLen mMeta) =-    case toPatchRep contents of-      Left errStr -> error errStr -- TODO-      Right bs ->-        if   offsetIsCorrect-        then case mMaxLen of-               Just maxLen -> if BS.length bs > fromIntegral maxLen then Nothing else overwrite bs-               Nothing     -> overwrite bs-        else Nothing-  where-    overwrite bs = case traverse toPatchRep meta of-                     Left errStr -> error errStr -- TODO-                     Right meta' ->-                         Just $ Patch os $ Edit { editData = bs-                                                , editMeta = meta' }-    meta = fromMaybe (EditMeta Nothing Nothing) mMeta-    offsetIsCorrect = case maos of Nothing  -> True-                                   Just aos -> os == aos-------------------------------------------------------------------------------------- | Map a failable function over a list, retaining "failed" 'Nothing' results.-partitionMaybe :: (a -> Maybe b) -> [a] -> ([b], [a])-partitionMaybe f =-    foldr (\x -> maybe (mapSnd (x:)) (\y -> mapFst (y:)) (f x)) ([], [])--mapFst :: (a -> c) -> (a, b) -> (c, b)-mapFst f (a, b) = (f a, b)--mapSnd :: (b -> c) -> (a, b) -> (a, c)-mapSnd f (a, b) = (a, f b)

@@ -1,62 +0,0 @@-{- |-A 'Data.ByteString.ByteString' newtype wrapper indicating a human-readable-bytestring, to be displayed in hex form (e.g. 00 12 AB FF).--}--{-# LANGUAGE TypeFamilies #-}--module BytePatch.Pretty.HexByteString-  ( HexByteString(..)-  , parseHexByteString-  , prettyHexByteString-  ) where--import           BytePatch.Pretty.PatchRep--import           Text.Megaparsec-import qualified Text.Megaparsec.Char       as MC-import qualified Data.ByteString            as BS-import qualified Data.Char                  as Char-import           Data.Word-import qualified Data.Text                  as Text-import           Data.Text                  ( Text )-import           Data.List                  as List--type Bytes = BS.ByteString--newtype HexByteString = HexByteString { unHexByteString :: Bytes }-    deriving (Eq)--instance Show HexByteString where-    show = Text.unpack . prettyHexByteString . unHexByteString--instance PatchRep HexByteString where-    toPatchRep = Right . unHexByteString---- | A hex bytestring looks like this: @00 01 89 8a   FEff@. You can mix and--- match capitalization and spacing, but I prefer to space each byte, full caps.-parseHexByteString :: (MonadParsec e s m, Token s ~ Char) => m Bytes-parseHexByteString = BS.pack <$> parseHexByte `sepBy` MC.hspace---- | Parse a byte formatted as two hex digits e.g. EF. You _must_ provide both--- nibbles e.g. @0F@, not @F@. They cannot be spaced e.g. @E F@ is invalid.------ Returns a value 0-255, so can fit in any Num type that can store that.-parseHexByte :: (MonadParsec e s m, Token s ~ Char, Num a) => m a-parseHexByte = do-    c1 <- MC.hexDigitChar-    c2 <- MC.hexDigitChar-    return $ 0x10 * fromIntegral (Char.digitToInt c1) + fromIntegral (Char.digitToInt c2)--prettyHexByteString :: Bytes -> Text-prettyHexByteString =-    Text.concat . List.intersperse (Text.singleton ' ') . fmap (f . prettyHexByte) . BS.unpack-  where-    f :: (Char, Char) -> Text-    f (c1, c2) = Text.cons c1 $ Text.singleton c2--prettyHexByte :: Word8 -> (Char, Char)-prettyHexByte w = (prettyNibble h, prettyNibble l)-  where-    (h,l) = fromIntegral w `divMod` 0x10-    prettyNibble = Char.toUpper . Char.intToDigit

@@ -1,56 +0,0 @@-{-| Newtype for manipulating length-prefixed strings.--This type is for UTF-8 'Text' that you intend to write out to a length-prefixed-bytestring. The size of the length field is static. You essentially have to-decide the maximum bytesize of the string on creation.--}--{-# LANGUAGE DataKinds, ScopedTypeVariables#-}--module BytePatch.Pretty.PascalText where--import           BytePatch.Pretty.PatchRep--import qualified Data.Text.Encoding         as Text-import           Data.Text                  ( Text )-import qualified Data.ByteString            as BS-import           GHC.TypeLits-import           Data.Proxy-import           Data.Bits--newtype PascalText (n :: Nat) = PascalText { unPascalText :: Text }--instance KnownNat n => PatchRep (PascalText n) where-    toPatchRep t =-        case encodePascalText t of-          Nothing -> Left "UTF-8 encoded text too long for length prefix field"-          Just bs -> Right bs--encodePascalText :: forall n. KnownNat n => PascalText n -> Maybe BS.ByteString-encodePascalText t = do-    lenBs <- encodeToSizedBE (fromIntegral (natVal (Proxy @n))) (BS.length bs)-    return $ lenBs <> bs-  where-    bs = Text.encodeUtf8 . unPascalText $ t--encodeToSizedBE :: (Integral a, Bits a) => Int -> a -> Maybe BS.ByteString-encodeToSizedBE byteSize x =-    let bs = i2be x-        nulls = byteSize - BS.length bs-     in if   nulls < 0-        then Nothing-        else Just $ BS.replicate nulls 0x00 <> bs---- | Re-encode an 'Integer' to a little-endian integer stored as a 'ByteString'---   using the fewest bytes needed to represent it.------ adapated from crypto-api 0.13.3, Crypto.Util.i2bs_unsized-i2be :: (Integral a, Bits a) => a -> BS.ByteString-i2be 0 = BS.singleton 0-i2be i = BS.reverse $ BS.unfoldr (\i' -> if i' <= 0 then Nothing else Just (fromIntegral i', (i' `shiftR` 8))) i---- 0 -> 255 = 1--- 256 -> 65535 = 2--ptLengthBytes :: forall n. KnownNat n => PascalText n -> Integer-ptLengthBytes _ = natVal (Proxy @n)

@@ -1,29 +0,0 @@-module BytePatch.Pretty.PatchRep where--import qualified Data.ByteString            as BS-import qualified Data.Text.Encoding         as Text-import           Data.Text                  ( Text )---- | Type has a binary representation for using in patchscripts.------ Patchscripts are parsed parameterized over the type to edit. That type needs--- to become a bytestring for eventual patch application. We're forced into--- newtypes and typeclasses by Aeson already, so this just enables us to define--- some important patch generation behaviour in one place. Similarly to Aeson,--- if you require custom behaviour for existing types (e.g. length-prefixed--- strings instead of C-style null terminated), define a newtype over it.------ Some values may not have valid patch representations, for example if you're--- patching a 1-byte length-prefixed string and your string is too long (>255--- encoded bytes). Thus, 'toPatchRep' is failable.-class PatchRep a where-    toPatchRep :: a -> Either String BS.ByteString---- | Bytestrings are copied as-is.-instance PatchRep BS.ByteString where-    toPatchRep = Right . id---- | Text is converted to UTF-8 bytes and null-terminated.-instance PatchRep Text where-    --toPatchRep t = BS.snoc (Text.encodeUtf8 t) 0x00-    toPatchRep = Right . flip BS.snoc 0x00 . Text.encodeUtf8

@@ -0,0 +1,60 @@+module StreamPatch.Apply where++import           StreamPatch.Stream+import           StreamPatch.Patch+import qualified StreamPatch.Patch.Binary   as Bin+import           StreamPatch.Patch.Binary   ( BinRep )++import           Data.Vinyl+import qualified Data.ByteString            as BS+import qualified Data.ByteString.Builder    as BB+import qualified Data.ByteString.Lazy       as BL+import           Control.Monad.State+import           Util++-- TODO how to clean up, use Either monad inside m? (lift didn't work)+applyBinFwd+    :: forall a m. (MonadFwdStream m, Chunk m ~ BS.ByteString, BinRep a)+    => Bin.Cfg+    -> [Patch 'FwdSeek '[Bin.MetaStream] a]+    -> m (Either (Bin.Error a) ())+applyBinFwd cfg = traverseM_ $ \(Patch a s (FunctorRec (Flap m :& RNil))) -> do+    case Bin.toBinRep' a of+      Left err -> return $ Left err+      Right bs -> do+        advance s+        bsStream <- readahead $ fromIntegral $ BS.length bs+        case Bin.check cfg bsStream m of+          Left err -> return $ Left err+          Right () -> do+            overwrite bs+            return $ Right ()++runPureFwdBin+    :: BinRep a+    => Bin.Cfg+    -> [Patch 'FwdSeek '[Bin.MetaStream] a]+    -> BS.ByteString+    -> Either (Bin.Error a) BL.ByteString+runPureFwdBin cfg ps bs =+    let (mErr, (bsRemaining, bbPatched)) = runState (applyBinFwd cfg ps) (bs, mempty)+        bbPatched' = bbPatched <> BB.byteString bsRemaining+     in case mErr of+          Left err -> Left err+          Right () -> Right $ BB.toLazyByteString bbPatched'++applySimpleFwd+    :: (MonadFwdStream m, Chunk m ~ a)+    => [Patch 'FwdSeek '[] a]+    -> m ()+applySimpleFwd =+    mapM_ $ \(Patch a s (FunctorRec RNil)) -> advance s >> overwrite a++-- stupid because no monotraversable :<+runPureSimpleFwdList+    :: [Patch 'FwdSeek '[] [a]]+    -> [a]+    -> [a]+runPureSimpleFwdList ps start =+    let ((), (remaining, patched)) = runState (applySimpleFwd ps) (start, mempty)+     in patched <> remaining

@@ -0,0 +1,79 @@+-- | Core patch type definitions: patches, seeks, metadata.++module StreamPatch.Patch where++import           Data.Kind+import           GHC.Generics ( Generic )+import           GHC.Natural+import           Data.Vinyl+import           Control.Applicative ( liftA2 )++type PatchLike = SeekKind -> [Type -> Type] -> Type -> Type+type Patch :: PatchLike+data Patch s fs a = Patch+  { patchData :: a+  , patchSeek :: SeekRep s+  , patchMeta :: FunctorRec fs a+  } deriving (Generic)++deriving instance (Eq   a, Eq   (SeekRep s), Eq (Rec (Flap a) fs))  => Eq (Patch s fs a)+deriving instance (Show a, Show (SeekRep s), ReifyConstraint Show (Flap a) fs, RMap fs, RecordToList fs) => Show (Patch s fs a)+deriving instance (Functor (FunctorRec fs)) => Functor (Patch s fs)++-- Taken from vinyl-plus. Functor and Applicative instances were provided.+newtype Flap a f = Flap { getFlap :: f a } deriving (Eq, Show, Generic)+newtype FunctorRec fs a = FunctorRec { getFunctorRec :: Rec (Flap a) fs } deriving (Generic)+deriving instance (ReifyConstraint Show (Flap a) fs, RMap fs, RecordToList fs) => Show (FunctorRec fs a)+deriving instance Eq (Rec (Flap a) fs) => Eq (FunctorRec fs a)++instance Functor (FunctorRec '[]) where+  fmap _ (FunctorRec RNil) = FunctorRec RNil+instance (Functor r, Functor (FunctorRec rs)) => Functor (FunctorRec (r ': rs)) where+  fmap f (FunctorRec (Flap r :& rs)) =+    FunctorRec (Flap (fmap f r) :& getFunctorRec (fmap f (FunctorRec rs)))++instance Applicative (FunctorRec '[]) where+  pure _ = FunctorRec RNil+  FunctorRec RNil <*> FunctorRec RNil = FunctorRec RNil+instance (Applicative r, Applicative (FunctorRec rs)) => Applicative (FunctorRec (r ': rs)) where+  pure a = FunctorRec (Flap (pure a) :& getFunctorRec (pure a))+  FunctorRec (Flap f :& fs) <*> FunctorRec (Flap a :& as) =+    FunctorRec (Flap (f <*> a) :& getFunctorRec (FunctorRec fs <*> FunctorRec as))++instance Foldable (FunctorRec '[]) where+  foldr _ z (FunctorRec RNil) = z+instance (Foldable r, Foldable (FunctorRec rs)) => Foldable (FunctorRec (r ': rs)) where+    -- TODO foldr is harder lol+    foldMap f (FunctorRec (Flap r :& rs)) = foldMap f r <> foldMap f (FunctorRec rs)++-- I am shit at this LOL+instance Traversable (FunctorRec '[]) where+  traverse _ (FunctorRec RNil) = pure (FunctorRec RNil)+instance (Traversable r, Traversable (FunctorRec rs)) => Traversable (FunctorRec (r ': rs)) where+  traverse+      :: forall f a b. Applicative f+      => (a -> f b)+      -> (FunctorRec (r ': rs)) a+      -> f (FunctorRec (r ': rs) b)+  traverse f (FunctorRec (Flap (r :: r a) :& rs)) =+      FunctorRec <$> rBoth+    where+      rBoth :: f (Rec (Flap b) (r ': rs))+      rBoth = liftA2 (:&) rHead rTail+      rHead :: f (Flap b r)+      rHead = Flap <$> traverse f r+      rTail :: f (Rec (Flap b) rs)+      rTail = getFunctorRec <$> traverse f (FunctorRec rs)++-- | What a patch seek value means.+data SeekKind+  = FwdSeek -- ^ seeks only move cursor forward+  | RelSeek -- ^ seeks are relative e.g. to a universal base, or a stream cursor+  | AbsSeek -- ^ seeks specify an exact offset in stream+    deriving (Eq, Show, Generic)++-- | Get the representation for a 'SeekKind'. Allows us a bit more safety.+type family SeekRep (s :: SeekKind) where+    SeekRep 'FwdSeek = Natural+    SeekRep 'RelSeek = Integer+    SeekRep 'AbsSeek = Natural

@@ -0,0 +1,59 @@+module StreamPatch.Patch.Align where++import           StreamPatch.Patch++import           GHC.Generics ( Generic )+import           Numeric.Natural+import           GHC.Natural ( naturalFromInteger )+import           Data.Vinyl+import           Data.Vinyl.TypeLevel+import           Data.Functor.Const++data Meta s = Meta+  { mExpected :: Maybe (SeekRep s)+  -- ^ Absolute stream offset for edit. Used for checking against actual offset.+  } deriving (Generic)++deriving instance (Eq   (SeekRep s)) => Eq   (Meta s)+deriving instance (Show (SeekRep s)) => Show (Meta s)++data Error s+  = ErrorSeekBelow0 (SeekRep 'RelSeek)+  | ErrorDoesntMatchExpected (SeekRep s) (SeekRep s) -- expected, then actual+    deriving (Generic)++deriving instance (Eq   (SeekRep s)) => Eq   (Error s)+deriving instance (Show (SeekRep s)) => Show (Error s)++-- | Attempt to align the given patch to 0 using the given base.+align+    :: forall s a ss rs is i r+    .  ( SeekRep s ~ Natural+       , r ~ Const (Meta s)+       , rs ~ RDelete r ss+       , RElem r ss i+       , RSubset rs ss is )+    => SeekRep 'RelSeek+    -> Patch 'RelSeek ss a+    -> Either (Error s) (Patch s rs a)+align sBase (Patch a s ms) =+    case tryIntegerToNatural sAligned of+      Nothing          -> Left $ ErrorSeekBelow0 sAligned+      Just sAlignedNat ->+        case mExpected m of+          Nothing        -> reform sAlignedNat+          Just sExpected ->+            if   sExpected == sAlignedNat+            then reform sAlignedNat+            else Left $ ErrorDoesntMatchExpected sExpected sAlignedNat+  where+    sAligned = sBase + s+    -- TODO require a visible type application here, unsure why. even without+    -- the SeekRep indirection+    m = getConst @(Meta s) $ getFlap $ rget $ getFunctorRec ms+    ms' = FunctorRec $ rcast @rs $ getFunctorRec ms+    reform s' = Right $ Patch a s' ms'++tryIntegerToNatural :: Integer -> Maybe Natural+tryIntegerToNatural n | n < 0     = Nothing+                      | otherwise = Just $ naturalFromInteger n

@@ -0,0 +1,181 @@+{-# LANGUAGE RecordWildCards     #-}++module StreamPatch.Patch.Binary+  ( Meta(..)+  , MetaStream(..)+  , Cfg(..)+  , Error(..)+  , patchBinRep+  , BinRep(..)+  , toBinRep'+  , check+  ) where++import           StreamPatch.Patch++import           GHC.Generics       ( Generic )+import           GHC.Natural+import qualified Data.ByteString    as BS+import qualified Data.Text.Encoding as Text+import qualified Data.Text          as Text+import           Data.Text          ( Text )+import           Data.Either.Combinators+import           Data.Vinyl+import           Data.Functor.Const+import           Data.Vinyl.TypeLevel++type Bytes = BS.ByteString++data Meta = Meta+  { mMaxBytes :: Maybe (SeekRep 'FwdSeek)+  -- ^ Maximum number of bytes permitted to write at the associated position.+  } deriving (Eq, Show, Generic)++data MetaStream a = MetaStream+  { msNullTerminates :: Maybe (SeekRep 'FwdSeek)+  -- ^ Stream segment should be null bytes (0x00) only from this index onwards.++  , msExpected       :: Maybe a+  -- ^ Stream segment should be this.+  } deriving (Eq, Show, Generic, Functor, Foldable, Traversable)++data Cfg = Cfg+  { cfgAllowPartialExpected :: Bool+  -- ^ If enabled, allow partial expected bytes checking. If disabled, then even+  --   if the expected bytes are a prefix of the actual, fail.+  } deriving (Eq, Show, Generic)++data Error a+  = ErrorBadBinRep a String+  | ErrorUnexpectedNonNull Bytes+  | ErrorDidNotMatchExpected Bytes Bytes+  | ErrorBinRepTooLong Bytes Natural+    deriving (Eq, Show, Generic, Functor, Foldable, Traversable)++patchBinRep+    :: forall a s ss rs is i r+    .  ( BinRep a+       , Traversable (FunctorRec rs)+       , r ~ Const Meta+       , rs ~ RDelete r ss+       , RElem r ss i+       , RSubset rs ss is )+    => Patch s ss a+    -> Either (Error a) (Patch s rs Bytes)+patchBinRep (Patch a s ms) = do+    a' <- toBinRep' a+    () <- case mMaxBytes m of+            Nothing       -> return ()+            Just maxBytes -> if   BS.length a' > fromIntegral maxBytes+                             then Left $ ErrorBinRepTooLong a' maxBytes+                             else return ()+    let msDroppedMeta = FunctorRec $ rcast @rs $ getFunctorRec ms+    ms' <- traverse toBinRep' msDroppedMeta+    return $ Patch a' s ms'+  where+    toBinRep' x = mapLeft (\e -> ErrorBadBinRep x e) $ toBinRep x+    m = getConst @Meta $ getFlap $ rget $ getFunctorRec ms++{-++--checkBinRep :: BinRep => a -> Either String Bytes++binRep :: BinRep a => a -> Maybe Natural -> Either (Error a) Bytes+binRep a mN =+    case toBinRep a of+      Left  err -> Left $ ErrorBadBinRep a err+      Right bs  ->+        case mN of+          Nothing -> Right bs+          Just n  ->+            if   fromIntegral (BS.length bs) > n+            then Left $ ErrorBinRepTooLong bs n+            else Right bs++check :: BinRep a => Cfg -> Bytes -> MetaStream a -> Either (Error a) ()+check cfg bs meta = do+    case msExpected meta of+      Nothing -> Right ()+      Just aExpected -> do+        bsExpected <- binRep aExpected Nothing -- cheating a bit here+        case msNullTerminates meta of+          Nothing -> check' bs bsExpected+          Just nullsFrom ->+            let (bs', bsNulls) = BS.splitAt (fromIntegral nullsFrom) bs+             in if   bsNulls == BS.replicate (BS.length bsNulls) 0x00+                then check' bs' bsExpected+                else Left $ ErrorUnexpectedNonNull bs+  where+    check' bs' bsExpected =+        case checkExpected cfg bs' bsExpected of+          True  -> Right ()+          False -> Left $ ErrorDidNotMatchExpected bs' bsExpected++checkExpected :: Cfg -> Bytes -> Bytes -> Bool+checkExpected cfg bs bsExpected =+    case cfgAllowPartialExpected cfg of+      True  -> BS.isPrefixOf bs bsExpected+      False -> bs == bsExpected++-}++-- | Type has a binary representation for using in patchscripts.+--+-- Patchscripts are parsed parameterized over the type to edit. That type needs+-- to become a bytestring for eventual patch application. We're forced into+-- newtypes and typeclasses by Aeson already, so this just enables us to define+-- some important patch generation behaviour in one place. Similarly to Aeson,+-- if you require custom behaviour for existing types (e.g. length-prefixed+-- strings instead of C-style null terminated), define a newtype over it.+--+-- Some values may not have valid patch representations, for example if you're+-- patching a 1-byte length-prefixed string and your string is too long (>255+-- encoded bytes). Thus, 'toPatchRep' is failable.+class BinRep a where+    toBinRep :: a -> Either String Bytes++toBinRep' :: BinRep a => a -> Either (Error a) Bytes+toBinRep' a = mapLeft (ErrorBadBinRep a) $ toBinRep a++-- | Bytestrings are copied as-is.+instance BinRep BS.ByteString where+    toBinRep = Right . id++-- | Text is converted to UTF-8 bytes and null-terminated.+instance BinRep Text where+    toBinRep = Right . flip BS.snoc 0x00 . Text.encodeUtf8++-- | String is the same but goes the long way round, through Text.+instance BinRep String where+    toBinRep = toBinRep . Text.pack++check :: BinRep a => Cfg -> Bytes -> MetaStream a -> Either (Error a) ()+check cfg bs meta = do+    case msExpected meta of+      Nothing -> Right ()+      Just aExpected -> do+        bsExpected <- checkInner aExpected Nothing -- cheating a bit here+        case msNullTerminates meta of+          Nothing -> check' bs bsExpected+          Just nullsFrom ->+            let (bs', bsNulls) = BS.splitAt (fromIntegral nullsFrom) bs+             in if   bsNulls == BS.replicate (BS.length bsNulls) 0x00+                then check' bs' bsExpected+                else Left $ ErrorUnexpectedNonNull bs+  where+    check' bs' bsExpected =+        case checkExpected bs' bsExpected of+          True  -> Right ()+          False -> Left $ ErrorDidNotMatchExpected bs' bsExpected+    checkInner a mn = do+        bs <- toBinRep' a+        case mn of+          Nothing -> Right bs+          Just n  ->+            if   fromIntegral (BS.length bs) > n+            then Left $ ErrorBinRepTooLong bs n+            else Right bs+    checkExpected bs' bsExpected =+        case cfgAllowPartialExpected cfg of+          True  -> BS.isPrefixOf bs' bsExpected+          False -> bs' == bsExpected

@@ -0,0 +1,48 @@+{-| Newtype for manipulating length-prefixed strings.++This type is for UTF-8 'Text' that you intend to write out to a length-prefixed+bytestring. The size of the length field is static. You essentially have to+decide the maximum bytesize of the string on creation.+-}++module StreamPatch.Patch.Binary.PascalText where++import           StreamPatch.Patch.Binary ( BinRep(..) )++import qualified Data.Text.Encoding         as Text+import           Data.Text                  ( Text )+import qualified Data.ByteString            as BS+import           GHC.TypeNats+import           Data.Proxy+import           Data.Bits++newtype PascalText (n :: Nat) = PascalText { unPascalText :: Text }++instance KnownNat n => BinRep (PascalText n) where+    toBinRep t =+        case encodePascalText t of+          Nothing -> Left "UTF-8 encoded text too long for length prefix field"+          Just bs -> Right bs++encodePascalText :: forall n. KnownNat n => PascalText n -> Maybe BS.ByteString+encodePascalText t = do+    lenBs <- encodeToSizedBE (fromIntegral (natVal (Proxy @n))) (BS.length bs)+    return $ lenBs <> bs+  where+    bs = Text.encodeUtf8 . unPascalText $ t++encodeToSizedBE :: (Integral a, Bits a) => Int -> a -> Maybe BS.ByteString+encodeToSizedBE byteSize x =+    let bs = i2be x+        nulls = byteSize - BS.length bs+     in if   nulls < 0+        then Nothing+        else Just $ BS.replicate nulls 0x00 <> bs++-- | Re-encode an 'Integer' to a little-endian integer stored as a 'ByteString'+--   using the fewest bytes needed to represent it.+--+-- adapated from crypto-api 0.13.3, Crypto.Util.i2bs_unsized+i2be :: (Integral a, Bits a) => a -> BS.ByteString+i2be 0 = BS.singleton 0+i2be i = BS.reverse $ BS.unfoldr (\i' -> if i' <= 0 then Nothing else Just (fromIntegral i', (i' `shiftR` 8))) i

@@ -0,0 +1,58 @@+module StreamPatch.Patch.Linearize where++import           StreamPatch.Patch++import           GHC.Generics ( Generic )+import           Numeric.Natural+import           GHC.Natural ( minusNaturalMaybe )+import           Data.Vinyl++import           Control.Monad.State+import qualified Data.List              as List+import qualified Data.ByteString        as BS+import qualified Data.Text              as Text+import           Data.Text              ( Text )+import           Util ( traverseM )++class HasLength a where+    getLength :: a -> Natural++instance HasLength BS.ByteString where+    getLength = fromIntegral . BS.length+instance HasLength Text where+    getLength = fromIntegral . Text.length+instance HasLength String where+    getLength = fromIntegral . List.length++data Error fs a+  = ErrorOverlap -- ^ Two edits wrote to the same offset.+        (SeekRep 'AbsSeek)    -- ^ absolute position in stream+        (Patch 'AbsSeek fs a) -- ^ overlapping patch+        (Patch 'AbsSeek fs a) -- ^ previous patch+    deriving (Generic)++deriving instance (Eq a, Eq (Patch 'AbsSeek fs a)) => Eq (Error fs a)+deriving instance (Show a, ReifyConstraint Show (Flap a) fs, RMap fs, RecordToList fs) => Show (Error fs a)+deriving instance (Functor     (Patch 'AbsSeek fs)) => Functor     (Error fs)+deriving instance (Foldable    (Patch 'AbsSeek fs)) => Foldable    (Error fs)+deriving instance (Traversable (Patch 'AbsSeek fs)) => Traversable (Error fs)++linearize+    :: HasLength a+    => [Patch 'AbsSeek fs a]+    -> Either (Error fs a) [Patch 'FwdSeek fs a]+linearize ps = evalState (traverseM go (List.sortBy comparePatchSeeks ps)) (0, undefined)+  where+    go p@(Patch a s _)  = do+        (cursor, pPrev) <- get+        case s `minusNaturalMaybe` cursor of+          -- next absolute seek is before cursor: current patch overlaps prev+          Nothing -> return $ Left $ ErrorOverlap cursor p pPrev+          Just skip -> do+            let cursor' = cursor + skip + getLength a+                p' = p { patchSeek = skip }+            put (cursor', p)+            return $ Right p'++comparePatchSeeks :: Ord (SeekRep s) => Patch s fs a -> Patch s fs a -> Ordering+comparePatchSeeks p1 p2 = compare (patchSeek p1) (patchSeek p2)

@@ -0,0 +1,81 @@+module StreamPatch.Stream where++import           StreamPatch.Patch++import           Util++import           Data.Vinyl+import           GHC.Natural+import           Data.Kind+import qualified Data.ByteString            as BS+import qualified Data.ByteString.Builder    as BB+import qualified Data.ByteString.Lazy       as BL+import           Control.Monad.State+import           Control.Monad.Reader+import           System.IO                  ( Handle, SeekMode(..), hSeek )++import qualified Data.List                  as List++-- TODO also require reporting cursor position (for error reporting)+class Monad m => MonadFwdStream m where+    type Chunk m :: Type++    -- | Read a number of bytes without advancing the cursor.+    readahead :: Natural -> m (Chunk m)++    -- | Advance cursor without reading.+    advance :: Natural -> m ()++    -- | Insert bytes into the stream at the cursor position, overwriting+    --   existing bytes.+    overwrite :: Chunk m -> m ()++-- TODO Need MonoTraversable to define for Text, ByteString etc easily. Bleh. I+-- think Snoyman's advice is to reimplement. Also bleh.+instance Monad m => MonadFwdStream (StateT ([a], [a]) m) where+    type Chunk (StateT ([a], [a]) m) = [a]+    readahead n = List.take (fromIntegral n) <$> gets fst+    advance n = do+        (src, out) <- get+        let (bs, src') = List.splitAt (fromIntegral n) src+        put (src', out <> bs)+    overwrite bs = do+        (src, out) <- get+        let (_, src') = List.splitAt (List.length bs) src+        put (src', out <> bs)++instance MonadIO m => MonadFwdStream (ReaderT Handle m) where+    type Chunk (ReaderT Handle m) = BS.ByteString+    readahead n = do+        hdl <- ask+        bs <- liftIO $ BS.hGet hdl (fromIntegral n)+        liftIO $ hSeek hdl RelativeSeek (- fromIntegral n)+        return bs+    advance n = do+        hdl <- ask+        liftIO $ hSeek hdl RelativeSeek (fromIntegral n)+    overwrite bs = do+        hdl <- ask+        liftIO $ BS.hPut hdl bs++instance Monad m => MonadFwdStream (StateT (BS.ByteString, BB.Builder) m) where+    type Chunk (StateT (BS.ByteString, BB.Builder) m) = BS.ByteString+    readahead n = BS.take (fromIntegral n) <$> gets fst+    advance n = do+        (src, out) <- get+        let (bs, src') = BS.splitAt (fromIntegral n) src+        put (src', out <> BB.byteString bs)+    overwrite bs = do+        (src, out) <- get+        let (_, src') = BS.splitAt (BS.length bs) src+        put (src', out <> BB.byteString bs)++-- | A forward stream, but backward too.+class MonadFwdStream m => MonadCursorStream m where+    -- | Move cursor.+    move :: Integer -> m ()++instance MonadIO m => MonadCursorStream (ReaderT Handle m) where+    move n = do+        hdl <- ask+        liftIO $ hSeek hdl RelativeSeek (fromIntegral n)

@@ -0,0 +1,19 @@+module Util where++import           Data.Foldable ( sequenceA_ )++-- lol. ty hw-kafka-client+traverseM+    :: (Traversable t, Applicative f, Monad m)+    => (v -> m (f v'))+    -> t v+    -> m (f (t v'))+traverseM f xs = sequenceA <$> traverse f xs++-- wonder if this is the correct type? oh well it works+traverseM_+    :: (Traversable t, Applicative f, Monad m)+    => (v -> m (f ()))+    -> t v+    -> m (f ())+traverseM_ f xs = sequenceA_ <$> traverse f xs

@@ -0,0 +1,23 @@+module BytePatch.HexByteStringSpec ( spec ) where++import           BytePatch.HexByteString+import           Test.Hspec+import           Util++import qualified Data.ByteString                as BS++spec :: Spec+spec = do+    let parse = parseFromCharStream parseHexByteString+        bs = BS.pack+    it "parses valid hex bytestrings" $ do+      parse "00" `shouldBe` Just (bs [0x00])+      parse "FF" `shouldBe` Just (bs [0xFF])+      parse "1234" `shouldBe` Just (bs [0x12, 0x34])+      parse "01 9A FE" `shouldBe` Just (bs [0x01, 0x9A, 0xFE])+      parse "FFFFFFFF" `shouldBe` Just (BS.replicate 4 0xFF)+      parse "12 34    AB CD" `shouldBe` Just (bs [0x12, 0x34, 0xAB, 0xCD])+    it "fails to parse invalid hex bytestrings" $ do+      parse "-00" `shouldBe` Nothing+      parse "FG" `shouldBe` Nothing+      parse "0x1234" `shouldBe` Nothing

@@ -1,23 +0,0 @@-module BytePatch.Pretty.HexByteStringSpec ( spec ) where--import           BytePatch.Pretty.HexByteString-import           Test.Hspec-import           Util--import qualified Data.ByteString                as BS--spec :: Spec-spec = do-    let parse = parseFromCharStream parseHexByteString-        bs = BS.pack-    it "parses valid hex bytestrings" $ do-      parse "00" `shouldBe` Just (bs [0x00])-      parse "FF" `shouldBe` Just (bs [0xFF])-      parse "1234" `shouldBe` Just (bs [0x12, 0x34])-      parse "01 9A FE" `shouldBe` Just (bs [0x01, 0x9A, 0xFE])-      parse "FFFFFFFF" `shouldBe` Just (BS.replicate 4 0xFF)-      parse "12 34    AB CD" `shouldBe` Just (bs [0x12, 0x34, 0xAB, 0xCD])-    it "fails to parse invalid hex bytestrings" $ do-      parse "-00" `shouldBe` Nothing-      parse "FG" `shouldBe` Nothing-      parse "0x1234" `shouldBe` Nothing

@@ -0,0 +1,48 @@+module StreamPatch.ApplySpec ( spec ) where++import           StreamPatch.Apply+import           Test.Hspec+import           Test.Hspec.QuickCheck+import           Test.QuickCheck+import           Util++import           StreamPatch.Patch+import           Data.Functor.Const+import           Data.Vinyl+import           GHC.Natural++spec :: Spec+spec = do+    let patch' ps = runPureSimpleFwdList $ makePatchscript ps+    it "applies valid simple forward in-place patches" $ do+      patch' []           "1234567890" `shouldBe` "1234567890"+      patch' [(0, "XXX")] "1234567890" `shouldBe` "XXX4567890"+      patch' [(1, "XXX")] "1234567890" `shouldBe` "1XXX567890"+      patch' [(7, "XXX")] "1234567890" `shouldBe` "1234567XXX"+    prop "applies valid generated simple forward in-place patches" $ do+      \n -> forAll (genPatchList @Char n) $+        \ps -> forAll (genBoundList @Char n n) $+          \a -> pendingWith "cba to reimplement patcher"+                -- patchListPure ps a `shouldBe` manualPatch ps a++-- | "Verified" implementation of a simple patch algorithm.+--+-- nah I cba lol just trust me+--manualPatch :: [Patch 'FwdSeek '[] [a]] -> [a] -> [a]++genPatchList :: Arbitrary a => Natural -> Gen [Patch 'FwdSeek '[] [a]]+genPatchList = skip []+  where+    skip ps n = do+        -- why no Random Natural...+        nSkip <- choose (0, naturalToInteger n)+        gen ps (naturalFromInteger nSkip) $ n - (fromIntegral nSkip)+    gen ps _     0 = return ps+    gen ps nSkip n = do+        a <- genBoundList n 1+        let n' = n - (fromIntegral (length a))+        skip (makePatch a nSkip : ps) n'++genBoundList :: Arbitrary a => Natural -> Natural -> Gen [a]+genBoundList x y =+    arbitrary `suchThat` \l -> fromIntegral (length l) <= x && fromIntegral (length l) >= y

@@ -0,0 +1,28 @@+module StreamPatch.Patch.AlignSpec ( spec ) where++import           StreamPatch.Patch.Align+import           Test.Hspec+import           Util++import           StreamPatch.Patch+import           Data.Vinyl+import           Data.Functor.Const+import           GHC.Natural++makeUnalignedPatch+    :: [(Integer, a)]+    -> [Patch 'RelSeek '[Const (Meta 'FwdSeek)] a]+makeUnalignedPatch = map go+  where go (n, a) = Patch a n $ FunctorRec $ Flap (Const (Meta Nothing)) :& RNil++align'+    :: Integer -> [(Integer, String)]+    -> Either (Error 'FwdSeek) [Patch 'FwdSeek '[] String]+align' sBase = traverse (align sBase) . makeUnalignedPatch++spec :: Spec+spec = do+    it "aligns valid simple patches" $ do+      align' 0 [] `shouldBe` Right (makePatchscript [])+      align' 0 [(0, "XXX")] `shouldBe` Right (makePatchscript [(0, "XXX")])+      align' 5 [(0, "XXX"), ((-5), "XXX")] `shouldBe` Right (makePatchscript [(5, "XXX"), (0, "XXX")])

@@ -0,0 +1,19 @@+module StreamPatch.Patch.LinearizeSpec ( spec ) where++import           StreamPatch.Patch.Linearize+import           Test.Hspec+import           Util++import           StreamPatch.Patch+import           Data.Functor.Const+import           Data.Either.Combinators+import           GHC.Natural+import           Optics+import           Data.Generics.Product.Any++spec :: Spec+spec = do+    let p  = makePatch' @'AbsSeek+        p' = makePatch' @'FwdSeek+    it "linearizes a simple valid patch" $ do+      linearize [p "1" 1, p "5" 5, p "2" 2] `shouldBe` Right [p' "1" 1, p' "2" 0, p' "5" 2]

@@ -1,10 +1,29 @@-{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Util where +import           StreamPatch.Patch+import           Data.Vinyl import           Text.Megaparsec import           Data.Void+import           GHC.Natural+import           Test.QuickCheck  --parseFromCharStream :: (MonadParsec e s m, Token s ~ Char) => m a -> s -> Maybe a parseFromCharStream :: (Stream s, Token s ~ Char) => Parsec Void s a -> s -> Maybe a parseFromCharStream parser text = parseMaybe parser text++-- TODO this is in quickcheck-instances+instance Arbitrary Natural where+  arbitrary = arbitrarySizedNatural+  shrink    = shrinkIntegral++makePatch :: a -> Natural -> Patch 'FwdSeek '[] a+makePatch a n = Patch a n $ FunctorRec RNil++makePatch' :: forall s a. a -> SeekRep s -> Patch s '[] a+makePatch' a n = Patch a n $ FunctorRec RNil++makePatchscript :: [(Natural, a)] -> [Patch 'FwdSeek '[] a]+makePatchscript = map go+  where go (n, a) = makePatch a n