Main.hs

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

import System.Exit
import Network.Socket (SockAddr(..))
import Control.Concurrent
import Data.Either (isRight)
import Control.Exception
import System.IO.Temp
import System.FilePath
import Control.Monad (void)
import Network.RPC.Curryer.Client (ClientConnectionConfig(..))
import qualified Network.RPC.Curryer.Server as S
#if defined(linux_HOST_OS)
import System.Directory
#endif

type Timeout = Int

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,
      testCurrentHead,
      testSession,
      testRelationVariableSummary,
      testNotification notificationTestMVar
      ] 
    serverTests = [testRequestTimeout, testFileDescriptorCount, testClientConnectFail]

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

testDatabaseName :: DatabaseName
testDatabaseName = "test"

testConnection :: Port -> MVar () -> IO (Either ConnectionError (SessionId, Connection))
testConnection serverPort mvar = do
  let connInfo = RemoteConnectionInfo testDatabaseName (RemoteServerHostAddress "127.0.0.1" serverPort) UnencryptedConnectionConfig (testNotificationCallback mvar) "admin"
  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 (Port, 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,
                                         bindAddress = RemoteServerHostAddress "127.0.0.1" 0,
                                         checkFS = False, --not strictly needed for these tests
                                         connConfig = S.UnencryptedConnectionConfig
                                       }
    
      void $ launchServer config (Just addressMVar)
  (SockAddrInet port _) <- takeMVar addressMVar
  pure (fromIntegral port, tid)
  
testRelationalExpr :: SessionId -> Connection -> Test  
testRelationalExpr sessionId conn = TestCase $ do
  relResult <- executeRelationalExpr sessionId conn (RelationVariable "true" ())
  assertEqual "invalid relation result" (Right relationTrue) relResult

#define eitherFail (\case { Left err -> assertFailure (show err); Right _ -> pure () })
{-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 TS.empty
  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 (executeTransactionGraphExpr 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
      expected = Define testrv [AttributeAndTypeNameExpr "x" (PrimitiveTypeConstructor "Int" IntAtomType) UncommittedContextMarker]
  planResult <- planForDatabaseContextExpr sessionId conn dbExpr
  case planResult of
    Left err -> assertFailure (show err)
    Right plan -> assertEqual "planForDatabaseContextExpr failure" expected 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 ()
  
testCurrentHead :: SessionId -> Connection -> Test
testCurrentHead sessionId conn = TestCase $ do
  eCurrentHead <- currentHead sessionId conn
  assertEqual "headName failure" (Right (CurrentHeadBranch "master")) eCurrentHead
  
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 <- createSessionAtTransactionId 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 "timeout 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

testClientConnectFail :: Test
testClientConnectFail = TestCase $ do
  let connInfo = RemoteConnectionInfo "nonexistentdb" (RemoteServerHostAddress "127.0.0.1" 7777) UnencryptedConnectionConfig emptyNotificationCallback "admin"
  eConn <- connectProjectM36 connInfo
  case eConn of
    Left (IOExceptionError _) -> pure ()
    _ -> assertFailure "connection failure failed"