bert 1.1.2.1 → 1.2
raw patch · 22 files changed
+897/−894 lines, 22 filesdep +asyncdep +bertdep +binary-conduitdep ~basedep ~binarydep ~bytestring
Dependencies added: async, bert, binary-conduit, conduit, network-conduit, smallcheck, tasty, tasty-hunit, tasty-smallcheck, void
Dependency ranges changed: base, binary, bytestring, containers, network
Files
- Data/BERT.hs +0/−21
- Data/BERT/Packet.hs +0/−54
- Data/BERT/Parser.hs +0/−76
- Data/BERT/Term.hs +0/−323
- Data/BERT/Types.hs +0/−37
- LICENSE +1/−0
- Network/BERT.hs +0/−30
- Network/BERT/Client.hs +0/−50
- Network/BERT/Server.hs +0/−87
- Network/BERT/Transport.hs +0/−140
- bert.cabal +30/−7
- bert.hs +0/−69
- src/Data/BERT.hs +12/−0
- src/Data/BERT/Packet.hs +34/−0
- src/Data/BERT/Parser.hs +65/−0
- src/Data/BERT/Term.hs +309/−0
- src/Data/BERT/Types.hs +28/−0
- src/Network/BERT.hs +20/−0
- src/Network/BERT/Client.hs +43/−0
- src/Network/BERT/Server.hs +92/−0
- src/Network/BERT/Transport.hs +140/−0
- tests/test.hs +123/−0
− Data/BERT.hs
@@ -1,21 +0,0 @@--- |--- 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
− Data/BERT/Packet.hs
@@ -1,54 +0,0 @@--- |--- Module : Data.BERT.Packet--- Copyright : (c) marius a. eriksen 2009--- --- License : BSD3--- Maintainer : marius@monkey.org--- Stability : experimental--- Portability : GHC--- --- BERP (BERT packets) support.-module Data.BERT.Packet - ( Packet(..)- , fromPacket- , packets- ) where--import Control.Monad (liftM)-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, runGet, runGetState)--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- where encoded = encode term- 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
− Data/BERT/Parser.hs
@@ -1,76 +0,0 @@-{-# LANGUAGE OverlappingInstances, TypeSynonymInstances #-}--- |--- 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
− Data/BERT/Term.hs
@@ -1,323 +0,0 @@-{-# LANGUAGE OverlappingInstances, TypeSynonymInstances, FlexibleInstances #-}--- |--- Module : Data.BERT.Term--- Copyright : (c) marius a. eriksen 2009--- --- License : BSD3--- Maintainer : marius@monkey.org--- Stability : experimental--- Portability : GHC--- --- 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- ( BERT(..)- ) where--import Control.Monad.Error-import Control.Monad (forM_, replicateM, liftM2, liftM3, liftM4)-import Control.Applicative ((<$>))-import Data.Bits (shiftR, (.&.))-import Data.Char (chr, isAsciiLower, isAscii)-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.List (intercalate)-import Data.Time (UTCTime(..), diffUTCTime, addUTCTime, Day(..))-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)-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--decomposeTime :: UTCTime -> (Int, Int, Int)-decomposeTime t = (mS, s, uS)- where- d = diffUTCTime t zeroHour- (mS, s) = (floor d) `divMod` 1000000- uS = floor $ 1000000 * (snd $ properFraction d)--composeTime :: (Int, Int, Int) -> UTCTime-composeTime (mS, s, uS) = addUTCTime seconds zeroHour- where- mS' = fromIntegral mS- s' = fromIntegral s- uS' = fromIntegral uS- seconds = ((mS' * 1000000) + s' + (uS' / 1000000))--instance Show Term where- -- Provide an erlang-compatible 'show' for terms. The results of- -- this should be parseable as erlang source. - show = showTerm--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--- that complicates syntax and semantics for end users. Let's do this--- one ugly thing instead, eh?-ct b rest = TupleTerm $ [AtomTerm "bert", AtomTerm b] ++ rest-compose NilTerm = ListTerm []-compose (BoolTerm True) = ct "true" []-compose (BoolTerm False) = ct "false" []-compose (DictionaryTerm kvs) = - ct "dict" [ListTerm $ map (\(k, v) -> TupleTerm [k, v]) kvs]-compose (TimeTerm t) =- ct "time" [IntTerm mS, IntTerm s, IntTerm uS]- where- (mS, s, uS) = decomposeTime t-compose (RegexTerm s os) = - ct "regex" [BytelistTerm (C.pack s), - TupleTerm [ListTerm $ map AtomTerm os]]-compose _ = error "invalid composite term"--showTerm (IntTerm x) = show x-showTerm (FloatTerm x) = printf "%15.15e" x-showTerm (AtomTerm "") = ""-showTerm (AtomTerm a@(x:xs))- | isAsciiLower x = a- | otherwise = "'" ++ a ++ "'"-showTerm (TupleTerm ts) = - "{" ++ intercalate ", " (map showTerm ts) ++ "}"-showTerm (BytelistTerm bs) = show $ C.unpack bs-showTerm (ListTerm ts) = - "[" ++ intercalate ", " (map showTerm ts) ++ "]"-showTerm (BinaryTerm b)- | all (isAscii . chr . fromIntegral) (B.unpack b) = - wrap $ "\"" ++ C.unpack b ++ "\""- | otherwise = - wrap $ intercalate ", " $ map show $ B.unpack b- where- wrap x = "<<" ++ x ++ ">>"-showTerm (BigintTerm x) = show x-showTerm (BigbigintTerm x) = show x--- All other terms are composite:-showTerm t = showTerm . compose $ t--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 >>= \magic ->- case magic of - 131 -> getTerm- _ -> fail "bad magic"---- | 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--- All other terms are composite:-putTerm t = putTerm . compose $ t---- | 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- -- First try & decode composite terms.- 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 [AtomTerm "bert", AtomTerm "time", - IntTerm mS, IntTerm s, IntTerm uS] = - return $ TimeTerm $ composeTime (mS, s, uS)- tupleTerm [AtomTerm "bert", AtomTerm "regex",- BytelistTerm s, ListTerm os] =- options os >>= return . RegexTerm (C.unpack s)- where- -- TODO: type-check the options values as well- options [] = return []- options ((AtomTerm o):os) = options os >>= return . (o:)- options _ = fail "regex options must be atoms"- -- All other tuples are just .. tuples- 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
− Data/BERT/Types.hs
@@ -1,37 +0,0 @@--- |--- 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)-
LICENSE view
@@ -1,4 +1,5 @@ Copyright (c) 2009 marius a. eriksen (marius@monkey.org)+ (c) 2013 Roman Cheplyaka All rights reserved. Redistribution and use in source and binary forms, with or without
− Network/BERT.hs
@@ -1,30 +0,0 @@--- |--- 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
@@ -1,50 +0,0 @@--- |--- 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
@@ -1,87 +0,0 @@--- |--- 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 - ( DispatchResult(..)- -- ** 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)--data DispatchResult- = Success Term- | 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 DispatchResult)- -> 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- Success term -> - sendt $ TupleTerm [AtomTerm "reply", term]- NoSuchModule ->- sendErr "server" 1 "BERTError" - (printf "no such module \"%s\"" mod :: String) []- NoSuchFunction ->- sendErr "server" 2 "BERTError" - (printf "no such function \"%s\"" fun :: String) []- Undesignated detail ->- sendErr "server" 0 "HandlerError" detail []-- 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 $ Success $ IntTerm (a + b)--- > dispatch "calc" _ _ =--- > return NoSuchFunction--- > dispatch _ _ _ =--- > return NoSuchModule
− Network/BERT/Transport.hs
@@ -1,140 +0,0 @@-{-# 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
bert.cabal view
@@ -1,16 +1,16 @@-cabal-version: >= 1.6+cabal-version: >= 1.16 name: bert-version: 1.1.2.1+version: 1.2 build-type: Simple license: BSD3 license-file: LICENSE-author: marius a. eriksen+author: marius a. eriksen, Roman Cheplyaka category: Data synopsis: BERT implementation description: Implements the BERT serialization and RPC protocols described at <http://bert-rpc.org/>. maintainer: Roman Cheplyaka <roma@ro-che.info>-copyright: (c) 2009-2011 marius a. eriksen+copyright: (c) 2009-2011 marius a. eriksen; (c) 2013 Roman Cheplyaka homepage: https://github.com/feuerbach/bert bug-reports: https://github.com/feuerbach/bert/issues @@ -19,10 +19,16 @@ location: git@github.com:feuerbach/bert.git library+ hs-source-dirs: src build-depends: base == 4.*, containers >= 0.2, bytestring >= 0.9, binary >= 0.5, mtl >= 1.1, network >= 2.2, unix >= 2.0, time >= 1.1, - parsec >= 2.0+ parsec >= 2.0,+ conduit >= 1.0,+ network-conduit >= 1.0,+ binary-conduit >= 1.2,+ void+ exposed-modules: Data.BERT Data.BERT.Packet@@ -33,6 +39,23 @@ Network.BERT.Transport Network.BERT.Client Network.BERT.Server+ ghc-options: -fwarn-unused-imports+ default-language: Haskell2010 -executable bert- main-is: bert.hs+test-suite test+ hs-source-dirs: tests+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ Main-is: test.hs+ build-depends:+ tasty >= 0.4,+ tasty-smallcheck,+ tasty-hunit,+ async,+ network,+ bert,+ base,+ smallcheck,+ containers,+ bytestring,+ binary
− bert.hs
@@ -1,69 +0,0 @@--- |--- 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 ()
+ src/Data/BERT.hs view
@@ -0,0 +1,12 @@+-- | 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
+ src/Data/BERT/Packet.hs view
@@ -0,0 +1,34 @@+-- | BERP (BERT packets) support.+module Data.BERT.Packet + ( Packet(..)+ , fromPacket+ ) where++import Control.Monad+import Data.ByteString.Lazy as L+import Data.Binary+import Data.Binary.Put+import Data.Binary.Get++import Data.BERT.Term ()+import Data.BERT.Types++-- | 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+ where encoded = encode term+ len = L.length encoded++ get = getPacket++getPacket =+ liftM fromIntegral getWord32be >>= + getLazyByteString >>= + return . Packet . decode
+ src/Data/BERT/Parser.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverlappingInstances, TypeSynonymInstances #-}+-- | Parse (simple) BERTs.+module Data.BERT.Parser+ ( parseTerm+ ) where++import Data.Char+import Control.Applicative+import Numeric+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++--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
+ src/Data/BERT/Term.hs view
@@ -0,0 +1,309 @@+{-# LANGUAGE OverlappingInstances, TypeSynonymInstances, FlexibleInstances #-}+-- | 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+ ( BERT(..)+ ) where++import Control.Monad.Error+import Control.Applicative+import Data.Bits+import Data.Char+import Data.Binary+import Data.Binary.Put+import Data.Binary.Get+import Data.List+import Data.Time+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+import Data.BERT.Types+import Data.BERT.Parser++-- The 0th-hour as per the BERT spec.+zeroHour = UTCTime (read "1970-01-01") 0++decomposeTime :: UTCTime -> (Int, Int, Int)+decomposeTime t = (mS, s, uS)+ where+ d = diffUTCTime t zeroHour+ (mS, s) = (floor d) `divMod` 1000000+ uS = floor $ 1000000 * (snd $ properFraction d)++composeTime :: (Int, Int, Int) -> UTCTime+composeTime (mS, s, uS) = addUTCTime seconds zeroHour+ where+ mS' = fromIntegral mS+ s' = fromIntegral s+ uS' = fromIntegral uS+ seconds = ((mS' * 1000000) + s' + (uS' / 1000000))++instance Show Term where+ -- Provide an erlang-compatible 'show' for terms. The results of+ -- this should be parseable as erlang source. + show = showTerm++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+-- that complicates syntax and semantics for end users. Let's do this+-- one ugly thing instead, eh?+ct b rest = TupleTerm $ [AtomTerm "bert", AtomTerm b] ++ rest+compose NilTerm = ListTerm []+compose (BoolTerm True) = ct "true" []+compose (BoolTerm False) = ct "false" []+compose (DictionaryTerm kvs) = + ct "dict" [ListTerm $ map (\(k, v) -> TupleTerm [k, v]) kvs]+compose (TimeTerm t) =+ ct "time" [IntTerm mS, IntTerm s, IntTerm uS]+ where+ (mS, s, uS) = decomposeTime t+compose (RegexTerm s os) = + ct "regex" [BytelistTerm (C.pack s), + TupleTerm [ListTerm $ map AtomTerm os]]+compose _ = error "invalid composite term"++showTerm (IntTerm x) = show x+showTerm (FloatTerm x) = printf "%15.15e" x+showTerm (AtomTerm "") = ""+showTerm (AtomTerm a@(x:xs))+ | isAsciiLower x = a+ | otherwise = "'" ++ a ++ "'"+showTerm (TupleTerm ts) = + "{" ++ intercalate ", " (map showTerm ts) ++ "}"+showTerm (BytelistTerm bs) = show $ C.unpack bs+showTerm (ListTerm ts) = + "[" ++ intercalate ", " (map showTerm ts) ++ "]"+showTerm (BinaryTerm b)+ | all (isAscii . chr . fromIntegral) (B.unpack b) = + wrap $ "\"" ++ C.unpack b ++ "\""+ | otherwise = + wrap $ intercalate ", " $ map show $ B.unpack b+ where+ wrap x = "<<" ++ x ++ ">>"+showTerm (BigintTerm x) = show x+showTerm (BigbigintTerm x) = show x+-- All other terms are composite:+showTerm t = showTerm . compose $ t++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 >>= \magic ->+ case magic of + 131 -> getTerm+ _ -> fail "bad magic"++-- | 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+-- All other terms are composite:+putTerm t = putTerm . compose $ t++-- | 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+ -- First try & decode composite terms.+ 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 [AtomTerm "bert", AtomTerm "time", + IntTerm mS, IntTerm s, IntTerm uS] = + return $ TimeTerm $ composeTime (mS, s, uS)+ tupleTerm [AtomTerm "bert", AtomTerm "regex",+ BytelistTerm s, ListTerm os] =+ options os >>= return . RegexTerm (C.unpack s)+ where+ -- TODO: type-check the options values as well+ options [] = return []+ options ((AtomTerm o):os) = options os >>= return . (o:)+ options _ = fail "regex options must be atoms"+ -- All other tuples are just .. tuples+ 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
+ src/Data/BERT/Types.hs view
@@ -0,0 +1,28 @@+-- | 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)+
+ src/Network/BERT.hs view
@@ -0,0 +1,20 @@+-- | 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
+ src/Network/BERT/Client.hs view
@@ -0,0 +1,43 @@+-- | BERT-RPC client (<http://bert-rpc.org/>). This implements the client RPC call logic.++module Network.BERT.Client+ ( Call, call, tcpClient+ ) where++import Data.BERT+import Network.BERT.Transport++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 t)+ => t+ -> String+ -> String+ -> [a]+ -> Call b+call transport mod fun args =+ runSession transport $ do+ sendt $ TupleTerm [AtomTerm "call", AtomTerm mod, AtomTerm fun,+ ListTerm $ map showBERT args]+ recvAndHandle+ where+ handle (TupleTerm [AtomTerm "reply", reply]) =+ return $ either (const . Left $ ClientError "decode failed") Right+ $ readBERT reply+ handle (TupleTerm (AtomTerm "info":_)) =+ recvAndHandle -- We don't yet handle info directives.+ handle t@(TupleTerm (AtomTerm "error":_)) =+ return $ Left . ServerError $ t+ handle t = fail $ "unknown reply " ++ (show t)++ recvAndHandle =+ recvt >>= maybe (fail "No answer") handle
+ src/Network/BERT/Server.hs view
@@ -0,0 +1,92 @@+-- | 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 + ( DispatchResult(..)+ -- ** Serve+ -- $example+ , serve+ , tcpServer+ ) where++import Control.Concurrent+import Control.Monad.Trans+import Control.Exception+import Network.BERT.Transport+import Network.Socket+import Data.ByteString.Lazy.Char8 as C+import Data.BERT+import Text.Printf+import qualified System.Posix.Signals as Sig++data DispatchResult+ = Success Term+ | NoSuchModule+ | NoSuchFunction+ | Undesignated String+ deriving (Eq, Show, Ord)++data TcpServer = TcpServer !Socket++-- | Serve from the given transport (forever), handling each request+-- with the given dispatch function in a new thread.+serve+ :: Server s+ => s+ -> (String -> String -> [Term] -> IO DispatchResult)+ -> IO ()+serve server dispatch = do+ -- Ignore sigPIPE, which can be delivered upon writing to a closed+ -- socket.+ Sig.installHandler Sig.sigPIPE Sig.Ignore Nothing++ (runServer server $ \t ->+ (forkIO $ runSession t $ handleCall dispatch) >> return ())+ `finally`+ cleanup server++handleCall dispatch = recvtForever handle+ where+ handle (TupleTerm [AtomTerm "info", AtomTerm "stream", _]) =+ sendErr "server" 0 "BERTError" "streams are unsupported" []+ handle (TupleTerm [AtomTerm "info", AtomTerm "cache", _]) =+ return () -- Ignore caching requests.+ handle (TupleTerm [+ AtomTerm "call", AtomTerm mod, + AtomTerm fun, ListTerm args]) = do+ res <- liftIO $ dispatch mod fun args+ case res of+ Success term -> + sendt $ TupleTerm [AtomTerm "reply", term]+ NoSuchModule ->+ sendErr "server" 1 "BERTError" + (printf "no such module \"%s\"" mod :: String) []+ NoSuchFunction ->+ sendErr "server" 2 "BERTError" + (printf "no such function \"%s\"" fun :: String) []+ Undesignated detail ->+ sendErr "server" 0 "HandlerError" detail []++ 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 server and call 'serve' with a+-- dispatch function.+-- +-- > main = do+-- > s <- tcpServer 8080+-- > serve s dispatch+-- >+-- > dispatch "calc" "add" [IntTerm a, IntTerm b] = +-- > return $ Success $ IntTerm (a + b)+-- > dispatch "calc" _ _ =+-- > return NoSuchFunction+-- > dispatch _ _ _ =+-- > return NoSuchModule
+ src/Network/BERT/Transport.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, FlexibleContexts #-}+-- | Underlying transport abstraction+module Network.BERT.Transport+ (+ -- * Core definitions+ Transport(..)+ , Server(..)+ , TransportM(..)+ , SendPacketFn+ -- * Sending and receiving packets+ , sendt, recvt, recvtForever+ -- * TCP transport+ , TCP(..)+ , tcpClient+ , TCPServer(..)+ , tcpServer+ -- * Utilities+ , resolve+ ) where++import Control.Monad+import Control.Applicative+import Control.Monad.Reader+import Network.Socket+import Data.Conduit+import Data.Conduit.Network+import Data.Conduit.Serialization.Binary+import Data.Void++import Data.BERT++-- | A function to send packets to the peer+type SendPacketFn = Packet -> IO ()++-- | The transport monad allows receiving packets through the conduit,+-- and sending functions via the provided 'SendPacketFn'+type TransportM = ReaderT SendPacketFn (ConduitM Packet Void IO)++-- | The class for transports+class Transport t where+ runSession :: t -> TransportM a -> IO a+ closeConnection :: t -> IO ()++class Transport (ServerTransport s) => Server s where+ -- | The underlying transport used by the server+ type ServerTransport s++ -- | This method should listen for incoming requests, establish some+ -- sort of a connection (represented by the transport) and then invoke+ -- the handling function+ runServer :: s -> (ServerTransport s -> IO ()) -> IO ()++ -- | Free any resources that the server has acquired (such as the+ -- listening socket)+ cleanup :: s -> IO ()++-- | The TCP transport+data TCP = TCP {+ getTcpSocket :: !Socket+ -- ^ The socket used for communication.+ --+ -- The connection is assumed to be already established when this+ -- structure is passed in.+ }++tcpSendPacketFn :: TCP -> SendPacketFn+tcpSendPacketFn (TCP sock) packet =+ yield packet $=+ conduitEncode $$+ sinkSocket sock++instance Transport TCP where+ runSession tcp@(TCP sock) session =+ sourceSocket sock $=+ conduitDecode $$+ (runReaderT session (tcpSendPacketFn tcp))+ closeConnection (TCP sock) = close sock++-- | Establish a connection to the TCP server and return the resulting+-- transport. It can be used to make multiple requests.+tcpClient :: HostName -> PortNumber -> IO TCP+tcpClient host port = do+ sock <- socket AF_INET Stream defaultProtocol+ sa <- SockAddrInet port <$> resolve host+ connect sock sa+ return $ TCP sock++-- | The TCP server+data TCPServer = TCPServer {+ getTcpListenSocket :: !Socket+ -- ^ The listening socket. Assumed to be bound but not listening yet.+ }++instance Server TCPServer where+ type ServerTransport TCPServer = TCP++ runServer (TCPServer sock) handle = do+ listen sock sOMAXCONN++ forever $ do+ (clientsock, _) <- accept sock+ setSocketOption clientsock NoDelay 1+ handle $ TCP clientsock++ cleanup (TCPServer sock) = close sock++-- | A simple 'TCPServer' constructor, listens on all local interfaces.+--+-- If you want to bind only to some of the interfaces, create the socket+-- manually using the functions from "Network.Socket".+tcpServer :: PortNumber -> IO TCPServer+tcpServer port = do+ sock <- socket AF_INET Stream defaultProtocol+ setSocketOption sock ReuseAddr 1+ bindSocket sock $ SockAddrInet port iNADDR_ANY+ return $ TCPServer sock++-- | Send a term+sendt :: Term -> TransportM ()+sendt t = ask >>= \send -> liftIO . send . Packet $ t++-- | Receive a term+recvt :: TransportM (Maybe Term)+recvt = fmap fromPacket <$> lift await++-- | Execute an action for every incoming term, until the connection is+-- closed+recvtForever :: (Term -> TransportM a) -> TransportM ()+recvtForever f =+ ReaderT $ \send -> awaitForever $ flip runReaderT send . f . fromPacket++-- | A simple address resolver+resolve :: HostName -> IO HostAddress+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 }
+ tests/test.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++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 Control.Concurrent+import Control.Concurrent.Async+import Network+import System.Timeout++import Test.Tasty+import Test.Tasty.SmallCheck+import Test.Tasty.HUnit+import Test.SmallCheck.Series++import Data.BERT+import Network.BERT.Client+import Network.BERT.Server++-- NB A better Char instance would help here — something like+--+-- generate $ \d -> take d $ map chr [0..255]++instance (Serial m a, Ord a, Serial m b) => Serial m (Map a b) where+ series = liftM Map.fromList series++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 = defaultMain $ localOption (SmallCheckDepth 4) $+ testGroup "Tests"+ [ testGroup "Serialization" [simpleTerms, simplePackets]+ , networkTests+ ]++simpleTerms = testGroup "Simple terms"+ [ testProperty "Bool" (t :: T Bool)+ , testProperty "Integer" (t :: T Integer)+ , testProperty "String" (t :: T String)+ , testProperty "(String, String)" (t :: T (String, String))+ , testProperty "(String, [String])" (t :: T (String, [String]))+ , testProperty "[String]" (t :: T [String])+ , testProperty "(Map String String)" (t :: T (Map String String))+ , testProperty "(String, Int, Int, Int)" (t :: T (String, Int, Int, Int))+ , testProperty "(Int, Int, Int, Int)" (t :: T (Int, Int, Int, Int))+ ]++simplePackets = testGroup "Simple packets"+ [ testProperty "Bool" (p :: T Bool)+ , testProperty "Integer" (p :: T Integer)+ , testProperty "String" (p :: T String)+ , testProperty "(String, String)" (p :: T (String, String))+ , testProperty "(String, [String])" (p :: T (String, [String]))+ , testProperty "[String]" (p :: T [String])+ , testProperty "(Map String String)" (p :: T (Map String String))+ , testProperty "(String, Int, Int, Int)" (p :: T (String, Int, Int, Int))+ ]++networkTests = testGroup "Network"+ [ networkTest1+ , networkTest2+ , networkTest3+ , networkTest4+ ]++port :: PortNumber+port = 1911++delay :: IO ()+delay = threadDelay (10^5)++networkTest1 = testCase "Simple call" $ do+ t <- tcpServer port+ let server = serve t $ \ "mod" "f" [IntTerm a] -> return $ Success $ IntTerm (a+1)+ withAsync server $ \_ -> do+ delay+ c <- tcpClient "localhost" port+ result <- call c "mod" "f" [IntTerm 3]+ result @?= Right (IntTerm 4)++networkTest2 = testCase "5 calls per connection" $ do+ t <- tcpServer port+ let server = serve t $ \ "mod" "f" [IntTerm a, IntTerm b] -> return $ Success $ IntTerm (a+b)+ withAsync server $ \_ -> do+ delay+ c <- tcpClient "localhost" port+ forM_ [1..5] $ \x -> do+ result <- call c "mod" "f" [IntTerm 3, IntTerm x]+ result @?= Right (IntTerm (3+x))++networkTest3 = testCase "5 sequential connections" $ do+ t <- tcpServer port+ let server = serve t $ \ "mod" "f" [IntTerm a, IntTerm b] -> return $ Success $ IntTerm (a+b)+ withAsync server $ \_ -> do+ delay+ forM_ [1..5] $ \x -> do+ c <- tcpClient "localhost" port+ result <- call c "mod" "f" [IntTerm 3, IntTerm x]+ result @?= Right (IntTerm (3+x))++networkTest4 = testCase "100 simultaneous connections" $ do+ t <- tcpServer port+ let server = serve t $ \ "mod" "f" [IntTerm a, IntTerm b] ->+ do+ threadDelay (5*10^5) -- 0.5s delay+ return $ Success $ IntTerm (a+b)+ r <-+ withAsync server $ \_ -> do+ delay+ timeout (10^6) $ do+ flip mapConcurrently [1..100] $ \x -> do+ c <- tcpClient "localhost" port+ result <- call c "mod" "f" [IntTerm 3, IntTerm x]+ result @?= Right (IntTerm (3+x))+ maybe (assertFailure "Timed out!") (const $ return ()) r