bert-1.2.2.5: tests/test.hs
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, OverloadedStrings #-}
import Control.Monad
import Data.Binary
import Data.Char (chr, ord)
import Data.List (genericLength)
import Data.Map (Map)
import qualified Data.ByteString.Lazy as L
import qualified Data.Map as Map
import Text.Printf
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 -> Either String String
eqVerbose :: (Eq a, Show a) => a -> a -> Either String String
eqVerbose x y =
let sx = show x
sy = show y
in
if x == y
then Right $ printf "%s == %s" sx sy
else Left $ printf "%s /= %s" sx sy
-- value -> Term -> encoded -> Term -> value
t :: (BERT a, Eq a, Show a) => T a
t a = Right a `eqVerbose` (readBERT . decode . encode . showBERT) a
-- value -> Term -> Packet -> encoded -> Packet -> Term -> value
p :: (BERT a, Eq a, Show a) => T a
p a = Right a `eqVerbose` (readBERT . fromPacket . decode . encode . Packet . showBERT) a
main :: IO ()
main = defaultMain $ localOption (SmallCheckDepth 4) $
testGroup "Tests"
[ testGroup "Serialization" [simpleTerms, simplePackets]
, networkTests
, testGroup "Specification compliance" specTests
]
simpleTerms :: TestTree
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 :: TestTree
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 :: TestTree
networkTests = testGroup "Network"
[ networkTest1
, networkTest2
, networkTest3
, networkTest4
]
port :: PortNumber
port = 1911
delay :: IO ()
delay = threadDelay (10^5)
networkTest1 :: TestTree
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 :: TestTree
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 :: TestTree
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 :: TestTree
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
ord' :: Char -> Word8
ord' = fromIntegral . ord
-- Test internal representation according to specification
-- http://erlang.org/doc/apps/erts/erl_ext_dist.html
specTests :: [TestTree]
specTests =
[ thereAndBackAgainTest "SMAL_INTEGER_EXT" (IntTerm 5) [131, 97, 5]
, thereAndBackAgainTest "INTEGER_EXT" (IntTerm 0x400) [131, 98, 0, 0, 4, 0]
, thereAndBackAgainTest "ATOM_EXT"
(AtomTerm "foobar")
([131, 100, 0, 6] ++ map ord' "foobar")
, thereAndBackAgainTest "SMALL_TUPLE_EXT"
(TupleTerm
[ AtomTerm x
| x <- ["a", "b", "c", "d"]
])
([131, 104, 4] ++
concat [ [100, 0, genericLength x] ++ map ord' x
| x <- ["a", "b", "c", "d"]
])
, thereAndBackAgainTest "LARGE_TUPLE_EXT"
(TupleTerm
[ AtomTerm [x]
| x <- take 512 $ cycle ['a'..'z']
])
([131, 105, 0, 0, 2, 0] ++
concat [ [100, 0, 1, ord' x]
| x <- take 512 $ cycle ['a'..'z']
])
, thereAndBackAgainTest "NIL_EXT"
(ListTerm [])
[131, 106]
, thereAndBackAgainTest "STRING_EXT"
(BytelistTerm "abc\0")
[131, 107, 0, 4, 97, 98, 99, 0]
, thereAndBackAgainTest "LIST_EXT"
(ListTerm [AtomTerm "abc", AtomTerm "xyz"])
([131, 108, 0, 0, 0, 2] ++
[100, 0, 3, 97, 98, 99] ++
[100, 0, 3, 120, 121, 122] ++
[106])
, thereAndBackAgainTest "LIST_EXT - nested"
(ListTerm [ListTerm [AtomTerm "abc"], ListTerm [AtomTerm "xyz"]])
([131, 108, 0, 0, 0, 2] ++
([108, 0, 0, 0, 1] ++ [100, 0, 3, 97, 98, 99] ++ [106]) ++
([108, 0, 0, 0, 1] ++ [100, 0, 3, 120, 121, 122] ++ [106]) ++
[106])
, thereAndBackAgainTest "BINARY_EXT"
(BinaryTerm "x\0y\1z")
([131, 109, 0, 0, 0, 5, 120, 0, 121, 1, 122])
, thereAndBackAgainTest " SMALL_BIG_EXT"
(BigintTerm $ 4 + 3 * 256 + 2 * 256^2 + 1 * 256^3)
([131, 110, 4, 0, 4, 3, 2, 1])
]
thereAndBackAgainTest :: String -> Term -> [Word8] -> TestTree
thereAndBackAgainTest name term binaryRepr = testGroup name
[ testCase "Term -> binary" $
L.unpack (encode term) @?= binaryRepr
, testCase "binary -> Term" $
decode (L.pack binaryRepr) @?= term
]