diff --git a/network-simple.cabal b/network-simple.cabal index ab87b44..3c4efd6 100644 --- a/network-simple.cabal +++ b/network-simple.cabal @@ -30,7 +30,8 @@ source-repository head library hs-source-dirs: src - exposed-modules: Network.Simple.SockAddr + exposed-modules: Network.Simple + Network.Simple.SockAddr Network.Simple.TCP other-modules: Network.Simple.Internal build-depends: base (>=4.5 && < 5) diff --git a/src/Network/Simple.hs b/src/Network/Simple.hs new file mode 100644 index 0000000..8b3a567 --- /dev/null +++ b/src/Network/Simple.hs @@ -0,0 +1,343 @@ +{-# LANGUAGE CPP #-} + +-- | This module exports functions that abstract simple TCP 'NS.Socket' +-- usage patterns. +-- +-- This module uses 'MonadIO' and 'C.MonadCatch' extensively so that you can +-- reuse these functions in monads other than 'IO'. However, if you don't care +-- about any of that, just pretend you are using the 'IO' monad all the time +-- and everything will work as expected. + +-- Some code in this file was adapted from the @pipes-network@ library by +-- Renzo Carbonara. Copyright (c) 2012-2013. See its licensing terms (BSD3) at: +-- https://github.com/k0001/pipes-network/blob/master/LICENSE +-- +-- Some code in this file was adapted from the @network-conduit@ library by +-- Michael Snoyman. Copyright (c) 2011. See its licensing terms (BSD3) at: +-- https://github.com/snoyberg/conduit/blob/master/network-conduit/LICENSE + +module Network.Simple ( + -- * Introduction to TCP networking + -- $tcp-101 + + -- * Client side + -- $client-side + connect + + -- * Server side + -- $server-side + , serve + -- ** Listening + , listen + -- ** Accepting + , accept + , acceptFork + + -- * Utils + , recv + , send + + -- * Low level support + , bindSock + , connectSock + , closeSock + + -- * Note to Windows users + , NS.withSocketsDo + + -- * Types + , HostPreference(..) + -- ** Re-exported from @Network.Socket@ + , NS.HostName + , NS.ServiceName + , NS.Socket + , NS.SockAddr + ) where + +import Control.Concurrent (ThreadId, forkIO) +import qualified Control.Exception as E +import qualified Control.Monad.Catch as C +import Control.Monad +import Control.Monad.IO.Class (MonadIO(liftIO)) +import qualified Data.ByteString as BS +import Data.List (partition) +import qualified Network.Socket as NS +import Network.Simple.Internal +import qualified Network.Socket.ByteString as NSB + +import qualified Network.Simple.SockAddr as NSA +import Network.Simple.SockAddr (accept) + +-------------------------------------------------------------------------------- +-- $tcp-101 +-- +-- This introduction aims to give you a overly simplified overview of some +-- concepts you need to know about TCP sockets in order to make effective use of +-- this module. +-- +-- There are two ends in a single TCP connection: one is the TCP «server» and +-- the other is the TCP «client». Each end is uniquely identified by an IP +-- address and a TCP port pair, and each end knows the IP address and TCP port +-- of the other end. Each end can send and receive data to and from the other +-- end. +-- +-- A TCP server, once «bound» to a well-known IP address and TCP port, starts +-- «listening» for incoming connections from TCP clients to such bound IP +-- address and TCP port. When a TCP client attempts to connect to the TCP +-- server, the TCP server must «accept» the incoming connection in order to +-- start exchanging data with the remote end. A single TCP server can +-- sequentially accept many incoming connections, possibly handling each one +-- concurrently. +-- +-- A TCP client can «connect» to a well-known IP address and TCP port previously +-- bound by a listening TCP server willing to accept new incoming connections. +-- Once the connection is established, the TCP client can immediately start +-- exchanging data with the TCP server. The TCP client is randomly assigned a +-- TCP port when connecting, and its IP address is selected by the operating +-- system so that it is reachable from the remote end. +-- +-- The TCP client a and the TCP server can be running in the same host or in +-- different hosts. + +-------------------------------------------------------------------------------- + +-- $client-side +-- +-- Here's how you could run a TCP client: +-- +-- @ +-- 'connect' \"www.example.org\" \"80\" $ \\(connectionSocket, remoteAddr) -> do +-- putStrLn $ \"Connection established to \" ++ show remoteAddr +-- -- Now you may use connectionSocket as you please within this scope, +-- -- possibly using 'recv' and 'send' to interact with the remote end. +-- @ + +-- | Connect to a TCP server and use the connection. +-- +-- The connection socket is closed when done or in case of exceptions. +-- +-- If you prefer to acquire and close the socket yourself, then use +-- 'connectSock' and 'closeSock'. +connect + :: (MonadIO m, C.MonadCatch m) + => NS.HostName -- ^Server hostname. + -> NS.ServiceName -- ^Server service port. + -> ((NS.Socket, NS.SockAddr) -> m r) + -- ^Computation taking the communication socket + -- and the server address. + -> m r +connect host port = C.bracket (connectSock host port) + (silentCloseSock . fst) + +-------------------------------------------------------------------------------- + +-- $server-side +-- +-- Here's how you can run a TCP server that handles in different threads each +-- incoming connection to port @8000@ at IPv4 address @127.0.0.1@: +-- +-- @ +-- 'serve' ('Host' \"127.0.0.1\") \"8000\" $ \\(connectionSocket, remoteAddr) -> do +-- putStrLn $ \"TCP connection established from \" ++ show remoteAddr +-- -- Now you may use connectionSocket as you please within this scope, +-- -- possibly using 'recv' and 'send' to interact with the remote end. +-- @ +-- +-- If you need more control on the way your server runs, then you can use more +-- advanced functions such as 'listen', 'accept' and 'acceptFork'. + +-------------------------------------------------------------------------------- + +-- | Start a TCP server that accepts incoming connections and handles them +-- concurrently in different threads. +-- +-- Any acquired network resources are properly closed and discarded when done or +-- in case of exceptions. +-- +-- Note: This function performs 'listen' and 'acceptFork', so you don't need to +-- perform those manually. +serve + :: (MonadIO m, C.MonadCatch m) + => HostPreference -- ^Preferred host to bind. + -> NS.ServiceName -- ^Service port to bind. + -> ((NS.Socket, NS.SockAddr) -> IO ()) + -- ^Computation to run in a different thread + -- once an incoming connection is accepted. Takes the + -- connection socket and remote end address. + -> m () +serve hp port k = do + addr <- resolve (hpHostName hp) (Just port) + NSA.serve addr k + +-------------------------------------------------------------------------------- + +-- | Bind a TCP listening socket and use it. +-- +-- The listening socket is closed when done or in case of exceptions. +-- +-- If you prefer to acquire and close the socket yourself, then use 'bindSock', +-- 'closeSock' and the 'NS.listen' function from "Network.Socket" instead. +-- +-- Note: 'N.maxListenQueue' is tipically 128, which is too small for high +-- performance servers. So, we use the maximum between 'N.maxListenQueue' and +-- 2048 as the default size of the listening queue. The 'NS.NoDelay' and +-- 'NS.ReuseAddr' options are set on the socket. +listen + :: (MonadIO m, C.MonadCatch m) + => HostPreference -- ^Preferred host to bind. + -> NS.ServiceName -- ^Service port to bind. + -> ((NS.Socket, NS.SockAddr) -> m r) + -- ^Computation taking the listening socket and + -- the address it's bound to. + -> m r +listen hp port k = do + addr <- resolve (hpHostName hp) (Just port) + NSA.listen addr k + +-------------------------------------------------------------------------------- + +-- | Accept a single incoming connection and use it in a different thread. +-- +-- The connection socket is closed when done or in case of exceptions. +acceptFork + :: MonadIO m + => NS.Socket -- ^Listening and bound socket. + -> ((NS.Socket, NS.SockAddr) -> IO ()) + -- ^Computation to run in a different thread + -- once an incoming connection is accepted. Takes the + -- connection socket and remote end address. + -> m ThreadId +acceptFork lsock k = liftIO $ do + conn@(csock,_) <- NS.accept lsock + forkFinally (k conn) + (\ea -> do silentCloseSock csock + either E.throwIO return ea) +{-# INLINABLE acceptFork #-} + +-------------------------------------------------------------------------------- + +-- | Obtain a 'NS.Socket' connected to the given host and TCP service port. +-- +-- The obtained 'NS.Socket' should be closed manually using 'closeSock' when +-- it's not needed anymore, otherwise you risk having the socket open for much +-- longer than needed. +-- +-- Prefer to use 'connect' if you will be using the socket within a limited +-- scope and would like it to be closed immediately after its usage or in case +-- of exceptions. +connectSock :: (MonadIO m, C.MonadCatch m) + => NS.HostName -> NS.ServiceName -> m (NS.Socket, NS.SockAddr) +connectSock host port = do + addr <- resolve (Just host) (Just port) + liftIO $ E.bracketOnError (NSA.newSocket addr) closeSock $ \sock -> do + liftIO $ NS.connect sock addr + return (sock, addr) + +-- | Obtain a 'NS.Socket' bound to the given host name and TCP service port. +-- +-- The obtained 'NS.Socket' should be closed manually using 'closeSock' when +-- it's not needed anymore. +-- +-- Prefer to use 'listen' if you will be listening on this socket and using it +-- within a limited scope, and would like it to be closed immediately after its +-- usage or in case of exceptions. +bindSock :: (MonadIO m, C.MonadCatch m) + => HostPreference -> NS.ServiceName -> m (NS.Socket, NS.SockAddr) +bindSock hp port = resolve (hpHostName hp) (Just port) >>= NSA.bindSock + +-- | Close the 'NS.Socket'. +closeSock :: MonadIO m => NS.Socket -> m () +closeSock = liftIO . +#if MIN_VERSION_network(2,4,0) + NS.close +#else + NS.sClose +#endif +{-# INLINE closeSock #-} + +-------------------------------------------------------------------------------- +-- Utils + +-- | Read up to a limited number of bytes from a socket. +-- +-- Returns `Nothing` if the remote end closed the connection or end-of-input was +-- reached. The number of returned bytes might be less than the specified limit. +recv :: MonadIO m => NS.Socket -> Int -> m (Maybe BS.ByteString) +recv sock nbytes = do + bs <- liftIO (NSB.recv sock nbytes) + if BS.null bs + then return Nothing + else return (Just bs) +{-# INLINABLE recv #-} + +-- | Writes the given bytes to the socket. +send :: MonadIO m => NS.Socket -> BS.ByteString -> m () +send sock = \bs -> liftIO (NSB.sendAll sock bs) +{-# INLINABLE send #-} + +-------------------------------------------------------------------------------- + +-- Misc + +newSocket :: NS.AddrInfo -> IO NS.Socket +newSocket addr = NS.socket (NS.addrFamily addr) + (NS.addrSocketType addr) + (NS.addrProtocol addr) + +isIPv4addr, isIPv6addr :: NS.AddrInfo -> Bool +isIPv4addr x = NS.addrFamily x == NS.AF_INET +isIPv6addr x = NS.addrFamily x == NS.AF_INET6 + +-- | Move the elements that match the predicate closer to the head of the list. +-- Sorting is stable. +prioritize :: (a -> Bool) -> [a] -> [a] +prioritize p = uncurry (++) . partition p + + +-------------------------------------------------------------------------------- + +-- | 'Control.Concurrent.forkFinally' was introduced in base==4.6.0.0. We'll use +-- our own version here for a while, until base==4.6.0.0 is widely establised. +forkFinally :: IO a -> (Either E.SomeException a -> IO ()) -> IO ThreadId +forkFinally action and_then = + E.mask $ \restore -> + forkIO $ E.try (restore action) >>= and_then + + +-- | Like 'closeSock', except it swallows all 'IOError' exceptions. +silentCloseSock :: MonadIO m => NS.Socket -> m () +silentCloseSock sock = liftIO $ do + E.catch (closeSock sock) + (\e -> let _ = e :: IOError in return ()) + +resolve :: (MonadIO m, C.MonadCatch m) => Maybe NS.HostName -> Maybe NS.ServiceName -> m NS.SockAddr +resolve = undefined + -- addrs <- NS.getAddrInfo (Just hints) (hpHostName hp) (Just port) + -- let addrs' = case hp of + -- HostIPv4 -> prioritize isIPv4addr addrs + -- HostIPv6 -> prioritize isIPv6addr addrs + -- _ -> addrs + -- tryAddrs addrs' + -- where + -- hints = NS.defaultHints { NS.addrFlags = [NS.AI_PASSIVE] + -- , NS.addrSocketType = NS.Stream } + + -- tryAddrs [] = error "bindSock: no addresses available" + -- tryAddrs [x] = useAddr x + -- tryAddrs (x:xs) = E.catch (useAddr x) + -- (\e -> let _ = e :: IOError in tryAddrs xs) + + -- useAddr addr = E.bracketOnError (newSocket addr) closeSock $ \sock -> do + -- let sockAddr = NS.addrAddress addr + -- NS.setSocketOption sock NS.NoDelay 1 + -- NS.setSocketOption sock NS.ReuseAddr 1 + -- NS.bindSocket sock sockAddr + -- -liftIO $ do + -- (addr:_) <- NS.getAddrInfo (Just hints) (Just host) (Just port) + -- E.bracketOnError (newSocket addr) closeSock $ \sock -> do + -- let sockAddr = NS.addrAddress addr + -- NS.connect sock sockAddr + -- return (sock, sockAddr) + -- where + -- hints = NS.defaultHints { NS.addrFlags = [NS.AI_ADDRCONFIG] + -- , NS.addrSocketType = NS.Stream }- return (sock, sockAddr) diff --git a/src/Network/Simple/Internal.hs b/src/Network/Simple/Internal.hs index bf0448e..b488acd 100644 --- a/src/Network/Simple/Internal.hs +++ b/src/Network/Simple/Internal.hs @@ -40,4 +40,3 @@ instance IsString HostPreference where hpHostName:: HostPreference -> Maybe NS.HostName hpHostName (Host s) = Just s hpHostName _ = Nothing - diff --git a/src/Network/Simple/SockAddr.hs b/src/Network/Simple/SockAddr.hs index 5ed0f8d..4b36925 100644 --- a/src/Network/Simple/SockAddr.hs +++ b/src/Network/Simple/SockAddr.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-| This is the same API as @network-simple@ with the difference @@ -11,16 +12,17 @@ module Network.Simple.SockAddr ( -- * Client side connect - , connectFork -- * Server side , serve , listen - , bind + , bindSock + , accept , acceptFork -- * Utils , send , recv , close + , newSocket -- * Re-exported from @Network.Socket@ , Socket , SockAddr @@ -28,6 +30,8 @@ module Network.Simple.SockAddr import Control.Monad (forever, when) import Control.Concurrent (ThreadId, forkIO, forkFinally) +import qualified Control.Exception as E +import qualified Control.Monad.Catch as C import Data.ByteString (ByteString) import Control.Monad.IO.Class (MonadIO, liftIO) import System.Directory (removeFile) @@ -51,25 +55,14 @@ import Control.Monad.Catch (MonadCatch, bracket, bracketOnError, throwM) connect :: (MonadIO m, MonadCatch m) => SockAddr -- ^ Server address. - -> (Socket -> m r) + -> ((Socket, SockAddr) -> m r) -- ^ Computation taking the socket connection socket. -> m r -connect addr = bracket connect' (liftIO . NS.close) +connect addr = bracket connect' (silentCloseSock . fst) where connect' = do sock <- newSocket addr liftIO $ NS.connect sock addr - return sock - --- | Like 'connect' but fork the connection in a different thread. -connectFork :: MonadIO m - => SockAddr - -- ^ Server address. - -> (forall m' . (Functor m', MonadIO m', MonadCatch m') - => Socket -> m' ()) - -- ^ Computation taking the socket connection socket. - -> m ThreadId -connectFork addr k = liftIO . forkIO $ connect addr k -{-# INLINABLE connectFork #-} + return (sock,addr) -- * Server side @@ -82,13 +75,13 @@ connectFork addr k = liftIO . forkIO $ connect addr k serve :: (MonadIO m, MonadCatch m) => SockAddr -- ^ Address to bind to. - -> (forall m' . (Functor m', MonadIO m', MonadCatch m') - => SockAddr -> Socket -> m' ()) + -> ((Socket, SockAddr) -> IO ()) -- ^ Computation to run in a different thread -- once an incoming connection is accepted. Takes the -- the remote end address and the connection socket. -> m () -serve addr k = listen addr $ \sock -> forever $ acceptFork sock k +serve addr k = listen addr $ \(lsock,_) -> + forever $ acceptFork lsock k {-| Bind a listening socket and use it. @@ -97,14 +90,49 @@ serve addr k = listen addr $ \sock -> forever $ acceptFork sock k listen :: (MonadIO m, MonadCatch m) => SockAddr -- ^ Address to bind to. - -> (Socket -> m r) + -> ((Socket, SockAddr) -> m r) -- ^ Computation taking the listening socket. -> m r -listen addr = bracket listen' (close addr) +listen addr = bracket listen' (silentCloseSock . fst) where - listen' = liftIO $ do sock <- bind addr - NS.listen sock $ max 2048 NS.maxListenQueue - return sock + listen' = liftIO $ do x@(bsock,_) <- bindSock addr + NS.listen bsock $ max 2048 NS.maxListenQueue + return x + +-- | Accept a single incoming connection and use it. +-- +-- The connection socket is closed when done or in case of exceptions. +accept + :: (MonadIO m, C.MonadCatch m) + => NS.Socket -- ^Listening and bound socket. + -> ((NS.Socket, NS.SockAddr) -> m r) + -- ^Computation to run once an incoming + -- connection is accepted. Takes the connection socket + -- and remote end address. + -> m r +accept lsock k = do + conn@(csock,_) <- liftIO (NS.accept lsock) + C.finally (k conn) (silentCloseSock csock) + +{-# INLINABLE accept #-} +-- | Accept a single incoming connection and use it in a different thread. +-- +-- The connection socket is closed when done or in case of exceptions. +acceptFork + :: MonadIO m + => NS.Socket -- ^Listening and bound socket. + -> ((NS.Socket, NS.SockAddr) -> IO ()) + -- ^Computation to run in a different thread + -- once an incoming connection is accepted. Takes the + -- connection socket and remote end address. + -> m ThreadId +acceptFork lsock k = liftIO $ do + conn@(csock,_) <- NS.accept lsock + forkFinally (k conn) + (\ea -> do silentCloseSock csock + either E.throwIO return ea) + +{-# INLINABLE acceptFork #-} {-| Obtain a 'Socket' bound to the given 'SockAddr'. The obtained 'Socket' should be closed manually using 'close' when it's not @@ -114,38 +142,20 @@ listen addr = bracket listen' (close addr) within a limited scope, and would like it to be closed immediately after its usage or in case of exceptions. -} -bind :: (MonadIO m, MonadCatch m) => SockAddr -> m Socket -bind addr = bracketOnError (newSocket addr) (close addr) + +bindSock :: (MonadIO m, MonadCatch m) => SockAddr -> m (Socket, SockAddr) +bindSock addr = bracketOnError (newSocket addr) (close addr) $ \sock -> liftIO $ do let set so n = when (NS.isSupportedSocketOption so) (NS.setSocketOption sock so n) when (isTCP addr) (set NS.NoDelay 1) set NS.ReuseAddr 1 NS.bindSocket sock addr - return sock + return (sock, addr) where isTCP (SockAddrUnix {}) = False isTCP _ = True -{-| Accept a single incoming connection and use it in a different thread. - - The connection socket is closed when done or in case of exceptions. --} -acceptFork :: (MonadIO m, MonadCatch m) - => Socket - -- ^ Listening and bound socket. - -> (forall m' . (Functor m', MonadIO m', MonadCatch m') - => SockAddr -> Socket -> m' ()) - -- ^ Computation to run in a different thread - -- once an incoming connection is accepted. Takes the - -- remote end address and connection socket. - -> m ThreadId -acceptFork lsock k = liftIO $ do - (csock,caddr) <- NS.accept lsock - forkFinally (k caddr csock) - (\ea -> NS.close csock >> either throwM return ea) -{-# INLINABLE acceptFork #-} - -- * Utils -- | Writes the given bytes to the socket. @@ -173,3 +183,19 @@ newSocket addr = liftIO $ NS.socket (fam addr) Stream defaultProtocol fam (SockAddrInet6 {}) = AF_INET6 fam (SockAddrUnix {}) = AF_UNIX {-# INLINABLE newSocket #-} + +-- | Close the 'NS.Socket'. +closeSock :: MonadIO m => NS.Socket -> m () +closeSock = liftIO . +#if MIN_VERSION_network(2,4,0) + NS.close +#else + NS.sClose +#endif +{-# INLINE closeSock #-} + +-- | Like 'closeSock', except it swallows all 'IOError' exceptions. +silentCloseSock :: MonadIO m => NS.Socket -> m () +silentCloseSock sock = liftIO $ do + E.catch (closeSock sock) + (\e -> let _ = e :: IOError in return ())