packages feed

bytepatch (empty) → 0.2.0

raw patch · 20 files changed

+968/−0 lines, 20 filesdep +aesondep +basedep +bytepatchsetup-changed

Dependencies added: aeson, base, bytepatch, bytestring, generic-optics, hspec, megaparsec, mtl, optics, optparse-applicative, text, yaml

Files

+ CHANGELOG.md view
@@ -0,0 +1,4 @@+## 0.2.0 (2021-12-03)+Initial release.++  * extracted & rewrote tool (library + CLI) from gtvm-hs
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2021 Ben Orchard (@raehik) <thefirstmuffinman@gmail.com>++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,54 @@+# bytepatch+A 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.++## What?+If you're modifying binaries, you often end up needing to make edits in a hex+editor. This is fun for a very short while, then you realise how easy it is to+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.++## When might I want to use this?+You might find bytepatch useful if you want to define edits to be made on binary+files (especially executables) that are *static* and *in-place*.++### Less relevant use cases+You can't use bytepatch directly for edits which are dynamic in nature (e.g.+you need to read a file header in order to know what to change). *(You could+have a patch preparer that does the dynamic work and emits a bytepatch patch,+but this tool is largely focused the patch representation, so you wouldn't be+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+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.++### Original rationale+I'm working on some binary files, and need to patch strings, machine code and+other data. I make some changes, I test them, they work. Then I note down the+changes I made. It's tedious and repetitive, but I really don't want to lose+track of what got changed how, and it's the clearest way to share my work+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.++## License+Provided under the MIT license. Please see `LICENSE` for the full license text.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Config.hs view
@@ -0,0 +1,17 @@+module Config where++import qualified BytePatch.Linear.Patch++data Config = Config+  { cfgPatchCfg    :: BytePatch.Linear.Patch.Cfg+  , cfgPatchscript :: FilePath+  , cfgStreamInOut :: CStreamInOut+  } deriving (Eq, Show)++-- | "Single file" stream.+data CStream+  = CStreamFile FilePath+  | CStreamStd+    deriving (Eq, Show)++newtype CStreamInOut = CStreamInOut { unCStreamInOut :: (CStream, CStream) } deriving (Eq, Show)
+ app/Main.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Main ( main ) where++import           Config+import qualified Options++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           Control.Monad.IO.Class+import qualified Data.ByteString            as BS+import qualified Data.Yaml                  as Yaml+import           Data.Aeson                 ( FromJSON )+import           Data.Text                  ( Text )++type Bytes = BS.ByteString++main :: IO ()+main = Options.parse >>= run++run :: MonadIO m => Config -> m ()+run cfg = do+    return ()+    tryReadPatchscript @Text (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+              (_, _:_)  -> quit "failed while generating patchscript"+              (ps', []) -> quit "TODO actually patch"++quit :: MonadIO m => String -> m ()+quit = liftIO . putStrLn++tryReadPatchscript :: forall a m. (PatchRep a, FromJSON a, MonadIO m) => FilePath -> m (Maybe [MultiPatches a])+tryReadPatchscript = tryDecodeYaml++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
+ app/Options.hs view
@@ -0,0 +1,39 @@+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))
+ bytepatch.cabal view
@@ -0,0 +1,154 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name:           bytepatch+version:        0.2.0+synopsis:       Patch byte-representable data in a bytestream.+homepage:       https://github.com/raehik/bytepatch#readme+bug-reports:    https://github.com/raehik/bytepatch/issues+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/raehik/bytepatch++library+  exposed-modules:+      BytePatch.Core+      BytePatch.JSON+      BytePatch.Linear.Core+      BytePatch.Linear.Gen+      BytePatch.Linear.Patch+      BytePatch.Pretty+      BytePatch.Pretty.HexByteString+      BytePatch.Pretty.PascalText+      BytePatch.Pretty.PatchRep+  other-modules:+      Paths_bytepatch+  hs-source-dirs:+      src+  default-extensions:+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      InstanceSigs+      MultiParamTypeClasses+      LambdaCase+      DeriveGeneric+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      GeneralizedNewtypeDeriving+      StandaloneDeriving+      BangPatterns+      KindSignatures+      TypeOperators+      TypeApplications+  build-depends:+      aeson >=1.5 && <2.1+    , base >=4.12 && <4.17+    , bytestring >=0.10 && <0.12+    , generic-optics >=2.1 && <2.4+    , megaparsec >=9.0 && <9.3+    , mtl ==2.2.*+    , optics >=0.3 && <0.5+    , text ==1.2.*+  default-language: Haskell2010++executable bytepatch+  main-is: Main.hs+  other-modules:+      Config+      Options+      Paths_bytepatch+  hs-source-dirs:+      app+  default-extensions:+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      InstanceSigs+      MultiParamTypeClasses+      LambdaCase+      DeriveGeneric+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      GeneralizedNewtypeDeriving+      StandaloneDeriving+      BangPatterns+      KindSignatures+      TypeOperators+      TypeApplications+  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+    , generic-optics >=2.1 && <2.4+    , megaparsec >=9.0 && <9.3+    , mtl ==2.2.*+    , optics >=0.3 && <0.5+    , optparse-applicative >=0.16.1 && <0.17+    , text ==1.2.*+    , yaml >=0.11.7 && <0.12+  default-language: Haskell2010++test-suite spec+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      BytePatch.Pretty.HexByteStringSpec+      Util+      Paths_bytepatch+  hs-source-dirs:+      test+  default-extensions:+      EmptyCase+      FlexibleContexts+      FlexibleInstances+      InstanceSigs+      MultiParamTypeClasses+      LambdaCase+      DeriveGeneric+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveLift+      DeriveTraversable+      DerivingStrategies+      GeneralizedNewtypeDeriving+      StandaloneDeriving+      BangPatterns+      KindSignatures+      TypeOperators+      TypeApplications+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      aeson >=1.5 && <2.1+    , base >=4.12 && <4.17+    , bytepatch+    , bytestring >=0.10 && <0.12+    , generic-optics >=2.1 && <2.4+    , hspec+    , megaparsec >=9.0 && <9.3+    , mtl ==2.2.*+    , optics >=0.3 && <0.5+    , text ==1.2.*+  default-language: Haskell2010
+ src/BytePatch/Core.hs view
@@ -0,0 +1,17 @@+module BytePatch.Core where++-- | A single in-place edit.+--+-- Overwrites may store extra metadata that can be used at patch time to+-- validate input data (i.e. check we're patching the expected file).+data Overwrite a = Overwrite a (OverwriteMeta a)+    deriving (Eq, Show)++-- | Optional patch time data for an overwrite.+data OverwriteMeta a = OverwriteMeta+  { omNullTerminates :: Maybe Int+  -- ^ Stream segment should be null bytes (0x00) only from this index onwards.++  , omExpected       :: Maybe a+  -- ^ Stream segment should be this.+  } deriving (Eq, Show, Functor, Foldable, Traversable)
+ src/BytePatch/JSON.hs view
@@ -0,0 +1,57 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Aeson instances for various types.+module BytePatch.JSON where++import           BytePatch.Core+import           BytePatch.Pretty+import           BytePatch.Pretty.HexByteString+import           Data.Aeson+import           GHC.Generics       (Generic)+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   (MultiPatches a) where+    toJSON     = genericToJSON     (jsonCfgCamelDrop 3)+    toEncoding = genericToEncoding (jsonCfgCamelDrop 3)+instance FromJSON a => FromJSON (MultiPatches a) where+    parseJSON  = genericParseJSON  (jsonCfgCamelDrop 3)++instance ToJSON   a => ToJSON   (MultiPatch a) where+    toJSON     = genericToJSON     (jsonCfgCamelDrop 2)+    toEncoding = genericToEncoding (jsonCfgCamelDrop 2)+instance FromJSON a => FromJSON (MultiPatch a) where+    parseJSON  = genericParseJSON  (jsonCfgCamelDrop 2)++instance ToJSON   a => ToJSON   (Offset a) where+    toJSON     = genericToJSON     (jsonCfgCamelDrop 1)+    toEncoding = genericToEncoding (jsonCfgCamelDrop 1)+instance FromJSON a => FromJSON (Offset a) where+    parseJSON  = genericParseJSON  (jsonCfgCamelDrop 1)++deriving instance Generic (OverwriteMeta a)+instance ToJSON   a => ToJSON   (OverwriteMeta a) where+    toJSON     = genericToJSON     (jsonCfgCamelDrop 2)+    toEncoding = genericToEncoding (jsonCfgCamelDrop 2)+instance FromJSON a => FromJSON (OverwriteMeta a) where+    parseJSON  = genericParseJSON  (jsonCfgCamelDrop 2)++deriving instance Generic (Overwrite a)+instance ToJSON   a => ToJSON   (Overwrite a) where+    toJSON     = genericToJSON     defaultOptions+    toEncoding = genericToEncoding defaultOptions+instance FromJSON a => FromJSON (Overwrite a) where+    parseJSON  = genericParseJSON  defaultOptions
+ src/BytePatch/Linear/Core.hs view
@@ -0,0 +1,13 @@+module BytePatch.Linear.Core where++import           BytePatch.Core++-- | A list of "keep n bytes, write data in-place" actions.+type Patchscript a = [(Int, Overwrite a)]++-- | Write the given data into the given offset.+data Patch a = Patch+  { patchContents :: a+  , patchOffset   :: Int+  , patchMeta     :: OverwriteMeta a+  } deriving (Eq, Show)
+ src/BytePatch/Linear/Gen.hs view
@@ -0,0 +1,52 @@+module BytePatch.Linear.Gen (gen, Error(..)) where++import           BytePatch.Core+import           BytePatch.Linear.Core++import qualified Data.ByteString        as BS+import           Control.Monad.State+import qualified Data.List              as List++type Bytes = BS.ByteString++-- | Error encountered during linear patchscript generation.+data Error a+  = ErrorOverlap (Patch a) (Patch a)+  -- ^ Two edits wrote to the same offset.+    deriving (Eq, Show)++-- | Process an offset patchscript into a linear patchscript.+--+-- 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 Bytes] -> (Patchscript Bytes, [Error 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 (Int, Patchscript Bytes, [Error Bytes], Patch Bytes) m) => [Patch Bytes] -> m ()+    go [] = return ()+    go (p@(Patch bs offset meta):ps) = do+        (cursor, script, errors, prevPatch) <- get+        case trySkipTo offset cursor of+          -- next offset is behind current cursor: overlapping patches+          -- record error, recover via dropping patch+          Left _ -> do+            let e = ErrorOverlap p prevPatch+            let errors' = e : errors+            put (cursor, script, errors', p)+            go ps+          Right skip -> do+            let cursor' = cursor + skip + BS.length bs+                o       = Overwrite bs meta+            put (cursor', (skip, o):script, errors, p)+            go ps+    trySkipTo to from =+        let diff = to - from in if diff >= 0 then Right diff else Left (-diff)
+ src/BytePatch/Linear/Patch.hs view
@@ -0,0 +1,139 @@+{- | 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+  , MonadFwdByteStream(..)+  , Cfg(..)+  , Error(..)+  ) where++import           BytePatch.Core+import           BytePatch.Linear.Core++import qualified Data.ByteString         as BS+import qualified Data.ByteString.Builder as BB+import           Control.Monad.State+import           Control.Monad.Reader+import           System.IO               ( Handle, SeekMode(..), hSeek )++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 :: Int -> m Bytes++    -- | Advance cursor without reading.+    advance :: Int -> 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 = do+        (src, out) <- get+        let (bs, src') = BS.splitAt n src+        put (src', out)+        return bs+    advance n = do+        (src, out) <- get+        let (bs, src') = BS.splitAt 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 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 -> Patchscript Bytes -> m (Maybe Error)+patch cfg = go+  where+    go [] = return Nothing+    go ((n, Overwrite bs meta):es) = do+        advance n+        bsStream <- readahead $ BS.length bs -- TODO catch overlong error++        -- if provided, strip trailing nulls from to-overwrite bytestring+        case tryStripNulls bsStream (omNullTerminates meta) of+          Nothing -> return $ Just ErrorPatchUnexpectedNonnull+          Just bsStream' -> do++            -- if provided, check the to-overwrite bytestring matches expected+            case checkExpected bsStream' (omExpected 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)++{-+finishPurePatch :: (BS.ByteString, BB.Builder) -> BL.ByteString+finishPurePatch (src, out) = BB.toLazyByteString $ out <> BB.byteString src++tmpExPatchscript :: Patchscript+tmpExPatchscript =+  [ (1, "ABC")+  , (2, "DEFG") ]++tmpExInitialState :: (BS.ByteString, BB.Builder)+tmpExInitialState = ("abcdefghijklmnopqrstuvwxyz", mempty)+-}
+ src/BytePatch/Pretty.hs view
@@ -0,0 +1,170 @@+-- | Convenience interface to enable defining edits at offsets with some+--   optional safety checks.++module BytePatch.Pretty+  (+  -- * Core types+    MultiPatches(..)+  , MultiPatch(..)+  , Offset(..)++  -- * Convenience functions+  , normalizeSimple++  -- * Low-level interface+  , applyBaseOffset+  , listAlgebraConcatEtc+  , normalize+  ) where++import           BytePatch.Core+import           BytePatch.Linear.Core+import           BytePatch.Pretty.PatchRep++import qualified Data.ByteString            as BS+import           Data.Maybe                 ( fromMaybe )+import           GHC.Generics               ( Generic )++type Bytes = BS.ByteString++-- | Normalize a set of 'MultiPatches', discarding everything on error.+normalizeSimple :: PatchRep a => [MultiPatches a] -> Maybe [Patch Bytes]+normalizeSimple mps =+    let (p, errs) = listAlgebraConcatEtc . map applyBaseOffset $ mps+     in case errs of+          _:_ -> Nothing+          []  -> normalize p++-- | A list of patches sharing a configuration, each applied at a list of+--   offsets, abstracted over patch type.+data MultiPatches a = MultiPatches+  { mpsBaseOffset :: Maybe Int+  -- ^ The base offset from which all offsets are located. Subtracted from each+  --   offset value to obtain the actual offset. Any offset located before the+  --   base offset (x where x < base) is discarded as erroneous.+  --+  -- This feature enables us to allow negative offsets. For example, say you set+  -- the base offset to @-10@. This is equivalent to stating that every offset+  -- in the list is to be shifted +10 bytes. Thus, all offsets x where x >= -10+  -- are now valid.+  --+  -- The original rationale behind this feature was to ease assembly patches on+  -- ELFs. Decompilers focus on virtual addresses, and apparently (in my+  -- experience) don't like to divulge physical file offsets. However, we can+  -- recover the physical offset of any virtual address via the following steps:+  --+  --   1. subtract the containing ELF segment's virtual address+  --   2.      add the containing ELF segment's physical offset+  --+  -- So we can prepare a base offset @elf_vaddr - elf_phys_offset@, which we can+  -- subtract from any virtual address inside that segment to retrieve its+  -- related byte offset in the ELF file. Thus, you need do that calculation+  -- manually once for every segment you patch, then you can use your+  -- decompiler's virtual addresses!+  --+  -- You can even specify absolute offsets, which are compared to the calculated+  -- actual offsets. So you get the best of both worlds!+  --+  -- Absolute offsets are only used for asserting correctness of calculated+  -- actual offsets. If you want to mix absolute and base-relative offsets...+  -- don't. I'm loath to support that, because I believe it would serve only to+  -- confuse the patch file interface. Instead, group patches into absolute+  -- (base offset = 0) and base-relative lists.++  , mpsPatches :: [MultiPatch a]+  } deriving (Eq, Show, Generic)++-- | A single patch applied at a list of offsets, parameterized by patch type.+data MultiPatch a = MultiPatch+  { mpContents    :: a+  -- ^ The value to patch in. Likely a bytestring or text for simple uses.+  , mpOffsets     :: [Offset a]+  } deriving (Eq, Show, Generic)++-- | An offset in a stream, with metadata about it to use when preparing the+--   patch and at patch time.+data Offset a = Offset+  { oOffset         :: Int+  -- ^ Stream offset to patch at.++  , oAbsoluteOffset :: Maybe Int+  -- ^ Absolute stream offset to patch at. Compared with actual offset+  --   (calculated from offset and base offset).++  , oMaxLength      :: Maybe Int+  -- ^ Maximum bytestring length allowed to patch in at this offset.+  -- TODO: use single range/span instead (default 0->x, also allow y->x)++  , oPatchMeta      :: Maybe (OverwriteMeta a)+  -- ^ Patch-time info for the overwrite at this offset.+  --+  -- Named "patch meta" instead of the more correct "overwrite meta" for more+  -- friendly JSON field naming. We wrap it in a 'Maybe' for similar reasons,+  -- plus it means the default can be inserted later on.+  } deriving (Eq, Show, Generic)++-- Drops no info, not easy to consume.+applyBaseOffset :: MultiPatches a -> (Int, [(MultiPatch a, [Offset a])])+applyBaseOffset mps =+    (baseOffset, recalculateMultiPatchOffsets baseOffset (mpsPatches mps))+      where baseOffset = fromMaybe 0 (mpsBaseOffset mps)++-- 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 :: Int -> [MultiPatch a] -> [(MultiPatch a, [Offset a])]+recalculateMultiPatchOffsets baseOffset = map go+  where+    go :: MultiPatch a -> (MultiPatch a, [Offset a])+    go mp =+        let (osRecalculated, osInvalid) = recalculateOffsets baseOffset (mpOffsets mp)+         in (mp { mpOffsets = osRecalculated }, osInvalid)++recalculateOffsets :: Int -> [Offset a] -> ([Offset a], [Offset a])+recalculateOffsets baseOffset = partitionMaybe go+  where+    go o = if actualOffset >= 0 then Just (o { oOffset = actualOffset }) else Nothing+      where actualOffset = oOffset o - baseOffset++normalize :: PatchRep a => [MultiPatch a] -> Maybe [Patch Bytes]+normalize xs = concat <$> mapM go xs+  where go (MultiPatch contents os) = mapM (tryMakeSingleReplace contents) os++-- TODO now can error with "[expected] content has no valid patch rep"+tryMakeSingleReplace :: PatchRep a => a -> Offset a -> Maybe (Patch Bytes)+tryMakeSingleReplace contents (Offset os maos maxLen mMeta) =+    case toPatchRep contents of+      Left errStr -> error errStr -- TODO+      Right bs ->+        if   offsetIsCorrect+        then case maxLen of+               Just len -> if BS.length bs > len 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 { patchContents = bs+                                                 , patchOffset   = os+                                                 , patchMeta     = meta' }+    meta = fromMaybe (OverwriteMeta 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)
+ src/BytePatch/Pretty/HexByteString.hs view
@@ -0,0 +1,62 @@+{- |+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
+ src/BytePatch/Pretty/PascalText.hs view
@@ -0,0 +1,56 @@+{-| 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)
+ src/BytePatch/Pretty/PatchRep.hs view
@@ -0,0 +1,29 @@+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
+ test/BytePatch/Pretty/HexByteStringSpec.hs view
@@ -0,0 +1,23 @@+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
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/Util.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE TypeFamilies #-}++module Util where++import           Text.Megaparsec+import           Data.Void++--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