Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Haskell implementation of BERT.

  • Loading branch information...
commit e9eefaa87dbb514e8966c3d19ebb268023b9115a 0 parents
@mariusae authored
Showing with 359 additions and 0 deletions.
  1. +104 −0 Data/BERT.hs
  2. +36 −0 Data/BERT/Packet.hs
  3. +176 −0 Data/BERT/Term.hs
  4. +43 −0 QC.hs
104 Data/BERT.hs
@@ -0,0 +1,104 @@
+{-# LANGUAGE OverlappingInstances #-}
+{-# OPTIONS -XTypeSynonymInstances #-}
+-- |
+-- Module : Data.BERT
+-- Copyright : (c) marius a. eriksen 2009
+--
+-- License : BSD3
+-- Maintainer : marius@monkey.org
+-- Stability : experimental
+-- Portability : GHC
+--
+-- BERT (Erlang terms + RPC) implementation.
+-- - <http://bert-rpc.org/>
+-- - <http://erlang.org/doc/apps/erts/erl_ext_dist.html>
+module Data.BERT
+ ( BERT(..)
+ , Term(..)
+ , Packet(..)
+ ) where
+
+import Control.Monad.Error
+import Data.Char (chr)
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as C
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Data.BERT.Term (Term(..))
+import Data.BERT.Packet (Packet(..))
+
+class BERT a where
+ showBERT :: a -> Term
+ readBERT :: Term -> (Either String a)
+
+-- Herein are some instances for common Haskell data types. To do
+-- anything more complicated, you should make your own instance.
+
+instance BERT Term where
+ showBERT = id
+ readBERT = return . id
+
+instance BERT Int where
+ showBERT = IntTerm
+ readBERT (IntTerm value) = return value
+
+instance BERT Bool where
+ showBERT = BoolTerm
+ readBERT (BoolTerm x) = return x
+
+instance BERT Integer where
+ showBERT = BigbigintTerm
+ readBERT (BigintTerm x) = return x
+ readBERT (BigbigintTerm x) = return x
+ readBERT _ = fail "Invalid integer type"
+
+instance BERT Float where
+ showBERT = FloatTerm
+ readBERT (FloatTerm value) = return value
+ readBERT _ = fail "Invalid floating point type"
+
+instance BERT String where
+ showBERT = BytelistTerm . C.pack
+ readBERT (BytelistTerm x) = return $ C.unpack x
+ readBERT (BinaryTerm x) = return $ C.unpack x
+ readBERT (AtomTerm x) = return x
+ readBERT (ListTerm xs) = mapM readBERT xs >>= return . map chr
+ readBERT _ = fail "Invalid string type"
+
+instance BERT ByteString where
+ showBERT = BytelistTerm
+ readBERT (BytelistTerm value) = return value
+ readBERT _ = fail "Invalid bytestring type"
+
+instance (BERT a) => BERT [a] where
+ showBERT xs = ListTerm $ map showBERT xs
+ readBERT (ListTerm xs) = mapM readBERT xs
+ readBERT _ = fail "Invalid list type"
+
+instance (BERT a, BERT b) => BERT (a, b) where
+ showBERT (a, b) = TupleTerm [showBERT a, showBERT b]
+ readBERT (TupleTerm [a, b]) = liftM2 (,) (readBERT a) (readBERT b)
+ readBERT _ = fail "Invalid tuple(2) type"
+
+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]) =
+ 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) =
+ TupleTerm [showBERT a, showBERT b, showBERT c, showBERT 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
+ $ map (\(k, v) -> (showBERT k, showBERT v)) (Map.toList m)
+ readBERT (DictionaryTerm kvs) =
+ mapM (\(k, v) -> liftM2 (,) (readBERT k) (readBERT v)) kvs >>=
+ return . Map.fromList
+ readBERT _ = fail "Invalid map type"
+
36 Data/BERT/Packet.hs
@@ -0,0 +1,36 @@
+-- |
+-- Module : Data.BERT.Packet
+-- Copyright : (c) marius a. eriksen 2009
+--
+-- License : BSD3
+-- Maintainer : marius@monkey.org
+-- Stability : experimental
+-- Portability : GHC
+--
+-- BERP support.
+module Data.BERT.Packet
+ ( Packet(..)
+ ) where
+
+import Control.Monad (liftM)
+import Data.ByteString (ByteString)
+import Data.ByteString.Lazy as B
+import Data.Binary (Binary(..), encode, decode)
+import Data.Binary.Put (putWord32be, putLazyByteString)
+import Data.Binary.Get (getWord32be, getLazyByteString)
+
+import Data.BERT.Term (Term(..))
+
+data Packet
+ = Packet Term
+ deriving (Show, Ord, Eq)
+
+instance Binary Packet where
+ put (Packet term) =
+ putWord32be (fromIntegral len) >> putLazyByteString encoded
+ where encoded = encode term
+ len = B.length encoded
+ get = liftM fromIntegral getWord32be >>=
+ getLazyByteString >>=
+ return . Packet . decode
+
176 Data/BERT/Term.hs
@@ -0,0 +1,176 @@
+{-# LANGUAGE OverlappingInstances #-}
+-- |
+-- Module : Data.BERT.Term
+-- Copyright : (c) marius a. eriksen 2009
+--
+-- License : BSD3
+-- Maintainer : marius@monkey.org
+-- Stability : experimental
+-- Portability : GHC
+--
+-- Define BERT terms and their binary encoding & decoding.
+module Data.BERT.Term
+ ( Term(..)
+ ) where
+
+import Control.Monad (forM_, replicateM)
+import Control.Applicative ((<$>))
+import Data.Bits (shiftR, (.&.))
+import Data.Binary (Binary(..), Word8)
+import Data.Binary.Put (Put, putWord8, putWord16be,
+ putWord32be, putLazyByteString)
+import Data.Binary.Get (Get, getWord8, getWord16be, getWord32be,
+ getLazyByteString)
+import Data.ByteString.Lazy (ByteString)
+import qualified Data.ByteString.Lazy as B
+import qualified Data.ByteString.Lazy.Char8 as C
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Text.Printf (printf)
+
+data Term
+ -- Simple (erlang) terms:
+ = IntTerm Int
+ | FloatTerm Float
+ | AtomTerm String
+ | TupleTerm [Term]
+ | BytelistTerm ByteString
+ | ListTerm [Term]
+ | BinaryTerm ByteString
+ | BigintTerm Integer
+ | BigbigintTerm Integer
+ -- Complex terms:
+ | NilTerm
+ | BoolTerm Bool
+ | DictionaryTerm [(Term, Term)]
+ -- TODO: time, regex
+ deriving (Show, Eq, Ord)
+
+-- Binary encoding & decoding.
+instance Binary Term where
+ put term = putWord8 131 >> putTerm term
+ get = getWord8 >>= \version ->
+ case version of
+ 131 -> getTerm
+ _ -> fail "wrong version"
+
+-- | Binary encoding of a single term (without header)
+putTerm (IntTerm value) = tag 98 >> put32i 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)
+ | 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
+ where
+ len = length value
+putTerm (BytelistTerm value)
+ | len < 65536 = tag 107 >> put16i len >> putL value
+ | otherwise = do -- too big: encode as a list.
+ tag 108
+ put32i len
+ forM_ (B.unpack value) $ \v -> do
+ tag 97
+ putWord8 v
+ 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
+ forM_ value putTerm
+ putNil
+ 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
+-- Complex terms:
+putTerm NilTerm = putTerm $ TupleTerm [AtomTerm "bert", AtomTerm "nil"]
+putTerm (BoolTerm value) =
+ putTerm $ TupleTerm [AtomTerm "bert", AtomTerm value']
+ where
+ value' = if value then "true" else "false"
+putTerm (DictionaryTerm value) =
+ putTerm $ TupleTerm [ AtomTerm "bert"
+ , AtomTerm "dict"
+ , ListTerm $ map (\(k, v) -> TupleTerm [k, v]) value
+ ]
+-- | Binary decoding of a single term (without header)
+getTerm = do
+ tag <- get8i
+ case tag of
+ 97 -> IntTerm <$> get8i
+ 98 -> IntTerm <$> get32i
+ 99 -> getL 31 >>= return . FloatTerm . read . C.unpack
+ 100 -> get16i >>= getL >>= return . AtomTerm . C.unpack
+ 104 -> get8i >>= getN >>= tupleTerm
+ 105 -> get32i >>= 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
+ where
+ getN n = replicateM n getTerm
+ tupleTerm [AtomTerm "bert", AtomTerm "true"] = return $ BoolTerm True
+ tupleTerm [AtomTerm "bert", AtomTerm "false"] = return $ BoolTerm False
+ tupleTerm [AtomTerm "bert", AtomTerm "dict", ListTerm kvs] =
+ mapM toTuple kvs >>= return . DictionaryTerm
+ where
+ toTuple (TupleTerm [k, v]) = return $ (k, v)
+ toTuple _ = fail "invalid dictionary"
+
+ tupleTerm xs = return $ TupleTerm xs
+
+putBigint putter value = do
+ putter len -- TODO: verify size?
+ if value < 0
+ then put8i 1
+ else put8i 0
+ putL $ B.pack $ map (fromIntegral . digit) [0..len-1]
+ where
+ value' = abs value
+ len = ceiling $ logBase 256 (fromIntegral $ value' + 1)
+ digit pos = (value' `shiftR` (8 * pos)) .&. 0xFF
+
+getBigint getter = do
+ len <- fromIntegral <$> getter
+ sign <- get8i
+ bytes <- getL len
+ multiplier <-
+ case sign of
+ 0 -> return 1
+ 1 -> return (-1)
+ _ -> fail "Invalid sign byte"
+ return $ (*) multiplier
+ $ 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
+putL = putLazyByteString
+
+get8i = fromIntegral <$> getWord8
+get16i = fromIntegral <$> getWord16be
+get32i = fromIntegral <$> getWord32be
+getL :: (Integral a) => a -> Get ByteString
+getL = getLazyByteString . fromIntegral
+
+tag :: Word8 -> Put
+tag which = putWord8 which
43 QC.hs
@@ -0,0 +1,43 @@
+{-# OPTIONS_GHC -fglasgow-exts #-}
+import Control.Monad
+
+import Data.Binary
+import Data.Char (chr)
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Test.QuickCheck.Batch
+import Test.QuickCheck
+
+import Data.BERT
+
+instance Arbitrary Char where
+ -- NB! We use a restricted notion of Char here, as we Char8-pack
+ -- strings in our implementation, truncating chars over 8 bits.
+ arbitrary = liftM chr $ choose (0, 255)
+ coarbitrary = undefined
+
+instance (Arbitrary a, Ord a, Arbitrary b) => Arbitrary (Map a b) where
+ arbitrary = liftM Map.fromList arbitrary
+ coarbitrary = undefined
+
+options = TestOptions
+ { no_of_tests = 500
+ , length_of_tests = 100
+ , debug_tests = False }
+
+type T a = a -> Bool
+t a = Right a == (readBERT . decode . encode . showBERT) a
+
+main = do
+ runTests "simple" options
+ [ run (t :: T Bool)
+ , run (t :: T Integer)
+ , run (t :: T String)
+ , run (t :: T (String, String))
+ , run (t :: T (String, [String]))
+ , run (t :: T [String])
+ , run (t :: T (Map String String))
+ , run (t :: T (Int, Int, Int, Int))
+ ]
+
Please sign in to comment.
Something went wrong with that request. Please try again.