packages feed

bert (empty) → 1.0

raw patch · 9 files changed

+453/−0 lines, 9 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, containers, mtl, network, network-bytestring, parsec, time, unix

Files

+ Data/BERT.hs view
@@ -0,0 +1,21 @@+-- |+-- Module      : Data.BERT+-- Copyright   : (c) marius a. eriksen 2009+-- +-- License     : BSD3+-- Maintainer  : marius@monkey.org+-- Stability   : experimental+-- Portability : GHC+-- +-- 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 +  ( module Data.BERT.Types+  , module Data.BERT.Term+  , module Data.BERT.Packet+  ) where++import Data.BERT.Types+import Data.BERT.Term+import Data.BERT.Packet
+ LICENSE view
@@ -0,0 +1,24 @@+Copyright (c) 2009 marius a. eriksen (marius@monkey.org)+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. The names of the authors may not be used to endorse or promote products+   derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.+IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF+THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/BERT.hs view
@@ -0,0 +1,30 @@+-- |+-- 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+  ( module Network.BERT.Transport+  , module Network.BERT.Client+  , module Network.BERT.Server+  -- * Example+  -- $example+  ) where++import Network.BERT.Transport+import Network.BERT.Client+import Network.BERT.Server++-- $example+-- +-- > t <- fromURI "bert://localhost:8000"+-- > r <- call t "errorcalc" "add" ([123, 300]::[Int])+-- > case r of +-- >   Right res -> print (res::Int)+-- >   Left e    -> print e
+ Network/BERT/Client.hs view
@@ -0,0 +1,51 @@+-- |+-- Module      : Network.BERT.Client+-- 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.Client+  ( Call, call +  ) where++import Data.BERT (Term(..), Packet(..), BERT(..))+import Network.BERT.Transport (Transport, withTransport, sendt, recvt)++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+    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+    handle (TupleTerm (AtomTerm "info":_)) = +      recvt >>= handle  -- We don't yet handle info directives.+    handle t@(TupleTerm (AtomTerm "error":_)) =+      return $ Left . ServerError $ t+    handle t = fail $ "unknown reply " ++ (show t)+
+ Network/BERT/Server.hs view
@@ -0,0 +1,87 @@+-- |+-- 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 +  ( DispatchError(..)+    -- ** Serve+    -- $example+  , serve+  ) where++import Control.Concurrent (forkIO)+import Control.Monad.Trans (liftIO)+import Network.BERT.Transport (Transport, withTransport, servet, recvt, sendt)+import Data.ByteString.Lazy.Char8 as C+import Data.BERT (Term(..))+import Text.Printf (printf)++-- TODO: just do DispatchResult?++data DispatchError +  = NoSuchModule+  | NoSuchFunction+  | Undesignated String+    deriving (Eq, Show, Ord)++-- | 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 DispatchError 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", _]) =+      sendErr "server" 0 "BERTError" "streams are unsupported" []+    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 NoSuchModule ->+          sendErr "server" 1 "BERTError" +                  (printf "no such module \"%s\"" mod :: String) []+        Left NoSuchFunction ->+          sendErr "server" 2 "BERTError" +                  (printf "no such function \"%s\"" fun :: String) []+        Left (Undesignated detail) ->+          sendErr "server" 0 "HandlerError" detail []+        Right term -> +          sendt $ TupleTerm [AtomTerm "reply", term]++    sendErr etype ecode eclass detail backtrace = +      sendt $ TupleTerm [+        AtomTerm "error", +        TupleTerm [+          AtomTerm etype, IntTerm ecode, BinaryTerm . C.pack $ eclass, +          ListTerm $ Prelude.map (BinaryTerm . C.pack) backtrace]]++-- $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!"
+ Network/BERT/Transport.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Module      : Network.BERT.Transport+-- Copyright   : (c) marius a. eriksen 2009+-- +-- License     : BSD3+-- Maintainer  : marius@monkey.org+-- Stability   : experimental+-- Portability : GHC+-- +-- Transport for BERT-RPC client. Creates a transport from a URI,+-- leaving flexibility for several underlying transport+-- implementations. The current one is over sockets (TCP), with the+-- URI scheme bert, eg: <bert://localhost:9000>+-- +-- The TCP transport will create a new connection for every request+-- (every block of 'withTransport'), which seems to be what the+-- current server implementations expect. It'd be great to have+-- persistent connections, however.++module Network.BERT.Transport+  ( 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(..), +  SocketOption(..), AddrInfo(..), connect, socket, sClose, +  setSocketOption, bindSocket, listen, accept, iNADDR_ANY, +  getAddrInfo, defaultHints)+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.Socket.ByteString.Lazy as LS+import qualified System.Posix.Signals as Sig++import Data.BERT (Term(..), BERT(..), Packet(..))+import Data.BERT.Packet (packets)++-- | Defines a transport endpoint. Create with 'fromURI'.+data Transport+  = TcpTransport       SockAddr+  | TcpServerTransport Socket+    deriving (Show, Eq)++data TransportState+  = TransportState {+      state_packets :: [Packet]+    , state_socket  :: Socket+    }++newtype TransportM a+  = TransportM (StateT TransportState IO a)+    deriving (Monad, MonadIO, MonadState TransportState)++-- | Create a transport from the given URI.+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 <- getAddrInfo (Just hints) (Just host) Nothing+  case r of+    (AddrInfo { addrAddress = (SockAddrInet _ addr) }:_) -> return addr+    _ -> fail $ "Failed to resolve " ++ host+  where+    hints = defaultHints { addrFamily = AF_INET }++-- | Execute the given transport monad action in the context of the+-- passed transport.+withTransport :: Transport -> TransportM a -> IO a+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 +                             , state_socket  = sock}+  sClose sock+  return result++-- | Send a term (inside the transport monad)+sendt :: Term -> TransportM ()+sendt t = do+  sock <- gets state_socket+  liftIO $ LS.sendAll sock $ encode (Packet t)+  return ()++-- | Receive a term (inside the transport monad)+recvt :: TransportM Term+recvt = do+  ps <- gets state_packets+  modify $ \state -> state { state_packets = drop 1 ps }+  let Packet t = head ps+  return t
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bert.cabal view
@@ -0,0 +1,29 @@+cabal-version: >= 1.6+name:          bert+version:       1.0+build-type:    Simple+license:       BSD3+license-file:  LICENSE+author:        marius a. eriksen+category:      Data+synopsis:      BERT implementation+description:   Implements the BERT serialization and RPC protocols+               described at <http://bert-rpc.org/>.+maintainer:    marius a. eriksen+copyright:     (c) 2009 marius a. eriksen++library+  build-depends: base == 4.*, containers >= 0.2, +                 bytestring >= 0.9, binary >= 0.5, +                 mtl >= 1.1, network-bytestring >= 0.1,+                 network >= 2.2, unix >= 2.0, time >= 1.1, +                 parsec >= 2.0+  exposed-modules:+    Data.BERT+    Network.BERT+    Network.BERT.Transport+    Network.BERT.Client+    Network.BERT.Server++executable bert+  main-is: bert.hs
+ bert.hs view
@@ -0,0 +1,69 @@+-- |+-- Copyright   : (c) marius a. eriksen 2009+-- +-- License     : BSD3+-- Maintainer  : marius@monkey.org+-- Stability   : experimental+-- Portability : GHC+-- +-- Tool to issue or serve BERT requests.+module Main where++import System.Console.GetOpt+import System.Environment (getArgs, getProgName)+import Data.Maybe (maybe)+import Text.Printf (printf)+import Data.BERT (Term(..))+import qualified Network.BERT as Net++data Flags+  = Help+    deriving (Show, Eq, Ord)++data Mode+  = Call String String String [Term]+  | Serve Int+    deriving (Show, Eq, Ord)++options =   +  [ Option ['h'] [] (NoArg Help) "show help"+  ]++usage = do+  header <- getProgName >>= +    return . printf ("Usage: %s [OPTION...] " +++                     "[call <uri> <mod> <fun> [args..]|serve PORT]" )+  return $ usageInfo header options++parseArgs argv = +  case getOpt Permute options argv of+    (o, n, []) -> +      if Help `elem` o+        then return $ Nothing+        else do+          m <- parse n+          return $ Just (o, m)+  where+    parse ("call":uri:mod:fun:args) = return $ Call uri mod fun (map read args)+    parse ["serve", port]           = return $ Serve (read port)+    parse _                         = help "Cannot parse command"++    help = fail . flip (++) " [-h for help]"++main = do+  args <- getArgs >>= parseArgs+  case args of+    Just (_, Serve port)            -> doServe port+    Just (_, Call uri mod fun args) -> doCall uri mod fun args+    Nothing                         -> usage >>= putStr++doServe = undefined++doCall :: String -> String -> String -> [Term] -> IO ()+doCall uri mod fun args = do+  t <- Net.fromURI uri+  r <- Net.call t mod fun args :: Net.Call Term+  case r of+    Right res  -> putStrLn $ printf "reply: %s" $ show res+    Left error -> putStrLn $ printf "error: %s" $ show error+  return ()