diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +Version 1.2.2.5 +--------------- + +* Fix a list deserialization bug +* Serialize small ints compactly + Version 1.2.2.4 --------------- diff --git a/bert.cabal b/bert.cabal --- a/bert.cabal +++ b/bert.cabal @@ -1,6 +1,6 @@ cabal-version: >= 1.16 name: bert -version: 1.2.2.4 +version: 1.2.2.5 build-type: Simple license: BSD3 license-file: LICENSE diff --git a/src/Data/BERT/Term.hs b/src/Data/BERT/Term.hs --- a/src/Data/BERT/Term.hs +++ b/src/Data/BERT/Term.hs @@ -177,7 +177,9 @@ -- | Binary encoding of a single term (without header) putTerm :: Term -> PutM () -putTerm (IntTerm value) = tag 98 >> put32s value +putTerm (IntTerm value) + | 0 <= value && value < 256 = tag 97 >> put8u value + | otherwise = tag 98 >> put32s value putTerm (FloatTerm value) = tag 99 >> (putL . C.pack . pad $ printf "%15.15e" value) where @@ -203,7 +205,7 @@ where len = B.length value putTerm (ListTerm value) - | len == 0 = putNil -- this is mentioend in the BERT spec. + | len == 0 = putNil -- this is mentioned in the BERT spec. | otherwise= do tag 108 put32u $ length value @@ -231,12 +233,19 @@ 105 -> get32u >>= getN >>= tupleTerm 106 -> return $ ListTerm [] 107 -> get16u >>= getL >>= return . BytelistTerm - 108 -> get32u >>= getN >>= return . ListTerm + 108 -> get32u >>= \n -> getN n <* expectNil >>= return . ListTerm 109 -> get32u >>= getL >>= return . BinaryTerm 110 -> getBigint get8u >>= return . BigintTerm . fromIntegral 111 -> getBigint get32u >>= return . BigintTerm . fromIntegral where + getN :: Int -> Get [Term] getN n = replicateM n getTerm + expectNil :: Get () + expectNil = do + tag <- get8u + case tag of + 106 -> return () + _ -> fail $ "invalid list - expected list ending with Nil" -- First try & decode composite terms. tupleTerm [AtomTerm "bert", AtomTerm "true"] = return $ BoolTerm True tupleTerm [AtomTerm "bert", AtomTerm "false"] = return $ BoolTerm False @@ -304,9 +313,13 @@ put32s = putWord32be . (fromIntegral :: Int32 -> Word32) . fromIntegral putL = putLazyByteString +get8u :: (Integral a) => Get a get8u = fromIntegral <$> getWord8 +get16u :: (Integral a) => Get a get16u = fromIntegral <$> getWord16be +get32u :: (Integral a) => Get a get32u = fromIntegral <$> getWord32be +get32s :: (Integral a) => Get a get32s = fromIntegral . (fromIntegral :: Word32 -> Int32) <$> getWord32be getL :: (Integral a) => a -> Get ByteString getL = getLazyByteString . fromIntegral diff --git a/tests/test.hs b/tests/test.hs --- a/tests/test.hs +++ b/tests/test.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-} import Control.Monad import Data.Binary -import Data.Char (chr) +import Data.Char (chr, ord) +import Data.List (genericLength) import Data.Map (Map) import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map @@ -42,16 +43,22 @@ else Left $ printf "%s /= %s" sx sy -- value -> Term -> encoded -> Term -> value +t :: (BERT a, Eq a, Show a) => T a t a = Right a `eqVerbose` (readBERT . decode . encode . showBERT) a + -- value -> Term -> Packet -> encoded -> Packet -> Term -> value +p :: (BERT a, Eq a, Show a) => T a p a = Right a `eqVerbose` (readBERT . fromPacket . decode . encode . Packet . showBERT) a +main :: IO () main = defaultMain $ localOption (SmallCheckDepth 4) $ testGroup "Tests" [ testGroup "Serialization" [simpleTerms, simplePackets] , networkTests + , testGroup "Specification compliance" specTests ] +simpleTerms :: TestTree simpleTerms = testGroup "Simple terms" [ testProperty "Bool" (t :: T Bool) , testProperty "Integer" (t :: T Integer) @@ -64,6 +71,7 @@ , testProperty "(Int, Int, Int, Int)" (t :: T (Int, Int, Int, Int)) ] +simplePackets :: TestTree simplePackets = testGroup "Simple packets" [ testProperty "Bool" (p :: T Bool) , testProperty "Integer" (p :: T Integer) @@ -75,6 +83,7 @@ , testProperty "(String, Int, Int, Int)" (p :: T (String, Int, Int, Int)) ] +networkTests :: TestTree networkTests = testGroup "Network" [ networkTest1 , networkTest2 @@ -88,6 +97,7 @@ delay :: IO () delay = threadDelay (10^5) +networkTest1 :: TestTree networkTest1 = testCase "Simple call" $ do t <- tcpServer port let server = serve t $ \ "mod" "f" [IntTerm a] -> return $ Success $ IntTerm (a+1) @@ -97,6 +107,7 @@ result <- call c "mod" "f" [IntTerm 3] result @?= Right (IntTerm 4) +networkTest2 :: TestTree networkTest2 = testCase "5 calls per connection" $ do t <- tcpServer port let server = serve t $ \ "mod" "f" [IntTerm a, IntTerm b] -> return $ Success $ IntTerm (a+b) @@ -107,6 +118,7 @@ result <- call c "mod" "f" [IntTerm 3, IntTerm x] result @?= Right (IntTerm (3+x)) +networkTest3 :: TestTree networkTest3 = testCase "5 sequential connections" $ do t <- tcpServer port let server = serve t $ \ "mod" "f" [IntTerm a, IntTerm b] -> return $ Success $ IntTerm (a+b) @@ -117,6 +129,7 @@ result <- call c "mod" "f" [IntTerm 3, IntTerm x] result @?= Right (IntTerm (3+x)) +networkTest4 :: TestTree networkTest4 = testCase "100 simultaneous connections" $ do t <- tcpServer port let server = serve t $ \ "mod" "f" [IntTerm a, IntTerm b] -> @@ -132,3 +145,68 @@ result <- call c "mod" "f" [IntTerm 3, IntTerm x] result @?= Right (IntTerm (3+x)) maybe (assertFailure "Timed out!") (const $ return ()) r + +ord' :: Char -> Word8 +ord' = fromIntegral . ord + +-- Test internal representation according to specification +-- http://erlang.org/doc/apps/erts/erl_ext_dist.html +specTests :: [TestTree] +specTests = + [ thereAndBackAgainTest "SMAL_INTEGER_EXT" (IntTerm 5) [131, 97, 5] + , thereAndBackAgainTest "INTEGER_EXT" (IntTerm 0x400) [131, 98, 0, 0, 4, 0] + , thereAndBackAgainTest "ATOM_EXT" + (AtomTerm "foobar") + ([131, 100, 0, 6] ++ map ord' "foobar") + , thereAndBackAgainTest "SMALL_TUPLE_EXT" + (TupleTerm + [ AtomTerm x + | x <- ["a", "b", "c", "d"] + ]) + ([131, 104, 4] ++ + concat [ [100, 0, genericLength x] ++ map ord' x + | x <- ["a", "b", "c", "d"] + ]) + , thereAndBackAgainTest "LARGE_TUPLE_EXT" + (TupleTerm + [ AtomTerm [x] + | x <- take 512 $ cycle ['a'..'z'] + ]) + ([131, 105, 0, 0, 2, 0] ++ + concat [ [100, 0, 1, ord' x] + | x <- take 512 $ cycle ['a'..'z'] + ]) + , thereAndBackAgainTest "NIL_EXT" + (ListTerm []) + [131, 106] + , thereAndBackAgainTest "STRING_EXT" + (BytelistTerm "abc\0") + [131, 107, 0, 4, 97, 98, 99, 0] + , thereAndBackAgainTest "LIST_EXT" + (ListTerm [AtomTerm "abc", AtomTerm "xyz"]) + ([131, 108, 0, 0, 0, 2] ++ + [100, 0, 3, 97, 98, 99] ++ + [100, 0, 3, 120, 121, 122] ++ + [106]) + , thereAndBackAgainTest "LIST_EXT - nested" + (ListTerm [ListTerm [AtomTerm "abc"], ListTerm [AtomTerm "xyz"]]) + ([131, 108, 0, 0, 0, 2] ++ + ([108, 0, 0, 0, 1] ++ [100, 0, 3, 97, 98, 99] ++ [106]) ++ + ([108, 0, 0, 0, 1] ++ [100, 0, 3, 120, 121, 122] ++ [106]) ++ + [106]) + , thereAndBackAgainTest "BINARY_EXT" + (BinaryTerm "x\0y\1z") + ([131, 109, 0, 0, 0, 5, 120, 0, 121, 1, 122]) + , thereAndBackAgainTest " SMALL_BIG_EXT" + (BigintTerm $ 4 + 3 * 256 + 2 * 256^2 + 1 * 256^3) + ([131, 110, 4, 0, 4, 3, 2, 1]) + ] + +thereAndBackAgainTest :: String -> Term -> [Word8] -> TestTree +thereAndBackAgainTest name term binaryRepr = testGroup name + [ testCase "Term -> binary" $ + L.unpack (encode term) @?= binaryRepr + , testCase "binary -> Term" $ + decode (L.pack binaryRepr) @?= term + ] +