diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +## 0.2.0 (2021-12-03) +Initial release. + + * extracted & rewrote tool (library + CLI) from gtvm-hs diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2021 Ben Orchard (@raehik) + +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Config.hs b/app/Config.hs new file mode 100644 --- /dev/null +++ b/app/Config.hs @@ -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) diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/app/Options.hs b/app/Options.hs new file mode 100644 --- /dev/null +++ b/app/Options.hs @@ -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)) diff --git a/bytepatch.cabal b/bytepatch.cabal new file mode 100644 --- /dev/null +++ b/bytepatch.cabal @@ -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 diff --git a/src/BytePatch/Core.hs b/src/BytePatch/Core.hs new file mode 100644 --- /dev/null +++ b/src/BytePatch/Core.hs @@ -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) diff --git a/src/BytePatch/JSON.hs b/src/BytePatch/JSON.hs new file mode 100644 --- /dev/null +++ b/src/BytePatch/JSON.hs @@ -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 diff --git a/src/BytePatch/Linear/Core.hs b/src/BytePatch/Linear/Core.hs new file mode 100644 --- /dev/null +++ b/src/BytePatch/Linear/Core.hs @@ -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) diff --git a/src/BytePatch/Linear/Gen.hs b/src/BytePatch/Linear/Gen.hs new file mode 100644 --- /dev/null +++ b/src/BytePatch/Linear/Gen.hs @@ -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) diff --git a/src/BytePatch/Linear/Patch.hs b/src/BytePatch/Linear/Patch.hs new file mode 100644 --- /dev/null +++ b/src/BytePatch/Linear/Patch.hs @@ -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) +-} diff --git a/src/BytePatch/Pretty.hs b/src/BytePatch/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/BytePatch/Pretty.hs @@ -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) diff --git a/src/BytePatch/Pretty/HexByteString.hs b/src/BytePatch/Pretty/HexByteString.hs new file mode 100644 --- /dev/null +++ b/src/BytePatch/Pretty/HexByteString.hs @@ -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 diff --git a/src/BytePatch/Pretty/PascalText.hs b/src/BytePatch/Pretty/PascalText.hs new file mode 100644 --- /dev/null +++ b/src/BytePatch/Pretty/PascalText.hs @@ -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) diff --git a/src/BytePatch/Pretty/PatchRep.hs b/src/BytePatch/Pretty/PatchRep.hs new file mode 100644 --- /dev/null +++ b/src/BytePatch/Pretty/PatchRep.hs @@ -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 diff --git a/test/BytePatch/Pretty/HexByteStringSpec.hs b/test/BytePatch/Pretty/HexByteStringSpec.hs new file mode 100644 --- /dev/null +++ b/test/BytePatch/Pretty/HexByteStringSpec.hs @@ -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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/Util.hs b/test/Util.hs new file mode 100644 --- /dev/null +++ b/test/Util.hs @@ -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