commit a3b253ce0c959cea80f971c8704c70b2b1441617 Author: Rhiannon Morris Date: Wed Feb 24 16:27:30 2021 +0100 first diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..21d9e6c --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +dist +dist-newstyle diff --git a/ips.cabal b/ips.cabal new file mode 100644 index 0000000..2527b4a --- /dev/null +++ b/ips.cabal @@ -0,0 +1,49 @@ +cabal-version: 2.2 +name: ips +version: 0.1.0 +synopsis: applies ips patches. remember those? +license: WTFPL + +author: rhiannon morris +maintainer: rhiannon morris + +common deps + default-language: Haskell2010 + default-extensions: + BlockArguments, + DerivingStrategies, + DuplicateRecordFields, + FlexibleContexts, + GeneralizedNewtypeDeriving, + NamedFieldPuns, + OverloadedStrings, + TupleSections + build-depends: + base ^>= 4.14.1.0, + bytestring ^>= 0.11.1.0, + vector ^>= 0.12.2.0, + attoparsec ^>= 0.13.2.5, + primitive ^>= 0.7.1.0 + ghc-options: + -Wall + +common exe + build-depends: + ips + ghc-options: + -threaded -rtsopts -with-rtsopts=-N + +library + import: deps + hs-source-dirs: src + exposed-modules: IPS + other-modules: + IPS.Word24, + IPS.Types, + IPS.Parse, + IPS.Apply + +executable ips + import: deps, exe + hs-source-dirs: main + main-is: ips.hs diff --git a/main/ips.hs b/main/ips.hs new file mode 100644 index 0000000..2236ca6 --- /dev/null +++ b/main/ips.hs @@ -0,0 +1,27 @@ +module Main (main) where + +import IPS (Bytes, makeBytes) +import qualified IPS +import System.Environment +import System.IO +import qualified Data.ByteString as ByteString +import qualified Data.Vector.Storable as Vector + +main :: IO () +main = do + args <- getArgs + case args of + [inf, ipsf, outf] -> do + buf <- readBytes inf + ips <- either error id <$> IPS.read ipsf + writeBytes outf $ IPS.apply ips buf + _ -> error "usage: $0 " + +readBytes :: FilePath -> IO Bytes +readBytes f = makeBytes <$> ByteString.readFile f + +writeBytes :: FilePath -> Bytes -> IO () +writeBytes f buf = + withFile f WriteMode \h -> + Vector.unsafeWith buf \ptr -> + hPutBuf h ptr (Vector.length buf) diff --git a/src/IPS.hs b/src/IPS.hs new file mode 100644 index 0000000..67305d7 --- /dev/null +++ b/src/IPS.hs @@ -0,0 +1,5 @@ +module IPS (module IPS) where + +import IPS.Types as IPS +import IPS.Parse as IPS +import IPS.Apply as IPS diff --git a/src/IPS/Apply.hs b/src/IPS/Apply.hs new file mode 100644 index 0000000..d4c1bf5 --- /dev/null +++ b/src/IPS/Apply.hs @@ -0,0 +1,62 @@ +module IPS.Apply (apply, applyM, unsafeApplyM) where + +import IPS.Types +import Data.Vector.Storable.Mutable (MVector) +import qualified Data.Vector.Storable.Mutable as MVector +import qualified Data.Vector.Storable as Vector +import Control.Monad.ST +import Control.Monad.Primitive (PrimMonad (PrimState)) +import Data.Foldable + + +type BytesM m = MVector (PrimState m) Word8 + +-- explodes if the patch tries to write outside the existing space +unsafeApplyM :: PrimMonad m => Patch -> BytesM m -> m () +unsafeApplyM p buf = + for_ p \Chunk {offset, body} -> + case body of + Normal bs -> do + let offset' = fromIntegral offset + let sz = Vector.length bs + let dst = MVector.slice offset' sz buf + Vector.unsafeCopy dst bs + RLE {size, value} -> do + let offset' = fromIntegral offset + let sz = fromIntegral size + let dst = MVector.slice offset' sz buf + MVector.set dst value + +-- size of patch output +-- (patches can write past the end of the input file) +outSize :: Patch -> Int +outSize = foldl' (\m c -> max m (end c)) 0 where + end (Chunk {offset, body}) = case body of + Normal bs -> offset' + Vector.length bs + RLE {size} -> offset' + fromIntegral size + where offset' = fromIntegral offset + +-- applies in place if it fits, otherwise allocates a new buffer for it +applyM :: PrimMonad m => Patch -> BytesM m -> m (Maybe (BytesM m)) +applyM p buf = do + let size = outSize p + (buf', realloc) <- + if MVector.length buf >= size then + pure (buf, False) + else do + newBuf <- MVector.new size + let dst = MVector.slice 0 (MVector.length buf) newBuf + MVector.copy dst buf + pure (newBuf, True) + unsafeApplyM p buf' + pure $ if realloc then Just buf' else Nothing + +-- copies an immutable vector (resizing if needed) and patches it +apply :: Patch -> Bytes -> Bytes +apply p inp = runST do + let size = outSize p `max` Vector.length inp + buf <- MVector.new size + let dst = MVector.slice 0 (Vector.length inp) buf + Vector.copy dst inp + unsafeApplyM p buf + Vector.unsafeFreeze buf diff --git a/src/IPS/Parse.hs b/src/IPS/Parse.hs new file mode 100644 index 0000000..f0f82f4 --- /dev/null +++ b/src/IPS/Parse.hs @@ -0,0 +1,51 @@ +module IPS.Parse (parser, read) where + +import Prelude hiding (read) +import IPS.Types +import Data.Attoparsec.ByteString (Parser) +import qualified Data.Attoparsec.ByteString as Parse +import Data.Bits +import Data.Bifunctor +import qualified Data.ByteString as ByteString +import Data.Functor +import qualified Data.Vector.Generic as Vector +import Control.Applicative + + +read :: FilePath -> IO (Either String Patch) +read f = Parse.parseOnly parser <$> ByteString.readFile f + + +parser :: Parser Patch +parser = Parse.string "PATCH" *> parseBody + +parseBody :: Parser Patch +parseBody = uncurry Vector.fromListN <$> go where + go = eof <|> chunk + eof = Parse.string "EOF" $> (0, []) + chunk = liftA2 cons parseChunk go + where cons c = bimap (+ 1) (c :) + +parseChunk :: Parser Chunk +parseChunk = do + offset <- parseWord24 + size₀ <- parseWord16 + body <- + if size₀ == 0 then + liftA2 RLE parseWord16 Parse.anyWord8 + else + Normal . makeBytes <$> Parse.take (fromIntegral size₀) + pure $ Chunk {offset, body} + +parseWord16 :: Parser Word16 +parseWord16 = parseWordBE 2 + +parseWord24 :: Parser Word24 +parseWord24 = parseWordBE 3 + +parseWordBE :: (Integral a, Bits a) => Word -> Parser a +parseWordBE = go 0 where + go acc 0 = pure acc + go acc i = do + b <- fromIntegral <$> Parse.anyWord8 + go ((acc `shiftL` 8) .|. b) (i - 1) diff --git a/src/IPS/Types.hs b/src/IPS/Types.hs new file mode 100644 index 0000000..d77889a --- /dev/null +++ b/src/IPS/Types.hs @@ -0,0 +1,35 @@ +module IPS.Types + (Patch, Chunk (..), ChunkBody (..), + Word8, Word16, Word24, + Bytes, makeBytes) +where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import Data.Vector (Vector) +import qualified Data.Vector.Storable as S +import Data.Word +import IPS.Word24 + + +type Patch = Vector Chunk + +data Chunk = + Chunk { + offset :: {-# UNPACK #-} !Word24, + body :: !ChunkBody + } + deriving (Show, Eq) + +data ChunkBody = + Normal {-# UNPACK #-} !Bytes + | RLE { + size :: {-# UNPACK #-} !Word16, + value :: {-# UNPACK #-} !Word8 + } + deriving (Show, Eq) + +type Bytes = S.Vector Word8 + +makeBytes :: ByteString -> Bytes +makeBytes bs = S.generate (ByteString.length bs) (ByteString.index bs) diff --git a/src/IPS/Word24.hs b/src/IPS/Word24.hs new file mode 100644 index 0000000..7c681c2 --- /dev/null +++ b/src/IPS/Word24.hs @@ -0,0 +1,84 @@ +module IPS.Word24 (Word24) where + +import Data.Word +import Data.Maybe +import Data.Bits + + +newtype Word24 = W24 Word32 + deriving newtype (Eq, Ord, Show) + +maxW24I :: Int +maxW24I = 0xFFFFFF + +maxW24 :: Word32 +maxW24 = 0xFFFFFF + +mkW24 :: Word32 -> Word24 +mkW24 x = W24 $ x .&. maxW24 + +instance Read Word24 where + readsPrec d str = mapMaybe isW24 $ readsPrec d str where + isW24 (x, r) | x <= maxW24 = Just (W24 x, r) + | otherwise = Nothing + +instance Bounded Word24 where + minBound = W24 0 + maxBound = W24 maxW24 + +instance Enum Word24 where + succ (W24 x) | x >= maxW24 = error "succ @Word24: maxBound" + | otherwise = W24 $ succ x + + pred (W24 x) | x <= 0 = error "pred @Word24: 0" + | otherwise = W24 $ pred x + + toEnum x | x >= 0 && x <= maxW24I = W24 $ fromIntegral x + | otherwise = error "toEnum @Word24: out of range" + + fromEnum (W24 x) = fromEnum x + +clamp1 :: (Word32 -> Word32) -> (Word24 -> Word24) +clamp1 f (W24 x) = mkW24 $ f x +clamp2 :: (Word32 -> Word32 -> Word32) -> (Word24 -> Word24 -> Word24) +clamp2 (·) (W24 x) (W24 y) = mkW24 $ x · y + +instance Num Word24 where + (+) = clamp2 (+) + (*) = clamp2 (*) + (-) = clamp2 (-) + + abs = id + signum x = if x == 0 then 0 else 1 + fromInteger x = mkW24 $ fromInteger x + +instance Real Word24 where + toRational (W24 x) = toRational x + +instance Integral Word24 where + W24 x `quotRem` W24 y = let (q, r) = x `quotRem` y in (mkW24 q, mkW24 r) + toInteger (W24 x) = toInteger x + +instance Bits Word24 where + (.&.) = clamp2 (.&.) + (.|.) = clamp2 (.|.) + xor = clamp2 xor + + complement = clamp1 complement + + shift (W24 x) i = mkW24 $ shift x i + + rotate x 0 = x + rotate (W24 x) i = mkW24 $ (x `shiftL` i) .|. (x `shiftR` (24 - i)) + + bitSize = finiteBitSize + bitSizeMaybe = Just . finiteBitSize + isSigned _ = False + + testBit = testBitDefault + bit = bitDefault + + popCount (W24 x) = popCount x + +instance FiniteBits Word24 where + finiteBitSize _ = 24