MVar 无限期阻塞；但仅在某些情况下。

Question

首先，因为这是一个具体的案例，我根本没有减少代码，所以会很长，分为两部分（Helper模块和main）。

ConcurHelper 中的 SpawnThreads 获取操作列表，将它们分叉，并获取包含操作结果的 MVar。它们组合结果，并返回结果列表。它在某些情况下可以正常工作，但在其他情况下会无限期地阻塞。

如果我给它一个 putStrLn 操作的列表，它会很好地执行它们，然后返回结果 ()s（是的，我知道在大多数情况下同时在不同的线程上运行打印命令是不好的）。

如果我尝试在 Scanner 中运行 multiTest（它需要 scanPorts 或 scanAddresses、扫描范围和要使用的线程数；然后将扫描范围拆分到线程上，并将操作列表传递给 SpawnThreads），它会无限期地阻塞。奇怪的是，根据分散在 ConcurHelper 周围的调试提示，在每个线程上，ForkIO 在 MVar 被填充之前返回。如果它不在 do 块中，这将是有意义的，但不应该按顺序执行操作吗？ （我不知道这是否与问题有关；这只是我在尝试调试时注意到的）。

我已经一步步想出来了，如果它按照 spawnThreads 中规定的顺序执行，应该会发生以下情况：

• 应该在 forkIOReturnMVar 中创建一个空的 MVar，并将其传递给 mVarWrapAct。
• mVarWrapAct 应该执行该动作，并将结果放入 MVar（这似乎是问题所在。“MVar 已填充”从未显示，表明从未放入 MVar）
• getResults 然后应该从结果列表中获取 MVar，并返回结果

如果第 2 点不是问题，我可以看到问题出在哪里（如果是问题，我看不出为什么 putMVar 永远不会执行。在扫描仪模块中，唯一真正感兴趣的功能因为这个问题是multiTest。我只包括了其余的，所以它可以运行）。

要做一个简单的测试，你可以运行以下命令：

• spawnThreads [putStrLn "Hello", putStrLn "World"]（应该返回[(),()]）

• multiTest (scanPorts "127.0.0.1") 1 (0,5)（创建 MVar，挂起一秒钟，然后因上述错误而崩溃）

对于理解这里发生的事情的任何帮助将不胜感激。我看不出这两个用例有什么区别。

谢谢

（而且我正在使用这个残暴的异常处理系统，因为 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

Answer 1

您的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"