diff --git a/Data/Conduit/Network.hs b/Data/Conduit/Network.hs --- a/Data/Conduit/Network.hs +++ b/Data/Conduit/Network.hs @@ -1,173 +1,178 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -module Data.Conduit.Network - ( -- * 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, throwIO, SomeException, try) -import Control.Exception.Lifted (bracket) -import Control.Monad (forever) -import Control.Monad.Trans.Resource (register) -import Control.Concurrent.Lifted (fork) - --- | Stream data from the socket. --- --- This function does /not/ automatically close the socket. --- --- Since 0.0.0 -sourceSocket :: ResourceIO m => Socket -> Source m ByteString -sourceSocket socket = - src - where - src = Source pull close - - pull = do - bs <- liftIO (recv socket 4096) - return $ if S.null bs then Closed else Open src bs - close = return () - --- | Stream data to the socket. --- --- This function does /not/ automatically close the socket. --- --- Since 0.0.0 -sinkSocket :: ResourceIO m => Socket -> Sink ByteString m () -sinkSocket socket = - SinkData push close - where - push bs = do - 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 () - --- | Same as @Application@, but allows an arbitrary inner monad. -type ApplicationM m = Source m ByteString - -> Sink ByteString m () - -> ResourceT m () - --- | 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 :: (Base m ~ IO, ResourceIO m) => ServerSettings -> ApplicationM m -> m () -runTCPServer (ServerSettings port host) app = bracket - (liftIO $ bindPort host port) - (liftIO . NS.sClose) - (forever . serve) - where - serve lsocket = do - (socket, _addr) <- liftIO $ NS.accept lsocket - fork $ runResourceT $ do - _ <- register $ NS.sClose socket - 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 :: ResourceIO m => ClientSettings -> ApplicationM m -> m () -runTCPClient (ClientSettings port host) app = bracket - (liftIO $ getSocket host port) - (liftIO . NS.sClose) - (\s -> runResourceT $ app (sourceSocket s) (sinkSocket s)) - --- | 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 +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Data.Conduit.Network + ( -- * Basic utilities + sourceSocket + , sinkSocket + -- * Simple TCP server/client interface. + , Application + , ApplicationM + -- ** 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, throwIO, SomeException, try) +import Control.Exception.Lifted (bracket) +import Control.Monad (forever) +import Control.Monad.Trans.Resource (register) +import Control.Concurrent.Lifted (fork) + +-- | Stream data from the socket. +-- +-- This function does /not/ automatically close the socket. +-- +-- Since 0.0.0 +sourceSocket :: ResourceIO m => Socket -> Source m ByteString +sourceSocket socket = + src + where + src = Source pull close + + pull = do + bs <- liftIO (recv socket 4096) + return $ if S.null bs then Closed else Open src bs + close = return () + +-- | Stream data to the socket. +-- +-- This function does /not/ automatically close the socket. +-- +-- Since 0.0.0 +sinkSocket :: ResourceIO m => Socket -> Sink ByteString m () +sinkSocket socket = + SinkData push close + where + push bs = do + 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 () + +-- | Same as @Application@, but allows an arbitrary inner monad. +-- +-- Since 0.2.2 +type ApplicationM m = Source m ByteString + -> Sink ByteString m () + -> ResourceT m () + +-- | 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 :: (Base m ~ IO, ResourceIO m) => ServerSettings -> ApplicationM m -> m () +runTCPServer (ServerSettings port host) app = bracket + (liftIO $ bindPort host port) + (liftIO . NS.sClose) + (forever . serve) + where + serve lsocket = do + (socket, _addr) <- liftIO $ NS.accept lsocket + fork $ runResourceT $ do + _ <- register $ NS.sClose socket + app (sourceSocket socket) (sinkSocket socket) + +-- | Settings for a TCP client, specifying how to connect to the server. +-- +-- Since 0.2.1 +data ClientSettings = ClientSettings + { clientPort :: Int + , clientHost :: String + } + +-- | Run an @Application@ by connecting to the specified server. +-- +-- Since 0.2.1 +runTCPClient :: ResourceIO m => ClientSettings -> ApplicationM m -> m () +runTCPClient (ClientSettings port host) app = bracket + (liftIO $ getSocket host port) + (liftIO . NS.sClose) + (\s -> runResourceT $ app (sourceSocket s) (sinkSocket s)) + +-- | 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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,30 +1,30 @@ -Copyright (c)2011, Michael Snoyman - -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 Michael Snoyman 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. +Copyright (c)2011, Michael Snoyman + +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 Michael Snoyman 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. diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,7 +1,7 @@ -#!/usr/bin/env runhaskell - -> module Main where -> import Distribution.Simple - -> main :: IO () -> main = defaultMain +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/network-conduit.cabal b/network-conduit.cabal --- a/network-conduit.cabal +++ b/network-conduit.cabal @@ -1,44 +1,44 @@ -Name: network-conduit -Version: 0.2.1.2 -Synopsis: Stream socket data using conduits. -Description: Stream socket data using conduits. -License: BSD3 -License-file: LICENSE -Author: Michael Snoyman -Maintainer: michael@snoyman.com -Category: Data, Conduit, Network -Build-type: Simple -Cabal-version: >=1.8 -Homepage: http://github.com/snoyberg/conduit -extra-source-files: test/main.hs - -flag network-bytestring - default: False - -Library - Exposed-modules: Data.Conduit.Network - Build-depends: base >= 4 && < 5 - , transformers >= 0.2.2 && < 0.3 - , bytestring >= 0.9 - , conduit >= 0.2 && < 0.3 - , lifted-base >= 0.1 && < 0.2 - if flag(network-bytestring) - build-depends: network >= 2.2.1 && < 2.2.3 - , network-bytestring >= 0.1.3 && < 0.1.4 - else - build-depends: network >= 2.3 && < 2.4 - ghc-options: -Wall - -test-suite test - hs-source-dirs: test - main-is: main.hs - type: exitcode-stdio-1.0 - cpp-options: -DTEST - build-depends: conduit - , base - , network-conduit - ghc-options: -Wall -threaded - -source-repository head - type: git - location: git://github.com/snoyberg/conduit.git +Name: network-conduit +Version: 0.2.2 +Synopsis: Stream socket data using conduits. +Description: Stream socket data using conduits. +License: BSD3 +License-file: LICENSE +Author: Michael Snoyman +Maintainer: michael@snoyman.com +Category: Data, Conduit, Network +Build-type: Simple +Cabal-version: >=1.8 +Homepage: http://github.com/snoyberg/conduit +extra-source-files: test/main.hs + +flag network-bytestring + default: False + +Library + Exposed-modules: Data.Conduit.Network + Build-depends: base >= 4 && < 5 + , transformers >= 0.2.2 && < 0.3 + , bytestring >= 0.9 + , conduit >= 0.2 && < 0.3 + , lifted-base >= 0.1 && < 0.2 + if flag(network-bytestring) + build-depends: network >= 2.2.1 && < 2.2.3 + , network-bytestring >= 0.1.3 && < 0.1.4 + else + build-depends: network >= 2.3 && < 2.4 + ghc-options: -Wall + +test-suite test + hs-source-dirs: test + main-is: main.hs + type: exitcode-stdio-1.0 + cpp-options: -DTEST + build-depends: conduit + , base + , network-conduit + ghc-options: -Wall -threaded + +source-repository head + type: git + location: git://github.com/snoyberg/conduit.git diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,17 +1,17 @@ -import Data.Conduit -import Data.Conduit.Network -import Control.Concurrent (forkIO, threadDelay) -import Control.Monad (replicateM_) - -main :: IO () -main = do - _ <- forkIO $ runTCPServer (ServerSettings 4000 Nothing) echo - threadDelay 1000 - replicateM_ 10000 - $ runTCPClient (ClientSettings 4000 "localhost") doNothing - -echo :: Application -echo src sink = src $$ sink - -doNothing :: Application -doNothing _ _ = return () +import Data.Conduit +import Data.Conduit.Network +import Control.Concurrent (forkIO, threadDelay) +import Control.Monad (replicateM_) + +main :: IO () +main = do + _ <- forkIO $ runTCPServer (ServerSettings 4000 Nothing) echo + threadDelay 1000 + replicateM_ 10000 + $ runTCPClient (ClientSettings 4000 "localhost") doNothing + +echo :: Application +echo src sink = src $$ sink + +doNothing :: Application +doNothing _ _ = return ()