Untested and unsanitary implementation of CheckRevision algorithm

CheckRev.hs

module Main where

import Data.Word
import Data.Int
import Text.Parsec
import Control.Monad
import Control.Applicative hiding ((<|>),many)

import qualified Data.ByteString.Lazy as S
import Data.ByteString.Lazy (ByteString)
import Data.Binary.Get

import Data.Bits

main = do
    ss <- testcr
    putStrLn $ show $ ss
    return 0

{-
	Exe: Auth\Game.exe
	Storm: Auth\Bnclient.dll
	Bnet: Auth\D2Client.dll
	Alg: A=2094451609 C=2272660696 B=2729338038 4 A=A+S B=B+C C=C-A A=A^B
	Ver: 16780544
	Checksum: 492962778
	:ExeInfo Game.exe 07/05/09 05:15:47 61440
	DllName: 5570456
	retval: 1

	Exe: Auth\Game.exe
	Storm: Auth\Bnclient.dll
	Bnet: Auth\D2Client.dll
	Alg: B=2073763076 A=2525637137 C=747557834 4 A=A^S B=B+C C=C-A A=A-B
	Ver: 16780544
	Checksum: -665504384
	:ExeInfo Game.exe 07/05/09 05:15:47 61440
	DllName: 4502536
	retval: 1

	Exe: Auth\Game.exe
	Storm: Auth\Bnclient.dll
	Bnet: Auth\D2Client.dll
	Alg: B=4114202703 C=683002601 A=1214174806 4 A=A+S B=B-C C=C-A A=A^B
	Ver: 16780544
	Checksum: 1133977
	:ExeInfo Game.exe 07/05/09 05:15:47 61440
	DllName: 4502656
	retval: 1
-}

mpqHashCodes = [ 0xE7F4CB62, 0xF6A14FFC, 0xAA5504AF, 0x871FCDC2
               , 0x11BF6A18, 0xC57292E6, 0x7927D27E, 0x2FEC8733
               ]

testcr :: IO [Int32]
testcr =  sequence $ fmap (\n->cr n dir alg files) [0..7] where
    dir = "D:/games/_P0/Diablo II/"
    --alg = "A=4095648652 B=3744856545 C=4182215876 4 A=A^S B=B+C C=C+A A=A^B"
    alg = "B=2073763076 A=2525637137 C=747557834 4 A=A^S B=B+C C=C-A A=A-B"
    files = ["Bnclient.dll","D2Client.dll","Game.exe"]

cr :: Int -- mpq number
   -> String -- base directory of files
   -> String -- string describing seeds and operations for algorithm
   -> [String] -- file names
   -> IO Int32 -- result
cr mpqId dir alg files = do
    blobs <- sequence $ fmap (\f -> S.readFile $ dir++f) files
    let ((a,b,c),ops) = case parse parseAlg alg alg of
            (Left err) -> error (show err)
            (Right ok) -> ok
        [one,two,three] = map wordStream blobs
        crFunc = checkRevision ops
        s1 = crFunc one (xor a (mpqHashCodes!!mpqId),b,c)
        s2 = crFunc two s1
        s3 = crFunc three s2
    (return . fromIntegral . (\(_,_,c)->c) $ s3)

type Op = Word32 -> Word32 -> Word32
type Vars = (Word32,Word32,Word32)
checkRevision :: (Op,Op,Op,Op) -> [Word32] -> Vars -> Vars
checkRevision _ [] nums = nums
checkRevision ops@(op1,op2,op3,op4) (s:ss) (a,b,c) =
    let a' = a `op1` s
        b' = b `op2` c
        c' = c `op3` a'
        a'' = a' `op4` b'
    in checkRevision ops ss (a'',b',c')

-- how does CR deal with odd ending tail?
wordStream :: ByteString -> [Word32]
wordStream bs = runGet getter padded where
    getter :: Get [Word32]
    getter = sequence . take (fromIntegral $ S.length padded `div` 4) . repeat $ getWord32le
    padded :: ByteString
    padded = bs `S.append` padding
    padding = S.pack $ take (fromIntegral padLength) gen where
        gen = concat . repeat $ [255,254..0]
    padLength = 1024 - (S.length bs `div` 1024)

-- take strings like:
--      "A=4095648652 B=3744856545 C=4182215876 4 A=A^S B=B+C C=C+A A=A^B"
--       A aaaaaaaaaa B bbbbbbbbbb C cccccccccc      ?     ?     ?     ?
-- and identify that stuff /\
-- A,B,C might not be in order, the rest will be
parseAlg :: Parsec String () ((Word32,Word32,Word32),(Op,Op,Op,Op))
parseAlg = do
    cs <- replicateM 3 constants
    operators <- ops
    let consts = (,,) <$> lookup 'A' cs <*> lookup 'B' cs <*> lookup 'C' cs
    case consts of
        Nothing -> unexpected "did not find all of A & B & C"
        Just c -> return (c,operators)
    where -- using Parsec to do this was probably overkill and a bad idea
    constants :: Parsec String () (Char,Word32)
    constants = (,) <$> (char 'A' <|> char 'B' <|> char 'C') <* char '='
                <*> (read::[Char]->Word32) `fmap` many digit <* space
    ops :: Parsec String () (Op,Op,Op,Op)
    ops = string "4 A=A" >> (,,,) <$> opCode <* string "S B=B" <*> opCode
                                  <* string "C C=C" <*> opCode
                                  <* string "A A=A" <*> opCode <* char 'B'
        where  opCode = (getOp '+' (+))
                   <|> (getOp '-' (-))
                   <|> (getOp '^' xor) where
                        getOp :: Char -> Op -> Parsec String () Op
                        getOp c op = (const op) <$> char c

testParseAlg = parse parseAlg "(uh?)" s where
    s = "A=4095648652 B=3744856545 C=4182215876 4 A=A^S B=B+C C=C+A A=A^B"