首先，因为这是一个特定的情况，我根本没有减少代码，所以它会很长，分为两部分（Helper模块和主要部分）。
ConcurHelper中的SpawnThreads获取操作列表，分叉它们，并获取包含操作结果的MVar。它们将结果组合在一起，并返回结果列表。它在某些情况下工作正常，但在其他情况下无限期阻止。
如果我给它一个putStrLn动作列表，它执行得很好，然后返回结果（）s（是的，我知道在不同的线程上同时运行打印命令在大多数情况下都是坏的）。
如果我尝试在扫描仪中运行multiTest（它需要scanPorts或scanAddresses，扫描范围和要使用的线程数;然后在线程上分割扫描范围，并将操作列表传递给SpawnThreads），它将无限期地阻止。奇怪的是，根据分散在ConcurHelper周围的调试提示，在每个线程上，ForkIO在MVar填充之前返回。如果它不在do块中，这是有意义的，但是不应该按顺序执行动作吗？ （我不知道这是否与问题有关;这只是我在尝试调试时注意到的事情。）
我一步一步地想到了，如果它按照spawnThreads中的顺序执行，则应该发生以下情况：
如果第2点不是问题，我可以看到问题所在（如果是问题，我看不出为什么putMVar永远不会执行。在扫描仪模块内部，唯一感兴趣的真正功能对于这个问题是multiTest。我只包括其余的所以它可以运行）。
要进行简单测试，您可以运行以下命令：
spawnThreads [putStrLn "Hello", putStrLn "World"]（应该返回[（），（）]）
multiTest (scanPorts "127.0.0.1") 1 (0,5)（创建MVar，挂起一秒钟，然后因上述错误而崩溃）
任何帮助理解这里发生的事情将不胜感激。我看不出这2个用例之间有什么区别。
谢谢
（我正在使用这个恶劣的异常处理系统，因为IO错误不会为特定的网络异常提供代码，所以我一直在解析消息以找出发生的事情）
主：
module Scanner where
import Network
import Network.Socket
import System.IO
import Control.Exception
import Control.Concurrent
import ConcurHelper
import Data.Maybe
import Data.Char
import NetHelp
data NetException = NetNoException | NetTimeOut | NetRefused | NetHostUnreach
| NetANotAvail | NetAccessDenied | NetAddrInUse
deriving (Show, Eq)
diffExcept :: Either SomeException Handle -> Either NetException Handle
diffExcept (Right h) = Right h
diffExcept (Left (SomeException m))
| err == "WSAETIMEDOUT" = Left NetTimeOut
| err == "WSAECONNREFUSED" = Left NetRefused
| err == "WSAEHOSTUNREACH" = Left NetHostUnreach
| err == "WSAEADDRNOTAVAIL" = Left NetANotAvail
| err == "WSAEACCESS" = Left NetAccessDenied
| err == "WSAEADDRINUSE" = Left NetAddrInUse
| otherwise = error $ show m
where
err = reverse . dropWhile (== ')') . reverse . dropWhile (/='W') $ show m
extJust :: Maybe a -> a
extJust (Just a) = a
selectJusts :: IO [Maybe a] -> IO [a]
selectJusts mayActs = do
mays <- mayActs; return . map extJust $ filter isJust mays
scanAddresses :: Int -> Int -> Int -> IO [String]
scanAddresses port minAddr maxAddr =
selectJusts $ mapM (\addr -> do
let sAddr = "192.168.1." ++ show addr
print $ "Trying " ++ sAddr ++ " " ++ show port
connection <- testConn sAddr port
if isJust connection
then do hClose $ extJust connection; return $ Just sAddr
else return Nothing) [minAddr..maxAddr]
scanPorts :: String -> Int -> Int -> IO [Int]
scanPorts addr minPort maxPort =
selectJusts $ mapM (\port -> do
--print $ "Trying " ++ addr ++ " " ++ show port
connection <- testConn addr port
if isJust connection
then do hClose $ extJust connection; return $ Just port
else return Nothing) [minPort..maxPort]
main :: IO ()
main = do
withSocketsDo $ do
putStrLn "Scan Addresses or Ports? (a/p)"
choice <- getLine
if (toLower $ head choice) == 'a'
then do
putStrLn "On what port?"
sPort <- getLine
addrs <- scanAddresses (read sPort :: Int) 0 255
print addrs
else do
putStrLn "At what address?"
address <- getLine
ports <- scanPorts address 0 9999
print ports
main
testConn :: HostName -> Int -> IO (Maybe Handle)
testConn host port = do
result <- try $ timedConnect 1 host port
let result' = diffExcept result
case result' of
Left e -> do putStrLn $ "\t" ++ show e; return Nothing
Right h -> return $ Just h
setPort :: AddrInfo -> Int -> AddrInfo
setPort addInf nPort = case addrAddress addInf of
(SockAddrInet _ host) -> addInf { addrAddress = (SockAddrInet (fromIntegral nPort) host)}
getHostAddress :: HostName -> Int -> IO SockAddr
getHostAddress host port = do
addrs <- getAddrInfo Nothing (Just host) Nothing
let adInfo = head addrs
newAdInfo = setPort adInfo port
return $ addrAddress newAdInfo
timedConnect :: Int -> HostName -> Int -> IO Handle
timedConnect time host port = do
s <- socket AF_INET Stream defaultProtocol
setSocketOption s RecvTimeOut time; setSocketOption s SendTimeOut time
addr <- getHostAddress host port
connect s addr
socketToHandle s ReadWriteMode
multiTest :: (Int -> Int -> IO a) -> Int -> (Int, Int) -> IO [a]
multiTest partAction threads (mi,ma) =
spawnThreads $ recDiv [mi,perThread..ma]
where
perThread = ((ma - mi) `div` threads) + 1
recDiv [] = []
recDiv (curN:restN) =
partAction (curN + 1) (head restN) : recDiv restN
助手：
module ConcurHelper where
import Control.Concurrent
import System.IO
spawnThreads :: [IO a] -> IO [a]
spawnThreads actions = do
ms <- mapM (\act -> do m <- forkIOReturnMVar act; return m) actions
results <- getResults ms
return results
forkIOReturnMVar :: IO a -> IO (MVar a)
forkIOReturnMVar act = do
m <- newEmptyMVar
putStrLn "Created MVar"
forkIO $ mVarWrapAct act m
putStrLn "Fork returned"
return m
mVarWrapAct :: IO a -> MVar a -> IO ()
mVarWrapAct act m = do a <- act; putMVar m a; putStrLn "MVar filled"
getResults :: [MVar a] -> IO [a]
getResults mvars = do
unpacked <- mapM (\m -> do r <- takeMVar m; return r) mvars
putStrLn "MVar taken from"
return unpacked
答案 0 :(得分：2)
您的forkIOReturnMVar并非例外情况安全：只要act抛出，MVar就不会被填充。
import ConcurHelper
main = spawnThreads [badOperation]
where badOperation = do
error "You're never going to put something in the MVar"
return True
如你所见，badOperation会抛出，因此MVar不会被mVarWrapAct填充。
如果遇到异常，请使用适当的值填充MVar。由于您无法为所有可能的类型a提供默认值，因此最好使用MVar (Maybe a)或MVar (Either b a)，就像您在网络代码中所做的那样。
为了捕获异常，请使用Control.Exception中提供的操作之一。例如，您可以使用onException：
mVarWrapAct :: IO a -> MVar (Maybe a) -> IO ()
mVarWrapAct act m = do
onException (act >>= putMVar m . Just) (putMVar m Nothing)
putStrLn "MVar filled"
但是，您可能希望保留实际的异常以获取更多信息。在这种情况下，您只需将catch与Either SomeException a一起使用：
mVarWrapAct :: IO a -> MVar (Either SomeException a) -> IO ()
mVarWrapAct act m = do
catch (act >>= putMVar m . Right) (putMVar m . Left)
putStrLn "MVar filled"