├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── bert.cabal ├── src ├── Data │ ├── BERT.hs │ └── BERT │ │ ├── Packet.hs │ │ ├── Parser.hs │ │ ├── Term.hs │ │ └── Types.hs └── Network │ ├── BERT.hs │ └── BERT │ ├── Client.hs │ ├── Server.hs │ └── Transport.hs └── tests └── test.hs /.gitignore: -------------------------------------------------------------------------------- 1 | .cabal-sandbox/** 2 | cabal.sandbox.config 3 | dist/ 4 | *.hi 5 | *.o 6 | QC 7 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | Version 1.2.2.5 2 | --------------- 3 | 4 | * Fix a list deserialization bug 5 | * Serialize small ints compactly 6 | 7 | Version 1.2.2.4 8 | --------------- 9 | 10 | Fix compatibility with GHC 7.10 11 | 12 | Version 1.2.2.3 13 | --------------- 14 | 15 | Fix compatibility with recent conduit. 16 | 17 | Version 1.2.2.2 18 | --------------- 19 | 20 | Migrate from network-conduit (which is deprecated) to conduit-extra 21 | 22 | Version 1.2.2.1 23 | --------------- 24 | 25 | Fix build on GHC 7.4 26 | 27 | Version 1.2.2 28 | --------------- 29 | 30 | * `Show` and `Read` instances for `Term` now use Haskell, not Erlang syntax. To 31 | get the Erlang-syntax-formatted terms, `showTerm` and `parseTerm` are now 32 | exposed. 33 | 34 | Version 1.2.1.2 35 | --------------- 36 | 37 | * Fix Windows compatibility 38 | 39 | Version 1.2.1.1 40 | --------------- 41 | 42 | * Fix integer (de)serialization on 64-bit platforms 43 | 44 | Version 1.2.1 45 | ------------- 46 | 47 | * Fix the docs 48 | * Export the `Error` data type 49 | 50 | Version 1.2 51 | ----------- 52 | 53 | * Drop the `bert` command-line tool 54 | * Remove support for the (non-standard) bert:// URI 55 | * Change the way transports are represented 56 | * Instead of `fromURI` or `fromHostPort`, you should now use `tcpClient` and 57 | `tcpServer` 58 | * Both the client and the server now support persistent connections 59 | * The default TCP backlog is increased for the server 60 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2009 marius a. eriksen (marius@monkey.org) 2 | (c) 2013 Roman Cheplyaka 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions 7 | are met: 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. The names of the authors may not be used to endorse or promote products 14 | derived from this software without specific prior written permission. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 18 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 19 | IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, 20 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 21 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 22 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 23 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 24 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 25 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | BERT[-RPC] for Haskell 2 | ====================== 3 | 4 | Originally written by marius a. eriksen (marius@monkey.org) 5 | 6 | This is a [BERT](http://bert-rpc.org/) serializer/deserializer and 7 | [BERT-RPC](http://bert-rpc.org) client and server for 8 | [Haskell](http://www.haskell.org/). BERT-RPC currently supports 9 | synchronous (`call`) requests. 10 | 11 | The primitives provided are fairly elementary: for the client, `call` 12 | provides the capability to perform the RPC call, while the server's 13 | `serve` is provided with a dispatch function providing the dispatching 14 | logic for the server. Thus, one can imagine building higher level 15 | abstractions on top of these primitives. 16 | 17 | Installation 18 | ------------ 19 | 20 | It's a cabal package, so 21 | 22 | $ cabal install bert 23 | 24 | should do the trick. 25 | 26 | BERT 27 | ---- 28 | 29 | import qualified Data.ByteString.Lazy.Char8 as C 30 | import Data.BERT 31 | 32 | Creating BERT terms is simple. 33 | 34 | TupleTerm [BytelistTerm (C.pack "hello"), IntTerm 123] 35 | 36 | Or by using the `BERT` typeclass. 37 | 38 | showBERT $ ("hello", 123) 39 | 40 | The `BERT` class can also read terms back. 41 | 42 | Right ("hello", 123) = readBERT . showBERT $ ("hello", 123) 43 | 44 | BERT-RPC client 45 | --------------- 46 | 47 | import Data.BERT 48 | import Network.BERT.Client 49 | 50 | Create a transport to the server endpoint, and issue a (synchronous) 51 | call with it. 52 | 53 | t <- tcpClient "localhost" 8080 54 | r <- call t "calc" "add" ([123, 3000]::[Int]) 55 | case r of 56 | Right res -> print (res :: Int) 57 | Left _ -> putStrLn "error" 58 | 59 | BERT-RPC server 60 | --------------- 61 | 62 | import Data.BERT 63 | import Network.BERT.Server 64 | 65 | Create a transport from which to accept connections, and provide a 66 | dispatch function for incoming RPCs. The dispatch function is issued 67 | in a new thread for each incoming request. 68 | 69 | main = do 70 | s <- tcpServer 8080 71 | serve s dispatch 72 | 73 | dispatch "calc" "add" [IntTerm a, IntTerm b] = 74 | return $ Success $ IntTerm (a + b) 75 | dispatch "calc" _ _ = 76 | return NoSuchFunction 77 | dispatch _ _ _ = 78 | return NoSuchModule 79 | 80 | Maintainers 81 | ----------- 82 | 83 | [Roman Cheplyaka](https://github.com/feuerbach) is the primary maintainer. 84 | 85 | [Oleksandr Manzyuk](https://github.com/manzyuk) is the backup maintainer. Please 86 | get in touch with him if the primary maintainer cannot be reached. 87 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bert.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >= 1.16 2 | name: bert 3 | version: 1.2.2.5 4 | build-type: Simple 5 | license: BSD3 6 | license-file: LICENSE 7 | author: marius a. eriksen, Roman Cheplyaka 8 | category: Data 9 | synopsis: BERT implementation 10 | description: Implements the BERT serialization and RPC protocols 11 | described at . 12 | maintainer: Roman Cheplyaka 13 | copyright: (c) 2009-2011 marius a. eriksen; (c) 2013 Roman Cheplyaka 14 | homepage: https://github.com/feuerbach/bert 15 | bug-reports: https://github.com/feuerbach/bert/issues 16 | extra-source-files: 17 | README.md 18 | CHANGELOG.md 19 | 20 | source-repository head 21 | type: git 22 | location: git@github.com:feuerbach/bert.git 23 | 24 | library 25 | hs-source-dirs: src 26 | build-depends: base == 4.*, containers >= 0.2, 27 | bytestring >= 0.9, binary >= 0.5, mtl >= 1.1, 28 | network >= 2.3, time >= 1.1, 29 | parsec >= 2.0, 30 | conduit >= 1.0, 31 | conduit-extra >= 1.1, 32 | binary-conduit >= 1.2, 33 | void 34 | if !os(windows) 35 | build-depends: unix >= 2.0 36 | 37 | exposed-modules: 38 | Data.BERT 39 | Data.BERT.Packet 40 | Data.BERT.Parser 41 | Data.BERT.Term 42 | Data.BERT.Types 43 | Network.BERT 44 | Network.BERT.Transport 45 | Network.BERT.Client 46 | Network.BERT.Server 47 | ghc-options: -fwarn-unused-imports 48 | default-language: Haskell2010 49 | 50 | test-suite test 51 | hs-source-dirs: tests 52 | default-language: Haskell2010 53 | type: exitcode-stdio-1.0 54 | Main-is: test.hs 55 | build-depends: 56 | tasty >= 0.4, 57 | tasty-smallcheck, 58 | tasty-hunit, 59 | async, 60 | network, 61 | bert, 62 | base, 63 | smallcheck >= 1.1, 64 | containers, 65 | bytestring, 66 | binary 67 | -------------------------------------------------------------------------------- /src/Data/BERT.hs: -------------------------------------------------------------------------------- 1 | -- | BERT (Erlang terms) implementation. See and 2 | -- for more 3 | -- details. 4 | module Data.BERT 5 | ( module Data.BERT.Types 6 | , module Data.BERT.Term 7 | , module Data.BERT.Packet 8 | ) where 9 | 10 | import Data.BERT.Types 11 | import Data.BERT.Term 12 | import Data.BERT.Packet 13 | -------------------------------------------------------------------------------- /src/Data/BERT/Packet.hs: -------------------------------------------------------------------------------- 1 | -- | BERP (BERT packets) support. 2 | module Data.BERT.Packet 3 | ( Packet(..) 4 | , fromPacket 5 | ) where 6 | 7 | import Control.Monad 8 | import Data.ByteString.Lazy as L 9 | import Data.Binary 10 | import Data.Binary.Put 11 | import Data.Binary.Get 12 | 13 | import Data.BERT.Term () 14 | import Data.BERT.Types 15 | 16 | -- | A single BERP. Little more than a wrapper for a term. 17 | data Packet 18 | = Packet Term 19 | deriving (Show, Ord, Eq) 20 | 21 | fromPacket (Packet t) = t 22 | 23 | instance Binary Packet where 24 | put (Packet term) = 25 | putWord32be (fromIntegral len) >> putLazyByteString encoded 26 | where encoded = encode term 27 | len = L.length encoded 28 | 29 | get = getPacket 30 | 31 | getPacket = 32 | liftM fromIntegral getWord32be >>= 33 | getLazyByteString >>= 34 | return . Packet . decode 35 | -------------------------------------------------------------------------------- /src/Data/BERT/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverlappingInstances, TypeSynonymInstances, FlexibleContexts #-} 2 | -- | Parse (simple) BERTs. 3 | module Data.BERT.Parser 4 | ( parseTerm 5 | ) where 6 | 7 | import Data.Char 8 | import Control.Applicative 9 | import Numeric 10 | import Text.ParserCombinators.Parsec hiding (many, optional, (<|>)) 11 | import qualified Data.ByteString.Lazy as B 12 | import qualified Data.ByteString.Lazy.Char8 as C 13 | import Data.BERT.Types 14 | 15 | --instance Applicative (GenParser s a) where 16 | -- pure = return 17 | -- (<*>) = ap 18 | --instance Alternative (GenParser s a) where 19 | -- empty = mzero 20 | -- (<|>) = mplus 21 | 22 | -- | Parse a simple BERT (erlang) term from a string in the erlang 23 | -- grammar. Does not attempt to decompose complex terms. 24 | parseTerm :: String -> Either ParseError Term 25 | parseTerm = parse p_term "term" 26 | 27 | p_term :: Parser Term 28 | p_term = t <* spaces 29 | where 30 | t = IntTerm <$> p_num (readSigned readDec) 31 | <|> FloatTerm <$> p_num (readSigned readFloat) 32 | <|> AtomTerm <$> p_atom 33 | <|> TupleTerm <$> p_tuple 34 | <|> BytelistTerm . C.pack <$> p_string 35 | <|> ListTerm <$> p_list 36 | <|> BinaryTerm . B.pack <$> p_binary 37 | 38 | p_num which = do 39 | s <- getInput 40 | case which s of 41 | [(n, s')] -> n <$ setInput s' 42 | _ -> empty 43 | 44 | p_atom = unquoted <|> quoted 45 | where 46 | unquoted = many1 $ lower <|> oneOf ['_', '@'] 47 | quoted = quote >> many1 letter <* quote 48 | quote = char '\'' 49 | 50 | p_seq open close elem = 51 | between (open >> spaces) (spaces >> close) $ 52 | elem `sepBy` (spaces >> char ',' >> spaces) 53 | 54 | p_tuple = p_seq (char '{') (char '}') p_term 55 | 56 | p_list = p_seq (char '[') (char ']') p_term 57 | 58 | p_string = char '"' >> many strchar <* char '"' 59 | where 60 | strchar = noneOf ['\\', '"'] <|> (char '\\' >> anyChar) 61 | 62 | p_binary = string "<<" >> (bstr <|> bseq) <* string ">>" 63 | where 64 | bseq = (p_num readDec) `sepBy` (spaces >> char ',' >> spaces) 65 | bstr = map (fromIntegral . ord) <$> p_string 66 | -------------------------------------------------------------------------------- /src/Data/BERT/Term.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverlappingInstances, TypeSynonymInstances, FlexibleInstances #-} 2 | -- | Define BERT terms their binary encoding & decoding and a typeclass 3 | -- for converting Haskell values to BERT terms and back. 4 | -- 5 | -- We define a number of convenient instances for 'BERT'. Users will 6 | -- probably want to define their own instances for composite types. 7 | module Data.BERT.Term 8 | ( BERT(..) 9 | , showTerm 10 | , parseTerm 11 | ) where 12 | 13 | import Control.Monad 14 | import Control.Applicative 15 | import Data.Bits 16 | import Data.Char 17 | import Data.Int 18 | import Data.Binary 19 | import Data.Binary.Put 20 | import Data.Binary.Get 21 | import Data.List 22 | import Data.Time 23 | import Data.ByteString.Lazy (ByteString) 24 | import qualified Data.ByteString.Lazy as B 25 | import qualified Data.ByteString.Lazy.Char8 as C 26 | import Data.Map (Map) 27 | import qualified Data.Map as Map 28 | import Text.Printf 29 | import Data.BERT.Types 30 | import Data.BERT.Parser 31 | 32 | -- The 0th-hour as per the BERT spec. 33 | zeroHour = UTCTime (read "1970-01-01") 0 34 | 35 | decomposeTime :: UTCTime -> (Int, Int, Int) 36 | decomposeTime t = (mS, s, uS) 37 | where 38 | d = diffUTCTime t zeroHour 39 | (mS, s) = (floor d) `divMod` 1000000 40 | uS = floor $ 1000000 * (snd $ properFraction d) 41 | 42 | composeTime :: (Int, Int, Int) -> UTCTime 43 | composeTime (mS, s, uS) = addUTCTime seconds zeroHour 44 | where 45 | mS' = fromIntegral mS 46 | s' = fromIntegral s 47 | uS' = fromIntegral uS 48 | seconds = ((mS' * 1000000) + s' + (uS' / 1000000)) 49 | 50 | -- Another design would be to split the Term type into 51 | -- SimpleTerm|CompositeTerm, and then do everything in one go, but 52 | -- that complicates syntax and semantics for end users. Let's do this 53 | -- one ugly thing instead, eh? 54 | ct b rest = TupleTerm $ [AtomTerm "bert", AtomTerm b] ++ rest 55 | compose NilTerm = ListTerm [] 56 | compose (BoolTerm True) = ct "true" [] 57 | compose (BoolTerm False) = ct "false" [] 58 | compose (DictionaryTerm kvs) = 59 | ct "dict" [ListTerm $ map (\(k, v) -> TupleTerm [k, v]) kvs] 60 | compose (TimeTerm t) = 61 | ct "time" [IntTerm mS, IntTerm s, IntTerm uS] 62 | where 63 | (mS, s, uS) = decomposeTime t 64 | compose (RegexTerm s os) = 65 | ct "regex" [BytelistTerm (C.pack s), 66 | TupleTerm [ListTerm $ map AtomTerm os]] 67 | compose _ = error "invalid composite term" 68 | 69 | showTerm (IntTerm x) = show x 70 | showTerm (FloatTerm x) = printf "%15.15e" x 71 | showTerm (AtomTerm "") = "" 72 | showTerm (AtomTerm a@(x:xs)) 73 | | isAsciiLower x = a 74 | | otherwise = "'" ++ a ++ "'" 75 | showTerm (TupleTerm ts) = 76 | "{" ++ intercalate ", " (map showTerm ts) ++ "}" 77 | showTerm (BytelistTerm bs) = show $ C.unpack bs 78 | showTerm (ListTerm ts) = 79 | "[" ++ intercalate ", " (map showTerm ts) ++ "]" 80 | showTerm (BinaryTerm b) 81 | | all (isAscii . chr . fromIntegral) (B.unpack b) = 82 | wrap $ "\"" ++ C.unpack b ++ "\"" 83 | | otherwise = 84 | wrap $ intercalate ", " $ map show $ B.unpack b 85 | where 86 | wrap x = "<<" ++ x ++ ">>" 87 | showTerm (BigintTerm x) = show x 88 | showTerm (BigbigintTerm x) = show x 89 | -- All other terms are composite: 90 | showTerm t = showTerm . compose $ t 91 | 92 | class BERT a where 93 | -- | Introduce a 'Term' from a Haskell value. 94 | showBERT :: a -> Term 95 | -- | Attempt to read a haskell value from a 'Term'. 96 | readBERT :: Term -> (Either String a) 97 | 98 | -- Herein are some instances for common Haskell data types. To do 99 | -- anything more complicated, you should make your own instance. 100 | 101 | instance BERT Term where 102 | showBERT = id 103 | readBERT = return . id 104 | 105 | instance BERT Int where 106 | showBERT = IntTerm 107 | readBERT (IntTerm value) = return value 108 | readBERT _ = fail "Invalid integer type" 109 | 110 | instance BERT Bool where 111 | showBERT = BoolTerm 112 | readBERT (BoolTerm x) = return x 113 | readBERT _ = fail "Invalid bool type" 114 | 115 | instance BERT Integer where 116 | showBERT = BigbigintTerm 117 | readBERT (BigintTerm x) = return x 118 | readBERT (BigbigintTerm x) = return x 119 | readBERT _ = fail "Invalid integer type" 120 | 121 | instance BERT Float where 122 | showBERT = FloatTerm 123 | readBERT (FloatTerm value) = return value 124 | readBERT _ = fail "Invalid floating point type" 125 | 126 | instance BERT String where 127 | showBERT = BytelistTerm . C.pack 128 | readBERT (BytelistTerm x) = return $ C.unpack x 129 | readBERT (BinaryTerm x) = return $ C.unpack x 130 | readBERT (AtomTerm x) = return x 131 | readBERT (ListTerm xs) = mapM readBERT xs >>= return . map chr 132 | readBERT _ = fail "Invalid string type" 133 | 134 | instance BERT ByteString where 135 | showBERT = BytelistTerm 136 | readBERT (BytelistTerm value) = return value 137 | readBERT _ = fail "Invalid bytestring type" 138 | 139 | instance (BERT a) => BERT [a] where 140 | showBERT xs = ListTerm $ map showBERT xs 141 | readBERT (ListTerm xs) = mapM readBERT xs 142 | readBERT _ = fail "Invalid list type" 143 | 144 | instance (BERT a, BERT b) => BERT (a, b) where 145 | showBERT (a, b) = TupleTerm [showBERT a, showBERT b] 146 | readBERT (TupleTerm [a, b]) = liftM2 (,) (readBERT a) (readBERT b) 147 | readBERT _ = fail "Invalid tuple(2) type" 148 | 149 | instance (BERT a, BERT b, BERT c) => BERT (a, b, c) where 150 | showBERT (a, b, c) = TupleTerm [showBERT a, showBERT b, showBERT c] 151 | readBERT (TupleTerm [a, b, c]) = 152 | liftM3 (,,) (readBERT a) (readBERT b) (readBERT c) 153 | readBERT _ = fail "Invalid tuple(3) type" 154 | 155 | instance (BERT a, BERT b, BERT c, BERT d) => BERT (a, b, c, d) where 156 | showBERT (a, b, c, d) = 157 | TupleTerm [showBERT a, showBERT b, showBERT c, showBERT d] 158 | readBERT (TupleTerm [a, b, c, d]) = 159 | liftM4 (,,,) (readBERT a) (readBERT b) (readBERT c) (readBERT d) 160 | readBERT _ = fail "Invalid tuple(4) type" 161 | 162 | instance (Ord k, BERT k, BERT v) => BERT (Map k v) where 163 | showBERT m = DictionaryTerm 164 | $ map (\(k, v) -> (showBERT k, showBERT v)) (Map.toList m) 165 | readBERT (DictionaryTerm kvs) = 166 | mapM (\(k, v) -> liftM2 (,) (readBERT k) (readBERT v)) kvs >>= 167 | return . Map.fromList 168 | readBERT _ = fail "Invalid map type" 169 | 170 | -- Binary encoding & decoding. 171 | instance Binary Term where 172 | put term = putWord8 131 >> putTerm term 173 | get = getWord8 >>= \magic -> 174 | case magic of 175 | 131 -> getTerm 176 | _ -> fail "bad magic" 177 | 178 | -- | Binary encoding of a single term (without header) 179 | putTerm :: Term -> PutM () 180 | putTerm (IntTerm value) 181 | | 0 <= value && value < 256 = tag 97 >> put8u value 182 | | otherwise = tag 98 >> put32s value 183 | putTerm (FloatTerm value) = 184 | tag 99 >> (putL . C.pack . pad $ printf "%15.15e" value) 185 | where 186 | pad s = s ++ replicate (31 - (length s)) '\0' 187 | putTerm (AtomTerm value) 188 | | len < 256 = tag 100 >> put16u len >> (putL $ C.pack value) 189 | | otherwise = fail "BERT atom too long (>= 256)" 190 | where 191 | len = length value 192 | putTerm (TupleTerm value) 193 | | len < 256 = tag 104 >> put8u len >> forM_ value putTerm 194 | | otherwise = tag 105 >> put32u len >> forM_ value putTerm 195 | where 196 | len = length value 197 | putTerm (BytelistTerm value) 198 | | len < 65536 = tag 107 >> put16u len >> putL value 199 | | otherwise = do -- too big: encode as a list. 200 | tag 108 201 | put32u len 202 | forM_ (B.unpack value) $ \v -> do 203 | tag 97 204 | putWord8 v 205 | where 206 | len = B.length value 207 | putTerm (ListTerm value) 208 | | len == 0 = putNil -- this is mentioned in the BERT spec. 209 | | otherwise= do 210 | tag 108 211 | put32u $ length value 212 | forM_ value putTerm 213 | putNil 214 | where 215 | len = length value 216 | putNil = putWord8 106 217 | putTerm (BinaryTerm value) = tag 109 >> (put32u $ B.length value) >> putL value 218 | putTerm (BigintTerm value) = tag 110 >> putBigint put8u value 219 | putTerm (BigbigintTerm value) = tag 111 >> putBigint put32u value 220 | -- All other terms are composite: 221 | putTerm t = putTerm . compose $ t 222 | 223 | -- | Binary decoding of a single term (without header) 224 | getTerm :: Get Term 225 | getTerm = do 226 | tag <- get8u 227 | case tag of 228 | 97 -> IntTerm <$> get8u 229 | 98 -> IntTerm <$> get32s 230 | 99 -> getL 31 >>= return . FloatTerm . read . C.unpack 231 | 100 -> get16u >>= getL >>= return . AtomTerm . C.unpack 232 | 104 -> get8u >>= getN >>= tupleTerm 233 | 105 -> get32u >>= getN >>= tupleTerm 234 | 106 -> return $ ListTerm [] 235 | 107 -> get16u >>= getL >>= return . BytelistTerm 236 | 108 -> get32u >>= \n -> getN n <* expectNil >>= return . ListTerm 237 | 109 -> get32u >>= getL >>= return . BinaryTerm 238 | 110 -> getBigint get8u >>= return . BigintTerm . fromIntegral 239 | 111 -> getBigint get32u >>= return . BigintTerm . fromIntegral 240 | where 241 | getN :: Int -> Get [Term] 242 | getN n = replicateM n getTerm 243 | expectNil :: Get () 244 | expectNil = do 245 | tag <- get8u 246 | case tag of 247 | 106 -> return () 248 | _ -> fail $ "invalid list - expected list ending with Nil" 249 | -- First try & decode composite terms. 250 | tupleTerm [AtomTerm "bert", AtomTerm "true"] = return $ BoolTerm True 251 | tupleTerm [AtomTerm "bert", AtomTerm "false"] = return $ BoolTerm False 252 | tupleTerm [AtomTerm "bert", AtomTerm "dict", ListTerm kvs] = 253 | mapM toTuple kvs >>= return . DictionaryTerm 254 | where 255 | toTuple (TupleTerm [k, v]) = return $ (k, v) 256 | toTuple _ = fail "invalid dictionary" 257 | tupleTerm [AtomTerm "bert", AtomTerm "time", 258 | IntTerm mS, IntTerm s, IntTerm uS] = 259 | return $ TimeTerm $ composeTime (mS, s, uS) 260 | tupleTerm [AtomTerm "bert", AtomTerm "regex", 261 | BytelistTerm s, ListTerm os] = 262 | options os >>= return . RegexTerm (C.unpack s) 263 | where 264 | -- TODO: type-check the options values as well 265 | options [] = return [] 266 | options ((AtomTerm o):os) = options os >>= return . (o:) 267 | options _ = fail "regex options must be atoms" 268 | -- All other tuples are just .. tuples 269 | tupleTerm xs = return $ TupleTerm xs 270 | 271 | putBigint putter value = do 272 | putter len -- TODO: verify size? 273 | if value < 0 274 | then put8u 1 275 | else put8u 0 276 | putL $ B.pack $ map (fromIntegral . digit) [0..len-1] 277 | where 278 | value' = abs value 279 | len = ceiling $ logBase 256 (fromIntegral $ value' + 1) 280 | digit pos = (value' `shiftR` (8 * pos)) .&. 0xFF 281 | 282 | getBigint getter = do 283 | len <- fromIntegral <$> getter 284 | sign <- get8u 285 | bytes <- getL len 286 | multiplier <- 287 | case sign of 288 | 0 -> return 1 289 | 1 -> return (-1) 290 | _ -> fail "Invalid sign byte" 291 | return $ (*) multiplier 292 | $ foldl (\s (n, d) -> s + d*(256^n)) 0 293 | $ zip [0..len-1] (map fromIntegral $ B.unpack bytes) 294 | 295 | -- Note about put32s/get32s: 296 | -- 297 | -- When dealing with 32-bit signed ints, we first convert between Int and 298 | -- Int32, and only then cast to Word32. This is to ensure put and get are 299 | -- as close to inverse as possible. Coercing word types to and from 300 | -- integer types using 'fromIntegral' is guaranteed to preserve 301 | -- representation (see Notes in "Data.Int"). 302 | -- 303 | -- For an example of what can go wrong, see 304 | -- https://github.com/feuerbach/bert/issues/6 305 | 306 | put8u :: (Integral a) => a -> Put 307 | put8u = putWord8 . fromIntegral 308 | put16u :: (Integral a) => a -> Put 309 | put16u = putWord16be . fromIntegral 310 | put32u :: (Integral a) => a -> Put 311 | put32u = putWord32be . fromIntegral 312 | put32s :: (Integral a) => a -> Put 313 | put32s = putWord32be . (fromIntegral :: Int32 -> Word32) . fromIntegral 314 | putL = putLazyByteString 315 | 316 | get8u :: (Integral a) => Get a 317 | get8u = fromIntegral <$> getWord8 318 | get16u :: (Integral a) => Get a 319 | get16u = fromIntegral <$> getWord16be 320 | get32u :: (Integral a) => Get a 321 | get32u = fromIntegral <$> getWord32be 322 | get32s :: (Integral a) => Get a 323 | get32s = fromIntegral . (fromIntegral :: Word32 -> Int32) <$> getWord32be 324 | getL :: (Integral a) => a -> Get ByteString 325 | getL = getLazyByteString . fromIntegral 326 | 327 | tag :: Word8 -> Put 328 | tag which = putWord8 which 329 | -------------------------------------------------------------------------------- /src/Data/BERT/Types.hs: -------------------------------------------------------------------------------- 1 | -- | The Term type. 2 | module Data.BERT.Types 3 | ( Term(..) 4 | ) where 5 | 6 | import Data.ByteString.Lazy (ByteString) 7 | import Data.Time (UTCTime) 8 | 9 | -- | A single BERT term. 10 | data Term 11 | -- Simple (erlang) terms: 12 | = IntTerm Int 13 | | FloatTerm Float 14 | | AtomTerm String 15 | | TupleTerm [Term] 16 | | BytelistTerm ByteString 17 | | ListTerm [Term] 18 | | BinaryTerm ByteString 19 | | BigintTerm Integer 20 | | BigbigintTerm Integer 21 | -- Composite (BERT specific) terms: 22 | | NilTerm 23 | | BoolTerm Bool 24 | | DictionaryTerm [(Term, Term)] 25 | | TimeTerm UTCTime 26 | | RegexTerm String [String] 27 | deriving (Eq, Ord, Show, Read) 28 | -------------------------------------------------------------------------------- /src/Network/BERT.hs: -------------------------------------------------------------------------------- 1 | -- | BERT-RPC client (). See "Network.BERT.Client" and "Network.BERT.Server" for more details. 2 | module Network.BERT 3 | ( module Network.BERT.Transport 4 | , module Network.BERT.Client 5 | , module Network.BERT.Server 6 | ) where 7 | 8 | import Network.BERT.Transport 9 | import Network.BERT.Client 10 | import Network.BERT.Server 11 | -------------------------------------------------------------------------------- /src/Network/BERT/Client.hs: -------------------------------------------------------------------------------- 1 | -- | BERT-RPC client (). This implements the client RPC call logic. 2 | 3 | module Network.BERT.Client 4 | ( -- * Example 5 | -- $example 6 | -- * Documentation 7 | call, tcpClient, 8 | Call, Error(..) 9 | ) where 10 | 11 | import Data.BERT 12 | import Network.BERT.Transport 13 | 14 | data Error 15 | = ClientError String 16 | | ServerError Term 17 | deriving (Show, Ord, Eq) 18 | 19 | -- | Convenience type for @call@ 20 | type Call a = IO (Either Error a) 21 | 22 | -- | Call the @{mod, func, args}@ synchronously on the endpoint 23 | -- defined by @transport@, returning the results of the call or an 24 | -- error. 25 | call :: (BERT a, BERT b, Transport t) 26 | => t 27 | -> String 28 | -> String 29 | -> [a] 30 | -> Call b 31 | call transport mod fun args = 32 | runSession transport $ do 33 | sendt $ TupleTerm [AtomTerm "call", AtomTerm mod, AtomTerm fun, 34 | ListTerm $ map showBERT args] 35 | recvAndHandle 36 | where 37 | handle (TupleTerm [AtomTerm "reply", reply]) = 38 | return $ either (const . Left $ ClientError "decode failed") Right 39 | $ readBERT reply 40 | handle (TupleTerm (AtomTerm "info":_)) = 41 | recvAndHandle -- We don't yet handle info directives. 42 | handle t@(TupleTerm (AtomTerm "error":_)) = 43 | return $ Left . ServerError $ t 44 | handle t = fail $ "unknown reply " ++ (show t) 45 | 46 | recvAndHandle = 47 | recvt >>= maybe (fail "No answer") handle 48 | 49 | -- $example 50 | -- 51 | -- > t <- tcpClient "localhost" 8080 52 | -- > r <- call t "calc" "add" ([123, 3000]::[Int]) 53 | -- > case r of 54 | -- > Right res -> print (res :: Int) 55 | -- > Left _ -> putStrLn "error" 56 | -------------------------------------------------------------------------------- /src/Network/BERT/Server.hs: -------------------------------------------------------------------------------- 1 | -- | BERT-RPC server (). This implements the 2 | -- client RPC call/reply logic. Only synchronous requests are 3 | -- supported at this time. 4 | 5 | {-# LANGUAGE CPP #-} 6 | 7 | module Network.BERT.Server 8 | ( 9 | -- * Example 10 | -- $example 11 | -- * Documentation 12 | serve 13 | , DispatchResult(..) 14 | , tcpServer 15 | ) where 16 | 17 | import Control.Concurrent 18 | import Control.Monad.Trans 19 | import Control.Exception 20 | import Network.BERT.Transport 21 | import Network.Socket 22 | import Data.ByteString.Lazy.Char8 as C 23 | import Data.BERT 24 | import Text.Printf 25 | #if !mingw32_HOST_OS 26 | import qualified System.Posix.Signals as Sig 27 | #endif 28 | 29 | data DispatchResult 30 | = Success Term 31 | | NoSuchModule 32 | | NoSuchFunction 33 | | Undesignated String 34 | deriving (Eq, Show, Ord) 35 | 36 | data TcpServer = TcpServer !Socket 37 | 38 | -- | Serve from the given transport (forever), handling each request 39 | -- with the given dispatch function in a new thread. 40 | serve 41 | :: Server s 42 | => s 43 | -> (String -> String -> [Term] -> IO DispatchResult) 44 | -> IO () 45 | serve server dispatch = do 46 | #if !mingw32_HOST_OS 47 | -- Ignore sigPIPE, which can be delivered upon writing to a closed 48 | -- socket. 49 | Sig.installHandler Sig.sigPIPE Sig.Ignore Nothing 50 | #endif 51 | 52 | (runServer server $ \t -> 53 | (forkIO $ runSession t $ handleCall dispatch) >> return ()) 54 | `finally` 55 | cleanup server 56 | 57 | handleCall dispatch = recvtForever handle 58 | where 59 | handle (TupleTerm [AtomTerm "info", AtomTerm "stream", _]) = 60 | sendErr "server" 0 "BERTError" "streams are unsupported" [] 61 | handle (TupleTerm [AtomTerm "info", AtomTerm "cache", _]) = 62 | return () -- Ignore caching requests. 63 | handle (TupleTerm [ 64 | AtomTerm "call", AtomTerm mod, 65 | AtomTerm fun, ListTerm args]) = do 66 | res <- liftIO $ dispatch mod fun args 67 | case res of 68 | Success term -> 69 | sendt $ TupleTerm [AtomTerm "reply", term] 70 | NoSuchModule -> 71 | sendErr "server" 1 "BERTError" 72 | (printf "no such module \"%s\"" mod :: String) [] 73 | NoSuchFunction -> 74 | sendErr "server" 2 "BERTError" 75 | (printf "no such function \"%s\"" fun :: String) [] 76 | Undesignated detail -> 77 | sendErr "server" 0 "HandlerError" detail [] 78 | 79 | sendErr etype ecode eclass detail backtrace = 80 | sendt $ TupleTerm [ 81 | AtomTerm "error", 82 | TupleTerm [ 83 | AtomTerm etype, IntTerm ecode, BinaryTerm . C.pack $ eclass, 84 | ListTerm $ Prelude.map (BinaryTerm . C.pack) backtrace]] 85 | 86 | -- $example 87 | -- 88 | -- To serve requests, create a server and call 'serve' with a 89 | -- dispatch function. 90 | -- 91 | -- > main = do 92 | -- > s <- tcpServer 8080 93 | -- > serve s dispatch 94 | -- > 95 | -- > dispatch "calc" "add" [IntTerm a, IntTerm b] = 96 | -- > return $ Success $ IntTerm (a + b) 97 | -- > dispatch "calc" _ _ = 98 | -- > return NoSuchFunction 99 | -- > dispatch _ _ _ = 100 | -- > return NoSuchModule 101 | -------------------------------------------------------------------------------- /src/Network/BERT/Transport.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies, FlexibleContexts #-} 2 | -- | Underlying transport abstraction 3 | module Network.BERT.Transport 4 | ( 5 | -- * Core definitions 6 | Transport(..) 7 | , Server(..) 8 | , TransportM(..) 9 | , SendPacketFn 10 | -- * Sending and receiving packets 11 | , sendt, recvt, recvtForever 12 | -- * TCP transport 13 | , TCP(..) 14 | , tcpClient 15 | , TCPServer(..) 16 | , tcpServer 17 | -- * Utilities 18 | , resolve 19 | ) where 20 | 21 | import Control.Monad 22 | import Control.Applicative 23 | import Control.Monad.Reader 24 | import Network.Socket as Net 25 | import Data.Conduit 26 | import Data.Conduit.Network 27 | import Data.Conduit.Serialization.Binary 28 | import Data.Void 29 | 30 | import Data.BERT 31 | 32 | -- | A function to send packets to the peer 33 | type SendPacketFn = Packet -> IO () 34 | 35 | -- | The transport monad allows receiving packets through the conduit, 36 | -- and sending functions via the provided 'SendPacketFn' 37 | type TransportM = ReaderT SendPacketFn (ConduitM Packet Void IO) 38 | 39 | -- | The class for transports 40 | class Transport t where 41 | runSession :: t -> TransportM a -> IO a 42 | closeConnection :: t -> IO () 43 | 44 | class Transport (ServerTransport s) => Server s where 45 | -- | The underlying transport used by the server 46 | type ServerTransport s 47 | 48 | -- | This method should listen for incoming requests, establish some 49 | -- sort of a connection (represented by the transport) and then invoke 50 | -- the handling function 51 | runServer :: s -> (ServerTransport s -> IO ()) -> IO () 52 | 53 | -- | Free any resources that the server has acquired (such as the 54 | -- listening socket) 55 | cleanup :: s -> IO () 56 | 57 | -- | The TCP transport 58 | data TCP = TCP { 59 | getTcpSocket :: !Socket 60 | -- ^ The socket used for communication. 61 | -- 62 | -- The connection is assumed to be already established when this 63 | -- structure is passed in. 64 | } 65 | 66 | tcpSendPacketFn :: TCP -> SendPacketFn 67 | tcpSendPacketFn (TCP sock) packet = 68 | yield packet $= 69 | conduitEncode $$ 70 | sinkSocket sock 71 | 72 | instance Transport TCP where 73 | runSession tcp@(TCP sock) session = 74 | sourceSocket sock $= 75 | conduitDecode $$ 76 | (runReaderT session (tcpSendPacketFn tcp)) 77 | closeConnection (TCP sock) = sClose sock 78 | 79 | -- | Establish a connection to the TCP server and return the resulting 80 | -- transport. It can be used to make multiple requests. 81 | tcpClient :: HostName -> PortNumber -> IO TCP 82 | tcpClient host port = do 83 | sock <- socket AF_INET Stream defaultProtocol 84 | sa <- SockAddrInet port <$> resolve host 85 | Net.connect sock sa 86 | return $ TCP sock 87 | 88 | -- | The TCP server 89 | data TCPServer = TCPServer { 90 | getTcpListenSocket :: !Socket 91 | -- ^ The listening socket. Assumed to be bound but not listening yet. 92 | } 93 | 94 | instance Server TCPServer where 95 | type ServerTransport TCPServer = TCP 96 | 97 | runServer (TCPServer sock) handle = do 98 | listen sock sOMAXCONN 99 | 100 | forever $ do 101 | (clientsock, _) <- accept sock 102 | setSocketOption clientsock NoDelay 1 103 | handle $ TCP clientsock 104 | 105 | cleanup (TCPServer sock) = sClose sock 106 | 107 | -- | A simple 'TCPServer' constructor, listens on all local interfaces. 108 | -- 109 | -- If you want to bind only to some of the interfaces, create the socket 110 | -- manually using the functions from "Network.Socket". 111 | tcpServer :: PortNumber -> IO TCPServer 112 | tcpServer port = do 113 | sock <- socket AF_INET Stream defaultProtocol 114 | setSocketOption sock ReuseAddr 1 115 | bindSocket sock $ SockAddrInet port iNADDR_ANY 116 | return $ TCPServer sock 117 | 118 | -- | Send a term 119 | sendt :: Term -> TransportM () 120 | sendt t = ask >>= \send -> liftIO . send . Packet $ t 121 | 122 | -- | Receive a term 123 | recvt :: TransportM (Maybe Term) 124 | recvt = fmap fromPacket <$> lift await 125 | 126 | -- | Execute an action for every incoming term, until the connection is 127 | -- closed 128 | recvtForever :: (Term -> TransportM a) -> TransportM () 129 | recvtForever f = 130 | ReaderT $ \send -> awaitForever $ flip runReaderT send . f . fromPacket 131 | 132 | -- | A simple address resolver 133 | resolve :: HostName -> IO HostAddress 134 | resolve host = do 135 | r <- getAddrInfo (Just hints) (Just host) Nothing 136 | case r of 137 | (AddrInfo { addrAddress = (SockAddrInet _ addr) }:_) -> return addr 138 | _ -> fail $ "Failed to resolve " ++ host 139 | where 140 | hints = defaultHints { addrFamily = AF_INET } 141 | -------------------------------------------------------------------------------- /tests/test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-} 2 | 3 | import Control.Monad 4 | 5 | import Data.Binary 6 | import Data.Char (chr, ord) 7 | import Data.List (genericLength) 8 | import Data.Map (Map) 9 | import qualified Data.ByteString.Lazy as L 10 | import qualified Data.Map as Map 11 | import Text.Printf 12 | 13 | import Control.Concurrent 14 | import Control.Concurrent.Async 15 | import Network 16 | import System.Timeout 17 | 18 | import Test.Tasty 19 | import Test.Tasty.SmallCheck 20 | import Test.Tasty.HUnit 21 | import Test.SmallCheck.Series 22 | 23 | import Data.BERT 24 | import Network.BERT.Client 25 | import Network.BERT.Server 26 | 27 | -- NB A better Char instance would help here — something like 28 | -- 29 | -- generate $ \d -> take d $ map chr [0..255] 30 | 31 | instance (Serial m a, Ord a, Serial m b) => Serial m (Map a b) where 32 | series = liftM Map.fromList series 33 | 34 | type T a = a -> Either String String 35 | 36 | eqVerbose :: (Eq a, Show a) => a -> a -> Either String String 37 | eqVerbose x y = 38 | let sx = show x 39 | sy = show y 40 | in 41 | if x == y 42 | then Right $ printf "%s == %s" sx sy 43 | else Left $ printf "%s /= %s" sx sy 44 | 45 | -- value -> Term -> encoded -> Term -> value 46 | t :: (BERT a, Eq a, Show a) => T a 47 | t a = Right a `eqVerbose` (readBERT . decode . encode . showBERT) a 48 | 49 | -- value -> Term -> Packet -> encoded -> Packet -> Term -> value 50 | p :: (BERT a, Eq a, Show a) => T a 51 | p a = Right a `eqVerbose` (readBERT . fromPacket . decode . encode . Packet . showBERT) a 52 | 53 | main :: IO () 54 | main = defaultMain $ localOption (SmallCheckDepth 4) $ 55 | testGroup "Tests" 56 | [ testGroup "Serialization" [simpleTerms, simplePackets] 57 | , networkTests 58 | , testGroup "Specification compliance" specTests 59 | ] 60 | 61 | simpleTerms :: TestTree 62 | simpleTerms = testGroup "Simple terms" 63 | [ testProperty "Bool" (t :: T Bool) 64 | , testProperty "Integer" (t :: T Integer) 65 | , testProperty "String" (t :: T String) 66 | , testProperty "(String, String)" (t :: T (String, String)) 67 | , testProperty "(String, [String])" (t :: T (String, [String])) 68 | , testProperty "[String]" (t :: T [String]) 69 | , testProperty "(Map String String)" (t :: T (Map String String)) 70 | , testProperty "(String, Int, Int, Int)" (t :: T (String, Int, Int, Int)) 71 | , testProperty "(Int, Int, Int, Int)" (t :: T (Int, Int, Int, Int)) 72 | ] 73 | 74 | simplePackets :: TestTree 75 | simplePackets = testGroup "Simple packets" 76 | [ testProperty "Bool" (p :: T Bool) 77 | , testProperty "Integer" (p :: T Integer) 78 | , testProperty "String" (p :: T String) 79 | , testProperty "(String, String)" (p :: T (String, String)) 80 | , testProperty "(String, [String])" (p :: T (String, [String])) 81 | , testProperty "[String]" (p :: T [String]) 82 | , testProperty "(Map String String)" (p :: T (Map String String)) 83 | , testProperty "(String, Int, Int, Int)" (p :: T (String, Int, Int, Int)) 84 | ] 85 | 86 | networkTests :: TestTree 87 | networkTests = testGroup "Network" 88 | [ networkTest1 89 | , networkTest2 90 | , networkTest3 91 | , networkTest4 92 | ] 93 | 94 | port :: PortNumber 95 | port = 1911 96 | 97 | delay :: IO () 98 | delay = threadDelay (10^5) 99 | 100 | networkTest1 :: TestTree 101 | networkTest1 = testCase "Simple call" $ do 102 | t <- tcpServer port 103 | let server = serve t $ \ "mod" "f" [IntTerm a] -> return $ Success $ IntTerm (a+1) 104 | withAsync server $ \_ -> do 105 | delay 106 | c <- tcpClient "localhost" port 107 | result <- call c "mod" "f" [IntTerm 3] 108 | result @?= Right (IntTerm 4) 109 | 110 | networkTest2 :: TestTree 111 | networkTest2 = testCase "5 calls per connection" $ do 112 | t <- tcpServer port 113 | let server = serve t $ \ "mod" "f" [IntTerm a, IntTerm b] -> return $ Success $ IntTerm (a+b) 114 | withAsync server $ \_ -> do 115 | delay 116 | c <- tcpClient "localhost" port 117 | forM_ [1..5] $ \x -> do 118 | result <- call c "mod" "f" [IntTerm 3, IntTerm x] 119 | result @?= Right (IntTerm (3+x)) 120 | 121 | networkTest3 :: TestTree 122 | networkTest3 = testCase "5 sequential connections" $ do 123 | t <- tcpServer port 124 | let server = serve t $ \ "mod" "f" [IntTerm a, IntTerm b] -> return $ Success $ IntTerm (a+b) 125 | withAsync server $ \_ -> do 126 | delay 127 | forM_ [1..5] $ \x -> do 128 | c <- tcpClient "localhost" port 129 | result <- call c "mod" "f" [IntTerm 3, IntTerm x] 130 | result @?= Right (IntTerm (3+x)) 131 | 132 | networkTest4 :: TestTree 133 | networkTest4 = testCase "100 simultaneous connections" $ do 134 | t <- tcpServer port 135 | let server = serve t $ \ "mod" "f" [IntTerm a, IntTerm b] -> 136 | do 137 | threadDelay (5*10^5) -- 0.5s delay 138 | return $ Success $ IntTerm (a+b) 139 | r <- 140 | withAsync server $ \_ -> do 141 | delay 142 | timeout (10^6) $ do 143 | flip mapConcurrently [1..100] $ \x -> do 144 | c <- tcpClient "localhost" port 145 | result <- call c "mod" "f" [IntTerm 3, IntTerm x] 146 | result @?= Right (IntTerm (3+x)) 147 | maybe (assertFailure "Timed out!") (const $ return ()) r 148 | 149 | ord' :: Char -> Word8 150 | ord' = fromIntegral . ord 151 | 152 | -- Test internal representation according to specification 153 | -- http://erlang.org/doc/apps/erts/erl_ext_dist.html 154 | specTests :: [TestTree] 155 | specTests = 156 | [ thereAndBackAgainTest "SMAL_INTEGER_EXT" (IntTerm 5) [131, 97, 5] 157 | , thereAndBackAgainTest "INTEGER_EXT" (IntTerm 0x400) [131, 98, 0, 0, 4, 0] 158 | , thereAndBackAgainTest "ATOM_EXT" 159 | (AtomTerm "foobar") 160 | ([131, 100, 0, 6] ++ map ord' "foobar") 161 | , thereAndBackAgainTest "SMALL_TUPLE_EXT" 162 | (TupleTerm 163 | [ AtomTerm x 164 | | x <- ["a", "b", "c", "d"] 165 | ]) 166 | ([131, 104, 4] ++ 167 | concat [ [100, 0, genericLength x] ++ map ord' x 168 | | x <- ["a", "b", "c", "d"] 169 | ]) 170 | , thereAndBackAgainTest "LARGE_TUPLE_EXT" 171 | (TupleTerm 172 | [ AtomTerm [x] 173 | | x <- take 512 $ cycle ['a'..'z'] 174 | ]) 175 | ([131, 105, 0, 0, 2, 0] ++ 176 | concat [ [100, 0, 1, ord' x] 177 | | x <- take 512 $ cycle ['a'..'z'] 178 | ]) 179 | , thereAndBackAgainTest "NIL_EXT" 180 | (ListTerm []) 181 | [131, 106] 182 | , thereAndBackAgainTest "STRING_EXT" 183 | (BytelistTerm "abc\0") 184 | [131, 107, 0, 4, 97, 98, 99, 0] 185 | , thereAndBackAgainTest "LIST_EXT" 186 | (ListTerm [AtomTerm "abc", AtomTerm "xyz"]) 187 | ([131, 108, 0, 0, 0, 2] ++ 188 | [100, 0, 3, 97, 98, 99] ++ 189 | [100, 0, 3, 120, 121, 122] ++ 190 | [106]) 191 | , thereAndBackAgainTest "LIST_EXT - nested" 192 | (ListTerm [ListTerm [AtomTerm "abc"], ListTerm [AtomTerm "xyz"]]) 193 | ([131, 108, 0, 0, 0, 2] ++ 194 | ([108, 0, 0, 0, 1] ++ [100, 0, 3, 97, 98, 99] ++ [106]) ++ 195 | ([108, 0, 0, 0, 1] ++ [100, 0, 3, 120, 121, 122] ++ [106]) ++ 196 | [106]) 197 | , thereAndBackAgainTest "BINARY_EXT" 198 | (BinaryTerm "x\0y\1z") 199 | ([131, 109, 0, 0, 0, 5, 120, 0, 121, 1, 122]) 200 | , thereAndBackAgainTest " SMALL_BIG_EXT" 201 | (BigintTerm $ 4 + 3 * 256 + 2 * 256^2 + 1 * 256^3) 202 | ([131, 110, 4, 0, 4, 3, 2, 1]) 203 | ] 204 | 205 | thereAndBackAgainTest :: String -> Term -> [Word8] -> TestTree 206 | thereAndBackAgainTest name term binaryRepr = testGroup name 207 | [ testCase "Term -> binary" $ 208 | L.unpack (encode term) @?= binaryRepr 209 | , testCase "binary -> Term" $ 210 | decode (L.pack binaryRepr) @?= term 211 | ] 212 | 213 | --------------------------------------------------------------------------------