bert 1.0 → 1.1
raw patch · 8 files changed
+506/−16 lines, 8 files
Files
- Data/BERT/Packet.hs +54/−0
- Data/BERT/Parser.hs +75/−0
- Data/BERT/Term.hs +323/−0
- Data/BERT/Types.hs +37/−0
- Network/BERT/Client.hs +0/−1
- Network/BERT/Server.hs +11/−13
- bert.cabal +5/−1
- bert.hs +1/−1
+ Data/BERT/Packet.hs view
@@ -0,0 +1,54 @@+-- |+-- 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 view
@@ -0,0 +1,75 @@+-- |+-- Module : Data.BERT.Parser+-- Copyright : (c) marius a. eriksen 2009+-- +-- License : BSD3+-- Maintainer : marius@monkey.org+-- Stability : experimental+-- Portability : GHC+-- +-- Parse (simple) BERTs.+module Data.BERT.Parser+ ( parseTerm+ ) where++import Data.Char (ord)+import Control.Applicative+import Control.Monad (MonadPlus(..), ap)+import Numeric (readSigned, readFloat, readDec)+import Control.Monad (liftM)+import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))+import qualified Data.ByteString.Lazy as B+import qualified Data.ByteString.Lazy.Char8 as C+import Data.BERT.Types (Term(..))++instance Applicative (GenParser s a) where+ pure = return+ (<*>) = ap+instance Alternative (GenParser s a) where+ empty = mzero+ (<|>) = mplus++-- | Parse a simple BERT (erlang) term from a string in the erlang+-- grammar. Does not attempt to decompose complex terms.+parseTerm :: String -> Either ParseError Term+parseTerm = parse p_term "term" ++p_term :: Parser Term+p_term = t <* spaces + where + t = IntTerm <$> p_num (readSigned readDec)+ <|> FloatTerm <$> p_num (readSigned readFloat)+ <|> AtomTerm <$> p_atom+ <|> TupleTerm <$> p_tuple+ <|> BytelistTerm . C.pack <$> p_string+ <|> ListTerm <$> p_list+ <|> BinaryTerm . B.pack <$> p_binary++p_num which = do+ s <- getInput+ case which s of+ [(n, s')] -> n <$ setInput s'+ _ -> empty++p_atom = unquoted <|> quoted+ where+ unquoted = many1 $ lower <|> oneOf ['_', '@']+ quoted = quote >> many1 letter <* quote+ quote = char '\''++p_seq open close elem = + between (open >> spaces) (spaces >> close) $+ elem `sepBy` (spaces >> char ',' >> spaces)++p_tuple = p_seq (char '{') (char '}') p_term++p_list = p_seq (char '[') (char ']') p_term++p_string = char '"' >> many strchar <* char '"'+ where+ strchar = noneOf ['\\', '"'] <|> (char '\\' >> anyChar)++p_binary = string "<<" >> (bstr <|> bseq) <* string ">>"+ where+ bseq = (p_num readDec) `sepBy` (spaces >> char ',' >> spaces)+ bstr = map (fromIntegral . ord) <$> p_string
+ Data/BERT/Term.hs view
@@ -0,0 +1,323 @@+{-# LANGUAGE OverlappingInstances, TypeSynonymInstances #-}+-- |+-- 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 view
@@ -0,0 +1,37 @@+-- |+-- Module : Data.BERT.Types+-- Copyright : (c) marius a. eriksen 2009+-- +-- License : BSD3+-- Maintainer : marius@monkey.org+-- Stability : experimental+-- Portability : GHC+-- +-- The Term type.+module Data.BERT.Types+ ( Term(..)+ ) where++import Data.ByteString.Lazy (ByteString)+import Data.Time (UTCTime)++-- | A single BERT term.+data Term+ -- Simple (erlang) terms:+ = IntTerm Int+ | FloatTerm Float+ | AtomTerm String+ | TupleTerm [Term]+ | BytelistTerm ByteString+ | ListTerm [Term]+ | BinaryTerm ByteString+ | BigintTerm Integer+ | BigbigintTerm Integer+ -- Composite (BERT specific) terms:+ | NilTerm+ | BoolTerm Bool+ | DictionaryTerm [(Term, Term)]+ | TimeTerm UTCTime+ | RegexTerm String [String]+ deriving (Eq, Ord)+
Network/BERT/Client.hs view
@@ -48,4 +48,3 @@ handle t@(TupleTerm (AtomTerm "error":_)) = return $ Left . ServerError $ t handle t = fail $ "unknown reply " ++ (show t)-
Network/BERT/Server.hs view
@@ -12,7 +12,7 @@ -- supported at this time. module Network.BERT.Server - ( DispatchError(..)+ ( DispatchResult(..) -- ** Serve -- $example , serve@@ -25,10 +25,9 @@ import Data.BERT (Term(..)) import Text.Printf (printf) --- TODO: just do DispatchResult?--data DispatchError - = NoSuchModule+data DispatchResult+ = Success Term+ | NoSuchModule | NoSuchFunction | Undesignated String deriving (Eq, Show, Ord)@@ -36,14 +35,13 @@ -- | Serve from the given transport (forever), handling each request -- with the given dispatch function in a new thread. serve :: Transport - -> (String -> String -> [Term] -> IO (Either DispatchError Term))+ -> (String -> String -> [Term] -> IO DispatchResult) -> IO () serve transport dispatch = servet transport $ \t -> (forkIO $ withTransport t $ handleCall dispatch) >> return () -handleCall dispatch =- recvt >>= handle+handleCall dispatch = recvt >>= handle where handle (TupleTerm [AtomTerm "info", AtomTerm "stream", _]) = sendErr "server" 0 "BERTError" "streams are unsupported" []@@ -54,16 +52,16 @@ AtomTerm fun, ListTerm args]) = do res <- liftIO $ dispatch mod fun args case res of- Left NoSuchModule ->+ Success term -> + sendt $ TupleTerm [AtomTerm "reply", term]+ NoSuchModule -> sendErr "server" 1 "BERTError" (printf "no such module \"%s\"" mod :: String) []- Left NoSuchFunction ->+ NoSuchFunction -> sendErr "server" 2 "BERTError" (printf "no such function \"%s\"" fun :: String) []- Left (Undesignated detail) ->+ Undesignated detail -> sendErr "server" 0 "HandlerError" detail []- Right term -> - sendt $ TupleTerm [AtomTerm "reply", term] sendErr etype ecode eclass detail backtrace = sendt $ TupleTerm [
bert.cabal view
@@ -1,6 +1,6 @@ cabal-version: >= 1.6 name: bert-version: 1.0+version: 1.1 build-type: Simple license: BSD3 license-file: LICENSE@@ -20,6 +20,10 @@ parsec >= 2.0 exposed-modules: Data.BERT+ Data.BERT.Packet+ Data.BERT.Parser+ Data.BERT.Term+ Data.BERT.Types Network.BERT Network.BERT.Transport Network.BERT.Client
bert.hs view
@@ -30,7 +30,7 @@ ] usage = do- header <- getProgName >>= + header <- getProgName >>= return . printf ("Usage: %s [OPTION...] " ++ "[call <uri> <mod> <fun> [args..]|serve PORT]" ) return $ usageInfo header options