Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

- parse BERT terms in the erlang term format (ie. a `read' for our

`show')
- correct error reply from server
- allow dispatchers to return type of error (which gets coded into the
right kind of BERT-RPC error)
- a command line tool to issue calls
  • Loading branch information...
commit c5e7fd6cab75c8d01734b869bb8241054731a1b4 1 parent a0abdc5
@mariusae authored
View
11 Data/BERT.hs
@@ -11,10 +11,11 @@
-- <http://erlang.org/doc/apps/erts/erl_ext_dist.html> for more
-- details.
module Data.BERT
- ( BERT(..)
- , Term(..)
- , Packet(..)
+ ( module Data.BERT.Types
+ , module Data.BERT.Term
+ , module Data.BERT.Packet
) where
-import Data.BERT.Term (Term(..), BERT(..))
-import Data.BERT.Packet (Packet(..))
+import Data.BERT.Types
+import Data.BERT.Term
+import Data.BERT.Packet
View
6 Data/BERT/Packet.hs
@@ -10,6 +10,7 @@
-- BERP (BERT packets) support.
module Data.BERT.Packet
( Packet(..)
+ , fromPacket
, packets
) where
@@ -19,13 +20,16 @@ import Data.Binary (Binary(..), Get(..), encode, decode)
import Data.Binary.Put (putWord32be, putLazyByteString)
import Data.Binary.Get (getWord32be, getLazyByteString, runGet, runGetState)
-import Data.BERT.Term (Term(..))
+import Data.BERT.Term
+import Data.BERT.Types (Term(..))
-- | A single BERP. Little more than a wrapper for a term.
data Packet
= Packet Term
deriving (Show, Ord, Eq)
+fromPacket (Packet t) = t
+
instance Binary Packet where
put (Packet term) =
putWord32be (fromIntegral len) >> putLazyByteString encoded
View
75 Data/BERT/Parser.hs
@@ -0,0 +1,75 @@
+-- |
+-- Module : Data.BERT.Parser
+-- Copyright : (c) marius a. eriksen 2009
+--
+-- License : BSD3
+-- Maintainer : marius@monkey.org
+-- Stability : experimental
+-- Portability : GHC
+--
+-- Parse (simple) BERTs.
+module Data.BERT.Parser
+ ( parseTerm
+ ) where
+
+import Data.Char (ord)
+import Control.Applicative
+import Control.Monad (MonadPlus(..), ap)
+import Numeric (readSigned, readFloat, readDec)
+import Control.Monad (liftM)
+import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))
+import qualified Data.ByteString.Lazy as B
+import qualified Data.ByteString.Lazy.Char8 as C
+import Data.BERT.Types (Term(..))
+
+instance Applicative (GenParser s a) where
+ pure = return
+ (<*>) = ap
+instance Alternative (GenParser s a) where
+ empty = mzero
+ (<|>) = mplus
+
+-- | Parse a simple BERT (erlang) term from a string in the erlang
+-- grammar. Does not attempt to decompose complex terms.
+parseTerm :: String -> Either ParseError Term
+parseTerm = parse p_term "term"
+
+p_term :: Parser Term
+p_term = t <* spaces
+ where
+ t = IntTerm <$> p_num (readSigned readDec)
+ <|> FloatTerm <$> p_num (readSigned readFloat)
+ <|> AtomTerm <$> p_atom
+ <|> TupleTerm <$> p_tuple
+ <|> BytelistTerm . C.pack <$> p_string
+ <|> ListTerm <$> p_list
+ <|> BinaryTerm . B.pack <$> p_binary
+
+p_num which = do
+ s <- getInput
+ case which s of
+ [(n, s')] -> n <$ setInput s'
+ _ -> empty
+
+p_atom = unquoted <|> quoted
+ where
+ unquoted = many1 $ lower <|> oneOf ['_', '@']
+ quoted = quote >> many1 letter <* quote
+ quote = char '\''
+
+p_seq open close elem =
+ between (open >> spaces) (spaces >> close) $
+ elem `sepBy` (spaces >> char ',' >> spaces)
+
+p_tuple = p_seq (char '{') (char '}') p_term
+
+p_list = p_seq (char '[') (char ']') p_term
+
+p_string = char '"' >> many strchar <* char '"'
+ where
+ strchar = noneOf ['\\', '"'] <|> (char '\\' >> anyChar)
+
+p_binary = string "<<" >> (bstr <|> bseq) <* string ">>"
+ where
+ bseq = (p_num readDec) `sepBy` (spaces >> char ',' >> spaces)
+ bstr = map (fromIntegral . ord) <$> p_string
View
43 Data/BERT/Term.hs
@@ -8,14 +8,13 @@
-- Stability : experimental
-- Portability : GHC
--
--- Define BERT termsm their binary encoding & decoding and a typeclass
+-- 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
- ( Term(..)
- , BERT(..)
+ ( BERT(..)
) where
import Control.Monad.Error
@@ -38,6 +37,8 @@ import qualified Data.ByteString.Lazy.Char8 as C
import Data.Map (Map)
import qualified Data.Map as Map
import Text.Printf (printf)
+import Data.BERT.Types (Term(..))
+import Data.BERT.Parser (parseTerm)
-- The 0th-hour as per the BERT spec.
zeroHour = UTCTime (read "1970-01-01") 0
@@ -57,27 +58,18 @@ composeTime (mS, s, uS) = addUTCTime seconds zeroHour
uS' = fromIntegral uS
seconds = ((mS' * 1000000) + s' + (uS' / 1000000))
-fromAtom (AtomTerm a) = a
+instance Show Term where
+ -- Provide an erlang-compatible 'show' for terms. The results of
+ -- this should be parseable as erlang source.
+ show = showTerm
--- | A single BERT term.
-data Term
- -- Simple (erlang) terms:
- = IntTerm Int
- | FloatTerm Float
- | AtomTerm String
- | TupleTerm [Term]
- | BytelistTerm ByteString
- | ListTerm [Term]
- | BinaryTerm ByteString
- | BigintTerm Integer
- | BigbigintTerm Integer
- -- Composite (BERT specific) terms:
- | NilTerm
- | BoolTerm Bool
- | DictionaryTerm [(Term, Term)]
- | TimeTerm UTCTime
- | RegexTerm String [String]
- deriving (Eq, Ord)
+instance Read Term where
+ readsPrec _ s =
+ case parseTerm s of
+ -- XXX TODO TODO XXX - normalize composite terms? (ie. we'd need
+ -- a "decompose")
+ Right t -> [(t, "")]
+ Left _ -> []
-- Another design would be to split the Term type into
-- SimpleTerm|CompositeTerm, and then do everything in one go, but
@@ -98,11 +90,6 @@ compose (RegexTerm s os) =
TupleTerm [ListTerm $ map AtomTerm os]]
compose _ = error "invalid composite term"
-instance Show Term where
- -- Provide an erlang-compatible 'show' for terms. The results of
- -- this should be parseable as erlang source.
- show = showTerm
-
showTerm (IntTerm x) = show x
showTerm (FloatTerm x) = printf "%15.15e" x
showTerm (AtomTerm "") = ""
View
37 Data/BERT/Types.hs
@@ -0,0 +1,37 @@
+-- |
+-- Module : Data.BERT.Types
+-- Copyright : (c) marius a. eriksen 2009
+--
+-- License : BSD3
+-- Maintainer : marius@monkey.org
+-- Stability : experimental
+-- Portability : GHC
+--
+-- The Term type.
+module Data.BERT.Types
+ ( Term(..)
+ ) where
+
+import Data.ByteString.Lazy (ByteString)
+import Data.Time (UTCTime)
+
+-- | A single BERT term.
+data Term
+ -- Simple (erlang) terms:
+ = IntTerm Int
+ | FloatTerm Float
+ | AtomTerm String
+ | TupleTerm [Term]
+ | BytelistTerm ByteString
+ | ListTerm [Term]
+ | BinaryTerm ByteString
+ | BigintTerm Integer
+ | BigbigintTerm Integer
+ -- Composite (BERT specific) terms:
+ | NilTerm
+ | BoolTerm Bool
+ | DictionaryTerm [(Term, Term)]
+ | TimeTerm UTCTime
+ | RegexTerm String [String]
+ deriving (Eq, Ord)
+
View
2  Network/BERT/Client.hs
@@ -47,3 +47,5 @@ call transport mod fun args =
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)
+
View
44 Network/BERT/Server.hs
@@ -12,34 +12,41 @@
-- supported at this time.
module Network.BERT.Server
- ( -- ** Serve
+ ( DispatchError(..)
+ -- ** Serve
-- $example
- serve
+ , 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
+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 String Term))
+ -> (String -> String -> [Term] -> IO (Either DispatchError Term))
-> IO ()
serve transport dispatch =
- servet transport $ \t ->
+ 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"]
+ sendErr "server" 0 "BERTError" "streams are unsupported" []
handle (TupleTerm [AtomTerm "info", AtomTerm "cache", _]) =
recvt >>= handle -- Ignore caching requests.
handle (TupleTerm [
@@ -47,13 +54,24 @@ handleCall dispatch =
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]
+ 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
View
19 Network/BERT/Transport.hs
@@ -34,18 +34,18 @@ import Control.Monad.State (
import Network.URI (URI(..), URIAuth(..), parseURI)
import Network.Socket (
Socket(..), Family(..), SockAddr(..), SocketType(..),
- SocketOption(..), connect, socket, sClose, setSocketOption,
- bindSocket, listen, accept, iNADDR_ANY)
+ 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.DNS.Client as DNS
import qualified Network.Socket.ByteString.Lazy as LS
import qualified System.Posix.Signals as Sig
-import Data.BERT.Term (Term(..), BERT(..))
-import Data.BERT.Packet (Packet(..), packets)
+import Data.BERT (Term(..), BERT(..), Packet(..))
+import Data.BERT.Packet (packets)
-- | Defines a transport endpoint. Create with 'fromURI'.
data Transport
@@ -99,11 +99,12 @@ servet (TcpTransport sa) dispatch = do
dispatch $ TcpServerTransport clientsock
resolve host = do
- r <- DNS.resolve DNS.A host
+ r <- getAddrInfo (Just hints) (Just host) Nothing
case r of
- Left error -> fail $ show error
- Right [] -> fail "No DNS A records!"
- Right (((_, DNS.RRA (addr:_))):_) -> return addr
+ (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.
View
17 QC.hs
@@ -4,6 +4,7 @@ import Control.Monad
import Data.Binary
import Data.Char (chr)
import Data.Map (Map)
+import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import Test.QuickCheck.Batch
@@ -27,10 +28,13 @@ options = TestOptions
, debug_tests = False }
type T a = a -> Bool
+-- value -> Term -> encoded -> Term -> value
t a = Right a == (readBERT . decode . encode . showBERT) a
+-- value -> Term -> Packet -> encoded -> Packet -> Term -> value
+p a = Right a == (readBERT . fromPacket . decode . encode . Packet . showBERT) a
main = do
- runTests "simple" options
+ runTests "simple terms" options
[ run (t :: T Bool)
, run (t :: T Integer)
, run (t :: T String)
@@ -38,6 +42,17 @@ main = do
, run (t :: T (String, [String]))
, run (t :: T [String])
, run (t :: T (Map String String))
+ , run (t :: T (String, Int, Int, Int))
, run (t :: T (Int, Int, Int, Int))
]
+ runTests "simple packets" options
+ [ run (p :: T Bool)
+ , run (p :: T Integer)
+ , run (p :: T String)
+ , run (p :: T (String, String))
+ , run (p :: T (String, [String]))
+ , run (p :: T [String])
+ , run (p :: T (Map String String))
+ , run (p :: T (String, Int, Int, Int))
+ ]
View
4 bert.cabal
@@ -16,8 +16,8 @@ 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,
- unix >= 2.0, time >= 1.1
+ network >= 2.2, unix >= 2.0, time >= 1.1,
+ parsec >= 2.0
exposed-modules:
Data.BERT
Network.BERT
View
69 bert.hs
@@ -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 BERT
+
+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 <- BERT.fromURI uri
+ r <- BERT.call t mod fun args :: BERT.Call Term
+ case r of
+ Right res -> putStrLn $ printf "reply: %s" $ show res
+ Left error -> putStrLn $ printf "error: %s" $ show error
+ return ()
Please sign in to comment.
Something went wrong with that request. Please try again.