Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

BERT-RPC implementation (both client & server), and a meaningful

README.md.
  • Loading branch information...
commit 738b0762bcdd598380752f8c240dcfa2a5af799d 1 parent e428ab4
@mariusae authored
View
3  Data/BERT/Term.hs
@@ -56,6 +56,9 @@ data Term
-- TODO: time, regex
deriving (Show, Eq, Ord)
+-- TODO: show(/read) instances that are like erlang's representation
+-- of this.
+
class BERT a where
-- | Introduce a 'Term' from a Haskell value.
showBERT :: a -> Term
View
4 Network/BERT.hs
@@ -16,13 +16,13 @@ module Network.BERT
-- $example
) where
-import Network.BERT.RPC (Call, call)
+import Network.BERT.Client (Call, call)
import Network.BERT.Transport (Transport, fromURI)
-- $example
--
-- > t <- fromURI "bert://localhost:8000"
--- > r <- call t "errorcalc" "add" [123::Int, 300::Int]
+-- > r <- call t "errorcalc" "add" ([123, 300]::[Int])
-- > case r of
-- > Right res -> print (res::Int)
-- > Left e -> print e
View
19 Network/BERT/RPC.hs → Network/BERT/Client.hs
@@ -1,5 +1,5 @@
-- |
--- Module : Network.BERT.RPC
+-- Module : Network.BERT.Client
-- Copyright : (c) marius a. eriksen 2009
--
-- License : BSD3
@@ -10,7 +10,7 @@
-- BERT-RPC client (<http://bert-rpc.org/>). This implements the
-- client RPC call logic.
-module Network.BERT.RPC
+module Network.BERT.Client
( Call, call
) where
@@ -22,7 +22,7 @@ data Error
| ServerError Term
deriving (Show, Ord, Eq)
--- Convenience type for @call@
+-- | Convenience type for @call@
type Call a = IO (Either Error a)
-- | Call the @{mod, func, args}@ synchronously on the endpoint
@@ -36,17 +36,14 @@ call :: (BERT a, BERT b)
-> Call b
call transport mod fun args =
withTransport transport $ do
- sendt $ TupleTerm [ AtomTerm "call"
- , AtomTerm mod
- , AtomTerm fun
- , ListTerm $ map showBERT args
- ]
+ sendt $ TupleTerm [AtomTerm "call", AtomTerm mod, AtomTerm fun,
+ ListTerm $ map showBERT args]
recvt >>= handle
where
handle (TupleTerm [AtomTerm "reply", reply]) =
return $ either (const . Left $ ClientError "decode failed") Right
- $ readBERT reply
- -- We don't yet handle info directives.
- handle (TupleTerm (AtomTerm "info":_)) = recvt >>= handle
+ $ readBERT reply
+ handle (TupleTerm (AtomTerm "info":_)) =
+ recvt >>= handle -- We don't yet handle info directives.
handle t@(TupleTerm (AtomTerm "error":_)) =
return $ Left . ServerError $ t
View
69 Network/BERT/Server.hs
@@ -0,0 +1,69 @@
+-- |
+-- Module : Network.BERT.Server
+-- Copyright : (c) marius a. eriksen 2009
+--
+-- License : BSD3
+-- Maintainer : marius@monkey.org
+-- Stability : experimental
+-- Portability : GHC
+--
+-- BERT-RPC server (<http://bert-rpc.org/>). This implements the
+-- client RPC call/reply logic. Only synchronous requests are
+-- supported at this time.
+
+module Network.BERT.Server
+ ( -- ** Serve
+ -- $example
+ serve
+ ) where
+
+import Control.Concurrent (forkIO)
+import Control.Monad.Trans (liftIO)
+import Data.BERT.Term (Term(..))
+import Network.BERT.Transport (Transport, withTransport, servet, recvt, sendt)
+import Data.ByteString.Lazy.Char8 as C
+
+-- | Serve from the given transport (forever), handling each request
+-- with the given dispatch function in a new thread.
+serve :: Transport
+ -> (String -> String -> [Term] -> IO (Either String Term))
+ -> IO ()
+serve transport dispatch =
+ servet transport $ \t ->
+ (forkIO $ withTransport t $ handleCall dispatch) >> return ()
+
+handleCall dispatch =
+ recvt >>= handle
+ where
+ handle (TupleTerm [AtomTerm "info", AtomTerm "stream", _]) =
+ sendt $ TupleTerm [ -- Streams are unsupported at this time.
+ AtomTerm "error", IntTerm 0,
+ BinaryTerm C.empty,
+ BinaryTerm $ C.pack "streams not supported"]
+ handle (TupleTerm [AtomTerm "info", AtomTerm "cache", _]) =
+ recvt >>= handle -- Ignore caching requests.
+ handle (TupleTerm [
+ AtomTerm "call", AtomTerm mod,
+ AtomTerm fun, ListTerm args]) = do
+ res <- liftIO $ dispatch mod fun args
+ case res of
+ Left error ->
+ sendt $ TupleTerm [
+ AtomTerm "error", IntTerm 0,
+ BinaryTerm C.empty, BinaryTerm $ C.pack error]
+ Right term ->
+ sendt $ TupleTerm [AtomTerm "reply", term]
+
+-- $example
+--
+-- To serve requests, create a transport and call 'serve' with a
+-- dispatch function.
+--
+-- > main = do
+-- > t <- fromHostPort "" 8080
+-- > serve t dispatch
+-- >
+-- > dispatch "calc" "add" [IntTerm a, IntTerm b] =
+-- > return $ Right $ IntTerm (a + b)
+-- > dispatch _ _ _ = do
+-- > return $ Left "no such m/f!"
View
55 Network/BERT/Transport.hs
@@ -19,41 +19,47 @@
-- persistent connections, however.
module Network.BERT.Transport
- ( Transport, fromURI
+ ( Transport, fromURI, fromHostPort
-- ** Transport monad
, TransportM, withTransport
, sendt, recvt
+ -- ** Server side
+ , servet
) where
+import Control.Monad (forever)
import Control.Monad.State (
StateT, MonadIO, MonadState, runStateT,
modify, gets, liftIO)
import Network.URI (URI(..), URIAuth(..), parseURI)
import Network.Socket (
Socket(..), Family(..), SockAddr(..), SocketType(..),
- connect, socket, sClose)
+ SocketOption(..), connect, socket, sClose, setSocketOption,
+ bindSocket, listen, accept, iNADDR_ANY)
import Data.Maybe (fromJust)
import Data.Binary (encode, decode)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString as B
import qualified Network.DNS.Client as DNS
import qualified Network.Socket.ByteString.Lazy as LS
+import qualified System.Posix.Signals as Sig
-import Data.BERT.Term (Term(..))
+import Data.BERT.Term (Term(..), BERT(..))
import Data.BERT.Packet (Packet(..), packets)
-- | Defines a transport endpoint. Create with 'fromURI'.
data Transport
- = TcpTransport SockAddr
+ = TcpTransport SockAddr
+ | TcpServerTransport Socket
deriving (Show, Eq)
-data TransportState
+data TransportState
= TransportState {
state_packets :: [Packet]
, state_socket :: Socket
}
-newtype TransportM a
+newtype TransportM a
= TransportM (StateT TransportState IO a)
deriving (Monad, MonadIO, MonadState TransportState)
@@ -61,12 +67,37 @@ newtype TransportM a
fromURI :: String -> IO Transport
fromURI = fromURI_ . fromJust . parseURI
+-- | Create a (TCP) transport from the given host and port
+fromHostPort :: (Integral a) => String -> a -> IO Transport
+fromHostPort "" port =
+ return $ TcpTransport
+ $ SockAddrInet (fromIntegral port) iNADDR_ANY
+fromHostPort host port = do
+ resolve host >>= return . TcpTransport
+ . SockAddrInet (fromIntegral port)
+
fromURI_ uri@(URI { uriScheme = "bert:"
, uriAuthority = Just URIAuth
{ uriRegName = host
, uriPort = ':':port}}) =
fromHostPort host (fromIntegral . read $ port)
+servet :: Transport -> (Transport -> IO ()) -> IO ()
+servet (TcpTransport sa) dispatch = do
+ -- Ignore sigPIPE, which can be delivered upon writing to a closed
+ -- socket.
+ Sig.installHandler Sig.sigPIPE Sig.Ignore Nothing
+
+ sock <- socket AF_INET Stream 0
+ setSocketOption sock ReuseAddr 1
+ bindSocket sock sa
+ listen sock 1
+
+ forever $ do
+ (clientsock, _) <- accept sock
+ setSocketOption clientsock NoDelay 1
+ dispatch $ TcpServerTransport clientsock
+
resolve host = do
r <- DNS.resolve DNS.A host
case r of
@@ -74,15 +105,17 @@ resolve host = do
Right [] -> fail "No DNS A records!"
Right (((_, DNS.RRA (addr:_))):_) -> return addr
-fromHostPort host port = do
- resolve host >>= return . TcpTransport . SockAddrInet (fromIntegral port)
-
-- | Execute the given transport monad action in the context of the
-- passed transport.
withTransport :: Transport -> TransportM a -> IO a
-withTransport (TcpTransport sa) (TransportM m) = do
+withTransport (TcpTransport sa) m = do
sock <- socket AF_INET Stream 0
connect sock sa
+ withTransport_ sock m
+withTransport (TcpServerTransport sock) m =
+ withTransport_ sock m
+
+withTransport_ sock (TransportM m) = do
ps <- LS.getContents sock >>= return . packets
(result, _) <- runStateT m TransportState
{ state_packets = ps
@@ -103,4 +136,4 @@ recvt = do
ps <- gets state_packets
modify $ \state -> state { state_packets = drop 1 ps }
let Packet t = head ps
- return t
+ return t
View
76 README.md
@@ -0,0 +1,76 @@
+BERT[-RPC] for Haskell
+======================
+
+by marius a. eriksen (marius@monkey.org)
+
+This is a [BERT](http://bert-rpc.org/) serializer/deserializer and
+[BERT-RPC](http://bert-rpc.org) client and server for
+[Haskell](http://www.haskell.org/). BERT-RPC currently supports
+synchronous (`call`) requests.
+
+The primitives provided are fairly elementary: for the client, `call`
+provides the capability to perform the RPC call, while the server's
+`serve` is provided with a dispatch function providing the dispatching
+logic for the server. Thus, one can imagine building higher level
+abstractions on top of these primitives.
+
+Installation
+------------
+
+It's a cabal package, so
+
+ $ cabal configure && cabal install
+
+should do the trick.
+
+BERT
+----
+
+ import qualified Data.ByteString.Lazy.Char8 as C
+ import Data.BERT
+
+Creating BERT terms is simple.
+
+ TupleTerm [BytelistTerm (C.pack "hello"), IntTerm 123]
+
+Or by using the `BERT` typeclass.
+
+ showBERT $ ("hello", 123)
+
+The `BERT` class can also read terms back.
+
+ Right ("hello", 123) = readBERT . showBERT $ ("hello", 123)
+
+BERT-RPC client
+---------------
+
+ import Data.BERT
+ import Network.BERT.Client
+
+Create a transport to the server endpoint, and issue a (synchronous)
+call with it.
+
+ t <- fromURI "bert://localhost:8000"
+ r <- call t "calc" "add" ([123, 3000]::[Int])
+ case r of
+ Right res -> print (res :: Int)
+ Left _ -> putStrLn "error"
+
+BERT-RPC server
+---------------
+
+ import Data.BERT
+ import Network.BERT.Server
+
+Create a transport from which to accept connections, and provide a
+dispatch function for incoming RPCs. The dispatch function is issued
+in a new thread for each incoming request.
+
+ main = do
+ t <- fromHostPort "" 8080
+ serve t dispatch
+
+ dispatch "calc" "add" [IntTerm a, IntTerm b] =
+ return $ Right $ IntTerm (a + b)
+ dispatch mod fun args = do
+ return $ Left "no such m/f!"
View
5 bert.cabal
@@ -17,7 +17,10 @@ library
build-depends: base == 4.*, containers >= 0.2,
bytestring >= 0.9, binary >= 0.5,
mtl >= 1.1, network-bytestring >= 0.1,
- network-dns >= 0.1, network >= 2.2
+ network-dns >= 0.1, network >= 2.2,
+ unix >= 2.0
exposed-modules:
Data.BERT
Network.BERT
+ Network.BERT.Client
+ Network.BERT.Server
Please sign in to comment.
Something went wrong with that request. Please try again.