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"))