@@ -4,6 +4,7 @@ test client/server interaction
44import Test.HUnit
55import ProjectM36.Client
66import qualified ProjectM36.Client as C
7+import ProjectM36.Server.EntryPoints
78import ProjectM36.Server
89import ProjectM36.Server.Config
910import ProjectM36.Relation
@@ -13,42 +14,54 @@ import ProjectM36.Base
1314
1415import System.Exit
1516import Control.Concurrent
17+import Network.Transport (EndPointAddress)
18+import Network.Transport.TCP (encodeEndPointAddress, decodeEndPointAddress)
1619import Data.Either (isRight)
1720import Data.Maybe (isJust)
21+import Control.Exception
22+import Control.Monad.IO.Class
1823
1924testList :: SessionId -> Connection -> MVar () -> Test
20−testList sessionId conn notificationTestMVar = TestList $ map (\t -> t sessionId conn) [
21− testRelationalExpr,
22− testSchemaExpr,
23− testTypeForRelationalExpr,
24− testDatabaseContextExpr,
25− testGraphExpr,
26− testPlanForDatabaseContextExpr,
27− testTransactionGraphAsRelation,
28− testHeadTransactionId,
29− testHeadName,
30− testSession,
31− testRelationVariableSummary,
32− testNotification notificationTestMVar
33− ]
25+testList sessionId conn notificationTestMVar = TestList $ serverTests
26+ where
27+ sessionTests = map (\t -> t sessionId conn) [
28+ testRelationalExpr,
29+ testSchemaExpr,
30+ testTypeForRelationalExpr,
31+ testDatabaseContextExpr,
32+ testGraphExpr,
33+ testPlanForDatabaseContextExpr,
34+ testTransactionGraphAsRelation,
35+ testHeadTransactionId,
36+ testHeadName,
37+ testSession,
38+ testRelationVariableSummary,
39+ testNotification notificationTestMVar
40+ ]
41+ serverTests = [testRequestTimeout]
3442
3543main :: IO ()
3644main = do
37− port <- launchTestServer
45+ (serverAddress, _) <- launchTestServer 0
3846 notificationTestMVar <- newEmptyMVar
39− eTestConn <- testConnection port notificationTestMVar
47+ eTestConn <- testConnection serverAddress notificationTestMVar
4048 case eTestConn of
4149 Left err -> putStrLn (show err) >> exitFailure
4250 Right (session, testConn) -> do
4351 tcounts <- runTestTT (testList session testConn notificationTestMVar)
4452 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
4553
54+{-main = do
55+ tcounts <- runTestTT (TestList [testRequestTimeout])
56+ if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess-}
57+
4658testDatabaseName :: DatabaseName
4759testDatabaseName = "test"
4860
49−testConnection :: Port -> MVar () -> IO (Either ConnectionError (SessionId, Connection))
50−testConnection port mvar = do
51− let connInfo = RemoteProcessConnectionInfo testDatabaseName (createNodeId "127.0.0.1" port) (testNotificationCallback mvar)
61+testConnection :: EndPointAddress -> MVar () -> IO (Either ConnectionError (SessionId, Connection))
62+testConnection serverAddress mvar = do
63+ let connInfo = RemoteProcessConnectionInfo testDatabaseName (NodeId serverAddress) (testNotificationCallback mvar)
64+ putStrLn ("Connecting to " ++ show serverAddress)
5265 eConn <- connectProjectM36 connInfo
5366 case eConn of
5467 Left err -> pure $ Left err
@@ -59,12 +72,18 @@ testConnection port mvar = do
5972 Right sessionId -> pure $ Right (sessionId, conn)
6073
6174-- | A version of 'launchServer' which returns the port on which the server is listening on a secondary thread
62−launchTestServer :: IO (Port)
63−launchTestServer = do
64− let config = defaultServerConfig { databaseName = testDatabaseName }
65− portVar <- newEmptyMVar
66− _ <- forkIO $ launchServer config (Just portVar) >> pure ()
67− takeMVar portVar
75+launchTestServer :: Timeout -> IO (EndPointAddress, ThreadId)
76+launchTestServer ti = do
77+ let config = defaultServerConfig { databaseName = testDatabaseName,
78+ perRequestTimeout = ti,
79+ testMode = True,
80+ bindPort = 0
81+ }
82+ addressMVar <- newEmptyMVar
83+ tid <- forkIO $ launchServer config (Just addressMVar) >> pure ()
84+ endPointAddress <- takeMVar addressMVar
85+ liftIO $ putStrLn ("launched server on " ++ show endPointAddress)
86+ pure (endPointAddress, tid)
6887
6988testRelationalExpr :: SessionId -> Connection -> Test
7089testRelationalExpr sessionId conn = TestCase $ do
@@ -172,3 +191,18 @@ testNotification mvar sess conn = TestCase $ do
172191 check $ executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse))
173192 check $ commit sess conn
174193 takeMVar mvar
194+
195+testRequestTimeout :: Test
196+testRequestTimeout = TestCase $ do
197+ (serverAddress, serverTid) <- launchTestServer 1000
198+ unusedMVar <- newEmptyMVar
199+ let Just (host, service, _) = decodeEndPointAddress serverAddress
200+ serverAddress' = encodeEndPointAddress host service 1
201+ eTestConn <- testConnection serverAddress' unusedMVar
202+ --eTestConn <- testConnection (encodeEndPointAddress "127.0.0.1" "10000" 1) unusedMVar
203+ case eTestConn of
204+ Left err -> putStrLn ("failed to connect: " ++ show err) >> exitFailure
205+ Right (session, testConn) -> do
206+ res <- catchJust (\exc -> if exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))
207+ assertBool "exception was not thrown" (not res)
208+ killThread serverTid