Main.hs

{-# LANGUAGE CPP #-}
{-
test client/server interaction
-}
import Test.HUnit
import ProjectM36.Client
import qualified ProjectM36.Client as C
import ProjectM36.Server.EntryPoints
import ProjectM36.Server
import ProjectM36.Server.Config
import ProjectM36.Relation
import ProjectM36.TupleSet
import ProjectM36.IsomorphicSchema
import ProjectM36.Base

import System.Exit

import Control.Concurrent
import Network.Transport (EndPointAddress)

#if MIN_VERSION_network_transport_tcp(0,6,0)                
import Network.Transport.TCP.Internal (encodeEndPointAddress, decodeEndPointAddress)
#else
import Network.Transport.TCP (encodeEndPointAddress, decodeEndPointAddress)
#endif

import Data.Either (isRight)
import Control.Exception
import System.IO.Temp
import System.FilePath
#if defined(linux_HOST_OS)
import System.Directory
#endif

testList :: SessionId -> Connection -> MVar () -> Test
testList sessionId conn notificationTestMVar = TestList $ serverTests ++ sessionTests
  where
    sessionTests = map (\t -> t sessionId conn) [
      testRelationalExpr,
      testSchemaExpr,
      testTypeForRelationalExpr,  
      testDatabaseContextExpr,
      testGraphExpr,
      testPlanForDatabaseContextExpr,
      testTransactionGraphAsRelation,
      testHeadTransactionId,
      testHeadName,
      testSession,
      testRelationVariableSummary,
      testNotification notificationTestMVar
      ] 
    serverTests = [testRequestTimeout, testFileDescriptorCount]

main :: IO ()
main = do
  (serverAddress, _) <- launchTestServer 0
  notificationTestMVar <- newEmptyMVar 
  eTestConn <- testConnection serverAddress notificationTestMVar
  case eTestConn of
    Left err -> print err >> exitFailure
    Right (session, testConn) -> do
      tcounts <- runTestTT (testList session testConn notificationTestMVar)
      if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess

{-main = do
    tcounts <- runTestTT (TestList [testRequestTimeout])
    if errors tcounts + failures tcounts > 0 then exitFailure else exitSuccess-}
                                                                     
testDatabaseName :: DatabaseName
testDatabaseName = "test"

testConnection :: EndPointAddress -> MVar () -> IO (Either ConnectionError (SessionId, Connection))
testConnection serverAddress mvar = do
  let Just (host, service, _) = decodeEndPointAddress serverAddress
      serverAddress' = encodeEndPointAddress host service 1  
  let connInfo = RemoteProcessConnectionInfo testDatabaseName (NodeId serverAddress') (testNotificationCallback mvar)
  --putStrLn ("testConnection: " ++ show serverAddress)
  eConn <- connectProjectM36 connInfo
  case eConn of 
    Left err -> pure $ Left err
    Right conn -> do
      eSessionId <- createSessionAtHead conn defaultHeadName
      case eSessionId of
        Left _ -> error "failed to create session"
        Right sessionId -> pure $ Right (sessionId, conn)

-- | A version of 'launchServer' which returns the port on which the server is listening on a secondary thread
launchTestServer :: Timeout -> IO (EndPointAddress, ThreadId)
launchTestServer ti = do
  addressMVar <- newEmptyMVar
  tid <- forkIO $ 
    withSystemTempDirectory "projectm36test" $ \tempdir -> do
      let config = defaultServerConfig { databaseName = testDatabaseName, 
                                         persistenceStrategy = CrashSafePersistence (tempdir </> "db"),
                                         perRequestTimeout = ti,
                                         testMode = True,
                                         bindPort = 0
                                       }
    
      launchServer config (Just addressMVar) >> pure ()
  endPointAddress <- takeMVar addressMVar
  --liftIO $ putStrLn ("launched server on " ++ show endPointAddress)
  pure (endPointAddress, tid)
  
testRelationalExpr :: SessionId -> Connection -> Test  
testRelationalExpr sessionId conn = TestCase $ do
  relResult <- executeRelationalExpr sessionId conn (RelationVariable "true" ())
  assertEqual "invalid relation result" (Right relationTrue) relResult
  
eitherFail :: (Show e) => Either e a -> IO ()
eitherFail (Left err) = assertFailure (show err)
eitherFail (Right _) = pure ()
  
-- test adding an removing a schema against true/false relations  
testSchemaExpr :: SessionId -> Connection -> Test
testSchemaExpr sessionId conn = TestCase $ do
  result <- executeSchemaExpr sessionId conn (AddSubschema "test-schema" [IsoRename "table_dee" "true", IsoRename "table_dum" "false"])
  assertEqual "executeSchemaExpr" (Right ()) result
  result' <- executeSchemaExpr sessionId conn (RemoveSubschema "test-schema")
  assertEqual "executeSchemaExpr2" (Right ()) result'  
  
testDatabaseContextExpr :: SessionId -> Connection -> Test
testDatabaseContextExpr sessionId conn = TestCase $ do 
  let attrExprs = [AttributeAndTypeNameExpr "x" (PrimitiveTypeConstructor "Text" TextAtomType) ()]
      attrs = attributesFromList [Attribute "x" TextAtomType]
      testrv = "testrv"
  executeDatabaseContextExpr sessionId conn (Define testrv attrExprs) >>= eitherFail
  eRel <- executeRelationalExpr sessionId conn (RelationVariable testrv ())
  let expected = mkRelation attrs emptyTupleSet
  case eRel of
    Left err -> assertFailure (show err)
    Right rel -> assertEqual "dbcontext definition failed" expected (Right rel)
        
testGraphExpr :: SessionId -> Connection -> Test        
testGraphExpr sessionId conn = TestCase (executeGraphExpr sessionId conn (JumpToHead "master") >>= eitherFail)
    
testTypeForRelationalExpr :: SessionId -> Connection -> Test
testTypeForRelationalExpr sessionId conn = TestCase $ do
  relResult <- typeForRelationalExpr sessionId conn (RelationVariable "true" ())
  case relResult of
    Left err -> assertFailure (show err)
    Right rel -> assertEqual "typeForRelationalExpr failure" relationFalse rel
    
testPlanForDatabaseContextExpr :: SessionId -> Connection -> Test    
testPlanForDatabaseContextExpr sessionId conn = TestCase $ do
  let attrExprs = [AttributeAndTypeNameExpr "x" (PrimitiveTypeConstructor "Int" IntAtomType) ()]
      testrv = "testrv"
      dbExpr = Define testrv attrExprs
  planResult <- planForDatabaseContextExpr sessionId conn dbExpr
  case planResult of
    Left err -> assertFailure (show err)
    Right plan -> assertEqual "planForDatabaseContextExpr failure" dbExpr plan
        
testTransactionGraphAsRelation :: SessionId -> Connection -> Test    
testTransactionGraphAsRelation sessionId conn = TestCase $ do
  eGraph <- transactionGraphAsRelation sessionId conn
  case eGraph of
    Left err -> assertFailure (show err)
    Right _ -> pure ()
    
testHeadTransactionId :: SessionId -> Connection -> Test    
testHeadTransactionId sessionId conn = TestCase $ do
  uuid <- headTransactionId sessionId conn
  assertBool "invalid head transaction uuid" (isRight uuid)
  pure ()
  
testHeadName :: SessionId -> Connection -> Test
testHeadName sessionId conn = TestCase $ do
  eHeadName <- headName sessionId conn
  assertEqual "headName failure" (Right "master") eHeadName
  
testRelationVariableSummary :: SessionId -> Connection -> Test  
testRelationVariableSummary sessionId conn = TestCase $ do
  eRel <- C.relationVariablesAsRelation sessionId conn
  case eRel of 
    Left err -> assertFailure ("relvar summary failed " ++ show err)
    Right rel -> assertBool "invalid tuple count in relvar summary" (cardinality rel == Finite 2)
  
testSession :: SessionId -> Connection -> Test
testSession _ conn = TestCase $ do
  -- create and close a new session using AtHead and AtCommit
  eSessionId1 <- createSessionAtHead conn defaultHeadName
  case eSessionId1 of
    Left _ -> assertFailure "invalid session" 
    Right sessionId1 -> do
      eHeadId <- headTransactionId sessionId1 conn
      case eHeadId of
        Left err -> assertFailure ("invalid head id: " ++ show err)
        Right headId -> do
          eSessionId2 <- createSessionAtCommit conn headId
          assertBool ("invalid session: " ++ show eSessionId2) (isRight eSessionId2)
          closeSession sessionId1 conn

testNotificationCallback :: MVar () -> NotificationCallback
testNotificationCallback mvar _ _ = putMVar mvar ()

-- create a relvar x, add a notification on x, update x and wait for the notification
testNotification :: MVar () -> SessionId -> Connection -> Test
testNotification mvar sess conn = TestCase $ do
  let relvarx = RelationVariable "x" ()
  executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationTrue)) >>= eitherFail
  executeDatabaseContextExpr sess conn (AddNotification "test notification" relvarx relvarx relvarx) >>= eitherFail
  commit sess conn >>= eitherFail
  executeDatabaseContextExpr sess conn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail
  commit sess conn >>= eitherFail
  takeMVar mvar

testRequestTimeout :: Test
testRequestTimeout = TestCase $ do
  (serverAddress, serverTid) <- launchTestServer 1000
  unusedMVar <- newEmptyMVar       
  eTestConn <- testConnection serverAddress unusedMVar  
  --eTestConn <- testConnection (encodeEndPointAddress "127.0.0.1" "10000" 1) unusedMVar
  case eTestConn of
    Left err -> putStrLn ("failed to connect: " ++ show err) >> exitFailure
    Right (session, testConn) -> do
      res <- catchJust (\exc -> if exc == RequestTimeoutException then Just exc else Nothing) (callTestTimeout_ session testConn) (const (pure False))
      assertBool "exception was not thrown" (not res)
      killThread serverTid
      
testFileDescriptorCount :: Test
#if defined(linux_HOST_OS)
--validate that creating a server, connecting a client, and then disconnecting doesn't leak file descriptors
testFileDescriptorCount = TestCase $ do
  (serverAddress, serverTid) <- launchTestServer 0
  unusedMVar <- newEmptyMVar
  startCount <- fdCount  
  Right (sess, testConn) <- testConnection serverAddress unusedMVar
  --add a test commit to trigger the fsync machinery
  executeDatabaseContextExpr sess testConn (Assign "x" (ExistingRelation relationFalse)) >>= eitherFail
  commit sess testConn >>= eitherFail
  close testConn
  endCount <- fdCount
  let fd_diff = endCount - startCount
  assertBool ("fd leak: " ++ show fd_diff) (fd_diff <= 0)
  killThread serverTid

  
-- returns the number of open file descriptors -- linux only /proc usage
fdCount :: IO Int
fdCount = do
  fds <- getDirectoryContents "/proc/self/fd"
  pure (length fds)
#else 
--pass on non-linux platforms
testFileDescriptorCount = TestCase (pure ())
#endif