bert 1.2.1 → 1.2.1.1
raw patch · 4 files changed
+89/−61 lines, 4 filesdep ~smallcheck
Dependency ranges changed: smallcheck
Files
- bert.cabal +2/−2
- src/Data/BERT/Term.hs +72/−55
- src/Network/BERT.hs +1/−1
- tests/test.hs +14/−3
bert.cabal view
@@ -1,6 +1,6 @@ cabal-version: >= 1.16 name: bert-version: 1.2.1+version: 1.2.1.1 build-type: Simple license: BSD3 license-file: LICENSE@@ -55,7 +55,7 @@ network, bert, base,- smallcheck,+ smallcheck >= 1.1, containers, bytestring, binary
src/Data/BERT/Term.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverlappingInstances, TypeSynonymInstances, FlexibleInstances #-} -- | Define BERT terms their binary encoding & decoding and a typeclass -- for converting Haskell values to BERT terms and back.--- +-- -- We define a number of convenient instances for 'BERT'. Users will -- probably want to define their own instances for composite types. module Data.BERT.Term@@ -12,6 +12,7 @@ import Control.Applicative import Data.Bits import Data.Char+import Data.Int import Data.Binary import Data.Binary.Put import Data.Binary.Get@@ -46,7 +47,7 @@ instance Show Term where -- Provide an erlang-compatible 'show' for terms. The results of- -- this should be parseable as erlang source. + -- this should be parseable as erlang source. show = showTerm instance Read Term where@@ -65,14 +66,14 @@ compose NilTerm = ListTerm [] compose (BoolTerm True) = ct "true" [] compose (BoolTerm False) = ct "false" []-compose (DictionaryTerm kvs) = +compose (DictionaryTerm kvs) = ct "dict" [ListTerm $ map (\(k, v) -> TupleTerm [k, v]) kvs] compose (TimeTerm t) = ct "time" [IntTerm mS, IntTerm s, IntTerm uS] where (mS, s, uS) = decomposeTime t-compose (RegexTerm s os) = - ct "regex" [BytelistTerm (C.pack s), +compose (RegexTerm s os) =+ ct "regex" [BytelistTerm (C.pack s), TupleTerm [ListTerm $ map AtomTerm os]] compose _ = error "invalid composite term" @@ -82,15 +83,15 @@ showTerm (AtomTerm a@(x:xs)) | isAsciiLower x = a | otherwise = "'" ++ a ++ "'"-showTerm (TupleTerm ts) = +showTerm (TupleTerm ts) = "{" ++ intercalate ", " (map showTerm ts) ++ "}" showTerm (BytelistTerm bs) = show $ C.unpack bs-showTerm (ListTerm ts) = +showTerm (ListTerm ts) = "[" ++ intercalate ", " (map showTerm ts) ++ "]" showTerm (BinaryTerm b)- | all (isAscii . chr . fromIntegral) (B.unpack b) = + | all (isAscii . chr . fromIntegral) (B.unpack b) = wrap $ "\"" ++ C.unpack b ++ "\""- | otherwise = + | otherwise = wrap $ intercalate ", " $ map show $ B.unpack b where wrap x = "<<" ++ x ++ ">>"@@ -158,21 +159,21 @@ instance (BERT a, BERT b, BERT c) => BERT (a, b, c) where showBERT (a, b, c) = TupleTerm [showBERT a, showBERT b, showBERT c]- readBERT (TupleTerm [a, b, c]) = + readBERT (TupleTerm [a, b, c]) = liftM3 (,,) (readBERT a) (readBERT b) (readBERT c) readBERT _ = fail "Invalid tuple(3) type" instance (BERT a, BERT b, BERT c, BERT d) => BERT (a, b, c, d) where- showBERT (a, b, c, d) = + showBERT (a, b, c, d) = TupleTerm [showBERT a, showBERT b, showBERT c, showBERT d]- readBERT (TupleTerm [a, b, c, d]) = + readBERT (TupleTerm [a, b, c, d]) = liftM4 (,,,) (readBERT a) (readBERT b) (readBERT c) (readBERT d) readBERT _ = fail "Invalid tuple(4) type" instance (Ord k, BERT k, BERT v) => BERT (Map k v) where- showBERT m = DictionaryTerm + showBERT m = DictionaryTerm $ map (\(k, v) -> (showBERT k, showBERT v)) (Map.toList m)- readBERT (DictionaryTerm kvs) = + readBERT (DictionaryTerm kvs) = mapM (\(k, v) -> liftM2 (,) (readBERT k) (readBERT v)) kvs >>= return . Map.fromList readBERT _ = fail "Invalid map type"@@ -181,68 +182,70 @@ instance Binary Term where put term = putWord8 131 >> putTerm term get = getWord8 >>= \magic ->- case magic of + case magic of 131 -> getTerm _ -> fail "bad magic" -- | Binary encoding of a single term (without header)-putTerm (IntTerm value) = tag 98 >> put32i value+putTerm :: Term -> PutM ()+putTerm (IntTerm value) = tag 98 >> put32s value putTerm (FloatTerm value) = tag 99 >> (putL . C.pack . pad $ printf "%15.15e" value) where pad s = s ++ replicate (31 - (length s)) '\0' putTerm (AtomTerm value)- | len < 256 = tag 100 >> put16i len >> (putL $ C.pack value)+ | len < 256 = tag 100 >> put16u len >> (putL $ C.pack value) | otherwise = fail "BERT atom too long (>= 256)" where len = length value putTerm (TupleTerm value)- | len < 256 = tag 104 >> put8i len >> forM_ value putTerm- | otherwise = tag 105 >> put32i len >> forM_ value putTerm+ | len < 256 = tag 104 >> put8u len >> forM_ value putTerm+ | otherwise = tag 105 >> put32u len >> forM_ value putTerm where len = length value putTerm (BytelistTerm value)- | len < 65536 = tag 107 >> put16i len >> putL value+ | len < 65536 = tag 107 >> put16u len >> putL value | otherwise = do -- too big: encode as a list. tag 108- put32i len- forM_ (B.unpack value) $ \v -> do + put32u len+ forM_ (B.unpack value) $ \v -> do tag 97 putWord8 v- where + where len = B.length value putTerm (ListTerm value) | len == 0 = putNil -- this is mentioend in the BERT spec. | otherwise= do tag 108- put32i $ length value+ put32u $ length value forM_ value putTerm putNil- where + where len = length value putNil = putWord8 106-putTerm (BinaryTerm value) = tag 109 >> (put32i $ B.length value) >> putL value-putTerm (BigintTerm value) = tag 110 >> putBigint put8i value-putTerm (BigbigintTerm value) = tag 111 >> putBigint put32i value+putTerm (BinaryTerm value) = tag 109 >> (put32u $ B.length value) >> putL value+putTerm (BigintTerm value) = tag 110 >> putBigint put8u value+putTerm (BigbigintTerm value) = tag 111 >> putBigint put32u value -- All other terms are composite: putTerm t = putTerm . compose $ t -- | Binary decoding of a single term (without header)+getTerm :: Get Term getTerm = do- tag <- get8i+ tag <- get8u case tag of- 97 -> IntTerm <$> get8i- 98 -> IntTerm <$> get32i+ 97 -> IntTerm <$> get8u+ 98 -> IntTerm <$> get32s 99 -> getL 31 >>= return . FloatTerm . read . C.unpack- 100 -> get16i >>= getL >>= return . AtomTerm . C.unpack- 104 -> get8i >>= getN >>= tupleTerm- 105 -> get32i >>= getN >>= tupleTerm + 100 -> get16u >>= getL >>= return . AtomTerm . C.unpack+ 104 -> get8u >>= getN >>= tupleTerm+ 105 -> get32u >>= getN >>= tupleTerm 106 -> return $ ListTerm []- 107 -> get16i >>= getL >>= return . BytelistTerm- 108 -> get32i >>= getN >>= return . ListTerm- 109 -> get32i >>= getL >>= return . BinaryTerm- 110 -> getBigint get8i >>= return . BigintTerm . fromIntegral- 111 -> getBigint get32i >>= return . BigintTerm . fromIntegral+ 107 -> get16u >>= getL >>= return . BytelistTerm+ 108 -> get32u >>= getN >>= return . ListTerm+ 109 -> get32u >>= getL >>= return . BinaryTerm+ 110 -> getBigint get8u >>= return . BigintTerm . fromIntegral+ 111 -> getBigint get32u >>= return . BigintTerm . fromIntegral where getN n = replicateM n getTerm -- First try & decode composite terms.@@ -253,8 +256,8 @@ where toTuple (TupleTerm [k, v]) = return $ (k, v) toTuple _ = fail "invalid dictionary"- tupleTerm [AtomTerm "bert", AtomTerm "time", - IntTerm mS, IntTerm s, IntTerm uS] = + tupleTerm [AtomTerm "bert", AtomTerm "time",+ IntTerm mS, IntTerm s, IntTerm uS] = return $ TimeTerm $ composeTime (mS, s, uS) tupleTerm [AtomTerm "bert", AtomTerm "regex", BytelistTerm s, ListTerm os] =@@ -270,8 +273,8 @@ putBigint putter value = do putter len -- TODO: verify size? if value < 0- then put8i 1- else put8i 0+ then put8u 1+ else put8u 0 putL $ B.pack $ map (fromIntegral . digit) [0..len-1] where value' = abs value@@ -280,10 +283,10 @@ getBigint getter = do len <- fromIntegral <$> getter- sign <- get8i+ sign <- get8u bytes <- getL len- multiplier <- - case sign of + multiplier <-+ case sign of 0 -> return 1 1 -> return (-1) _ -> fail "Invalid sign byte"@@ -291,17 +294,31 @@ $ foldl (\s (n, d) -> s + d*(256^n)) 0 $ zip [0..len-1] (map fromIntegral $ B.unpack bytes) -put8i :: (Integral a) => a -> Put-put8i = putWord8 . fromIntegral-put16i :: (Integral a) => a -> Put-put16i = putWord16be . fromIntegral-put32i :: (Integral a) => a -> Put-put32i = putWord32be . fromIntegral+-- Note about put32s/get32s:+--+-- When dealing with 32-bit signed ints, we first convert between Int and+-- Int32, and only then cast to Word32. This is to ensure put and get are+-- as close to inverse as possible. Coercing word types to and from+-- integer types using 'fromIntegral' is guaranteed to preserve+-- representation (see Notes in "Data.Int").+--+-- For an example of what can go wrong, see+-- https://github.com/feuerbach/bert/issues/6++put8u :: (Integral a) => a -> Put+put8u = putWord8 . fromIntegral+put16u :: (Integral a) => a -> Put+put16u = putWord16be . fromIntegral+put32u :: (Integral a) => a -> Put+put32u = putWord32be . fromIntegral+put32s :: (Integral a) => a -> Put+put32s = putWord32be . (fromIntegral :: Int32 -> Word32) . fromIntegral putL = putLazyByteString -get8i = fromIntegral <$> getWord8-get16i = fromIntegral <$> getWord16be-get32i = fromIntegral <$> getWord32be+get8u = fromIntegral <$> getWord8+get16u = fromIntegral <$> getWord16be+get32u = fromIntegral <$> getWord32be+get32s = fromIntegral . (fromIntegral :: Word32 -> Int32) <$> getWord32be getL :: (Integral a) => a -> Get ByteString getL = getLazyByteString . fromIntegral
src/Network/BERT.hs view
@@ -1,4 +1,4 @@--- | BERT-RPC client (<http://bert-rpc.org/>). See "Network.BERT.Transport" and "Network.BERT.RPC" for more details.+-- | BERT-RPC client (<http://bert-rpc.org/>). See "Network.BERT.Client" and "Network.BERT.Server" for more details. module Network.BERT ( module Network.BERT.Transport , module Network.BERT.Client
tests/test.hs view
@@ -7,6 +7,7 @@ import Data.Map (Map) import qualified Data.ByteString.Lazy as L import qualified Data.Map as Map+import Text.Printf import Control.Concurrent import Control.Concurrent.Async@@ -29,11 +30,21 @@ instance (Serial m a, Ord a, Serial m b) => Serial m (Map a b) where series = liftM Map.fromList series -type T a = a -> Bool+type T a = a -> Either String String++eqVerbose :: (Eq a, Show a) => a -> a -> Either String String+eqVerbose x y =+ let sx = show x+ sy = show y+ in+ if x == y+ then Right $ printf "%s == %s" sx sy+ else Left $ printf "%s /= %s" sx sy+ -- value -> Term -> encoded -> Term -> value-t a = Right a == (readBERT . decode . encode . showBERT) a+t a = Right a `eqVerbose` (readBERT . decode . encode . showBERT) a -- value -> Term -> Packet -> encoded -> Packet -> Term -> value-p a = Right a == (readBERT . fromPacket . decode . encode . Packet . showBERT) a+p a = Right a `eqVerbose` (readBERT . fromPacket . decode . encode . Packet . showBERT) a main = defaultMain $ localOption (SmallCheckDepth 4) $ testGroup "Tests"