diff --git a/BitSyntax.cabal b/BitSyntax.cabal new file mode 100644 --- /dev/null +++ b/BitSyntax.cabal @@ -0,0 +1,11 @@ +Name: BitSyntax +Version: 0.2 +License: BSD3 +Author: Adam Langley +Homepage: http://www.imperialviolet.org/binary/bitsyntax +Stability: experimental +Synopsis: A module to aid in the (de)serialisation of binary data +Build-Depends: base, QuickCheck, template-haskell +Exposed-modules: Data.BitSyntax +Extensions: ForeignFunctionInterface +Description: This provides a simple function for the construction of binary data (a cross between Erlang's bit syntax and Python's struct module) as well as a Template Haskell function which deconstructs similar binary data. diff --git a/Data/BitSyntax.hs b/Data/BitSyntax.hs new file mode 100644 --- /dev/null +++ b/Data/BitSyntax.hs @@ -0,0 +1,362 @@ +-- | This module contains fuctions and templates for building up and breaking +-- down packed bit structures. It's something like Erlang's bit-syntax (or, +-- actually, more like Python's struct module). +-- +-- This code uses Data.ByteString which is included in GHC 6.5 and you can +-- get it for 6.4 at +module Data.BitSyntax ( + -- * Building bit structures + -- | The core function here is makeBits, which is a perfectly normal function. + -- Here's an example which makes a SOCKS4a request header: + -- @ + -- makeBits [U8 4, U8 1, U16 80, U32 10, NullTerminated \"username\", + -- NullTerminated \"www.haskell.org\"] + -- @ + BitBlock(..), + makeBits, + -- * Breaking up bit structures + -- | The main function for this is bitSyn, which is a template function and + -- so you'll need to run with @-fth@ to enable template haskell + -- . This function expands at the place where its + -- used and includes references to functions by name, so those references need + -- to resolve at the point of /use/. To make sure that happens you'll need: + -- + -- > import BitSyntax + -- > import qualified Data.ByteString as BS + -- + -- To expand the function you use the splice command: + -- @ + -- $(bitSyn [...]) + -- @ + -- + -- The expanded function has type @ByteString -> (...)@ where the elements of + -- the tuple depend of the argument to bitSyn (that's why it has to be a template + -- function). + -- + -- Heres an example, translated from the Erlang manual, which parses an IP header: + -- + -- @ + -- decodeOptions bs ([_, hlen], _, _, _, _, _, _, _, _, _) = + -- if hlen > 5 + -- then BS.splitAt (fromIntegral ((hlen - 5) * 4)) bs + -- else (BS.empty, bs) + -- @ + -- + -- @ + -- ipDecode = $(bitSyn [PackedBits [4, 4], Unsigned 1, Unsigned 2, Unsigned 2, + -- PackedBits [3, 13], Unsigned 1, Unsigned 1, Unsigned 2, + -- Fixed 4, Fixed 4, Context \"decodeOptions\", Rest]) + -- @ + -- + -- @ + -- ipPacket = BS.pack [0x45, 0, 0, 0x34, 0xd8, 0xd2, 0x40, 0, 0x40, 0x06, + -- 0xa0, 0xca, 0xac, 0x12, 0x68, 0x4d, 0xac, 0x18, + -- 0x00, 0xaf] + -- @ + -- + -- This function has several weaknesses compared to the Erlang version: The + -- elements of the bit structure are not named in place, instead you have to + -- do a pattern match on the resulting tuple and match up the indexes. The + -- type system helps in this, but it's still not quite as nice. + -- + -- The need to have the correct functions in scope (as pointed out above) is a + -- problem. + + ReadType(..), bitSyn, + -- * Utility functions + -- | These are exposed because bitSyn is a template function and so + -- functions referred to by it have to be in scope at the location where + -- bitSyn is used. + decodeU8, decodeU16, decodeU32, decodeBits) where + +import Language.Haskell.TH +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Syntax + +import qualified Data.ByteString as BS +import Data.Word +import Data.Bits +import Data.Char (chr, ord) +import Control.Monad +import Test.QuickCheck + +import Foreign +import Foreign.C + +foreign import ccall unsafe "htonl" htonl :: Word32 -> Word32 +foreign import ccall unsafe "htons" htons :: Word16 -> Word16 + +data BitBlock = -- | Unsigned 8-bit int + U8 Int | + -- | Unsigned 16-bit int + U16 Int | + -- | Unsigned 32-bit int + U32 Int | + -- | Appends the string with a trailing NUL byte + NullTerminated String | + -- | Appends the string without any terminator + RawString String | + -- | Appends a ByteString + RawByteString BS.ByteString | + -- | Packs a series of bit fields together. The argument is + -- a list of pairs where the first element is the size + -- (in bits) and the second is the value. The sum of the + -- sizes for a given PackBits must be a multiple of 8 + PackBits [(Int, Int)] + deriving (Show) + +-- Encodes a member of the Bits class as a series of bytes and returns the +-- ByteString of those bytes. +getBytes :: (Integral a, Bounded a, Bits a) => a -> BS.ByteString +getBytes input = + let getByte _ 0 = [] + getByte x remaining = (fromIntegral $ (x .&. 0xff)) : + getByte (shiftR x 8) (remaining - 1) + in + if (bitSize input `mod` 8) /= 0 + then error "Input data bit size must be a multiple of 8" + else BS.pack $ getByte input (bitSize input `div` 8) + +-- Performs the work behind PackBits +packBits :: (Word8, Int, [Word8]) -- ^ The current byte, the number of bits + -- used in that byte and the (reverse) + -- list of produced bytes + -> (Int, Int) -- ^ The size (in bits) of the value, and the value + -> (Word8, Int, [Word8]) -- See first argument +packBits (current, used, bytes) (size, value) = + if bitsWritten < size + then packBits (0, 0, current' : bytes) (size - bitsWritten, value) + else if used' == 8 + then (0, 0, current' : bytes) + else (current', used', bytes) + where + top = size - 1 + topOfByte = 7 - used + aligned = value `shift` (topOfByte - top) + newBits = (fromIntegral aligned) :: Word8 + current' = current .|. newBits + bitsWritten = min (8 - used) size + used' = used + bitsWritten + +bits (U8 v) = BS.pack [((fromIntegral v) :: Word8)] +bits (U16 v) = getBytes ((htons $ fromIntegral v) :: Word16) +bits (U32 v) = getBytes ((htonl $ fromIntegral v) :: Word32) +bits (NullTerminated str) = BS.pack $ (map (fromIntegral . ord) str) ++ [0] +bits (RawString str) = BS.pack $ map (fromIntegral . ord) str +bits (RawByteString bs) = bs +bits (PackBits bitspec) = + if (sum $ map fst bitspec) `mod` 8 /= 0 + then error "Sum of sizes of a bit spec must == 0 mod 8" + else (\(_, _, a) -> BS.pack $ reverse a) $ foldl packBits (0, 0, []) bitspec + +-- | Make a binary string from the list of elements given +makeBits :: [BitBlock] -> BS.ByteString +makeBits = BS.concat . (map bits) + +data ReadType = -- | An unsigned number of some number of bytes. Valid + -- arguments are 1, 2 and 4 + Unsigned Integer | + -- | A variable length element to be decoded by a custom + -- function. The function's name is given as the single + -- argument and should have type + -- @ByteString -> (v, ByteString)@ + Variable String | + -- | Skip some number of bytes + Skip Integer | + -- | A fixed size field, the result of which is a ByteString + -- of that length. + Fixed Integer | + -- | Decode a value and ignore it (the result will not be part + -- of the returned tuple) + Ignore ReadType | + -- | Like variable, but the decoding function is passed the + -- entire result tuple so far. Thus the function whose name + -- passed has type @ByteString -> (...) -> (v, ByteString)@ + Context String | + -- | Takes the most recent element of the result tuple and + -- interprets it as the length of this field. Results in + -- a ByteString + LengthPrefixed | + -- | Decode a series of bit fields, results in a list of + -- Integers. Each element of the argument is the length of + -- the bit field. The sums of the lengths must be a multiple + -- of 8 + PackedBits [Integer] | + -- | Results in a ByteString containing the undecoded bytes so + -- far. Generally used at the end to return the trailing body + -- of a structure, it can actually be used at any point in the + -- decoding to return the trailing part at that point. + Rest + +fromBytes :: (Bits a) => [a] -> a +fromBytes input = + let dofb accum [] = accum + dofb accum (x:xs) = dofb ((shiftL accum 8) .|. x) xs + in + dofb 0 $ reverse input + +decodeU8 :: BS.ByteString -> Word8 +decodeU8 = fromIntegral . head . BS.unpack +decodeU16 :: BS.ByteString -> Word16 +decodeU16 = htons . fromBytes . map fromIntegral . BS.unpack +decodeU32 :: BS.ByteString -> Word32 +decodeU32 = htonl . fromBytes . map fromIntegral . BS.unpack + +decodeBits :: [Integer] -> BS.ByteString -> [Integer] +decodeBits sizes bs = + reverse values + where + (values, _, _) = foldl unpackBits ([], 0, BS.unpack bitdata) sizes + bytesize = (sum sizes) `shiftR` 3 + (bitdata, rest) = BS.splitAt (fromIntegral bytesize) bs + +unpackBits :: ([Integer], Integer, [Word8]) -> Integer -> ([Integer], Integer, [Word8]) +unpackBits state size = unpackBitsInner 0 state size + +unpackBitsInner :: Integer -> + ([Integer], Integer, [Word8]) -> + Integer -> + ([Integer], Integer, [Word8]) +unpackBitsInner _ (output, used, []) _ = (output, used, []) +unpackBitsInner val (output, used, current : input) bitsToGet = + if bitsToGet' > 0 + then unpackBitsInner val'' (output, 0, input) bitsToGet' + else if used' < 8 + then (val'' : output, used', current'' : input) + else (val'' : output, 0, input) + where + bitsAv = 8 - used + bitsTaken = min bitsAv bitsToGet + val' = val `shift` (fromIntegral bitsTaken) + current' = current `shiftR` (fromIntegral (8 - bitsTaken)) + current'' = current `shiftL` (fromIntegral bitsTaken) + val'' = val' .|. (fromIntegral current') + bitsToGet' = bitsToGet - bitsTaken + used' = used + bitsTaken + +readElement :: ([Dec], Name, [Name]) -> ReadType -> Q ([Dec], Name, [Name]) + +readElement (decs, inputname, tuplenames) (Context funcname) = do + valname <- newName "val" + restname <- newName "rest" + + let dec = ValD (TupP [VarP valname, VarP restname]) + (NormalB $ AppE (AppE (VarE $ mkName funcname) + (VarE inputname)) + (TupE $ map VarE $ reverse tuplenames)) + [] + return (dec : decs, restname, valname : tuplenames) + +readElement (decs, inputname, tuplenames) (Fixed n) = do + valname <- newName "val" + restname <- newName "rest" + let dec1 = ValD (TupP [VarP valname, VarP restname]) + (NormalB $ AppE (AppE (VarE $ mkName "BS.splitAt") + (LitE (IntegerL n))) + (VarE inputname)) + [] + + return (dec1 : decs, restname, valname : tuplenames) + +readElement state@(_, _, tuplenames) (Ignore n) = do + (a, b, c) <- readElement state n + return (a, b, tuplenames) + +readElement (decs, inputname, tuplenames) LengthPrefixed = do + valname <- newName "val" + restname <- newName "rest" + + let sourcename = head tuplenames + dec = ValD (TupP [VarP valname, VarP restname]) + (NormalB $ AppE (AppE (VarE $ mkName "BS.splitAt") + (AppE (VarE $ mkName "fromIntegral") + (VarE sourcename))) + (VarE inputname)) + [] + + return (dec : decs, restname, valname : tuplenames) + +readElement (decs, inputname, tuplenames) (Variable funcname) = do + valname <- newName "val" + restname <- newName "rest" + + let dec = ValD (TupP [VarP valname, VarP restname]) + (NormalB $ AppE (VarE $ mkName funcname) + (VarE inputname)) + [] + return (dec : decs, restname, valname : tuplenames) + +readElement (decs, inputname, tuplenames) Rest = do + restname <- newName "rest" + let dec = ValD (VarP restname) + (NormalB $ VarE inputname) + [] + return (dec : decs, inputname, restname : tuplenames) + +readElement (decs, inputname, tuplenames) (Skip n) = do + -- Expands to something like: + -- rest = BS.drop n input + restname <- newName "rest" + let dec = ValD (VarP restname) + (NormalB $ AppE (AppE (VarE $ mkName "BS.drop") + (LitE (IntegerL n))) + (VarE inputname)) + [] + return (dec : decs, restname, tuplenames) + +readElement state (Unsigned size) = do + -- Expands to something like: + -- (aval, arest) = BS.splitAt 1 input + -- a = decodeU8 aval + let decodefunc = case size of + 1 -> "decodeU8" + 2 -> "decodeU16" + 4 -> "decodeU32" + decodeHelper state (VarE $ mkName decodefunc) size + +readElement state (PackedBits sizes) = + if sum sizes `mod` 8 /= 0 + then error "Sizes of packed bits must == 0 mod 8" + else decodeHelper state + (AppE (VarE $ mkName "decodeBits") + (ListE $ map (LitE . IntegerL) sizes)) + ((sum sizes) `shiftR` 3) + +decodeHelper (decs, inputname, tuplenames) decodefunc size = do + valname <- newName "val" + restname <- newName "rest" + tuplename <- newName "tup" + let dec1 = ValD (TupP [VarP valname, VarP restname]) + (NormalB $ AppE (AppE (VarE $ mkName "BS.splitAt") + (LitE (IntegerL size))) + (VarE inputname)) + [] + let dec2 = ValD (VarP tuplename) + (NormalB $ AppE decodefunc (VarE valname)) + [] + + return (dec1 : dec2 : decs, restname, tuplename : tuplenames) + +decGetName (ValD (VarP name) _ _) = name + +bitSyn :: [ReadType] -> Q Exp +bitSyn elements = do + inputname <- newName "input" + (lets, restname, tuplenames) <- foldM readElement ([], inputname, []) elements + return $ LamE [VarP inputname] (LetE lets $ TupE $ map VarE $ reverse tuplenames) + + +-- Tests + +prop_bitPacking fields = + prevalues == (map fromIntegral postvalues) || + any (< 1) (map fst fields) || + any (< 0) (map snd fields) + where + undershoot = sum (map fst fields) `mod` 8 + fields' = if undershoot > 0 + then (8 - undershoot, 1) : fields + else fields + prevalues = map snd fields' + packed = bits $ PackBits fields' + postvalues = decodeBits (map (fromIntegral . fst) fields') packed diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain