diff --git a/Data/BERT.hs b/Data/BERT.hs deleted file mode 100644 --- a/Data/BERT.hs +++ /dev/null @@ -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 and --- 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 diff --git a/Data/BERT/Packet.hs b/Data/BERT/Packet.hs deleted file mode 100644 --- a/Data/BERT/Packet.hs +++ /dev/null @@ -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 diff --git a/Data/BERT/Parser.hs b/Data/BERT/Parser.hs deleted file mode 100644 --- a/Data/BERT/Parser.hs +++ /dev/null @@ -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 diff --git a/Data/BERT/Term.hs b/Data/BERT/Term.hs deleted file mode 100644 --- a/Data/BERT/Term.hs +++ /dev/null @@ -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 diff --git a/Data/BERT/Types.hs b/Data/BERT/Types.hs deleted file mode 100644 --- a/Data/BERT/Types.hs +++ /dev/null @@ -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) - diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/Network/BERT.hs b/Network/BERT.hs deleted file mode 100644 --- a/Network/BERT.hs +++ /dev/null @@ -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 (). 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 diff --git a/Network/BERT/Client.hs b/Network/BERT/Client.hs deleted file mode 100644 --- a/Network/BERT/Client.hs +++ /dev/null @@ -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 (). 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) diff --git a/Network/BERT/Server.hs b/Network/BERT/Server.hs deleted file mode 100644 --- a/Network/BERT/Server.hs +++ /dev/null @@ -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 (). 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 diff --git a/Network/BERT/Transport.hs b/Network/BERT/Transport.hs deleted file mode 100644 --- a/Network/BERT/Transport.hs +++ /dev/null @@ -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: --- --- 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 diff --git a/bert.cabal b/bert.cabal --- a/bert.cabal +++ b/bert.cabal @@ -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 . maintainer: Roman Cheplyaka -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 diff --git a/bert.hs b/bert.hs deleted file mode 100644 --- a/bert.hs +++ /dev/null @@ -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 [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 () diff --git a/src/Data/BERT.hs b/src/Data/BERT.hs new file mode 100644 --- /dev/null +++ b/src/Data/BERT.hs @@ -0,0 +1,12 @@ +-- | BERT (Erlang terms) implementation. See and +-- 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 diff --git a/src/Data/BERT/Packet.hs b/src/Data/BERT/Packet.hs new file mode 100644 --- /dev/null +++ b/src/Data/BERT/Packet.hs @@ -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 diff --git a/src/Data/BERT/Parser.hs b/src/Data/BERT/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/BERT/Parser.hs @@ -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 diff --git a/src/Data/BERT/Term.hs b/src/Data/BERT/Term.hs new file mode 100644 --- /dev/null +++ b/src/Data/BERT/Term.hs @@ -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 diff --git a/src/Data/BERT/Types.hs b/src/Data/BERT/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/BERT/Types.hs @@ -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) + diff --git a/src/Network/BERT.hs b/src/Network/BERT.hs new file mode 100644 --- /dev/null +++ b/src/Network/BERT.hs @@ -0,0 +1,20 @@ +-- | BERT-RPC client (). 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 diff --git a/src/Network/BERT/Client.hs b/src/Network/BERT/Client.hs new file mode 100644 --- /dev/null +++ b/src/Network/BERT/Client.hs @@ -0,0 +1,43 @@ +-- | BERT-RPC client (). 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 diff --git a/src/Network/BERT/Server.hs b/src/Network/BERT/Server.hs new file mode 100644 --- /dev/null +++ b/src/Network/BERT/Server.hs @@ -0,0 +1,92 @@ +-- | BERT-RPC server (). 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 diff --git a/src/Network/BERT/Transport.hs b/src/Network/BERT/Transport.hs new file mode 100644 --- /dev/null +++ b/src/Network/BERT/Transport.hs @@ -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 } diff --git a/tests/test.hs b/tests/test.hs new file mode 100644 --- /dev/null +++ b/tests/test.hs @@ -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