BitSyntax 0.2 → 0.3
raw patch · 2 files changed
+125/−66 lines, 2 files
Files
- BitSyntax.cabal +2/−3
- Data/BitSyntax.hs +123/−63
BitSyntax.cabal view
@@ -1,11 +1,10 @@ Name: BitSyntax-Version: 0.2+Version: 0.3 License: BSD3 Author: Adam Langley-Homepage: http://www.imperialviolet.org/binary/bitsyntax+Homepage: http://www.imperialviolet.org/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.
Data/BitSyntax.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fth -ffi #-} -- | 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).@@ -17,12 +18,7 @@ -- * 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- -- <http://www.haskell.org/th/>. 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+ -- <http://www.haskell.org/th/>. -- -- To expand the function you use the splice command: -- @@@ -36,18 +32,17 @@ -- 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)+ -- decodeOptions bs ([_, hlen], _, _, _, _, _, _, _, _, _)+ -- | hlen > 5 = return $ BS.splitAt (fromIntegral ((hlen - 5) * 4)) bs+ -- | otherwise = return (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])+ -- 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,@@ -58,17 +53,13 @@ -- 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 + -- I get errors if these aren't exported (Can't find interface-file+ -- declaration for Data.BitSyntax.decodeU16)+ decodeU8, decodeU16, decodeU32, decodeU16LE, decodeU32LE) where+ import Language.Haskell.TH import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax@@ -86,12 +77,48 @@ foreign import ccall unsafe "htonl" htonl :: Word32 -> Word32 foreign import ccall unsafe "htons" htons :: Word16 -> Word16 +-- There's no good way to convert to little-endian. The htons functions only+-- convert to big endian and they don't have any little endian friends. So we+-- need to detect which kind of system we are on and act accordingly. We can+-- detect the type of system by seeing if htonl actaully doesn't anything (it's+-- the identity function on big-endian systems, of course). If it doesn't we're+-- on a big-endian system and so need to do the byte-swapping in Haskell because+-- the C functions are no-ops++-- | A native Haskell version of htonl for the case where we need to convert+-- to little-endian on a big-endian system+endianSwitch32 :: Word32 -> Word32+endianSwitch32 a = ((a .&. 0xff) `shiftL` 24) .|.+ ((a .&. 0xff00) `shiftL` 8) .|.+ ((a .&. 0xff0000) `shiftR` 8) .|.+ (a `shiftR` 24)++-- | A native Haskell version of htons for the case where we need to convert+-- to little-endian on a big-endian system+endianSwitch16 :: Word16 -> Word16+endianSwitch16 a = ((a .&. 0xff) `shiftL` 8) .|.+ (a `shiftR` 8)++littleEndian32 :: Word32 -> Word32+littleEndian32 a = if htonl 1 == 1+ then endianSwitch32 a+ else a++littleEndian16 :: Word16 -> Word16+littleEndian16 a = if htonl 1 == 1+ then endianSwitch16 a+ else a+ data BitBlock = -- | Unsigned 8-bit int U8 Int | -- | Unsigned 16-bit int U16 Int | -- | Unsigned 32-bit int U32 Int |+ -- | Little-endian, unsigned 16-bit int+ U16LE Int |+ -- | Little-endian, unsigned 32-bit int+ U32LE Int | -- | Appends the string with a trailing NUL byte NullTerminated String | -- | Appends the string without any terminator@@ -141,6 +168,8 @@ 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 (U16LE v) = getBytes (littleEndian16 $ fromIntegral v)+bits (U32LE v) = getBytes (littleEndian32 $ fromIntegral v) bits (NullTerminated str) = BS.pack $ (map (fromIntegral . ord) str) ++ [0] bits (RawString str) = BS.pack $ map (fromIntegral . ord) str bits (RawByteString bs) = bs@@ -156,11 +185,14 @@ data ReadType = -- | An unsigned number of some number of bytes. Valid -- arguments are 1, 2 and 4 Unsigned Integer |+ -- | An unsigned, little-endian integer of some number of+ -- bytes. Valid arguments are 2 and 4+ UnsignedLE 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 |+ -- @Monad m => ByteString -> m (v, ByteString)@+ Variable Name | -- | Skip some number of bytes Skip Integer | -- | A fixed size field, the result of which is a ByteString@@ -171,8 +203,9 @@ 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 |+ -- passed has type+ -- @Monad m => ByteString -> (...) -> m (v, ByteString)@+ Context Name | -- | Takes the most recent element of the result tuple and -- interprets it as the length of this field. Results in -- a ByteString@@ -201,6 +234,10 @@ decodeU16 = htons . fromBytes . map fromIntegral . BS.unpack decodeU32 :: BS.ByteString -> Word32 decodeU32 = htonl . fromBytes . map fromIntegral . BS.unpack+decodeU16LE :: BS.ByteString -> Word16+decodeU16LE = littleEndian16 . fromBytes . map fromIntegral . BS.unpack+decodeU32LE :: BS.ByteString -> Word32+decodeU32LE = littleEndian32 . fromBytes . map fromIntegral . BS.unpack decodeBits :: [Integer] -> BS.ByteString -> [Integer] decodeBits sizes bs =@@ -234,100 +271,108 @@ bitsToGet' = bitsToGet - bitsTaken used' = used + bitsTaken -readElement :: ([Dec], Name, [Name]) -> ReadType -> Q ([Dec], Name, [Name])+readElement :: ([Stmt], Name, [Name]) -> ReadType -> Q ([Stmt], Name, [Name]) -readElement (decs, inputname, tuplenames) (Context funcname) = do+readElement (stmts, 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)+ let stmt = BindS (TupP [VarP valname, VarP restname])+ (AppE (AppE (VarE funcname)+ (VarE inputname))+ (TupE $ map VarE $ reverse tuplenames)) -readElement (decs, inputname, tuplenames) (Fixed n) = do+ return (stmt : stmts, restname, valname : tuplenames)++readElement (stmts, 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")+ (NormalB $ AppE (AppE (VarE 'BS.splitAt) (LitE (IntegerL n))) (VarE inputname)) [] - return (dec1 : decs, restname, valname : tuplenames)+ return (LetS [dec1] : stmts, 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+readElement (stmts, 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")+ (NormalB $ AppE (AppE (VarE 'BS.splitAt)+ (AppE (VarE 'fromIntegral) (VarE sourcename))) (VarE inputname)) [] - return (dec : decs, restname, valname : tuplenames)+ return (LetS [dec] : stmts, restname, valname : tuplenames) -readElement (decs, inputname, tuplenames) (Variable funcname) = do+readElement (stmts, 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)+ let stmt = BindS (TupP [VarP valname, VarP restname])+ (AppE (VarE funcname) (VarE inputname)) -readElement (decs, inputname, tuplenames) Rest = do+ return (stmt : stmts, restname, valname : tuplenames)++readElement (stmts, inputname, tuplenames) Rest = do restname <- newName "rest" let dec = ValD (VarP restname) (NormalB $ VarE inputname) []- return (dec : decs, inputname, restname : tuplenames)+ return (LetS [dec] : stmts, inputname, restname : tuplenames) -readElement (decs, inputname, tuplenames) (Skip n) = do+readElement (stmts, inputname, tuplenames) (Skip n) = do -- Expands to something like:- -- rest = BS.drop n input+ -- rest = Data.ByteString.drop n input restname <- newName "rest" let dec = ValD (VarP restname)- (NormalB $ AppE (AppE (VarE $ mkName "BS.drop")+ (NormalB $ AppE (AppE (VarE 'BS.drop) (LitE (IntegerL n))) (VarE inputname)) []- return (dec : decs, restname, tuplenames)+ return (LetS [dec] : stmts, restname, tuplenames) readElement state (Unsigned size) = do -- Expands to something like:- -- (aval, arest) = BS.splitAt 1 input- -- a = decodeU8 aval+ -- (aval, arest) = Data.ByteString.splitAt 1 input+ -- a = BitSyntax.decodeU8 aval let decodefunc = case size of- 1 -> "decodeU8"- 2 -> "decodeU16"- 4 -> "decodeU32"- decodeHelper state (VarE $ mkName decodefunc) size+ 1 -> 'decodeU8+ 2 -> 'decodeU16+ 4 -> 'decodeU32+ decodeHelper state (VarE decodefunc) size +readElement state (UnsignedLE size) = do+ -- Expands to something like:+ -- (aval, arest) = Data.ByteString.splitAt 1 input+ -- a = BitSyntax.decodeU8LE aval+ let decodefunc = case size of+ 2 -> 'decodeU16LE+ 4 -> 'decodeU32LE+ decodeHelper state (VarE 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")+ (AppE (VarE 'decodeBits) (ListE $ map (LitE . IntegerL) sizes)) ((sum sizes) `shiftR` 3) -decodeHelper (decs, inputname, tuplenames) decodefunc size = do+decodeHelper (stmts, 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")+ (NormalB $ AppE (AppE (VarE 'BS.splitAt) (LitE (IntegerL size))) (VarE inputname)) []@@ -335,15 +380,16 @@ (NormalB $ AppE decodefunc (VarE valname)) [] - return (dec1 : dec2 : decs, restname, tuplename : tuplenames)+ return (LetS [dec1, dec2] : stmts, 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)+ (stmts, restname, tuplenames) <- foldM readElement ([], inputname, []) elements+ returnS <- NoBindS `liftM` [| return $(tupE . map varE $ reverse tuplenames) |]+ return $ LamE [VarP inputname] (DoE . reverse $ returnS : stmts) -- Tests@@ -360,3 +406,17 @@ prevalues = map snd fields' packed = bits $ PackBits fields' postvalues = decodeBits (map (fromIntegral . fst) fields') packed++instance Arbitrary Word16 where+ arbitrary = (arbitrary :: Gen Int) >>= return . fromIntegral+ coarbitrary = error "not implemented"+instance Arbitrary Word32 where+ arbitrary = (arbitrary :: Gen Int) >>= return . fromIntegral+ coarbitrary = error "not implemented"++-- | This only works on little-endian machines as it checks that the foreign+-- functions (htonl and htons) match the native ones+prop_nativeByteShuffle32 x = endianSwitch32 x == htonl x+prop_nativeByteShuffle16 x = endianSwitch16 x == htons x+prop_littleEndian16 x = littleEndian16 x == x+prop_littleEndian32 x = littleEndian32 x == x