diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,8 @@ +## 0.2.1 (2021-12-03) + * large internal refactoring (still more to come!) + * schema refactoring (patch -> edit, offsets -> at) + * Hackage metadata improvements (initial release was a bit wonky) + ## 0.2.0 (2021-12-03) Initial release. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,10 +1,12 @@ # 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. +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. + +Intended as a general tool for making simple binary editing more manageable. ## What? If you're modifying binaries, you often end up needing to make edits in a hex diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -7,17 +7,18 @@ import BytePatch.Pretty import BytePatch.Pretty.PatchRep -import BytePatch.JSON +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.ByteString.Lazy as BL import qualified Data.Yaml as Yaml import Data.Aeson ( FromJSON ) -import Data.Text ( Text ) -type Bytes = BS.ByteString +import Data.Text ( Text ) +import BytePatch.Pretty.HexByteString main :: IO () main = Options.parse >>= run @@ -25,20 +26,49 @@ run :: MonadIO m => Config -> m () run cfg = do return () - tryReadPatchscript @Text (cfgPatchscript cfg) >>= \case + 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 - (_, _:_) -> quit "failed while generating patchscript" - (ps', []) -> quit "TODO actually patch" + (_, 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') + where + io = cfgStreamInOut cfg +readStream :: MonadIO m => CStream -> m BS.ByteString +readStream stream = liftIO $ + case stream of + CStreamStd -> BS.getContents + CStreamFile fp -> BS.readFile fp + +readStream' :: MonadIO m => CStreamInOut -> m BS.ByteString +readStream' = readStream . fst . unCStreamInOut + +writeStream :: MonadIO m => CStream -> BS.ByteString -> m () +writeStream stream bs = liftIO $ + case stream 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 [MultiPatches a]) +tryReadPatchscript :: forall a m. (PatchRep a, FromJSON a, MonadIO m) => FilePath -> m (Maybe [CommonMultiEdits a]) tryReadPatchscript = tryDecodeYaml tryDecodeYaml :: (FromJSON a, MonadIO m) => FilePath -> m (Maybe a) diff --git a/bytepatch.cabal b/bytepatch.cabal --- a/bytepatch.cabal +++ b/bytepatch.cabal @@ -5,13 +5,19 @@ -- see: https://github.com/sol/hpack name: bytepatch -version: 0.2.0 +version: 0.2.1 synopsis: Patch byte-representable data in a bytestream. +description: Please see README.md. +category: CLI homepage: https://github.com/raehik/bytepatch#readme bug-reports: https://github.com/raehik/bytepatch/issues +author: Ben Orchard +maintainer: Ben Orchard license: MIT license-file: LICENSE build-type: Simple +tested-with: + GHC >= 8.6 && < 9.2 extra-source-files: README.md CHANGELOG.md @@ -24,7 +30,6 @@ exposed-modules: BytePatch.Core BytePatch.JSON - BytePatch.Linear.Core BytePatch.Linear.Gen BytePatch.Linear.Patch BytePatch.Pretty diff --git a/src/BytePatch/Core.hs b/src/BytePatch/Core.hs --- a/src/BytePatch/Core.hs +++ b/src/BytePatch/Core.hs @@ -1,17 +1,38 @@ +{-# LANGUAGE DataKinds, TypeFamilies, UndecidableInstances #-} + 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) +import GHC.Generics ( Generic ) +import GHC.Natural --- | Optional patch time data for an overwrite. -data OverwriteMeta a = OverwriteMeta - { omNullTerminates :: Maybe Int +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. - , omExpected :: Maybe a + , emExpected :: Maybe a -- ^ Stream segment should be this. - } deriving (Eq, Show, Functor, Foldable, Traversable) + } deriving (Eq, Show, Generic, Functor, Foldable, Traversable) diff --git a/src/BytePatch/JSON.hs b/src/BytePatch/JSON.hs --- a/src/BytePatch/JSON.hs +++ b/src/BytePatch/JSON.hs @@ -1,13 +1,13 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} -- | Aeson instances for various types. module BytePatch.JSON where import BytePatch.Core -import BytePatch.Pretty +import qualified BytePatch.Pretty as Pretty import BytePatch.Pretty.HexByteString import Data.Aeson -import GHC.Generics (Generic) import Text.Megaparsec import Data.Void @@ -24,34 +24,32 @@ { 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 (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 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 (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 a => ToJSON (Offset a) where - toJSON = genericToJSON (jsonCfgCamelDrop 1) - toEncoding = genericToEncoding (jsonCfgCamelDrop 1) -instance FromJSON a => FromJSON (Offset a) where - parseJSON = genericParseJSON (jsonCfgCamelDrop 1) +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 -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) +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 -deriving instance Generic (Overwrite a) -instance ToJSON a => ToJSON (Overwrite a) where +instance ToJSON a => ToJSON (Edit a) where toJSON = genericToJSON defaultOptions toEncoding = genericToEncoding defaultOptions -instance FromJSON a => FromJSON (Overwrite a) where +instance FromJSON a => FromJSON (Edit a) where parseJSON = genericParseJSON defaultOptions diff --git a/src/BytePatch/Linear/Core.hs b/src/BytePatch/Linear/Core.hs deleted file mode 100644 --- a/src/BytePatch/Linear/Core.hs +++ /dev/null @@ -1,13 +0,0 @@ -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 --- a/src/BytePatch/Linear/Gen.hs +++ b/src/BytePatch/Linear/Gen.hs @@ -1,28 +1,34 @@ +{-# LANGUAGE DataKinds, TypeFamilies, UndecidableInstances #-} + 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 +import GHC.Natural type Bytes = BS.ByteString -- | Error encountered during linear patchscript generation. -data Error a - = ErrorOverlap (Patch a) (Patch a) +data Error s a + = ErrorOverlap (Patch s a) (Patch s a) -- ^ Two edits wrote to the same offset. - deriving (Eq, Show) --- | Process an offset patchscript into a linear patchscript. +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 Bytes] -> (Patchscript Bytes, [Error Bytes]) +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) @@ -30,23 +36,24 @@ -- 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 () + 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 bs offset meta):ps) = do + go (p@(Patch offset edit) : ps) = do (cursor, script, errors, prevPatch) <- get - case trySkipTo offset cursor of + case offset `minusNaturalMaybe` cursor of -- next offset is behind current cursor: overlapping patches -- record error, recover via dropping patch - Left _ -> do + Nothing -> 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) + 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 - 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 --- a/src/BytePatch/Linear/Patch.hs +++ b/src/BytePatch/Linear/Patch.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE DataKinds, TypeFamilies #-} + {- | Low-level patchscript processing and application. Patchscripts are applied as a list of @(skip x, write in-place y)@ commands. An @@ -13,44 +15,50 @@ -} module BytePatch.Linear.Patch - ( patch - , MonadFwdByteStream(..) + ( + -- * Patch interface + MonadFwdByteStream(..) , Cfg(..) , Error(..) + + -- * Prepared patchers + , patchPure + + -- * General patcher + , patch + ) where import BytePatch.Core -import BytePatch.Linear.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 :: Int -> m Bytes + readahead :: Natural -> m Bytes -- | Advance cursor without reading. - advance :: Int -> m () + 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 = do - (src, out) <- get - let (bs, src') = BS.splitAt n src - put (src', out) - return bs + readahead n = BS.take (fromIntegral n) <$> gets fst advance n = do (src, out) <- get - let (bs, src') = BS.splitAt n src + let (bs, src') = BS.splitAt (fromIntegral n) src put (src', out <> BB.byteString bs) overwrite bs = do (src, out) <- get @@ -60,7 +68,7 @@ instance MonadIO m => MonadFwdByteStream (ReaderT Handle m) where readahead n = do hdl <- ask - bs <- liftIO $ BS.hGet hdl n + bs <- liftIO $ BS.hGet hdl (fromIntegral n) liftIO $ hSeek hdl RelativeSeek (- fromIntegral n) return bs advance n = do @@ -88,21 +96,24 @@ | ErrorPatchDidNotMatchExpected Bytes Bytes deriving (Eq, Show) -patch :: MonadFwdByteStream m => Cfg -> Patchscript Bytes -> m (Maybe Error) +patch + :: MonadFwdByteStream m + => Cfg -> [Patch 'FwdSeek Bytes] + -> m (Maybe Error) patch cfg = go where go [] = return Nothing - go ((n, Overwrite bs meta):es) = do + go (Patch n (Edit bs meta):es) = do advance n - bsStream <- readahead $ BS.length bs -- TODO catch overlong error + bsStream <- readahead $ fromIntegral $ BS.length bs -- TODO catch overlong error -- if provided, strip trailing nulls from to-overwrite bytestring - case tryStripNulls bsStream (omNullTerminates meta) of + 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' (omExpected meta) of + case checkExpected bsStream' (emExpected meta) of Just (bsa, bse) -> return $ Just $ ErrorPatchDidNotMatchExpected bsa bse Nothing -> overwrite bs >> go es @@ -125,15 +136,11 @@ 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) --} +-- | 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 --- a/src/BytePatch/Pretty.hs +++ b/src/BytePatch/Pretty.hs @@ -1,12 +1,22 @@ --- | Convenience interface to enable defining edits at offsets with some --- optional safety checks. +{-# 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 - MultiPatches(..) - , MultiPatch(..) - , Offset(..) + CommonMultiEdits(..) + , MultiEdit(..) + , EditOffset(..) -- * Convenience functions , normalizeSimple @@ -18,96 +28,70 @@ ) 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 ) +import GHC.Natural 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 '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. --- | 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. + , cmesEdits :: [MultiEdit 'CursorSeek a] + } deriving (Eq, Show, Generic, Functor, Foldable, Traversable) - , mpsPatches :: [MultiPatch a] - } deriving (Eq, Show, Generic) +-- | 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) --- | 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) +deriving instance (Eq (SeekRep s), Eq a) => Eq (MultiEdit s a) +deriving instance (Show (SeekRep s), Show a) => Show (MultiEdit s a) --- | 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. +-- | 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. - , oAbsoluteOffset :: Maybe Int - -- ^ Absolute stream offset to patch at. Compared with actual offset - -- (calculated from offset and base offset). + , eoAbsOffset :: Maybe (SeekRep 'AbsSeek) + -- ^ Absolute stream offset for edit. Used for checking against actual 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) + , eoMaxLength :: Maybe Natural + -- ^ Maximum number of bytes allowed to write at this offset. - , 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) + , 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 :: MultiPatches a -> (Int, [(MultiPatch a, [Offset a])]) -applyBaseOffset mps = - (baseOffset, recalculateMultiPatchOffsets baseOffset (mpsPatches mps)) - where baseOffset = fromMaybe 0 (mpsBaseOffset mps) +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)]) @@ -117,42 +101,54 @@ 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 + :: Integer + -> [MultiEdit 'CursorSeek a] + -> [(MultiEdit 'AbsSeek a, [EditOffset 'CursorSeek 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) + 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 :: Int -> [Offset a] -> ([Offset a], [Offset a]) +recalculateOffsets + :: Integer + -> [EditOffset 'CursorSeek a] + -> ([EditOffset 'AbsSeek a], [EditOffset 'CursorSeek a]) recalculateOffsets baseOffset = partitionMaybe go where - go o = if actualOffset >= 0 then Just (o { oOffset = actualOffset }) else Nothing - where actualOffset = oOffset o - baseOffset + go o = let actualOffset = baseOffset + eoOffset o + in case tryIntegerToNatural actualOffset of + Nothing -> Nothing + Just actualOffset' -> Just $ o { eoOffset = actualOffset' } -normalize :: PatchRep a => [MultiPatch a] -> Maybe [Patch Bytes] +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 (MultiPatch contents os) = mapM (tryMakeSingleReplace contents) os + 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 -> Offset a -> Maybe (Patch Bytes) -tryMakeSingleReplace contents (Offset os maos maxLen mMeta) = +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 maxLen of - Just len -> if BS.length bs > len then Nothing else overwrite bs - Nothing -> overwrite bs + 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 { patchContents = bs - , patchOffset = os - , patchMeta = meta' } - meta = fromMaybe (OverwriteMeta Nothing Nothing) mMeta + 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