first

.gitignore

@@ -0,0 +1,2 @@
+dist
+dist-newstyle

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 <rhi@rhiannon.website>
+maintainer: rhiannon morris <rhi@rhiannon.website>
+
+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

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 <in> <ips> <out>"
+
+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)

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

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

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)

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)

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