diff --git a/BitSyntax.cabal b/BitSyntax.cabal --- a/BitSyntax.cabal +++ b/BitSyntax.cabal @@ -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. diff --git a/Data/BitSyntax.hs b/Data/BitSyntax.hs --- a/Data/BitSyntax.hs +++ b/Data/BitSyntax.hs @@ -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 - -- . 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: -- @ @@ -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