Permalink
Browse files

Simple TCP server/client interface

  • Loading branch information...
1 parent 65e96ab commit 2a8f89ddb7c60a876d72c675ac42580f1645c6a7 @snoyberg committed Jan 31, 2012
@@ -1,14 +1,31 @@
+{-# LANGUAGE ScopedTypeVariables #-}
module Data.Conduit.Network
- ( sourceSocket
+ ( -- * Basic utilities
+ sourceSocket
, sinkSocket
+ -- * Simple TCP server/client interface.
+ , Application
+ -- ** Server
+ , ServerSettings (..)
+ , runTCPServer
+ -- ** Client
+ , ClientSettings (..)
+ , runTCPClient
+ -- * Helper utilities
+ , bindPort
+ , getSocket
) where
import Data.Conduit
+import qualified Network.Socket as NS
import Network.Socket (Socket)
import Network.Socket.ByteString (sendAll, recv)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Control.Monad.IO.Class (liftIO)
+import Control.Exception (bracketOnError, IOException, bracket, throwIO, SomeException, try)
+import Control.Monad (forever)
+import Control.Concurrent (forkIO)
-- | Stream data from the socket.
--
@@ -39,3 +56,107 @@ sinkSocket socket =
liftIO (sendAll socket bs)
return (Processing push close)
close = return ()
+
+-- | A simple TCP application. It takes two arguments: the @Source@ to read
+-- input data from, and the @Sink@ to send output data to.
+--
+-- Since 0.2.1
+type Application = Source IO ByteString
+ -> Sink ByteString IO ()
+ -> ResourceT IO ()
+
+-- | Settings for a TCP server. It takes a port to listen on, and an optional
+-- hostname to bind to.
+--
+-- Since 0.2.1
+data ServerSettings = ServerSettings
+ { serverPort :: Int
+ , serverHost :: Maybe String -- ^ 'Nothing' indicates no preference
+ }
+
+-- | Run an @Application@ with the given settings. This function will create a
+-- new listening socket, accept connections on it, and spawn a new thread for
+-- each connection.
+--
+-- Since 0.2.1
+runTCPServer :: ServerSettings -> Application -> IO ()
+runTCPServer (ServerSettings port host) app = bracket
+ (bindPort host port)
+ NS.sClose
+ (forever . serve)
+ where
+ serve lsocket = do
+ (socket, _addr) <- NS.accept lsocket
+ forkIO $ runResourceT $ app (sourceSocket socket) (sinkSocket socket)
+
+-- | Settings for a TCP client, specifying how to connect to the server.
+data ClientSettings = ClientSettings
+ { clientPort :: Int
+ , clientHost :: String
+ }
+
+-- | Run an @Application@ by connecting to the specified server.
+--
+-- Since 0.2.1
+runTCPClient :: ClientSettings -> Application -> IO ()
+runTCPClient (ClientSettings port host) app = do
+ socket <- getSocket host port
+ runResourceT $ app (sourceSocket socket) (sinkSocket socket)
+
+-- | Attempt to connect to the given host/port.
+--
+-- Since 0.2.1
+getSocket :: String -> Int -> IO NS.Socket
+getSocket host' port' = do
+ let hints = NS.defaultHints {
+ NS.addrFlags = [NS.AI_ADDRCONFIG]
+ , NS.addrSocketType = NS.Stream
+ }
+ (addr:_) <- NS.getAddrInfo (Just hints) (Just host') (Just $ show port')
+ sock <- NS.socket (NS.addrFamily addr) (NS.addrSocketType addr)
+ (NS.addrProtocol addr)
+ ee <- try' $ NS.connect sock (NS.addrAddress addr)
+ case ee of
+ Left e -> NS.sClose sock >> throwIO e
+ Right () -> return sock
+ where
+ try' :: IO a -> IO (Either SomeException a)
+ try' = try
+
+-- | Attempt to bind a listening @Socket@ on the given host/port. If no host is
+-- given, will use the first address available.
+--
+-- Since 0.2.1
+bindPort :: Maybe String -> Int -> IO Socket
+bindPort host p = do
+ let hints = NS.defaultHints
+ { NS.addrFlags =
+ [ NS.AI_PASSIVE
+ , NS.AI_NUMERICSERV
+ , NS.AI_NUMERICHOST
+ ]
+ , NS.addrSocketType = NS.Stream
+ }
+ port = Just . show $ p
+ addrs <- NS.getAddrInfo (Just hints) host port
+ let
+ tryAddrs (addr1:rest@(_:_)) =
+ catch
+ (theBody addr1)
+ (\(_ :: IOException) -> tryAddrs rest)
+ tryAddrs (addr1:[]) = theBody addr1
+ tryAddrs _ = error "bindPort: addrs is empty"
+ theBody addr =
+ bracketOnError
+ (NS.socket
+ (NS.addrFamily addr)
+ (NS.addrSocketType addr)
+ (NS.addrProtocol addr))
+ NS.sClose
+ (\sock -> do
+ NS.setSocketOption sock NS.ReuseAddr 1
+ NS.bindSocket sock (NS.addrAddress addr)
+ NS.listen sock NS.maxListenQueue
+ return sock
+ )
+ tryAddrs addrs
@@ -0,0 +1,8 @@
+import Data.Conduit
+import Data.Conduit.Network
+
+main :: IO ()
+main = runTCPServer (ServerSettings 5000 Nothing) echo
+
+echo :: Application
+echo src sink = src $$ sink
@@ -0,0 +1,27 @@
+import Data.Conduit
+import Data.Conduit.Network
+import Data.Conduit.Binary (sinkHandle)
+import System.IO (stdout)
+import Data.ByteString.Char8 (ByteString, pack)
+import Control.Monad.Trans.Resource (resourceForkIO)
+import Control.Concurrent (threadDelay)
+import Control.Monad.IO.Class (liftIO)
+
+fibs :: ResourceIO m => Source m Int
+fibs =
+ sourceState (1, 1) pull
+ where
+ pull (x, y) = do
+ liftIO $ threadDelay 1000000
+ return $ StateOpen (y, z) x
+ where
+ z = x + y
+
+fibsBS :: ResourceIO m => Source m ByteString
+fibsBS = fmap (\i -> pack $ show i ++ "\n") fibs
+
+main :: IO ()
+main = do
+ runTCPClient (ClientSettings 5000 "localhost") $ \src sink -> do
+ resourceForkIO $ fibsBS $$ sink
+ src $$ sinkHandle stdout
@@ -1,5 +1,5 @@
Name: network-conduit
-Version: 0.2.0
+Version: 0.2.1
Synopsis: Stream socket data using conduits.
Description: Stream socket data using conduits.
License: BSD3

0 comments on commit 2a8f89d

Please sign in to comment.