network-conduit 0.2.2 → 0.3.0
raw patch · 5 files changed
+315/−276 lines, 5 filesdep +monad-controldep ~conduitsetup-changed
Dependencies added: monad-control
Dependency ranges changed: conduit
Files
- Data/Conduit/Network.hs +215/−178
- LICENSE +30/−30
- Setup.lhs +7/−7
- network-conduit.cabal +45/−44
- test/main.hs +18/−17
Data/Conduit/Network.hs view
@@ -1,178 +1,215 @@-{-# 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 +{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+module Data.Conduit.Network+ ( -- * Basic utilities+ sourceSocket+ , sinkSocket+ -- * Simple TCP server/client interface.+ , Application+ -- ** Server+ , ServerSettings (..)+ , runTCPServer+ -- ** Client+ , ClientSettings (..)+ , runTCPClient+ -- * Helper utilities+ , HostPreference (..)+ , 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 (MonadIO (liftIO))+import Control.Exception (bracketOnError, IOException, throwIO, SomeException, try, finally, bracket)+import Control.Monad (forever)+import Control.Monad.Trans.Control (MonadBaseControl, control)+import Control.Concurrent (forkIO)+import Data.String (IsString (fromString))++-- | Stream data from the socket.+--+-- This function does /not/ automatically close the socket.+--+-- Since 0.0.0+sourceSocket :: MonadIO m => Socket -> Source m ByteString+sourceSocket socket =+ src+ where+ src = SourceM pull close++ pull = do+ bs <- liftIO (recv socket 4096)+ return $ if S.null bs then Closed else Open src close bs+ close = return ()++-- | Stream data to the socket.+--+-- This function does /not/ automatically close the socket.+--+-- Since 0.0.0+sinkSocket :: MonadIO m => Socket -> Sink ByteString m ()+sinkSocket socket =+ Processing push close+ where+ push bs = SinkM $ 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.3.0+type Application m = Source m ByteString+ -> Sink ByteString m ()+ -> m ()++-- | Settings for a TCP server. It takes a port to listen on, and an optional+-- hostname to bind to.+--+-- Since 0.3.0+data ServerSettings = ServerSettings+ { serverPort :: Int+ , serverHost :: HostPreference+ }++-- | 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.3.0+runTCPServer :: (MonadIO m, MonadBaseControl IO m) => ServerSettings -> Application m -> m ()+runTCPServer (ServerSettings port host) app = control $ \run -> bracket+ (liftIO $ bindPort port host)+ (liftIO . NS.sClose)+ (run . forever . serve)+ where+ serve lsocket = do+ (socket, _addr) <- liftIO $ NS.accept lsocket+ let src = sourceSocket socket+ sink = sinkSocket socket+ app' run = run (app src sink) >> return ()+ appClose run = app' run `finally` NS.sClose socket+ control $ \run -> forkIO (appClose run) >> run (return ())++-- | 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 :: (MonadIO m, MonadBaseControl IO m) => ClientSettings -> Application m -> m ()+runTCPClient (ClientSettings port host) app = control $ \run -> bracket+ (getSocket host port)+ NS.sClose+ (\s -> run $ 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++-- | Which host to bind.+--+-- Note: The @IsString@ instance recognizes the following special values:+--+-- * @*@ means @HostAny@+--+-- * @*4@ means @HostIPv4@+--+-- * @*6@ means @HostIPv6@+data HostPreference =+ HostAny+ | HostIPv4+ | HostIPv6+ | Host String+ deriving (Show, Eq, Ord)++instance IsString HostPreference where+ -- The funny code coming up is to get around some irritating warnings from+ -- GHC. I should be able to just write:+ {-+ fromString "*" = HostAny+ fromString "*4" = HostIPv4+ fromString "*6" = HostIPv6+ -}+ fromString s'@('*':s) =+ case s of+ [] -> HostAny+ ['4'] -> HostIPv4+ ['6'] -> HostIPv6+ _ -> Host s'+ fromString s = Host s++-- | Attempt to bind a listening @Socket@ on the given host/port. If no host is+-- given, will use the first address available.+--+-- Since 0.3.0+bindPort :: Int -> HostPreference -> IO Socket+bindPort p s = do+ let hints = NS.defaultHints+ { NS.addrFlags = [ NS.AI_PASSIVE+ , NS.AI_NUMERICSERV+ , NS.AI_NUMERICHOST+ ]+ , NS.addrSocketType = NS.Stream+ }+ host =+ case s of+ Host s' -> Just s'+ _ -> Nothing+ port = Just . show $ p+ addrs <- NS.getAddrInfo (Just hints) host port+ -- Choose an IPv6 socket if exists. This ensures the socket can+ -- handle both IPv4 and IPv6 if v6only is false.+ let addrs4 = filter (\x -> NS.addrFamily x /= NS.AF_INET6) addrs+ addrs6 = filter (\x -> NS.addrFamily x == NS.AF_INET6) addrs+ addrs' =+ case s of+ HostIPv4 -> addrs4 ++ addrs6+ HostIPv6 -> addrs6 ++ addrs4+ _ -> addrs++ 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'
LICENSE view
@@ -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.
Setup.lhs view
@@ -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
network-conduit.cabal view
@@ -1,44 +1,45 @@-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 +Name: network-conduit+Version: 0.3.0+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.3 && < 0.4+ , lifted-base >= 0.1 && < 0.2+ , monad-control >= 0.3 && < 0.4+ 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
test/main.hs view
@@ -1,17 +1,18 @@-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 () +{-# LANGUAGE OverloadedStrings #-}+import Data.Conduit+import Data.Conduit.Network+import Control.Concurrent (forkIO, threadDelay)+import Control.Monad (replicateM_)++main :: IO ()+main = do+ _ <- forkIO $ runTCPServer (ServerSettings 4000 "*4") echo+ threadDelay 1000000+ replicateM_ 10000+ $ runTCPClient (ClientSettings 4000 "localhost") doNothing++echo :: Application IO+echo src sink = src $$ sink++doNothing :: Application IO+doNothing _ _ = return ()