packages feed

codec-libevent (empty) → 0.1

raw patch · 8 files changed

+621/−0 lines, 8 filesdep +QuickCheckdep +arraydep +basebuild-type:Customsetup-changed

Dependencies added: QuickCheck, array, base, binary, binary-strict, bytestring, containers, parsec, regex-compat

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) Lennart Kolmodin++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ codec-libevent.cabal view
@@ -0,0 +1,21 @@+name:            codec-libevent+version:         0.1+license:         BSD3+license-file:    LICENSE+author:          Adam Langley <agl@imperialviolet.org>+description:     This package parses and generates Haskell code for+                 serialising and deserialising the tagging format in+                 libevent 1.4.+synopsis:        Cross-platform structure serialisation+category:        Data, Parsing+build-depends:   base, containers, array, bytestring>=0.9, QuickCheck>=1.1, binary-strict>=0.1, binary>=0.4.1, parsec>=2.1, regex-compat>=0.71+stability:       provisional+tested-with:     GHC == 6.8.1+exposed-modules: Codec.Libevent, Codec.Libevent.Parse, Codec.Libevent.Generate, Codec.Libevent.Class+extensions:      CPP, FlexibleContexts+hs-source-dirs:  src+ghc-options:     -O2++executable:      codec-libevent-generate+hs-source-dirs:  src+main-is:         codec-libevent-generate.hs
+ src/Codec/Libevent.hs view
@@ -0,0 +1,151 @@+-- |+-- Tagged data structures are an extensible way of serialising data in a+-- platform independent way for transmission across a network etc. This package+-- implements the tagged structures from libevent 1.4.0-beta.+--+-- A tagged structure is described in a text file and might look like this:+--+-- > struct foo {+-- >   required int count = 1;+-- >   optional struct[bar] names = 2;+-- > }+-- >+-- > struct bar {+-- >   repeated string s = 1;+-- > }+--+-- The numbers after the equals signs are the tag numbers for each element of+-- a structure. The tag numbers must be unique within a structure and should+-- be sequenctial (but are not required to be).+--+-- The tag numbers must also be fixed for all time. When deserialising,+-- unknown tags are ignored. Thus one can add a new (non-required) element to+-- @foo@ in the future and still interoperate with older code which knows+-- nothing of the new element.+--+-- Each element in the description looks like:+--+-- > <presence> <type> <name> = <tag number> ;+--+-- The possible presence values are: @required@, @optional@ and @repeated@. The+-- types are (currently): @int@, @string@, @struct[NAME]@ and @bytes@.+--+-- Other modules in this package parse these descriptions and automatically+-- generate Haskell code for them. You should have a binary called+-- @codec-libevent-generate@ which does this. See the documentation for+-- "Codec.Libevent.Generate" about the structure of the generated code.+--+-- Once you have generated the code, you can import it as a regular Haskell+-- module and serialise\/deserialise these structures. You can also use+-- the libevent library to process them in C.+--+-- This module contains helper functions and is imported by the code generated+-- by "Codec.Libevent.Generate". Apart from the @TaggedStructure@ class, there's+-- probably not anything generally useful here.+module Codec.Libevent where++import Data.List (unfoldr)+import Data.Bits+import Data.Char (ord, chr)+import Data.Maybe (fromJust)+import Data.Word+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL++import Data.Binary.Put+import Data.Binary.Strict.Get++import Test.QuickCheck++-- | Decode a base128 encoded integer. This is a variable length encoded int+--   where the last byte has the MSB set to 0.+getBase128 :: Get Word32+getBase128 = f 0 0 where+  f n x = do v <- getWord8+             if v .&. 0x80 == 0+                then return $ x .|. (fromIntegral (v `shiftL` (7 * n)))+                else f (n + 1) $ x .|. (fromIntegral ((v .&. 0x7f) `shiftL` (7 * n)))++-- | Encode a integer in Base128 form+putBase128 :: Word32 -> Put+putBase128 n = do+  let next = n `shiftR` 7+  if next == 0+     then putWord8 (fromIntegral n)+     else putWord8 (fromIntegral ((n .&. 0x7f) .|. 0x80)) >> putBase128 next++-- | Decode a number where the first nibble of the first byte is the number+--   of nibbles in the number. The remaining nibbles appear in little-endian+--   order following, with 0 padding to the nearest byte.+getLengthPrefixed :: Get Word32+getLengthPrefixed = do+  i <- getWord8+  let numNibbles = (i `shiftR` 4) + 1+      numBytes = (numNibbles `shiftR` 1) + 1+      numExtraBytes = fromIntegral $ numBytes - 1+      toNibbles = concatMap (\x -> [x `shiftR` 4, x .&. 0x0f]) . BS.unpack+      firstNibble = i .&. 0x0f++      f :: Word32 -> Word8 -> Word32+      f acc x = (acc `shiftL` 4) .|. (fromIntegral x)++  rest <- getByteString numExtraBytes+  let nibbles = reverse $ take (fromIntegral numNibbles) $ firstNibble : toNibbles rest+  return $ foldl f 0 nibbles++-- | Return the number of nibbles, n, required to encode a given number. n >= 1+nibbleLength :: Word32 -> Int+nibbleLength 0 = 1+nibbleLength n = f n where+  f 0 = 0+  f n = 1 + f (n `shiftR` 4)++-- | Encode a Word32 by prefixing the number of nibbles and following with the+--   nibbles of the number in little-endian order+putLengthPrefixed :: Word32 -> Put+putLengthPrefixed n = do+  let nibbles = fromIntegral $ nibbleLength n+      firstNibble = fromIntegral $ n .&. 0xf+      rest = BS.unfoldr f (n `shiftR` 4)++      f :: Word32 -> Maybe (Word8, Word32)+      f 0 = Nothing+      f n = Just ((fromIntegral $ n `shiftL` 4) .|. (fromIntegral $ n `shiftR` 4), n `shiftR` 8)++  putWord8 ((nibbles - 1) `shiftL` 4 .|. firstNibble)+  putByteString rest++-- | Return the length of the length-prefixed representation of a Word32+lengthPrefixedLength :: Word32 -> Int+lengthPrefixedLength n = (numNibbles + 1) `div` 2 where+  numNibbles = nibbleLength n++putTaggedWord32 :: Word32 -> Word32 -> Put+putTaggedWord32 tag v =+  putBase128 tag >> putWord8 (fromIntegral $ lengthPrefixedLength v) >> putLengthPrefixed v++putTaggedString :: Word32 -> String -> Put+putTaggedString tag s = do+  putBase128 tag+  putLengthPrefixed (fromIntegral $ length s)+  putByteString (BS.pack $ map (fromIntegral . ord) s)++putTaggedVarBytes :: Word32 -> BS.ByteString -> Put+putTaggedVarBytes tag s =+  putBase128 tag >> putLengthPrefixed (fromIntegral $ BS.length s) >> putByteString s++decodeString :: BS.ByteString -> String+decodeString = map (chr . fromIntegral) . BS.unpack++-- | Properties that check that (encode . decode) is the identity function+prop_lengthPrefixed :: Int -> Property+prop_lengthPrefixed n =+  (n >= 0) ==>+  (fst $ runGet getLengthPrefixed $+    BS.concat $ BSL.toChunks $ runPut $ putLengthPrefixed $ fromIntegral n) == Right (fromIntegral n)++prop_base128 :: Int -> Property+prop_base128 n =+  (n >= 0) ==>+  (fst $ runGet getBase128 $+    BS.concat $ BSL.toChunks $ runPut $ putBase128 $ fromIntegral n) == Right (fromIntegral n)
+ src/Codec/Libevent/Class.hs view
@@ -0,0 +1,12 @@+module Codec.Libevent.Class where++import qualified Data.ByteString as BS++class TaggedStructure a where+  -- | Return a structure filled with default values+  empty :: a+  -- | Serialise a structure to a strict bytestring+  serialise :: a -> BS.ByteString+  -- | Attempt to deserialise a bytestring, returning either an error+  --   message or a structure+  deserialise :: BS.ByteString -> Either String a
+ src/Codec/Libevent/Generate.hs view
@@ -0,0 +1,216 @@+-- |+-- Module: Codec.Libevent.Generate+-- Copyright: Adam Langley 2007+-- License: BSD+--+-- This module generates Haskell code for serialising and deserialising+-- libevent tagged data structures, as implemented in libevent-1.4.0-beta.+--+-- A single .rpc file (containing one or more structures) is mapped to a single+-- Haskell file. Take this example:+--+-- > struct test {+-- >   required int a = 1;+-- >   optional string b = 2;+-- >   repeated struct[test2] c = 3;+-- > }+--+-- This will result in a data decl for 'Test', having named members:+-- test_a, test_b and test_c. Required elements are simple, optional+-- elements are wrapped in a Maybe and repeated elements in a list.+--+-- Types are mapped thus:+--+--    * int -> Word32+--+--    * string -> String+--+--    * bytes -> ByteString (strict)+--+--    * bytes[n] -> ByteString (with runtime checks on the size)+--+--    * struct[name] -> Name (the struct must be defined in the same file)+--+-- In the example above, @test2@ is required to be in the same .rpc file.+--+-- For a structure named @test@, the following would also be generated:+--+--   * @testEmpty@ - a Test filled with default values+--+--   * @testDeserialise@ - a strict Get instance to deserialise a test. Note+--     that these structures are self-deliminating, so additional garbage at+--     the end will be consumed and will probably result in an error+--+--   * @testDeserialiseBS@ - a function with type+--     ByteString -> Either String Test where the String is an error message+--+--   * @testSerialise@ - a Put Test function. Again, recall that these+--     structures aren't self deliminating+--+--   * @testSerialiseBS@ - a function with type Test -> ByteString+--+-- Each structure will also be an instance of the @TaggedStructure@ class+-- that you can find in "Codec.Libevent.Class"+--+module Codec.Libevent.Generate (generate) where++import System.Environment (getArgs)+import Data.Char (toUpper)+import Data.List (intersperse)+import Data.Maybe (mapMaybe)++import Text.Printf (printf)++import Codec.Libevent.Parse++-- | Generate the Haskell code for the given RPC file and write to standard+--   out. The generated module will export everything and takes the given+--   name+generate :: String  -- ^ the name of the module in the output+         -> RPCFile  -- ^ the RPC file to generate code for+         -> IO ()+generate modulename rpcfile = do+  printf "module %s where\n\n" modulename+  putStr "import Codec.Libevent\nimport Data.Word\n\n"+  putStr "import qualified Data.IntSet as IS\n\n"+  putStr "import Data.Binary.Put\nimport Data.Binary.Strict.Get\n\n"+  putStr "import qualified Data.ByteString as BS\n"+  putStr "import qualified Data.ByteString.Lazy as BSL\n\n"+  putStr "import Codec.Libevent.Class\n"++  sequence $ map generateStruct $ rpcstructs rpcfile+  putStr "\n"+  return ()++-- | Convert a struct name to a Haskell type name by uppercasing the first+--   letter+toDataName :: String -> String+toDataName (first:rest) = (toUpper first) : rest++rpcTypeToTypeString Int = "Word32"+rpcTypeToTypeString VarBytes = "BS.ByteString"+rpcTypeToTypeString String = "String"+rpcTypeToTypeString (Bytes _) = "BS.ByteString"+rpcTypeToTypeString (Struct name) = toDataName name++typeString :: Presence -> Type -> String+typeString Required x = rpcTypeToTypeString x+typeString Optional x = printf "Maybe %s" $ rpcTypeToTypeString x+typeString Repeated x = printf "[%s]" $ rpcTypeToTypeString x++generateElem :: String -> RPCElem -> String+generateElem structname elem =+  printf "%s_%s :: %s" structname (elemname elem) typestring where+  typestring = typeString (elempresence elem) (elemtype elem)++generateSerialiseElem :: String -> RPCElem -> String+generateSerialiseElem structname elem@(RPCElem { elempresence = Required }) =+  generateSerialiseElem' structname elem var where+  var :: String+  var = printf "%s_%s x" structname (elemname elem)+generateSerialiseElem structname elem@(RPCElem { elempresence = Optional }) =+  printf "case (%s x) of\n       Nothing -> return ()\n       (Just x) -> %s" a b where+  a :: String+  a = printf "%s_%s" structname (elemname elem)+  b = generateSerialiseElem' structname elem "x"+generateSerialiseElem structname elem@(RPCElem { elempresence = Repeated }) =+  printf "sequence $ map (\\x -> %s) $ %s x" a b where+  a = generateSerialiseElem' structname elem "x"+  b :: String+  b = printf "%s_%s" structname (elemname elem)++generateSerialiseElem' :: String -> RPCElem -> String -> String+generateSerialiseElem' structname elem@(RPCElem { elemtype = Bytes n }) var =+  printf "if (BS.length (%s)) /= %d then error \"Bad length for %s while serialising a %s\" else putTaggedVarBytes %d (%s)" var n (elemname elem) dataname tag var where+  dataname = toDataName structname+  tag = elemtag elem+generateSerialiseElem' structname elem@(RPCElem { elemtype = VarBytes }) var =+  printf "putTaggedVarBytes %d (%s)" (elemtag elem) var+generateSerialiseElem' structname elem@(RPCElem { elemtype = Int }) var =+  printf "putTaggedWord32 %d (%s)" (elemtag elem) var+generateSerialiseElem' structname elem@(RPCElem { elemtype = String }) var =+  printf "putTaggedString %d (%s)" (elemtag elem) var+generateSerialiseElem' structname elem@(RPCElem { elemtype = Struct struct }) var =+  printf "putTaggedVarBytes %d $ %sSerialiseBS (%s)" (elemtag elem) struct var++-- | Return the default value for a given type as a string+defaultValue :: RPCElem -> String+defaultValue (RPCElem { elempresence = Optional }) = "Nothing"+defaultValue (RPCElem { elempresence = Repeated }) = "[]"+defaultValue (RPCElem { elemtype = String }) = "\"\""+defaultValue (RPCElem { elemtype = Int }) = "0"+defaultValue (RPCElem { elemtype = Bytes _ }) = "BS.empty"+defaultValue (RPCElem { elemtype = VarBytes }) = "BS.empty"+defaultValue (RPCElem { elemtype = Struct n }) = printf "%sEmpty" n++-- | Return a list of tag numbers which are required elements+requiredTags :: [RPCElem] -> [Integer]+requiredTags = mapMaybe f where+  f (RPCElem { elempresence = Required, elemtag = tag }) = Just tag+  f _ = Nothing++-- | Generate the code to add the given variable (called @valuename)+--   to an object (called @objectname).+wrapValue structname elem@(RPCElem { elempresence = Required }) objectname valuename =+  valuename+wrapValue structname elem@(RPCElem { elempresence = Optional }) objectname valuename =+  printf "(Just %s)" valuename+wrapValue structname elem@(RPCElem { elempresence = Repeated }) objectname valuename =+  printf "(%s : %s_%s %s)" valuename structname (elemname elem) objectname++generateDeserialise :: String -> RPCElem -> String+generateDeserialise name elem@(RPCElem { elemtype = Int }) =+  printf "                 %d -> getWord8 >> getLengthPrefixed >>= (\\v -> f (o { %s_%s = %s }) (IS.insert %d set))"+         tag name (elemname elem) (wrapValue name elem "o" "v") tag where+  tag = elemtag elem+generateDeserialise name elem@(RPCElem { elemtype = String }) =+  printf "                 %d -> getLengthPrefixed >>= getByteString . fromIntegral >>= (\\v -> f (o { %s_%s = %s }) (IS.insert %d set))"+         tag name (elemname elem) (wrapValue name elem "o" "(decodeString v)") tag where+  tag = elemtag elem+generateDeserialise name elem@(RPCElem { elemtype = VarBytes }) =+  printf "                 %d -> getLengthPrefixed >>= getByteString . fromIntegral >>= (\\v -> f (o { %s_%s = %s }) (IS.insert %d set))"+         tag name (elemname elem) (wrapValue name elem "o" "v") tag where+  tag = elemtag elem+generateDeserialise name elem@(RPCElem { elemtype = Bytes n }) =+  printf "                 %d -> getLengthPrefixed >>= getByteString . fromIntegral >>= (\\v -> if (BS.length v) /= %d then fail \"bytes element had incorrect length decoding %s\" else f (o { %s_%s = %s }) (IS.insert %d set))"+         tag n (toDataName name) name (elemname elem) (wrapValue name elem "o" "v") tag where+  tag = elemtag elem+generateDeserialise name elem@(RPCElem { elemtype = Struct struct }) =+  printf "                 %d -> getLengthPrefixed >>= getByteString . fromIntegral >>= (\\v -> case (%sDeserialiseBS v) of { Left err -> fail (\"Failed to deserialse %s: \" ++ err) ; Right result -> f (o {%s_%s = %s }) (IS.insert %d set) })" (elemtag elem) struct (toDataName name) name (elemname elem) (wrapValue name elem "o" "result") (elemtag elem)++generateStruct (RPCStruct { structname = name, structelems = elems }) = do+  let dataname = toDataName name+  printf "data %s = %s { " dataname dataname+  putStr $ concat $ intersperse ", " $ map (generateElem name) elems+  putStr " } deriving (Show, Eq)\n\n"++  printf "%sSerialise :: %s -> Put\n" name dataname+  printf "%sSerialise x = do\n" name+  putStr "  "+  putStr $ concat $ intersperse "\n  " $ map (generateSerialiseElem name) elems+  putStr "\n\n"+  printf "%sSerialiseBS = BS.concat . BSL.toChunks . runPut . %sSerialise\n\n" name name+  printf "%sEmpty = %s %s" name dataname $ concat $ intersperse " " $ map defaultValue elems+  putStr "\n\n"+  printf "%sRequiredElementsSet = IS.fromList %s\n\n" name $ show $ requiredTags elems+  printf "%sDeserialise :: Get %s\n" name dataname+  printf "%sDeserialise = f %sEmpty IS.empty where\n" name name+  putStr "  f o set = do\n"+  putStr "    emptyp <- isEmpty\n"+  putStr "    if emptyp\n"+  printf "       then if not (IS.isSubsetOf %sRequiredElementsSet set)\n" name+  printf "               then fail \"%s did not contain all required elements\"\n" dataname+  putStr "               else return o\n"+  putStr "       else do tag <- getBase128\n"+  putStr "               case tag of\n"+  putStr $ concat $ intersperse "\n" $ map (generateDeserialise name) elems+  putStr "\n"+  putStr "                 otherwise -> getLengthPrefixed >>= getByteString . fromIntegral >> f o set\n"+  putStr "\n\n"+  printf "%sDeserialiseBS = fst . runGet %sDeserialise\n" name name+  putStr "\n"+  printf "instance TaggedStructure %s where\n" dataname+  printf "  empty = %sEmpty\n" name+  printf "  serialise = %sSerialiseBS\n" name+  printf "  deserialise = %sDeserialiseBS\n" name+  putStr "\n"
+ src/Codec/Libevent/Parse.hs view
@@ -0,0 +1,172 @@+-- |+-- Module: Codec.Libevent.Parse+-- Copyright: Adam Langley 2007+-- License: BSD+--+-- Stability: experimental+--+-- This module parses libevent <http://monkey.org/~provos/libevent> tagged+-- data structures as implimented in libevent-1.4.0-beta. These data structures+-- are described in a .rpc file.+--+module Codec.Libevent.Parse (+  -- * Data structures+    RPCFile(..)+  , RPCStruct(..)+  , RPCElem(..)+  , Presence(..)+  , Type(..)++  -- * Parsing functions+  , parseRPCFile+  , parseRPC+  ) where++import Control.Monad (when)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Maybe (isJust)+import Text.Printf (printf)+import Text.Regex (mkRegex, matchRegex)++import Text.ParserCombinators.Parsec++-- | This is a libevent .rpc file - just a list of the structures within+data RPCFile = RPCFile { rpcstructs :: [RPCStruct] }+               deriving (Show)++-- | An RPC structure has a name and a list of elements+data RPCStruct = RPCStruct { structname :: String+                           , structelems :: [RPCElem] }+                 deriving (Show)++-- | An RPC element is a tagged member+data RPCElem = RPCElem { elempresence :: Presence+                       , elemtype :: Type+                       , elemname :: String+                       , elemtag :: Integer }+               deriving (Show)++data Presence = Required | Optional | Repeated deriving (Show)+data Type = Bytes Int | VarBytes | String | Int | Struct String+            deriving (Eq, Show)++comment = do+  char '/'+  ((char '/' >> skipMany (noneOf "\n") >> return '\n') <|>+   (char '*' >> manyTill anyChar (try (string "*/")) >> return '\n'))++ws = many (char ' ' <|> char '\t' <|> char '\n' <|> try comment)++ident = many1 $ oneOf (['a' .. 'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ "_")++parsePresence =+  (string "optional" >> return Optional)+    <|> (string "array" >> return Repeated)++parseType =+  (try $ string "string" >> return String)+    <|> (string "bytes" >> return VarBytes)+    <|> (string "int" >> return Int)+    <|> (do string "struct["+            name <- ident+            char ']'+            return $ Struct name)++parseOptionalLength =+  option Nothing (do+    char '['+    v <- many1 (oneOf "0123456789")+    char ']'+    return $ Just $ read v)++parseTag = many1 (oneOf "0123456789") >>= return . read++parseElem = do+  presence <- option Required parsePresence+  ws+  ty <- parseType+  ws+  name <- ident+  length <- parseOptionalLength+  ws+  char '='+  ws+  tag <- parseTag+  ws+  char ';'++  case length of+       (Just x) -> do when (ty /= VarBytes) (fail "Cannot have length with non-bytes element")+                      return $ RPCElem presence (Bytes x) name tag+       Nothing -> return $ RPCElem presence ty name tag++validStructNameRegex = mkRegex "[a-z][a-zA-Z0-9_]*"+isValidStructName = isJust . matchRegex validStructNameRegex++parseStruct = do+  string "struct"+  ws+  name <- ident+  ws+  char '{'+  ws+  elems <- sepEndBy parseElem ws+  ws+  char '}'+  if isValidStructName name+     then return $ RPCStruct name elems+     else fail ("Invalid struct name: " ++ name)++dups :: (Ord a) => [a] -> [a]+dups = Map.keys . Map.filter ((<) 1) . Map.fromListWith (+) . map (\x -> (x, 1))++-- | Return true iff the given structure is valid+rpcStructSane :: RPCStruct -> Bool+rpcStructSane (RPCStruct { structname = name, structelems = elems }) =+  let+    duplicatedTags = dups $ map elemtag elems+    duplicatedNames = dups $ map elemname elems+  in+    if (length duplicatedTags) > 0+       then error $ printf "In RPC struct %s, the following tags are duplicated: %s" name (show duplicatedTags)+       else if (length duplicatedNames) > 0+               then error $ printf "In RPC struct %s, these names are duplicated: %s" name (show duplicatedNames)+               else True++-- | Return a list of all structs referenced by a struct+usedStructs struct = [s | RPCElem { elemtype = Struct s } <- structelems struct]++-- | Checks that all used structures are defined and, if so, acts as the identity+--   function. Otherwise it throws an exception.+rpcAllStructsDefined :: RPCFile -> RPCFile+rpcAllStructsDefined file =+  let+    used = foldl Set.union Set.empty $ map (Set.fromList . usedStructs) $ rpcstructs file+    defined = Set.fromList $ map structname $ rpcstructs file+  in+    if used `Set.isSubsetOf` defined+       then file+       else error ("Undefined: " ++ show (used `Set.difference` defined))++-- | If the given RPCFile is valid, act as the identity function. Otherwise,+--   throw an exception.+rpcFileSane :: RPCFile -> RPCFile+rpcFileSane file = if all id (map rpcStructSane $ rpcstructs file)+                      then rpcAllStructsDefined file+                      else error "Errors found in RPC file"++parseRPCFile' = do+  ws+  structs <- sepEndBy parseStruct ws+  ws+  eof+  return $ rpcFileSane $ RPCFile structs++-- | Parse the given filename+parseRPCFile :: FilePath -> IO (Either ParseError RPCFile)+parseRPCFile = parseFromFile parseRPCFile'++-- | Parse the given string as an RPC file+parseRPC :: String -> Either ParseError RPCFile+parseRPC = parse parseRPCFile' "<input>"
+ src/codec-libevent-generate.hs view
@@ -0,0 +1,16 @@+module Main where++import System.Environment++import Codec.Libevent.Parse+import Codec.Libevent.Generate++main = do+  args <- getArgs+  case args of+       [inputfile, modulename] -> do+         parseResult <- parseRPCFile inputfile+         case parseResult of+           Left err -> fail $ show err+           Right rpc -> generate modulename rpc >> return ()+       otherwise -> fail "Usage: <input rpc file> <module name>"