Question

问题

您好！我在Cloud Haskell中编写了一个简单的Server-Worker程序。问题是，当我尝试创建ManagedProcess时，在服务器发送步骤之后，即使使用callTimeout（我应该在100毫秒后中断），我的示例也会永远挂起。代码很简单，但我发现它没有任何问题。

我也在邮件列表上发布了这个问题，但就我所知的SO社区而言，我在这里的答案要快得多。如果我从邮件列表中得到答案，我也会在这里发帖。

源代码

Worker.hs：

{-# LANGUAGE DeriveDataTypeable        #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE TemplateHaskell           #-}

module Main where

import Network.Transport     (EndPointAddress(EndPointAddress))
import Control.Distributed.Process hiding (call)
import Control.Distributed.Process.Platform hiding (__remoteTable)
import Control.Distributed.Process.Platform.Async
import Control.Distributed.Process.Platform.ManagedProcess
import Control.Distributed.Process.Platform.Time
import Control.Distributed.Process.Platform.Timer (sleep)
import Control.Distributed.Process.Closure (mkClosure, remotable)
import Network.Transport.TCP (createTransport, defaultTCPParameters)
import Control.Distributed.Process.Node hiding (call)
import Control.Concurrent (threadDelay)
import GHC.Generics (Generic)
import Data.Binary (Binary) 
import Data.Typeable (Typeable)
import Data.ByteString.Char8 (pack)
import System.Environment    (getArgs)

import qualified Server as Server

main = do
  [host, port, serverAddr] <- getArgs

  Right transport <- createTransport host port defaultTCPParameters
  node <- newLocalNode transport initRemoteTable

  let addr = EndPointAddress (pack serverAddr)
      srvID = NodeId addr

  _ <- forkProcess node $ do
    sid <- discoverServer srvID
    liftIO $ putStrLn "x"
    liftIO $ print sid
    r <- callTimeout sid (Server.Add 5 6) 100 :: Process (Maybe Double)
    liftIO $ putStrLn "x"
    liftIO $ threadDelay (10 * 1000 * 1000)


  threadDelay (10 * 1000 * 1000)
  return ()


discoverServer srvID = do
  whereisRemoteAsync srvID "serverPID"
  reply <- expectTimeout 100 :: Process (Maybe WhereIsReply)
  case reply of
    Just (WhereIsReply _ msid) -> case msid of
      Just sid -> return sid
      Nothing  -> discoverServer srvID
    Nothing                    -> discoverServer srvID

Server.hs：

{-# LANGUAGE DeriveDataTypeable        #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE DeriveGeneric             #-}
{-# LANGUAGE TemplateHaskell           #-}

module Server where

import Control.Distributed.Process hiding (call)
import Control.Distributed.Process.Platform hiding (__remoteTable)
import Control.Distributed.Process.Platform.Async
import Control.Distributed.Process.Platform.ManagedProcess
import Control.Distributed.Process.Platform.Time
import Control.Distributed.Process.Platform.Timer (sleep)
import Control.Distributed.Process.Closure (mkClosure, remotable)
import Network.Transport.TCP (createTransport, defaultTCPParameters)
import Control.Distributed.Process.Node hiding (call)
import Control.Concurrent (threadDelay)
import GHC.Generics (Generic)
import Data.Binary (Binary) 
import Data.Typeable (Typeable)


data Add = Add Double Double
  deriving (Typeable, Generic)
instance Binary Add

launchServer :: Process ProcessId
launchServer = spawnLocal $ serve () (statelessInit Infinity) server >> return () where
  server = statelessProcess { apiHandlers            = [ handleCall_ (\(Add x y) -> liftIO (putStrLn "!") >> return (x + y)) ]
                            , unhandledMessagePolicy = Drop
                            }


main = do
  Right transport <- createTransport "127.0.0.1" "8080" defaultTCPParameters
  node <- newLocalNode transport initRemoteTable
  _ <- forkProcess node $ do
    self <- getSelfPid
    register "serverPID" self

    liftIO $ putStrLn "x"
    mid <- launchServer
    liftIO $ putStrLn "y"
    r <- call mid (Add 5 6) :: Process Double
    liftIO $ print r
    liftIO $ putStrLn "z"
    liftIO $ threadDelay (10 * 1000 * 1000)
    liftIO $ putStrLn "z2"

  threadDelay (10 * 1000 * 1000)
  return ()

我们可以按照以下方式运行它们：

runhaskell Server.hs
runhaskell Worker.hs 127.0.0.2 8080 127.0.0.1:8080:0

结果

当我们运行程序时，我们得到了以下结果：

来自服务器：

x
y
!
11.0 -- this one shows that inside the same process we were able to use the "call" function
z
-- waiting - all the output above were tests from inside the server now it waits for external messages

来自工人：

x
pid://127.0.0.1:8080:0:10 -- this is the process id of the server optained with whereisRemoteAsync 
-- waiting forever on the "callTimeout sid (Server.Add 5 6) 100" code!

作为旁注 - 我发现，在使用send（来自Control.Distributed.Process）发送邮件并使用expect收到邮件时，我们发现了这些邮件。但是发送call（来自Control.Distributed.Process.Platform）并尝试使用ManagedProcess api处理程序重新发送它们 - 会永久挂起call（即使使用callTimeout！）< / p>

Answer 1

您的客户端正在获取异常，由于您在forkProcess中运行客户端，因此无法轻松观察到该异常。如果你想这样做很好，但是你需要监控或链接到该过程。在这种情况下，简单地使用runProcess会简单得多。如果你这样做，你会看到你得到这个例外：

Worker.hs: trying to call fromInteger for a TimeInterval. Cannot guess units

callTimeout不接受Integer，它使用TimeInterval，它是使用Time模块中的函数构造的。这是一个伪Num - 它实际上并不支持fromInteger。我会考虑一个错误或至少是糟糕的形式（在Haskell中），但无论如何修复代码的方法都是

r <- callTimeout sid (Server.Add 5 6) (milliSeconds 100) :: Process (Maybe Double)

要解决客户端调用服务器的问题，您需要注册您生成的服务器进程的pid，而不是您生成它的主进程 - 即更改

self <- getSelfPid
register "serverPID" self

liftIO $ putStrLn "x"
mid <- launchServer
liftIO $ putStrLn "y"

到

mid <- launchServer
register "serverPID" mid
liftIO $ putStrLn "y"

在向ManagedProcess发送消息时，Cloud Haskell永远挂起

1 个答案: