patcher.hs

{-# LANGUAGE OverloadedStrings #-}
import Data.Attoparsec.ByteString.Lazy
import Data.Attoparsec.Combinator (lookAhead)
import Debug.Trace
import qualified Data.ByteString.Lazy.Char8 as BL
import qualified Data.ByteString as BS

import Data.Binary.Put (runPut, putFloatle, putDoublele)

import GHC.Float (float2Double)
import Data.Char
import Data.List (sortOn)
import Control.Applicative

import Data.Bifunctor

import System.Environment

import Prelude hiding (take, takeWhile)
import qualified Prelude
--util sh ss = do

newFPS :: Floating a => a
newFPS = 180.0

patches = [ ("Data\\Movies\\%s.usm", "Data\\Movies\\%s.off", [7023292])
            ( runPut . putFloatle $ 1/60.0
            , runPut . putFloatle $ 1/newFPS
            , [6681384,6688940,7023008])
          , ( runPut . putDoublele . float2Double $ 1/60.0
            , runPut . putDoublele $ 1/newFPS
            , [7024776])
          , ( runPut $ putDoublele 60.0
            , runPut $ putDoublele newFPS
            , [7024784])
          ]

dropFst (a, b, c) = (b, c)

fst3 (a, _, _) = a

expand [] = []
expand ((s, r, offs):xs) = map (,s,r) offs <> expand xs

takeLast [] = []
takeLast (a:[]) = [a]
takeLast (_:xs) = takeLast xs

findOffsets str m = offsets
  where
    len = BL.length m
    pred e = m == (BL.take len $ BL.drop e str)
    offsets = filter pred candidates
    candidates = BL.elemIndices (BL.head m) str

manyCont :: Alternative f => f a -> f a -> f b -> f [a]
manyCont p cont pred = start <|> end
  where start = (pred *> pure [])
        end   = liftA2 (:) p scan
        scan  = start <|> (fmap (:) cont) <*> end

upTo ss = scan
  where
    scan = ((,[]) <$> string ss) <|> liftA2 (\s -> fmap (s:)) (takeWhile (/=sh)) scan
    Just (sh, st) = BS.uncons ss



parser ss r = do
  if BS.length ss == BS.length r then pure () else error "not matching lengths"
  before <-  manyCont tt cont (string ss)
  _ <- string ss <?> ("char: " <> show [chr $ fromIntegral sh] <> " before bytes: " <> (show $ BS.takeEnd 16 $ BS.concat before))
  return . BS.concat $ before <> [r]
  where
    -- ttrace = fmap (traceShowWith ( (ss :) . map (BS.takeEnd 16) . takeLast))
    tt = takeWhile (/=sh) <?> show ("search: " <> ss <> " replace: " <> r)
    cont = BS.singleton <$> word8 sh
    Just (sh, st) = BS.uncons ss

parserChain :: (Applicative  f, Semigroup a) => [ f a ] -> f a
parserChain (x:[]) = x
parserChain (x:xs) = fmap (<>) x <*> parserChain xs

main = do
  file <- BL.readFile "ASN_App_PcDx9_Final.original.exe"
  let o_file = BS.writeFile "ASN_App_PcDx9_Final.exe"

  {-
  args <- getArgs

  case args of
    a:xs -> print $ findOffsets file $ fst $ patches !! 2 --findOffsets file (BL.pack a)
    _    -> return ()
-}
  let testString = "TestDataTestData"
  let parsers' = map (bimap BL.toStrict BL.toStrict) . sortOn fst3 . expand $ patches
      parsers = map (\(a, b, c) -> parser b c <?> show a <> " ") parsers'

  case parse (parserChain $ parsers ++ [takeByteString]) file of
    Done i r -> o_file r >> putStrLn "Done!"
    Fail i cts e -> error $ e <> " " <> mconcat cts <> " next few bytes: " <> show (BL.take 16 i)