Question

首先，因为这是一个特定的情况，我根本没有减少代码，所以它会很长，分为两部分（Helper模块和主要部分）。

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

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

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

我一步一步地想到了，如果它按照spawnThreads中的顺序执行，则应该发生以下情况：

应在forkIOReturnMVar中创建一个空的MVar，并传递给mVarWrapAct。
mVarWrapAct应该执行动作，并将结果放在MVar中（这就是问题所在的位置。“MVar filled”从未显示过，表明MVar永远不会被放入）
getResults应该从结果MVar列表中获取，并返回结果

如果第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

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"

MVars无限期地封锁;但仅限于某些情况。

1 个答案:

最小的例子

修复