{-# LANGUAGE DeriveDataTypeable        #-}
{-# OPTIONS_GHC -fno-warn-orphans      #-}
module Main where

import Control.Concurrent.MVar
  ( MVar
  , newEmptyMVar
  , putMVar
  , takeMVar
  )
import Control.Distributed.Process
import Control.Distributed.Process.Node
  ( forkProcess
  , newLocalNode
  , initRemoteTable
  , closeLocalNode
  , LocalNode)
import Data.Binary()
import Data.Typeable()
import Network.Transport.TCP
import Prelude hiding (catch, log)
import Test.Framework
  ( Test
  , defaultMain
  , testGroup
  )
import Test.HUnit (Assertion)
import Test.HUnit.Base (assertBool)
import Test.Framework.Providers.HUnit (testCase)

-- these utilities have been cribbed from distributed-process-platform
-- we should really find a way to share them...

-- | A mutable cell containing a test result.
type TestResult a = MVar a

delayedAssertion :: (Eq a) => String -> LocalNode -> a ->
                    (TestResult a -> Process ()) -> Assertion
delayedAssertion note localNode expected testProc = do
  result <- newEmptyMVar
  _ <- forkProcess localNode $ testProc result
  assertComplete note result expected

assertComplete :: (Eq a) => String -> MVar a -> a -> IO ()
assertComplete msg mv a = do
  b <- takeMVar mv
  assertBool msg (a == b)

stash :: TestResult a -> a -> Process ()
stash mvar x = liftIO $ putMVar mvar x

------

testLocalDeadProcessInfo :: TestResult (Maybe ProcessInfo) -> Process ()
testLocalDeadProcessInfo result = do
  pid <- spawnLocal $ do "finish" <- expect; return ()
  mref <- monitor pid
  send pid "finish"
  _ <- receiveWait [
      matchIf (\(ProcessMonitorNotification ref' pid' r) ->
                    ref' == mref && pid' == pid && r == DiedNormal)
              (\p -> return p)
    ]
  getProcessInfo pid >>= stash result

testLocalLiveProcessInfo :: TestResult Bool -> Process ()
testLocalLiveProcessInfo result = do
  self <- getSelfPid
  node <- getSelfNode
  register "foobar" self

  mon <- liftIO $ newEmptyMVar
  -- TODO: we can't get the mailbox's length
  -- mapM (send self) ["hello", "there", "mr", "process"]
  pid <- spawnLocal $ do
       link self
       mRef <- monitor self
       stash mon mRef
       "die" <- expect
       return ()

  monRef <- liftIO $ takeMVar mon

  mpInfo <- getProcessInfo self
  case mpInfo of
    Nothing -> stash result False
    Just p  -> verifyPInfo p pid monRef node
  where verifyPInfo :: ProcessInfo
                    -> ProcessId
                    -> MonitorRef
                    -> NodeId
                    -> Process ()
        verifyPInfo pInfo pid mref node =
          stash result $ infoNode pInfo     == node           &&
                         infoLinks pInfo    == [pid]          &&
                         infoMonitors pInfo == [(pid, mref)]  &&
--                         infoMessageQueueLength pInfo == Just 4 &&
                         infoRegisteredNames pInfo == ["foobar"]

testRemoteLiveProcessInfo :: LocalNode -> Assertion
testRemoteLiveProcessInfo node1 = do
  serverAddr <- liftIO $ newEmptyMVar :: IO (MVar ProcessId)
  liftIO $ launchRemote serverAddr
  serverPid <- liftIO $ takeMVar serverAddr
  withActiveRemote node1 $ \result -> do
    self <- getSelfPid
    link serverPid
    -- our send op shouldn't overtake link or monitor requests AFAICT
    -- so a little table tennis should get us synchronised properly
    send serverPid (self, "ping")
    "pong" <- expect
    pInfo <- getProcessInfo serverPid
    stash result $ pInfo /= Nothing
  where 
    launchRemote :: MVar ProcessId -> IO ()
    launchRemote locMV = do
        node2 <- liftIO $ mkNode "8082"
        _ <- liftIO $ forkProcess node2 $ do
            self <- getSelfPid
            liftIO $ putMVar locMV self
            _ <- receiveWait [
                  match (\(pid, "ping") -> send pid "pong") 
                ]
            "stop" <- expect
            return ()
        return ()

    withActiveRemote :: LocalNode
                     -> ((TestResult Bool -> Process ()) -> Assertion)
    withActiveRemote n = do
      a <- delayedAssertion "getProcessInfo remotePid failed" n True
      return a

tests :: LocalNode -> IO [Test]
tests node1 = do
  return [
    testGroup "Process Info" [
        testCase "testLocalDeadProcessInfo"
            (delayedAssertion
             "expected dead process-info to be ProcessInfoNone"
             node1 (Nothing) testLocalDeadProcessInfo)
      , testCase "testLocalLiveProcessInfo"
            (delayedAssertion
             "expected process-info to be correctly populated"
             node1 True testLocalLiveProcessInfo)
      , testCase "testRemoveLiveProcessInfo"
                 (testRemoteLiveProcessInfo node1)
    ] ]

mkNode :: String -> IO LocalNode
mkNode port = do
  Right (transport1, _) <- createTransportExposeInternals
                                    "127.0.0.1" port defaultTCPParameters
  newLocalNode transport1 initRemoteTable

main :: IO ()
main = do
  node1 <- mkNode "8081"
  testData <- tests node1
  defaultMain testData
  closeLocalNode node1
  return ()