Ticket #2996: check-all-ops.patch

File check-all-ops.patch, 5.7 KB (added by amthrax, 6 years ago)

Proposed patch in addition to closed-state.patch that adds checks for a valid FD in all operations. This is a fairly simple approach. In particular, it punts on the problem of one thread closing the socket in the middle of a socket operation in another thread. Arguably, the semantics of this are sufficiently unclear (especially for blocking operations) that applications should be doing their own synchronization in such situations.

  • Network/Socket.hsc

    diff -r fdfc6e0886e6 Network/Socket.hsc
    a b  
    829829          -> IO Int           -- Number of Bytes sent
    830830
    831831sendBufTo (MkSocket s _family _stype _protocol status) ptr nbytes addr = do
     832 ensureNotClosed status "sendBufTo"
    832833 withSockAddr addr $ \p_addr sz -> do
    833834   liftM fromIntegral $
    834835#if !defined(__HUGS__)
     
    848849recvBufFrom :: Socket -> Ptr a -> Int -> IO (Int, SockAddr)
    849850recvBufFrom sock@(MkSocket s family _stype _protocol status) ptr nbytes
    850851 | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recvFrom")
    851  | otherwise   =
     852 | otherwise   = do
     853    ensureNotClosed status "recvBufFrom"
    852854    withNewSockAddr family $ \ptr_addr sz -> do
    853855      alloca $ \ptr_len -> do
    854856        poke ptr_len (fromIntegral sz)
     
    881883     -> String  -- Data to send
    882884     -> IO Int  -- Number of Bytes sent
    883885send (MkSocket s _family _stype _protocol status) xs = do
     886 ensureNotClosed status "send"
    884887 let len = length xs
    885888 withCString xs $ \str -> do
    886889   liftM fromIntegral $
     
    902905recvLen sock@(MkSocket s _family _stype _protocol status) nbytes
    903906 | nbytes <= 0 = ioError (mkInvalidRecvArgError "Network.Socket.recv")
    904907 | otherwise   = do
     908     ensureNotClosed status "recvLen"
    905909     allocaBytes nbytes $ \ptr -> do
    906910        len <-
    907911#if defined(__GLASGOW_HASKELL__) && defined(mingw32_HOST_OS)
     
    952956-- local machine is $getSocketName$.
    953957
    954958getPeerName   :: Socket -> IO SockAddr
    955 getPeerName (MkSocket s family _ _ _) = do
     959getPeerName (MkSocket s family _ _ status) = do
     960 ensureNotClosed status "getPeerName"
    956961 withNewSockAddr family $ \ptr sz -> do
    957962   with (fromIntegral sz) $ \int_star -> do
    958963   throwSocketErrorIfMinus1Retry "getPeerName" $ c_getpeername s ptr int_star
     
    960965   peekSockAddr ptr
    961966   
    962967getSocketName :: Socket -> IO SockAddr
    963 getSocketName (MkSocket s family _ _ _) = do
     968getSocketName (MkSocket s family _ _ status) = do
     969 ensureNotClosed status "getSocketName"
    964970 withNewSockAddr family $ \ptr sz -> do
    965971   with (fromIntegral sz) $ \int_star -> do
    966972   throwSocketErrorIfMinus1Retry "getSocketName" $ c_getsockname s ptr int_star
     
    11161122                -> SocketOption -- Option Name
    11171123                -> Int          -- Option Value
    11181124                -> IO ()
    1119 setSocketOption (MkSocket s _ _ _ _) so v = do
     1125setSocketOption (MkSocket s _ _ _ status) so v = do
     1126   ensureNotClosed status "setSocketOption"
    11201127   with (fromIntegral v) $ \ptr_v -> do
    11211128   throwErrnoIfMinus1_ "setSocketOption" $
    11221129       c_setsockopt s (socketOptLevel so) (packSocketOption so) ptr_v
     
    11271134getSocketOption :: Socket
    11281135                -> SocketOption  -- Option Name
    11291136                -> IO Int        -- Option Value
    1130 getSocketOption (MkSocket s _ _ _ _) so = do
     1137getSocketOption (MkSocket s _ _ _ status) so = do
     1138   ensureNotClosed status "getSocketOption"
    11311139   alloca $ \ptr_v ->
    11321140     with (fromIntegral (sizeOf (undefined :: CInt))) $ \ptr_sz -> do
    11331141       throwErrnoIfMinus1 "getSocketOption" $
     
    11411149-- Only available on platforms that support SO_PEERCRED on domain sockets.
    11421150getPeerCred :: Socket -> IO (CUInt, CUInt, CUInt)
    11431151getPeerCred sock = do
     1152  ensureSockNotClosed sock "getPeerCred"
    11441153  let fd = fdSocket sock
    11451154  let sz = (fromIntegral (#const sizeof(struct ucred)))
    11461155  with sz $ \ ptr_cr ->
     
    11591168-- for transmitting file descriptors, mainly.
    11601169sendFd :: Socket -> CInt -> IO ()
    11611170sendFd sock outfd = do
     1171  ensureSockNotClosed sock "sendFd"
    11621172  let fd = fdSocket sock
    11631173#if !defined(__HUGS__)
    11641174  throwErrnoIfMinus1Retry_repeatOnBlock "sendFd"
     
    11741184 
    11751185recvFd :: Socket -> IO CInt
    11761186recvFd sock = do
     1187  ensureSockNotClosed sock "recvFd"
    11771188  let fd = fdSocket sock
    11781189  theFd <-
    11791190#if !defined(__HUGS__)
     
    11921203              -> Int
    11931204              -> IO ()
    11941205sendAncillary sock level ty flags datum len = do
     1206  ensureSockNotClosed sock "sendAncillary"
    11951207  let fd = fdSocket sock
    11961208  _ <-
    11971209#if !defined(__HUGS__)
     
    12071219              -> Int
    12081220              -> IO (Int,Int,Ptr a,Int)
    12091221recvAncillary sock flags len = do
     1222  ensureSockNotClosed sock "recvAncillary"
    12101223  let fd = fdSocket sock
    12111224  alloca      $ \ ptr_len   ->
    12121225   alloca      $ \ ptr_lev   ->
     
    19831996sdownCmdToInt ShutdownBoth    = 2
    19841997
    19851998shutdown :: Socket -> ShutdownCmd -> IO ()
    1986 shutdown (MkSocket s _ _ _ _) stype = do
     1999shutdown (MkSocket s _ _ _ status) stype = do
     2000  ensureNotClosed status "shutdown"
    19872001  throwSocketErrorIfMinus1Retry "shutdown" (c_shutdown s (sdownCmdToInt stype))
    19882002  return ()
    19892003
     
    20382052sIsAcceptable (MkSocket _ _ _ _ status) = do
    20392053    value <- readMVar status
    20402054    return (value == Connected || value == Listening)
     2055
     2056ensureNotClosed :: MVar SocketStatus -> String -> IO ()
     2057ensureNotClosed status fnName = do
     2058    -- We use tryTakeMVar because we might already be nested inside a
     2059    -- withMVar/modifyMVar.  If that is the case, then we've already
     2060    -- checked the status.
     2061    value <- tryTakeMVar status
     2062    case value of
     2063      Nothing -> return ()
     2064      Just Closed -> ioError (userError (fnName ++ ": socket is closed"))
     2065      Just value' -> putMVar status value'
     2066
     2067ensureSockNotClosed :: Socket -> String -> IO ()
     2068ensureSockNotClosed (MkSocket _ _ _ _ status) fnName =
     2069    ensureNotClosed status fnName
    20412070   
    20422071-- -----------------------------------------------------------------------------
    20432072-- Internet address manipulation routines:
     
    20672096#ifndef __PARALLEL_HASKELL__
    20682097socketToHandle :: Socket -> IOMode -> IO Handle
    20692098socketToHandle s@(MkSocket fd _ _ _ socketStatus) mode = do
     2099 ensureNotClosed socketStatus "socketToHandle"
    20702100 modifyMVar socketStatus $ \ status ->
    20712101    if status == ConvertedToHandle
    20722102        then ioError (userError ("socketToHandle: already a Handle"))