git.iko.soy/project-m36
on d64cdeb help sign in
project-m36/test/Server/Main.hs
231 lines 9.9 kB history raw
1{-# LANGUAGE CPP #-}
2{-
3test client/server interaction
4-}
5import Test.HUnit
6import ProjectM36.Client
7import qualified ProjectM36.Client as C
8import ProjectM36.Server.EntryPoints
9import ProjectM36.Server
10import ProjectM36.Server.Config
11import ProjectM36.Relation
12import ProjectM36.TupleSet
13import ProjectM36.IsomorphicSchema
14import ProjectM36.Base
16import System.Exit
18import Control.Concurrent
19import Network.Transport (EndPointAddress)
20import Network.Transport.TCP (encodeEndPointAddress, decodeEndPointAddress)
21import Data.Either (isRight)
22import Control.Exception
23--import Control.Monad.IO.Class
24#if defined(linux_HOST_OS)
25import System.Directory
26#endif
28testList :: SessionId -> Connection -> MVar () -> Test
29testList sessionId conn notificationTestMVar = TestList $ serverTests ++ sessionTests
30 where
31 sessionTests = map (\t -> t sessionId conn) [
32 testRelationalExpr,
33 testSchemaExpr,
34 testTypeForRelationalExpr,
35 testDatabaseContextExpr,
36 testGraphExpr,
37 testPlanForDatabaseContextExpr,
38 testTransactionGraphAsRelation,
39 testHeadTransactionId,
40 testHeadName,
41 testSession,
42 testRelationVariableSummary,
43 testNotification notificationTestMVar
44 ]
45 serverTests = [testRequestTimeout, testFileDescriptorCount]
47main :: IO ()
48main = do
49 (serverAddress, _) <- launchTestServer 0
50 notificationTestMVar <- newEmptyMVar
51 eTestConn <- testConnection serverAddress notificationTestMVar
52 case eTestConn of
53 Left err -> print err >> exitFailure
54 Right (session, testConn) -> do
55 tcounts <- runTestTT (testList session testConn notificationTestMVar)
56 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess
58{-main = do
59 tcounts <- runTestTT (TestList [testRequestTimeout])
60 if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess-}
62testDatabaseName :: DatabaseName
63testDatabaseName = "test"
65testConnection :: EndPointAddress -> MVar () -> IO (Either ConnectionError (SessionId, Connection))
66testConnection serverAddress mvar = do
67 let Just (host, service, _) = decodeEndPointAddress serverAddress
68 serverAddress' = encodeEndPointAddress host service 1
69 let connInfo = RemoteProcessConnectionInfo testDatabaseName (NodeId serverAddress') (testNotificationCallback mvar)
70 --putStrLn ("testConnection: " ++ show serverAddress)
71 eConn <- connectProjectM36 connInfo
72 case eConn of
73 Left err -> pure $ Left err
74 Right conn -> do
75 eSessionId <- createSessionAtHead conn defaultHeadName
76 case eSessionId of
77 Left _ -> error "failed to create session"
78 Right sessionId -> pure $ Right (sessionId, conn)
80-- | A version of 'launchServer' which returns the port on which the server is listening on a secondary thread
81launchTestServer :: Timeout -> IO (EndPointAddress, ThreadId)
82launchTestServer ti = do
83 let config = defaultServerConfig { databaseName = testDatabaseName,
84 perRequestTimeout = ti,
85 testMode = True,
86 bindPort = 0
87 }
88 addressMVar <- newEmptyMVar
89 tid <- forkIO $ launchServer config (Just addressMVar) >> pure ()
90 endPointAddress <- takeMVar addressMVar
91 --liftIO $ putStrLn ("launched server on " ++ show endPointAddress)
92 pure (endPointAddress, tid)
94testRelationalExpr :: SessionId -> Connection -> Test
95testRelationalExpr sessionId conn = TestCase $ do
96 relResult <- executeRelationalExpr sessionId conn (RelationVariable "true" ())
97 assertEqual "invalid relation result" (Right relationTrue) relResult
99eitherFail :: (Show e) => Either e a -> IO ()
100eitherFail (Left err) = assertFailure (show err)
101eitherFail (Right _) = pure ()
103-- test adding an removing a schema against true/false relations
104testSchemaExpr :: SessionId -> Connection -> Test
105testSchemaExpr sessionId conn = TestCase $ do
106 result <- executeSchemaExpr sessionId conn (AddSubschema "test-schema" [IsoRename "table_dee" "true", IsoRename "table_dum" "false"])
107 assertEqual "executeSchemaExpr" (Right ()) result
108 result' <- executeSchemaExpr sessionId conn (RemoveSubschema "test-schema")
109 assertEqual "executeSchemaExpr2" (Right ()) result'
111testDatabaseContextExpr :: SessionId -> Connection -> Test
112testDatabaseContextExpr sessionId conn = TestCase $ do
113 let attrExprs = [AttributeAndTypeNameExpr "x" (PrimitiveTypeConstructor "Text" TextAtomType) ()]
114 attrs = attributesFromList [Attribute "x" TextAtomType]
115 testrv = "testrv"
116 executeDatabaseContextExpr sessionId conn (Define testrv attrExprs) >>= eitherFail
117 eRel <- executeRelationalExpr sessionId conn (RelationVariable testrv ())
118 let expected = mkRelation attrs emptyTupleSet
119 case eRel of
120 Left err -> assertFailure (show err)
121 Right rel -> assertEqual "dbcontext definition failed" expected (Right rel)
123testGraphExpr :: SessionId -> Connection -> Test
124testGraphExpr sessionId conn = TestCase (executeGraphExpr sessionId conn (JumpToHead "master") >>= eitherFail)
126testTypeForRelationalExpr :: SessionId -> Connection -> Test
127testTypeForRelationalExpr sessionId conn = TestCase $ do
128 relResult <- typeForRelationalExpr sessionId conn (RelationVariable "true" ())
129 case relResult of
130 Left err -> assertFailure (show err)
131 Right rel -> assertEqual "typeForRelationalExpr failure" relationFalse rel
133testPlanForDatabaseContextExpr :: SessionId -> Connection -> Test
134testPlanForDatabaseContextExpr sessionId conn = TestCase $ do
135 let attrExprs = [AttributeAndTypeNameExpr "x" (PrimitiveTypeConstructor "Int" IntAtomType) ()]
136 testrv = "testrv"
137 dbExpr = Define testrv attrExprs
138 planResult <- planForDatabaseContextExpr sessionId conn dbExpr
139 case planResult of
140 Left err -> assertFailure (show err)
141 Right plan -> assertEqual "planForDatabaseContextExpr failure" dbExpr plan
143testTransactionGraphAsRelation :: SessionId -> Connection -> Test
144testTransactionGraphAsRelation sessionId conn = TestCase $ do
145 eGraph <- transactionGraphAsRelation sessionId conn
146 case eGraph of
147 Left err -> assertFailure (show err)
148 Right _ -> pure ()
150testHeadTransactionId :: SessionId -> Connection -> Test
151testHeadTransactionId sessionId conn = TestCase $ do
152 uuid <- headTransactionId sessionId conn
153 assertBool "invalid head transaction uuid" (isRight uuid)
154 pure ()
156testHeadName :: SessionId -> Connection -> Test
157testHeadName sessionId conn = TestCase $ do
158 eHeadName <- headName sessionId conn
159 assertEqual "headName failure" (Right "master") eHeadName
161testRelationVariableSummary :: SessionId -> Connection -> Test
162testRelationVariableSummary sessionId conn = TestCase $ do
163 eRel <- C.relationVariablesAsRelation sessionId conn
164 case eRel of
165 Left err -> assertFailure ("relvar summary failed " ++ show err)
166 Right rel -> assertBool "invalid tuple count in relvar summary" (cardinality rel == Finite 2)
168testSession :: SessionId -> Connection -> Test
169testSession _ conn = TestCase $ do
170 -- create and close a new session using AtHead and AtCommit
171 eSessionId1 <- createSessionAtHead conn defaultHeadName
172 case eSessionId1 of
173 Left _ -> assertFailure "invalid session"
174 Right sessionId1 -> do
175 eHeadId <- headTransactionId sessionId1 conn
176 case eHeadId of
177 Left err -> assertFailure ("invalid head id: " ++ show err)
178 Right headId -> do
179 eSessionId2 <- createSessionAtCommit conn headId
180 assertBool ("invalid session: " ++ show eSessionId2) (isRight eSessionId2)
181 closeSession sessionId1 conn
183testNotificationCallback :: MVar () -> NotificationCallback
184testNotificationCallback mvar _ _ = putMVar mvar ()
186-- create a relvar x, add a notification on x, update x and wait for the notification
187testNotification :: MVar () -> SessionId -> Connection -> Test
188testNotification mvar sess conn = TestCase $ do
189 let relvarx = RelationVariable "x" ()
190 executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) >>= eitherFail
191 executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx relvarx) >>= eitherFail
192 commit sess conn >>= eitherFail
193 executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail
194 commit sess conn >>= eitherFail
195 takeMVar mvar
197testRequestTimeout :: Test
198testRequestTimeout = TestCase $ do
199 (serverAddress, serverTid) <- launchTestServer 1000
200 unusedMVar <- newEmptyMVar
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
210testFileDescriptorCount :: Test
211#if defined(linux_HOST_OS)
212--validate that creating a server, connecting a client, and then disconnecting doesn't leak file descriptors
213testFileDescriptorCount = TestCase $ do
214 (serverAddress, serverTid) <- launchTestServer 1000
215 startCount <- fdCount
216 unusedMVar <- newEmptyMVar
217 Right (_, testConn) <- testConnection serverAddress unusedMVar
218 close testConn
219 endCount <- fdCount
220 assertBool "fd leak" (endCount - startCount <= 1)
221 killThread serverTid
223-- returns the number of open file descriptors -- linux only /proc usage
224fdCount :: IO Int
225fdCount = do
226 fds <- getDirectoryContents "/proc/self/fd"
227 pure ((length fds) - 2)
228#else
229--pass on non-linux platforms
230testFileDescriptorCount = TestCase (pure ())
231#endif