Parse sol data

parse-sol.hs

import qualified Data.ByteString as B
import Data.Binary.Strict.Get
import System.IO
import Text.Printf (printf)
import System.Environment (getArgs)
import Control.Applicative ((<$>))
import Data.Bits ((.|.), (.&.), shiftL, shiftR)
import Data.ByteString.UTF8 (toString)
import Text.JSON.Types
import Text.JSON (encode)

--查看一段二进制Byte,用于debug
showBytes from to contents = putStrLn $ show $ hexSeg where
    hexSeg = concat $ map hexWord8 $ B.unpack seg
    (Right seg, _) = runGet fetchBytes contents
    hexWord8 x = (printf " %02X" $ toInteger x)::String
    fetchBytes = do
        skip from
        getByteString $ to - from + 1

main = do
    file:_ <- getArgs
    handle <- openFile file ReadMode
    contents <- B.hGetContents handle
    let (Right res,c1) = runGet (do
        header <- readHeader
        let readPairs = do
            eof <- isEmpty
            case eof of
                True -> return []
                False -> do
                    name <- readString
                    value <- readData
                    readPadding
                    ((name, value):) <$> readPairs
        let isRight x = case x of
                            Right _ -> True 
                            _ -> False
        res <- readPairs
        return $ JSObject $ JSONObject res
        ) contents
    --let (str,_) = runGet (readString >> readDataFlag) c1
    putStrLn $ encode res
    --showBytes 0 5 c1
    
readHeader = do
    version <- getWord16be
    l <- getWord32be
    signature <- getByteString 10
    l <- getWord16be
    name <- getByteString $ fromIntegral l
    amf <- fromIntegral <$> getWord32be
    return (version, name, amf)
    
--读取一个utf-8字符串
readString = do
    l <- readUInt29
    let ref = l .&. 1
    if ref == 0 then return "$ref" else do
        let str_len = l `shiftR` 1
        str <- getByteString $ fromIntegral str_len
        return $ toString str
--读取一个整数
readInt = do
    i <- readUInt29
    return $ (i `shiftL` 3) `shiftR` 3

--读取一个amf3类型标志
readDataFlag = do
    flag <- toInteger <$> getWord8
    return flag
--读取一个变量
readData::Get JSValue
readData = do
    flag <- readDataFlag
    case flag of
        0 -> return JSNull
        1 -> return JSNull
        2 -> return $ JSBool False
        3 -> return $ JSBool True
        4 -> do
            i <- readInt
            return $ JSRational False $ toRational i
        5 -> readDouble
        6 -> do
            str <- readString
            return $ JSString $ JSONString str
        9 -> readArray
        _ -> return JSNull
readDouble = do
    num <- getFloat64host
    return $ JSRational False $ toRational num
--读取一个数组
readArray = do
    l <- readUInt29
    let ref = l .&. 1
    if ref == 0 then return $ JSArray [JSNull] else do
        let readAttr xs = do
            str <- readString
            if str == "" then return $ reverse xs else do
                dt <- readData
                readAttr ((str,dt):xs)
        pairs <- readAttr []
        let arr_len = l `shiftR` 1
        let readArr xs n len = do
            if n == len then return $ reverse xs else do
                dt <- readData
                readArr ((show n, dt):xs) (n + 1) len
        arrs <- readArr [] 0 arr_len
        if length pairs == 0
        then
            return $ JSArray [dt | (_,dt) <- arrs]
        else
            return $ JSObject $ JSONObject $ pairs ++ arrs
--读取一Byte分隔
readPadding = do
    0 <- toInteger <$> getWord8
    return True

readUInt29 = do
    let readUByte = toInteger <$> getWord8
    a0 <- readUByte
    if a0 < 128 then return a0 else do
        let a1 = (a0 .&. 127) `shiftL` 7
        a2 <- readUByte
        if a2 < 128 then return (a1 .|. a2) else do
            let a3 = (a1 .|. a2 .&. 127) `shiftL` 7
            a4 <- readUByte
            if a4 < 128 then return (a3 .|. a4) else do
                let a5 = (a3 .|. a4 .&. 127) `shiftL` 8
                a6 <- readUByte
                return $ a5 .|. a6