pipes-network (empty) → 0.0.1
raw patch · 4 files changed
+188/−0 lines, 4 filesdep +basedep +bytestringdep +mtlsetup-changed
Dependencies added: base, bytestring, mtl, network, pipes-core
Files
- Control/Pipe/Network.hs +129/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- pipes-network.cabal +27/−0
+ Control/Pipe/Network.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE ScopedTypeVariables #-}+module Control.Pipe.Network (+ Application,+ socketReader,+ socketWriter,+ ServerSettings(..),+ runTCPServer,+ ClientSettings(..),+ runTCPClient,+ ) where++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 B+import Control.Concurrent (forkIO)+import qualified Control.Exception as E+import Control.Monad (forever, unless)+import Control.Monad.Trans (MonadIO, liftIO, lift)+import Control.Pipe++-- adapted from conduit++-- | Stream data from the socket.+socketReader :: MonadIO m => Socket -> Pipe () ByteString m ()+socketReader socket = go+ where+ go = do+ bs <- lift . liftIO $ recv socket 4096+ unless (B.null bs) $+ yield bs >> go++-- | Stream data to the socket.+socketWriter :: MonadIO m => Socket -> Pipe ByteString Void m r+socketWriter socket = forever $ await >>= lift . liftIO . sendAll socket++-- | A simple TCP application. It takes two arguments: the 'Producer' to read+-- input data from, and the 'Consumer' to send output data to.+type Application m r = Pipe () ByteString m ()+ -> Pipe ByteString Void m ()+ -> IO r++-- | Settings for a TCP server. It takes a port to listen on, and an optional+-- hostname to bind to.+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.+runTCPServer :: MonadIO m => ServerSettings -> Application m r -> IO r+runTCPServer (ServerSettings port host) app = E.bracket+ (bindPort host port)+ NS.sClose+ (forever . serve)+ where+ serve lsocket = do+ (socket, _addr) <- NS.accept lsocket+ forkIO $ do+ E.finally+ (app (socketReader socket) (socketWriter socket))+ (NS.sClose socket)+ return ()++-- | 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.+runTCPClient :: MonadIO m => ClientSettings -> Application m r -> IO r+runTCPClient (ClientSettings port host) app = E.bracket+ (getSocket host port)+ NS.sClose+ (\s -> app (socketReader s) (socketWriter s))++-- | Attempt to connect to the given host/port.+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')+ E.bracketOnError+ (NS.socket (NS.addrFamily addr)+ (NS.addrSocketType addr)+ (NS.addrProtocol addr))+ NS.sClose+ (\sock -> NS.connect sock (NS.addrAddress addr) >> return sock)++-- | Attempt to bind a listening @Socket@ on the given host/port. If no host is+-- given, will use the first address available.+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@(_:_)) = E.catch+ (theBody addr1)+ (\(_ :: E.IOException) -> tryAddrs rest)+ tryAddrs (addr1:[]) = theBody addr1+ tryAddrs _ = error "bindPort: addrs is empty"+ theBody addr =+ E.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
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2012, Paolo Capriotti++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Paolo Capriotti nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ pipes-network.cabal view
@@ -0,0 +1,27 @@+Name: pipes-network+Version: 0.0.1+License: BSD3+License-file: LICENSE+Author: Paolo Capriotti+Maintainer: p.capriotti@gmail.com+Stability: Experimental+Homepage: https://github.com/pcapriotti/pipes-extra+Category: Control, Enumerator, Network+Build-type: Simple+Synopsis: Utilities to deal with sockets.+Description: Utilities to deal with sockets.+Cabal-version: >=1.8++Source-Repository head+ Type: git+ Location: https://github.com/pcapriotti/pipes-extra++Library+ Build-Depends:+ base (== 4.*),+ mtl,+ pipes-core (== 0.0.*),+ bytestring (== 0.9.*),+ network+ Exposed-Modules:+ Control.Pipe.Network