diff --git a/examples/chat-tcp.hs b/examples/chat-tcp.hs new file mode 100644 --- /dev/null +++ b/examples/chat-tcp.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- This is an example chat TCP server that listens on port 9000 and broadcast +-- incomming messages to every connected client. +-- Messages are treated as UTF-8 encoded text. + +module Main (main) where + +import Control.Concurrent.STM (STM, atomically) +import Control.Concurrent.STM.TChan (TChan, newTChanIO, writeTChan + ,readTChan, dupTChan) +import Control.Concurrent (forkIO, killThread) +import Control.Exception (finally) +import Control.Monad (forever, when) +import Data.Char (isSpace) +import Data.Monoid ((<>)) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import Network.Simple.TCP (listen, acceptFork) +import Network.Socket (Socket, SockAddr) +import Network.Socket.ByteString (recv, sendAll) + + +main :: IO () +main = do + bchan <- newTChanIO :: IO (TChan T.Text) + -- ^XXX we should really use 'newBroadcastTCHanIO' from STM-2.4 + listen "*" "9000" $ \(lsock, laddr) -> do + putStrLn $ "Listening for TCP connections at " ++ show laddr + forever . acceptFork lsock $ \(csock,caddr) -> do + putStrLn $ "Accepted incoming connection from " ++ show caddr + let talk s = writeTChan bchan $ T.pack (show caddr) <> " " <> s <> "\r\n" + sendText = sendAll csock . encodeUtf8 + recvText = return . decodeUtf8 =<< recv csock 4096 + -- ^XXX we don't handle messages longer than 4096 bytes! + atomically $ talk "joined." + rochan <- atomically $ dupTChan bchan + finally (handleClient talk rochan sendText recvText) + (atomically $ talk "gone.") + putStrLn $ "Closing connection from " ++ show caddr + + +handleClient :: (T.Text -> STM ()) -- ^Broadcast a message to all chat users. + -> TChan T.Text -- ^Incomming chat messages. + -> (T.Text -> IO ()) -- ^Send text to the client. + -> IO T.Text -- ^Receive text from the client. + -> IO () +handleClient talk inbox sendText recvText = do + tid <- forkIO . forever $ atomically (readTChan inbox) >>= sendText + fromClient + killThread tid + where + fromClient = do + t <- return . T.strip =<< recvText + when (not (T.null t)) $ do + atomically (talk $ "says: " <> t) >> fromClient + + diff --git a/examples/echo-tcp.hs b/examples/echo-tcp.hs new file mode 100644 --- /dev/null +++ b/examples/echo-tcp.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- This is an example TCP server that listens on port 9000 and echoes +-- back to clients whatever they send. Incoming connections and handled +-- concurrently. + +module Main (main) where + +import Control.Concurrent (forkIO) +import Control.Monad +import qualified Data.ByteString.Char8 as B +import qualified Network.Simple.TCP as T +import Network.Socket.ByteString (recv, sendAll) + + +main :: IO () +main = do + T.listen "*" "9000" $ \(lsock, laddr) -> do + putStrLn $ "Listening for TCP connections at " ++ show laddr + forever . T.acceptFork lsock $ \(csock, caddr) -> do + putStrLn $ "Accepted incoming connection from " ++ show caddr + echoloop csock + + where + echoloop sock = do + bs <- recv sock 4096 + when (not (B.null bs)) $ do + sendAll sock bs + echoloop sock + + diff --git a/network-simple.cabal b/network-simple.cabal --- a/network-simple.cabal +++ b/network-simple.cabal @@ -1,7 +1,5 @@ name: network-simple -version: 0.1.0.1 -synopsis: Simple network sockets usage patterns. -description: Simple network sockets usage patterns. +version: 0.2.0.0 homepage: https://github.com/k0001/network-simple bug-reports: https://github.com/k0001/network-simple/issues license: BSD3 @@ -12,7 +10,18 @@ category: Network build-type: Simple cabal-version: >=1.8 -extra-source-files: README.md PEOPLE +synopsis: Simple network sockets usage patterns. +description: + Simple network sockets usage patterns. + . + See the @NEWS@ file in the source distribution to learn about any + important changes between version. +extra-source-files: + README.md + PEOPLE + examples/echo-tcp.hs + examples/chat-tcp.hs + source-repository head type: git diff --git a/src/Network/Simple/TCP.hs b/src/Network/Simple/TCP.hs --- a/src/Network/Simple/TCP.hs +++ b/src/Network/Simple/TCP.hs @@ -9,31 +9,29 @@ -- Michael Snoyman. Copyright (c) 2011. See its licensing terms (BSD3) at: -- https://github.com/snoyberg/conduit/blob/master/network-conduit/LICENSE - module Network.Simple.TCP ( -- * Introduction to TCP networking -- $tcp-101 + -- * Client side + -- $client-side + connect + -- * Server side -- $server-side - serve, - serveFork, + , serve -- ** Listening - listen, + , listen -- ** Accepting - accept, - acceptFork, - - -- * Client side - -- $client-side - connect, + , accept + , acceptFork -- * Low level support - bindSock, - connectSock, + , bindSock + , connectSock -- * Exports - HostPreference(..), + , HostPreference(..) ) where import Control.Concurrent (ThreadId, forkIO) @@ -50,10 +48,11 @@ -- concepts you need to know about TCP sockets in order to make effective use of -- this module. -- --- There's 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. +-- 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 @@ -77,9 +76,6 @@ -- $client-side -- --- The following functions allow you to obtain and use 'NS.Socket's useful to --- the client side of a TCP connection. --- -- Here's how you could run a TCP client: -- -- > connect "www.example.org" "80" $ \(connectionSocket, remoteAddr) -> do @@ -105,23 +101,40 @@ -- $server-side -- --- The following functions allow you to obtain and use 'NS.Socket's useful to --- the server side of a TCP connection. --- --- Here's how you could run a TCP server that handles in different threads each +-- 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@: -- --- > listen (Host "127.0.0.1") "8000" $ \(listeningSocket, listeningAddr) -> do --- > putStrLn $ "Listening for incoming connections at " ++ show listeningAddr --- > forever . acceptFork listeningSocket $ \(connectionSocket, remoteAddr) -> do --- > putStrLn $ "Connection established from " ++ show remoteAddr --- > -- now you may use connectionSocket as you please within this scope. +-- > 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. -- --- If you keep reading you'll discover there are different ways to achieve --- the same, some ways more general than others. The above one was just an --- example using a pretty general approach, you are encouraged to use simpler --- approaches such as 'serve' if those suit your needs. +-- 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 + :: 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. + -> IO () +serve hp port k = do + listen hp port $ \(lsock,_) -> do + forever $ acceptFork lsock k + +-------------------------------------------------------------------------------- + -- | Bind a TCP listening socket and use it. -- -- The listening socket is closed when done or in case of exceptions. @@ -147,45 +160,7 @@ NS.listen bsock $ max 2048 NS.maxListenQueue return x --- | Start a TCP server that sequentially accepts and uses each incoming --- connection. --- --- Both the listening and connection sockets are closed when done or in case of --- exceptions. --- --- Note: You don't need to use 'listen' nor 'accept' manually if you use this --- function. -serve - :: HostPreference -- ^Preferred host to bind. - -> NS.ServiceName -- ^Service port to bind. - -> ((NS.Socket, NS.SockAddr) -> IO r) - -- ^Computation to run once an incoming - -- connection is accepted. Takes the connection socket - -- and remote end address. - -> IO r -serve hp port k = do - listen hp port $ \(lsock,_) -> do - forever $ accept lsock k - --- | Start a TCP server that accepts incoming connections and uses them --- concurrently in different threads. --- --- The listening and connection sockets are closed when done or in case of --- exceptions. --- --- Note: You don't need to use 'listen' nor 'acceptFork' manually if you use --- this function. -serveFork - :: 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. - -> IO () -serveFork hp port k = do - listen hp port $ \(lsock,_) -> do - forever $ acceptFork lsock k +-------------------------------------------------------------------------------- -- | Accept a single incoming connection and use it. -- @@ -212,9 +187,9 @@ -- once an incoming connection is accepted. Takes the -- connection socket and remote end address. -> IO ThreadId -acceptFork lsock f = do - client@(csock,_) <- NS.accept lsock - forkIO $ E.finally (f client) (NS.sClose csock) +acceptFork lsock k = do + conn@(csock,_) <- NS.accept lsock + forkIO $ E.finally (k conn) (NS.sClose csock) {-# INLINABLE acceptFork #-} --------------------------------------------------------------------------------