tricu

A lazy functional language based on Tree Calculus
Log | Files | Refs | README | LICENSE

Network.hs (5069B)

      1 {-# LANGUAGE ScopedTypeVariables #-}
      2 -- TCP transports: numeric IPv4/IPv6 endpoints, no implicit resolver/retry policy.
      3 module IO.Network (listenTCP, connectTCP, duplexBackend, backlogLimit) where
      4 import qualified IO.Resources as R
      5 import qualified Network.Socket as N
      6 import qualified Network.Socket.ByteString as B
      7 import qualified Data.ByteString as BS
      8 import Control.Exception
      9 import Control.Monad (when, unless)
     10 import Data.IORef
     11 import GHC.IO.Exception (ioe_errno)
     12 import Foreign.C.Error
     13 
     14 backlogLimit :: Int
     15 backlogLimit = 4096
     16 address (R.IPv4 host port) = N.SockAddrInet (fromIntegral port) (N.tupleToHostAddress host)
     17 address (R.IPv6 host scope port) = N.SockAddrInet6 (fromIntegral port) 0 (N.tupleToHostAddress6 host) scope
     18 family (R.IPv4 _ _) = N.AF_INET
     19 family (R.IPv6 _ _ _) = N.AF_INET6
     20 port (R.IPv4 _ p) = p
     21 port (R.IPv6 _ _ p) = p
     22 endpoint (N.SockAddrInet p h) = pure (R.IPv4 (N.hostAddressToTuple h) (fromIntegral p))
     23 endpoint (N.SockAddrInet6 p _ h scope) = pure (R.IPv6 (N.hostAddress6ToTuple h) scope (fromIntegral p))
     24 endpoint _ = ioError (userError "unexpected TCP address family")
     25 
     26 networkIO :: String -> IO a -> IO a
     27 networkIO op action = action `catch` \(e :: IOException) -> do
     28   let generic = R.ioProblem op e
     29       category = case ioe_errno e of
     30         Just code -> maybe (R.category generic) id (lookup (Errno code)
     31           [(eCONNREFUSED,"connection-refused"),(eCONNRESET,"connection-reset"),
     32            (eCONNABORTED,"connection-aborted"),(eADDRINUSE,"address-in-use"),
     33            (eADDRNOTAVAIL,"address-unavailable"),(eNETUNREACH,"network-unreachable"),
     34            (eHOSTUNREACH,"host-unreachable"),(ePIPE,"broken-pipe"),(eTIMEDOUT,"timed-out")])
     35         _ -> R.category generic
     36   R.resourceFault (generic {R.category=category,
     37     R.progress=if op `elem` ["local-address","peer-address"] then "none" else "unknown"})
     38 
     39 listenTCP :: R.Runtime -> R.Scope -> R.Endpoint -> Int -> IO (Either R.Problem R.Token)
     40 listenTCP runtime owner target backlog
     41   | backlog <= 0 || backlog > backlogLimit = pure (Left (R.Problem "invalid-bound" "listen" "" "none"))
     42   | otherwise = R.acquire runtime owner $ networkIO "listen" $
     43       bracketOnError (N.socket (family target) N.Stream N.defaultProtocol) N.close $ \socket -> do
     44         N.setSocketOption socket N.ReuseAddr 1
     45         when (family target == N.AF_INET6) (N.setSocketOption socket N.IPv6Only 1)
     46         N.bind socket (address target)
     47         N.listen socket backlog
     48         let accept = networkIO "accept" $
     49               bracketOnError (fst <$> N.accept socket) N.close duplexBackend
     50         pure (R.Listener (R.ListenerOps accept
     51           (networkIO "local-address" (N.getSocketName socket >>= endpoint)) (N.close socket)))
     52 
     53 connectTCP :: R.Runtime -> R.Scope -> R.Endpoint -> IO (Either R.Problem R.Token)
     54 connectTCP runtime owner target
     55   | port target == 0 = pure (Left (R.Problem "invalid-bound" "connect" "zero peer port" "none"))
     56   | otherwise = R.acquire runtime owner $ networkIO "connect" $
     57       bracketOnError (N.socket (family target) N.Stream N.defaultProtocol) N.close $ \socket -> do
     58         N.connect socket (address target)
     59         duplexBackend socket
     60 
     61 data Direction = Open | Ended | Poisoned
     62 -- The registry supplies separate read/write leases; direction state is not
     63 -- synchronized across unrelated sockets, aliases or host IO outside this runtime.
     64 duplexBackend :: N.Socket -> IO R.Backend
     65 duplexBackend socket = do
     66   reading <- newIORef Open
     67   writing <- newIORef Open
     68   let invalid op = R.resourceFault (R.Problem "invalid-state" op "socket direction failed; close explicitly" "unknown")
     69       receive count = mask $ \restore -> do
     70         phase <- readIORef reading
     71         case phase of
     72           Ended -> pure BS.empty
     73           Poisoned -> invalid "read"
     74           Open -> (do
     75             bytes <- restore (networkIO "read" (B.recv socket count))
     76             when (BS.null bytes) (writeIORef reading Ended)
     77             pure bytes) `onException` writeIORef reading Poisoned
     78       send bytes = mask $ \restore -> do
     79         phase <- readIORef writing
     80         case phase of
     81           Ended -> R.resourceFault (R.Problem "invalid-state" "write" "write direction shut down" "none")
     82           Poisoned -> invalid "write"
     83           Open -> (do
     84             count <- restore (networkIO "write" (B.send socket bytes))
     85             unless (count > 0 && count <= BS.length bytes)
     86               (ioError (userError "invalid socket write progress"))
     87             pure count) `onException` writeIORef writing Poisoned
     88       shutdown = mask $ \restore -> do
     89         phase <- readIORef writing
     90         case phase of
     91           Ended -> pure ()
     92           Poisoned -> invalid "shutdown-write"
     93           Open -> (restore (networkIO "shutdown-write" (N.shutdown socket N.ShutdownSend)) >>
     94             writeIORef writing Ended) `onException` writeIORef writing Poisoned
     95   pure (R.Duplex (R.DuplexOps receive send shutdown
     96     (networkIO "local-address" (N.getSocketName socket >>= endpoint))
     97     (networkIO "peer-address" (N.getPeerName socket >>= endpoint)) (N.close socket)))