Permalink
Browse files

Client side (synchronous) RPC support.

Confirmed to work with "ernie".
  • Loading branch information...
1 parent b1cc701 commit 8005cbdbb1750cee52c60a3a053232a932290dc6 @mariusae committed Nov 1, 2009
Showing with 310 additions and 108 deletions.
  1. +4 −88 Data/BERT.hs
  2. +23 −10 Data/BERT/Packet.hs
  3. +96 −8 Data/BERT/Term.hs
  4. +28 −0 Network/BERT.hs
  5. +50 −0 Network/BERT/RPC.hs
  6. +104 −0 Network/BERT/Transport.hs
  7. +5 −2 bert.cabal
View
@@ -1,5 +1,3 @@
-{-# LANGUAGE OverlappingInstances #-}
-{-# OPTIONS -XTypeSynonymInstances #-}
-- |
-- Module : Data.BERT
-- Copyright : (c) marius a. eriksen 2009
@@ -9,96 +7,14 @@
-- Stability : experimental
-- Portability : GHC
--
--- BERT (Erlang terms + RPC) implementation.
--- - <http://bert-rpc.org/>
--- - <http://erlang.org/doc/apps/erts/erl_ext_dist.html>
+-- BERT (Erlang terms) implementation. See <http://bert-rpc.org/> and
+-- <http://erlang.org/doc/apps/erts/erl_ext_dist.html> for more
+-- details.
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.Term (Term(..), BERT(..))
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"
-
View
@@ -7,30 +7,43 @@
-- Stability : experimental
-- Portability : GHC
--
--- BERP support.
+-- BERP (BERT packets) support.
module Data.BERT.Packet
( Packet(..)
+ , packets
) where
import Control.Monad (liftM)
-import Data.ByteString (ByteString)
-import Data.ByteString.Lazy as B
-import Data.Binary (Binary(..), encode, decode)
+import Data.ByteString.Lazy as L
+import Data.Binary (Binary(..), Get(..), encode, decode)
import Data.Binary.Put (putWord32be, putLazyByteString)
-import Data.Binary.Get (getWord32be, getLazyByteString)
+import Data.Binary.Get (getWord32be, getLazyByteString, runGet, runGetState)
import Data.BERT.Term (Term(..))
-data Packet
+-- | A single BERP. Little more than a wrapper for a 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
+ len = L.length encoded
+ get = getPacket
+
+getPacket =
+ liftM fromIntegral getWord32be >>=
+ getLazyByteString >>=
+ return . Packet . decode
+
+-- | From a lazy bytestring, return a (lazy) list of packets. This is
+-- convenient for parsing a stream of adjacent packets. (Eg. by using
+-- some form of @getContents@ to get a @ByteString@ out of a data
+-- source).
+packets :: L.ByteString -> [Packet]
+packets b
+ | L.null b = []
+ | otherwise = p:packets b' where (p, b', _) = runGetState getPacket b 0
View
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverlappingInstances #-}
+{-# LANGUAGE OverlappingInstances, TypeSynonymInstances #-}
-- |
-- Module : Data.BERT.Term
-- Copyright : (c) marius a. eriksen 2009
@@ -8,26 +8,36 @@
-- Stability : experimental
-- Portability : GHC
--
--- Define BERT terms and their binary encoding & decoding.
+-- Define BERT termsm 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
( Term(..)
+ , BERT(..)
) where
-import Control.Monad (forM_, replicateM)
+import Control.Monad.Error
+import Control.Monad (forM_, replicateM, liftM2, liftM3, liftM4)
import Control.Applicative ((<$>))
import Data.Bits (shiftR, (.&.))
+import Data.Char (chr)
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.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)
+-- | A single BERT term.
data Term
-- Simple (erlang) terms:
= IntTerm Int
@@ -46,13 +56,91 @@ data Term
-- TODO: time, regex
deriving (Show, Eq, Ord)
+class BERT a where
+ -- | Introduce a 'Term' from a Haskell value.
+ showBERT :: a -> Term
+ -- | Attempt to read a haskell value from 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
+ readBERT _ = fail "Invalid integer type"
+
+instance BERT Bool where
+ showBERT = BoolTerm
+ readBERT (BoolTerm x) = return x
+ readBERT _ = fail "Invalid bool type"
+
+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"
+
-- Binary encoding & decoding.
instance Binary Term where
put term = putWord8 131 >> putTerm term
get = getWord8 >>= \version ->
case version of
131 -> getTerm
- _ -> fail "wrong version"
+ _ -> fail "bad magic"
-- | Binary encoding of a single term (without header)
putTerm (IntTerm value) = tag 98 >> put32i value
View
@@ -0,0 +1,28 @@
+-- |
+-- Module : Network.BERT
+-- Copyright : (c) marius a. eriksen 2009
+--
+-- License : BSD3
+-- Maintainer : marius@monkey.org
+-- Stability : experimental
+-- Portability : GHC
+--
+-- BERT-RPC client (<http://bert-rpc.org/>). See
+-- "Network.BERT.Transport" and "Network.BERT.RPC" for more details.
+module Network.BERT
+ ( Transport, Call
+ , fromURI, call
+ -- * Example
+ -- $example
+ ) where
+
+import Network.BERT.RPC (Call, call)
+import Network.BERT.Transport (Transport, fromURI)
+
+-- $example
+--
+-- > t <- fromURI "bert://localhost:8000"
+-- > r <- call t "errorcalc" "add" [123::Int, 300::Int]
+-- > case r of
+-- > Right res -> print (res::Int)
+-- > Left e -> print e
View
@@ -0,0 +1,50 @@
+-- |
+-- Module : Network.BERT.RPC
+-- Copyright : (c) marius a. eriksen 2009
+--
+-- License : BSD3
+-- Maintainer : marius@monkey.org
+-- Stability : experimental
+-- Portability : GHC
+--
+-- BERT-RPC client (<http://bert-rpc.org/>). This implements the
+-- client RPC call logic.
+
+module Network.BERT.RPC
+ ( Call, call
+ ) where
+
+import Data.BERT (Term(..), Packet(..), BERT(..))
+import Network.BERT.Transport (Transport, withTransport, sendp, recvp)
+
+data Error
+ = ClientError String
+ | ServerError Term
+ deriving (Show, Ord, Eq)
+
+-- Convenience type for @call@
+type Call a = IO (Either Error a)
+
+-- | Call the @{mod, func, args}@ synchronously on the endpoint
+-- defined by @transport@, returning the results of the call or an
+-- error.
+call :: (BERT a, BERT b)
+ => Transport
+ -> String
+ -> String
+ -> [a]
+ -> Call b
+call transport mod fun args =
+ withTransport transport $ do
+ sendp $ Packet (TupleTerm [ AtomTerm "call"
+ , AtomTerm mod
+ , AtomTerm fun
+ , ListTerm $ map showBERT args
+ ])
+ Packet t <- recvp
+ case t of
+ TupleTerm [AtomTerm "reply", reply] ->
+ return $ either (const . Left $ ClientError "decode failed") Right
+ $ readBERT reply
+ TupleTerm (AtomTerm "error":_) ->
+ return $ Left . ServerError $ t
Oops, something went wrong.

0 comments on commit 8005cbd

Please sign in to comment.