diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/app/CLI.hs b/app/CLI.hs new file mode 100644 --- /dev/null +++ b/app/CLI.hs @@ -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)) diff --git a/app/Config.hs b/app/Config.hs --- a/app/Config.hs +++ b/app/Config.hs @@ -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) diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 +-} diff --git a/app/Options.hs b/app/Options.hs deleted file mode 100644 --- a/app/Options.hs +++ /dev/null @@ -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)) diff --git a/bytepatch.cabal b/bytepatch.cabal --- a/bytepatch.cabal +++ b/bytepatch.cabal @@ -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 diff --git a/src/BytePatch.hs b/src/BytePatch.hs new file mode 100644 --- /dev/null +++ b/src/BytePatch.hs @@ -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 diff --git a/src/BytePatch/Core.hs b/src/BytePatch/Core.hs deleted file mode 100644 --- a/src/BytePatch/Core.hs +++ /dev/null @@ -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) diff --git a/src/BytePatch/HexByteString.hs b/src/BytePatch/HexByteString.hs new file mode 100644 --- /dev/null +++ b/src/BytePatch/HexByteString.hs @@ -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 diff --git a/src/BytePatch/JSON.hs b/src/BytePatch/JSON.hs deleted file mode 100644 --- a/src/BytePatch/JSON.hs +++ /dev/null @@ -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 diff --git a/src/BytePatch/Linear/Gen.hs b/src/BytePatch/Linear/Gen.hs deleted file mode 100644 --- a/src/BytePatch/Linear/Gen.hs +++ /dev/null @@ -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 diff --git a/src/BytePatch/Linear/Patch.hs b/src/BytePatch/Linear/Patch.hs deleted file mode 100644 --- a/src/BytePatch/Linear/Patch.hs +++ /dev/null @@ -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' diff --git a/src/BytePatch/Pretty.hs b/src/BytePatch/Pretty.hs deleted file mode 100644 --- a/src/BytePatch/Pretty.hs +++ /dev/null @@ -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) diff --git a/src/BytePatch/Pretty/HexByteString.hs b/src/BytePatch/Pretty/HexByteString.hs deleted file mode 100644 --- a/src/BytePatch/Pretty/HexByteString.hs +++ /dev/null @@ -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 diff --git a/src/BytePatch/Pretty/PascalText.hs b/src/BytePatch/Pretty/PascalText.hs deleted file mode 100644 --- a/src/BytePatch/Pretty/PascalText.hs +++ /dev/null @@ -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) diff --git a/src/BytePatch/Pretty/PatchRep.hs b/src/BytePatch/Pretty/PatchRep.hs deleted file mode 100644 --- a/src/BytePatch/Pretty/PatchRep.hs +++ /dev/null @@ -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 diff --git a/src/StreamPatch/Apply.hs b/src/StreamPatch/Apply.hs new file mode 100644 --- /dev/null +++ b/src/StreamPatch/Apply.hs @@ -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 diff --git a/src/StreamPatch/Patch.hs b/src/StreamPatch/Patch.hs new file mode 100644 --- /dev/null +++ b/src/StreamPatch/Patch.hs @@ -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 diff --git a/src/StreamPatch/Patch/Align.hs b/src/StreamPatch/Patch/Align.hs new file mode 100644 --- /dev/null +++ b/src/StreamPatch/Patch/Align.hs @@ -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 diff --git a/src/StreamPatch/Patch/Binary.hs b/src/StreamPatch/Patch/Binary.hs new file mode 100644 --- /dev/null +++ b/src/StreamPatch/Patch/Binary.hs @@ -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 diff --git a/src/StreamPatch/Patch/Binary/PascalText.hs b/src/StreamPatch/Patch/Binary/PascalText.hs new file mode 100644 --- /dev/null +++ b/src/StreamPatch/Patch/Binary/PascalText.hs @@ -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 diff --git a/src/StreamPatch/Patch/Linearize.hs b/src/StreamPatch/Patch/Linearize.hs new file mode 100644 --- /dev/null +++ b/src/StreamPatch/Patch/Linearize.hs @@ -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) diff --git a/src/StreamPatch/Stream.hs b/src/StreamPatch/Stream.hs new file mode 100644 --- /dev/null +++ b/src/StreamPatch/Stream.hs @@ -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) diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -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 diff --git a/test/BytePatch/HexByteStringSpec.hs b/test/BytePatch/HexByteStringSpec.hs new file mode 100644 --- /dev/null +++ b/test/BytePatch/HexByteStringSpec.hs @@ -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 diff --git a/test/BytePatch/Pretty/HexByteStringSpec.hs b/test/BytePatch/Pretty/HexByteStringSpec.hs deleted file mode 100644 --- a/test/BytePatch/Pretty/HexByteStringSpec.hs +++ /dev/null @@ -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 diff --git a/test/StreamPatch/ApplySpec.hs b/test/StreamPatch/ApplySpec.hs new file mode 100644 --- /dev/null +++ b/test/StreamPatch/ApplySpec.hs @@ -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 diff --git a/test/StreamPatch/Patch/AlignSpec.hs b/test/StreamPatch/Patch/AlignSpec.hs new file mode 100644 --- /dev/null +++ b/test/StreamPatch/Patch/AlignSpec.hs @@ -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")]) diff --git a/test/StreamPatch/Patch/LinearizeSpec.hs b/test/StreamPatch/Patch/LinearizeSpec.hs new file mode 100644 --- /dev/null +++ b/test/StreamPatch/Patch/LinearizeSpec.hs @@ -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] diff --git a/test/Util.hs b/test/Util.hs --- a/test/Util.hs +++ b/test/Util.hs @@ -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