diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,14 @@ +# ChangeLog / ReleaseNotes + + +## Version 0.1.0.0 + +* First public release. +* Uploaded to [Hackage][]: + + + + +[Hackage]: + http://hackage.haskell.org/ + "HackageDB (or just Hackage) is a collection of releases of Haskell packages." diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Peter Trško + +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 Peter Trško 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,126 @@ +Connection Pool +=============== + +[![Hackage](https://budueba.com/hackage/connection-pool)][Hackage: connection-pool] + + +Description +----------- + +Connection poll is a family specialised resource pools. Currently package +provides two + +1. pool for TCP client connections, +2. and pool for UNIX Sockets client connections. + +This package is built on top of [resource-pool][] and [streaming-commons][]. +The later allows us to use [conduit-extra][] package for implementation of TCP +or UNIX Sockets clients. + + +Documentation +------------- + +Stable releases with API documentation are available on +[Hackage][Hackage: connection-pool] + + +TCP Client Example +------------------ + +Here is a simple example that demonstrates how TCP client can be created and +how connection pool behaves. + +```haskell +{-# LANGUAGE OverloadedStrings #-} +module Main (main) + where + +import Control.Monad (void) +import Control.Concurrent (forkIO, threadDelay) +import System.Environment (getArgs) + +import Control.Lens ((.~), (&)) +import Data.ConnectionPool + ( createTcpClientPool + , numberOfResourcesPerStripe + , numberOfStripes + , withTcpClientConnection + ) +import Data.Default.Class (Default(def)) +import Data.Streaming.Network (appWrite, clientSettingsTCP) + + +main :: IO () +main = do + [port, numStripes, numPerStripe] <- getArgs + pool <- createTcpClientPool + (poolParams numStripes numPerStripe) + (clientSettingsTCP (read port) "127.0.0.1") + void . forkIO . withTcpClientConnection pool $ \appData -> do + threadDelay 100 + appWrite appData "1: I'm alive!\n" + void . forkIO . withTcpClientConnection pool $ \appData -> + appWrite appData "2: I'm alive!\n" + where + poolParams m n = + def & numberOfStripes .~ read m + & numberOfResourcesPerStripe .~ read n +``` + +To test it we can use `socat` or some `netcat` like application. Our test will +require two terminals, in one we will execute `socat` as a server listenting on +UNIX socket and in the other one we execute above example. + +Simple TCP server listening on port `8001` that prints what it receives to +stdout: + + $ socat TCP4-LISTEN:8001,bind=127.0.0.1,fork - + +The `fork` parameter in the above example is important, otherwise `socat` would +terminate when client closes its connection. + +If we run above example as: + + $ runghc tcp-example.hs 8001 1 1 + +We can see that `socat` received following text: + + 1: I'm alive! + 2: I'm alive! + +But if we increment number of stripes or number of connections (resources) per +stripe, then we will get: + + 2: I'm alive! + 1: I'm alive! + +The reason for this is that we use `threadDelay 100` in the first executed +thread. So when we have only one stripe and one connection per stripe, then we +have only one connection in the pool. Therefore when the first thread executes +and acquires a connection, then all the other threads (the other one in above +example) will block. If we have more then one connection available in our pool, +then the first thread acquires connection, blocks on `threadDelay` call, but +the other thread also acquires connection and prints its output while the first +thread is still blocked on `threadDelay`. This example demonstrates how +connection pool behaves if it reached its capacity and when it has onough free +resources. + + +Contributions +------------- + +Contributions, pull requests and bug reports are welcome! Please don't be +afraid to contact author using GitHub or by e-mail (see `.cabal` file for +that). + + + +[conduit-extra]: + http://hackage.haskell.org/package/conduit-extra +[connection-pool] + http://hackage.haskell.org/package/connection-pool +[resource-pool]: + http://hackage.haskell.org/package/resource-pool +[streaming-commons]: + http://hackage.haskell.org/package/streaming-commons diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/connection-pool.cabal b/connection-pool.cabal new file mode 100644 --- /dev/null +++ b/connection-pool.cabal @@ -0,0 +1,114 @@ +name: connection-pool +version: 0.1.0.0 +synopsis: + Connection pool built on top of resource-pool and streaming-commons. +description: + Connection poll is a family specialised resource pools. Currently package + provides two + . + 1. pool for TCP client connections, + . + 2. and pool for UNIX Sockets client connections. + . + This package is built on top of + and + . + The later allows us to use + package + for implementation of TCP or UNIX Sockets clients. + . + For examples and other details see documentation in "Data.ConnectionPool" + module. + +homepage: https://github.com/trskop/connection-pool +bug-reports: https://github.com/trskop/connection-pool/issues +license: BSD3 +license-file: LICENSE +author: Peter Trško +maintainer: peter.trsko@gmail.com +copyright: (c) 2014 Peter Trško +category: Data +build-type: Simple +cabal-version: >=1.10 + +extra-source-files: + README.md + , ChangeLog.md + , example/*.hs + +flag pedantic + description: + Pass additional warning flags including -Werror to GHC during compilation. + default: False + manual: True + +library + hs-source-dirs: src + + exposed-modules: + Data.ConnectionPool + , Data.ConnectionPool.Internal.ConnectionPool + , Data.ConnectionPool.Internal.ConnectionPoolFamily + , Data.ConnectionPool.Internal.ResourcePoolParams + , Data.ConnectionPool.Internal.Streaming + + other-extensions: + CPP + , DeriveDataTypeable + , FlexibleContexts + , NoImplicitPrelude + , TupleSections + , TypeFamilies + + build-depends: + -- Packages distributed with HaskellPlatform (or GHC itself): + base >=4.6 && <4.8 + , network >= 2.2.3 + -- Version 2.2.3 introduced module "Network.Socket.ByteString". + , time >= 1.0 + -- Version 1.0 is the oldest available version of time on Hackage and it + -- defines NominalDiffTime. Package -- resource-pool doesn't define any + -- version boundaries on this package. + + -- Other packages: + , between >= 0.9.0.0 + , data-default-class == 0.0.* + , monad-control >= 0.2.0.1 + -- Version boundary same as resource-pool (version 0.2.0.0) has. + , resource-pool >= 0.2.0.0 && < 1 + -- Version 0.2.0.0 was the first that used monad-control package. + -- At the time of writing (version 0.2.3.0) used subset of API is stable. + , streaming-commons >= 0.1.3 + -- First version that had getSocketFamilyTCP function and also Earlier + -- versions have different definition of ClientSettings. Those two things + -- are actually related. At the time of writing (version 0.1.4.2) used + -- subset of API is stable. + , transformers-base >= 0.4.2 && < 0.5 + -- Version bounds taken from latest monad-control package (at the moment + -- 0.3.3.0), which is a dependency of resource-pool package. + + default-language: Haskell2010 + + if os(windows) + cpp-options: -DWINDOWS + + if impl(ghc >= 7.8.1) + cpp-options: -DKIND_POLYMORPHIC_TYPEABLE + + ghc-options: -Wall + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs + if flag(pedantic) + ghc-options: + -fwarn-implicit-prelude + -fwarn-missing-import-lists + -Werror + +source-repository head + type: git + location: git://github.com/trskop/connection-pool.git + +source-repository this + type: git + location: git://github.com/trskop/connection-pool.git + tag: v0.1.0.0 diff --git a/example/tcp.hs b/example/tcp.hs new file mode 100644 --- /dev/null +++ b/example/tcp.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module: Main +-- Description: UNIX Sockets client example. +-- Copyright: (c) 2014 Peter Trsko +-- License: BSD3 +module Main (main) + where + +import Control.Monad (void) +import Control.Concurrent (forkIO, threadDelay) +import System.Environment (getArgs) + +import Control.Lens ((.~), (&)) +import Data.ConnectionPool + ( createTcpClientPool + , numberOfResourcesPerStripe + , numberOfStripes + , withTcpClientConnection + ) +import Data.Default.Class (Default(def)) +import Data.Streaming.Network (appWrite, clientSettingsTCP) + + +main :: IO () +main = do + [port, numStripes, numPerStripe] <- getArgs + pool <- createTcpClientPool + (poolParams numStripes numPerStripe) + (clientSettingsTCP (read port) "127.0.0.1") + void . forkIO . withTcpClientConnection pool $ \appData -> do + threadDelay 100 + appWrite appData "1: I'm alive!\n" + void . forkIO . withTcpClientConnection pool $ \appData -> + appWrite appData "2: I'm alive!\n" + where + poolParams m n = + def & numberOfStripes .~ read m + & numberOfResourcesPerStripe .~ read n diff --git a/example/unix-sockets.hs b/example/unix-sockets.hs new file mode 100644 --- /dev/null +++ b/example/unix-sockets.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module: Main +-- Description: UNIX Sockets client example. +-- Copyright: (c) 2014 Peter Trsko +-- License: BSD3 +module Main (main) + where + +import Control.Concurrent (forkIO, threadDelay) +import Control.Monad (void) +import System.Environment (getArgs) + +import Control.Lens ((.~), (&)) +import Data.ConnectionPool + ( createUnixClientPool + , numberOfResourcesPerStripe + , numberOfStripes + , withUnixClientConnection + ) +import Data.Default.Class (Default(def)) +import Data.Streaming.Network (appWrite, clientSettingsUnix) + + +main :: IO () +main = do + [socket, numStripes, numPerStripe] <- getArgs + pool <- createUnixClientPool + (poolParams numStripes numPerStripe) + (clientSettingsUnix socket) + void . forkIO . withUnixClientConnection pool $ \appData -> do + threadDelay 100 + appWrite appData "1: I'm alive!\n" + void . forkIO . withUnixClientConnection pool $ \appData -> + appWrite appData "2: I'm alive!\n" + where + poolParams m n = + def & numberOfStripes .~ read m + & numberOfResourcesPerStripe .~ read n diff --git a/src/Data/ConnectionPool.hs b/src/Data/ConnectionPool.hs new file mode 100644 --- /dev/null +++ b/src/Data/ConnectionPool.hs @@ -0,0 +1,364 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TupleSections #-} +-- | +-- Module: $HEADER$ +-- Description: Connection pools for various transport protocols. +-- Copyright: (c) 2014 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: unstable +-- Portability: non-portable (CPP, FlexibleContexts, NoImplicitPrelude, +-- TupleSections) +-- +-- Connection pools for TCP clients and UNIX Socket clients (not supported on +-- Windows). +-- +-- This package is built on top of +-- and +-- +-- packages. The later allows us to use +-- package +-- for implementing TCP and UNIX Sockets clients. Package /conduit-extra/ +-- defines @appSource@ and @appSink@ based on abstractions from +-- /streaming-commons/ package and they can be therefore reused. Difference +-- between using /conduit-extra/ or /streaming-commons/ is that instead of +-- using @runTCPClient@ (or its lifted variant @runGeneralTCPClient@ from +-- /conduit-extra/) one would use 'withTcpClientConnection', and instead of +-- @runUnixClient@ it would be 'withUnixClientConnection'. +module Data.ConnectionPool + ( + -- * TCP Client Example + -- + -- $tcpClientExample + +#ifndef WINDOWS + -- Windows doesn't support UNIX Sockets. + + -- * Unix Client Example + -- + -- $unixClientExample +#endif + -- !WINDOWS + + -- * Connection Pool + -- + -- $connectionPool + ConnectionPool + + -- * Constructing Connection Pool + -- + -- $constructingConnectionPool + , ResourcePoolParams + , numberOfResourcesPerStripe + , numberOfStripes + , resourceIdleTimeout + + -- * TCP Client Connection Pool + , TcpClient + , ClientSettings + , AppData + , createTcpClientPool + , withTcpClientConnection + +#ifndef WINDOWS + -- Windows doesn't support UNIX Sockets. + + -- * UNIX Client Connection Pool + , UnixClient + , ClientSettingsUnix + , AppDataUnix + , createUnixClientPool + , withUnixClientConnection +#endif + -- !WINDOWS + ) + where + +import Control.Applicative ((<$>)) +import Data.Function ((.)) +import Data.Maybe (Maybe(Nothing)) +import System.IO (IO) + +import qualified Network.Socket as Socket (sClose) + +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Streaming.Network + ( AppData + , ClientSettings +#ifndef WINDOWS + -- Windows doesn't support UNIX Sockets. + , AppDataUnix + , ClientSettingsUnix + , getPath + , getSocketUnix +#endif + -- !WINDOWS + ) + +import Data.ConnectionPool.Internal.ConnectionPoolFamily + ( ConnectionPool + , TcpClient +#ifndef WINDOWS + -- Windows doesn't support UNIX Sockets. + , UnixClient +#endif + -- !WINDOWS + ) +import qualified Data.ConnectionPool.Internal.ConnectionPool as Internal + ( createConnectionPool + , withConnection + ) +import qualified Data.ConnectionPool.Internal.ConnectionPoolFamily as Internal + ( ConnectionPool(..) + ) +import Data.ConnectionPool.Internal.ResourcePoolParams + ( ResourcePoolParams + , numberOfResourcesPerStripe + , numberOfStripes + , resourceIdleTimeout + ) +import qualified Data.ConnectionPool.Internal.Streaming as Internal + ( acquireTcpClientConnection + , runTcpApp +#ifndef WINDOWS + -- Windows doesn't support UNIX Sockets. + , runUnixApp +#endif + -- !WINDOWS + ) + + +-- | Create connection pool for TCP clients. +createTcpClientPool + :: ResourcePoolParams + -> ClientSettings + -> IO (ConnectionPool TcpClient) +createTcpClientPool poolParams tcpParams = Internal.TcpConnectionPool + <$> Internal.createConnectionPool acquire release poolParams + where + acquire = Internal.acquireTcpClientConnection tcpParams + release = Socket.sClose + +-- | Temporarily take a TCP connection from a pool, run client with it, and +-- return it to the pool afterwards. For details how connections are allocated +-- see 'Data.Pool.withResource'. +withTcpClientConnection + :: MonadBaseControl IO m + => ConnectionPool TcpClient + -> (AppData -> m r) + -> m r +withTcpClientConnection (Internal.TcpConnectionPool pool) = + Internal.withConnection pool . Internal.runTcpApp Nothing + +#ifndef WINDOWS +-- Windows doesn't support UNIX Sockets. + +-- | Create connection pool for UNIX Sockets clients. +createUnixClientPool + :: ResourcePoolParams + -> ClientSettingsUnix + -> IO (ConnectionPool UnixClient) +createUnixClientPool poolParams unixParams = Internal.UnixConnectionPool + <$> Internal.createConnectionPool acquire release poolParams + where + acquire = (, ()) <$> getSocketUnix (getPath unixParams) + release = Socket.sClose + +-- | Temporarily take a UNIX Sockets connection from a pool, run client with +-- it, and return it to the pool afterwards. For details how connections are +-- allocated see 'Data.Pool.withResource'. +withUnixClientConnection + :: MonadBaseControl IO m + => ConnectionPool UnixClient + -> (AppDataUnix -> m r) + -> m r +withUnixClientConnection (Internal.UnixConnectionPool pool) = + Internal.withConnection pool . Internal.runUnixApp +#endif + -- !WINDOWS + +-- $tcpClientExample +-- +-- Here is a simple example that demonstrates how TCP client can be created and +-- how connection pool behaves. +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- module Main (main) +-- where +-- +-- import Control.Monad (void) +-- import Control.Concurrent (forkIO, threadDelay) +-- import System.Environment (getArgs) +-- +-- import Control.Lens ((.~), (&)) +-- import Data.ConnectionPool +-- ( 'createTcpClientPool' +-- , 'numberOfResourcesPerStripe' +-- , 'numberOfStripes' +-- , 'withTcpClientConnection' +-- ) +-- import Data.Default.Class (Default(def)) +-- import Data.Streaming.Network (appWrite, clientSettingsTCP) +-- +-- +-- main :: IO () +-- main = do +-- [port, numStripes, numPerStripe] <- getArgs +-- pool <- 'createTcpClientPool' +-- (poolParams numStripes numPerStripe) +-- (clientSettingsTCP (read port) "127.0.0.1") +-- void . forkIO . 'withTcpClientConnection' pool $ \\appData -> do +-- threadDelay 100 +-- appWrite appData "1: I'm alive!\\n" +-- void . forkIO . 'withTcpClientConnection' pool $ \\appData -> +-- appWrite appData "2: I'm alive!\\n" +-- where +-- poolParams m n = +-- def & 'numberOfStripes' .~ read m +-- & 'numberOfResourcesPerStripe' .~ read n +-- @ +-- +-- To test it we can use @socat@ or some @netcat@ like application. Our test +-- will require two terminals, in one we will execute @socat@ as a server +-- listenting on UNIX socket and in the other one we execute above example. +-- +-- Simple TCP server listening on port @8001@ that prints what it receives to +-- stdout: +-- +-- > $ socat TCP4-LISTEN:8001,bind=127.0.0.1,fork - +-- +-- The @fork@ parameter in the above example is important, otherwise @socat@ +-- would terminate when client closes its connection. +-- +-- If we run above example as: +-- +-- > $ runghc tcp-example.hs 8001 1 1 +-- +-- We can see that @socat@ received following text: +-- +-- > 1: I'm alive! +-- > 2: I'm alive! +-- +-- But if we increment number of stripes or number of connections (resources) +-- per stripe, then we will get: +-- +-- > 2: I'm alive! +-- > 1: I'm alive! +-- +-- The reason for this is that we use @threadDelay 100@ in the first executed +-- thread. So when we have only one stripe and one connection per stripe, then +-- we have only one connection in the pool. Therefore when the first thread +-- executes and acquires a connection, then all the other threads (the other +-- one in above example) will block. If we have more then one connection +-- available in our pool, then the first thread acquires connection, blocks on +-- @threadDelay@ call, but the other thread also acquires connection and prints +-- its output while the first thread is still blocked on @threadDelay@. This +-- example demonstrates how connection pool behaves if it reached its capacity +-- and when it has onough free resources. + +-- $unixClientExample +-- +-- Here is a simple example that demonstrates how UNIX Sockets client can be +-- created and how connection pool behaves. +-- +-- @ +-- {-\# LANGUAGE OverloadedStrings \#-} +-- module Main (main) +-- where +-- +-- import Control.Concurrent (forkIO, threadDelay) +-- import Control.Monad (void) +-- import System.Environment (getArgs) +-- +-- import Control.Lens ((.~), (&)) +-- import Data.ConnectionPool +-- ( 'createUnixClientPool' +-- , 'numberOfResourcesPerStripe' +-- , 'numberOfStripes' +-- , 'withUnixClientConnection' +-- ) +-- import Data.Default.Class (Default(def)) +-- import Data.Streaming.Network (appWrite, clientSettingsUnix) +-- +-- +-- main :: IO () +-- main = do +-- [socket, numStripes, numPerStripe] <- getArgs +-- pool <- 'createUnixClientPool' +-- (poolParams numStripes numPerStripe) +-- (clientSettingsUnix socket) +-- void . forkIO . 'withUnixClientConnection' pool $ \\appData -> do +-- threadDelay 100 +-- appWrite appData "1: I'm alive!\\n" +-- void . forkIO . 'withUnixClientConnection' pool $ \\appData -> +-- appWrite appData "2: I'm alive!\\n" +-- where +-- poolParams m n = +-- def & 'numberOfStripes' .~ read m +-- & 'numberOfResourcesPerStripe' .~ read n +-- @ +-- +-- Above example is very similar to our TCP Client Example and most notably the +-- implementation of two client threads is the same. Testing it is very similar +-- to testing TCP Client Example, but we would use different command for +-- @socat@ and for executing the example. +-- +-- Simple UNIX socket server that prints what it receives to stdout: +-- +-- > $ socat UNIX-LISTEN:test.sock,fork - +-- +-- Parameter @fork@ has the same importance as when we used it in the command +-- for running TCP server. +-- +-- We can execute UNIX Sockets Example using: +-- +-- > $ runghc unix-sockets-example.hs test.sock 1 1 +-- +-- Result of the test will be the same in case of using one stripe and one +-- connection per stripe, and when we increase total number connections, to +-- what we had with the TCP Client Example. + +-- $connectionPool +-- +-- For each supported protocol we have a 'ConnectionPool' data family instance +-- that is tagged with supported protocol. Currently it can be either +-- 'TcpClient' or 'UnixClient'. This way we are able to use same core +-- implementation for both and only need to deviate from common code where +-- necessary. +-- +-- Under the hood we use 'Network.Socket.Socket' to represent connections and +-- that limits possible implementations of 'ConnectionPool' instances to +-- protocols supported by +-- package. +-- +-- Those interested in details should look in to +-- "Data.ConnectionPool.Internal.ConnectionPool" and +-- "Data.ConnectionPool.Internal.ConnectionPoolFamily" modules. + +-- $constructingConnectionPool +-- +-- For each protocol we provide separate function that creates 'ConnectionPool' +-- instance. For TCP clients it's 'createTcpClientPool' and for UNIX Socket +-- clients it's 'createUnixClientPool' (not available on Windows). +-- +-- To simplify things we provide 'ResourcePoolParams' data type that is +-- accepted by concrete constructors of 'ConnectionPool' instances and it wraps +-- all common connection pool parameters. +-- +-- In example, to specify connection pool with 2 stripes with 8 connections in +-- each stripe we can use: +-- +-- @ +-- def & numberOfStripes .~ 2 +-- & numberOfResourcesPerStripe .~ 8 +-- @ +-- +-- Functions @&@ and @.~@ are defined by +-- package, and 'def' is a +-- method of 'Default' type class defined in +-- +-- package. diff --git a/src/Data/ConnectionPool/Internal/ConnectionPool.hs b/src/Data/ConnectionPool/Internal/ConnectionPool.hs new file mode 100644 --- /dev/null +++ b/src/Data/ConnectionPool/Internal/ConnectionPool.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: ConnectionPool data type which is a specialized Pool wrapper. +-- Copyright: (c) 2014 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: unstable (internal module) +-- Portability: non-portable (DeriveDataTypeable, FlexibleContexts, +-- NoImplicitPrelude) +-- +-- Internal packages are here to provide access to internal definitions for +-- library writers, but they should not be used in application code. +-- +-- Preferably use qualified import, e.g.: +-- +-- > import qualified Data.ConnectionPool.Internal.ConnectionPool as Internal +-- +-- This module doesn't depend on +-- +-- and other non-HaskellPlatform packages with notable exception of +-- . Another +-- notable thing is that this package is not OS specific. Please, bear this in +-- mind when doing modifications. +module Data.ConnectionPool.Internal.ConnectionPool + ( ConnectionPool(ConnectionPool) + , createConnectionPool + , withConnection + ) + where + +import Control.Applicative ((<$>)) +import Data.Function ((.)) +import Data.Tuple (fst, uncurry) +import Data.Typeable (Typeable) +import System.IO (IO) + +import Control.Monad.Trans.Control (MonadBaseControl) +import Network.Socket (Socket) + +import Data.Pool (Pool) +import Data.Pool as Pool (createPool, withResource) + +import Data.ConnectionPool.Internal.ResourcePoolParams (ResourcePoolParams) +import qualified Data.ConnectionPool.Internal.ResourcePoolParams + as ResourcePoolParams (ResourcePoolParams(..)) + + +-- | Simple specialized wrapper for 'Pool'. +newtype ConnectionPool a = ConnectionPool (Pool (Socket, a)) + deriving (Typeable) + +-- | Specialized wrapper for 'Pool.createPool', see its documentation for +-- details. +createConnectionPool + :: IO (Socket, a) + -- ^ Acquire a connection which is prepresented by a 'Socket'. There might + -- be additional information associated with specific connection that we + -- represent here as a sencond type in a tuple. Such information are + -- considered read only and aren't passed to release function (see next + -- argument). + -> (Socket -> IO ()) + -- ^ Release a connection which is prepresented by a 'Socket'. + -> ResourcePoolParams + -- ^ Data type representing all 'Pool.createPool' parameters that describe + -- internal 'Pool' parameters. + -> IO (ConnectionPool a) + -- ^ Created connection pool that is parametrised by additional connection + -- details. +createConnectionPool acquire release params = + ConnectionPool <$> Pool.createPool + acquire + (release . fst) + (ResourcePoolParams._numberOfStripes params) + (ResourcePoolParams._resourceIdleTimeout params) + (ResourcePoolParams._numberOfResourcesPerStripe params) + +-- | Specialized wrapper for 'Pool.withConnection'. +withConnection + :: MonadBaseControl IO m + => ConnectionPool a + -> (Socket -> a -> m r) + -> m r +withConnection (ConnectionPool pool) f = + Pool.withResource pool (uncurry f) diff --git a/src/Data/ConnectionPool/Internal/ConnectionPoolFamily.hs b/src/Data/ConnectionPool/Internal/ConnectionPoolFamily.hs new file mode 100644 --- /dev/null +++ b/src/Data/ConnectionPool/Internal/ConnectionPoolFamily.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE NoImplicitPrelude #-} +#ifdef KIND_POLYMORPHIC_TYPEABLE +{-# LANGUAGE StandaloneDeriving #-} +#endif +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module: $HEADER$ +-- Description: Family of connection pools specialized by transport protocol. +-- Copyright: (c) 2014 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: unstable (internal module) +-- Portability: non-portable (CPP, DeriveDataTypeable, StandaloneDeriving, +-- NoImplicitPrelude, TypeFamilies) +-- +-- Module defines type family of connection pools that is later specialised +-- using type tags (phantom types) to specialize implementation of underlying +-- 'Internal.ConnectionPool' for various protocols. +-- +-- Internal packages are here to provide access to internal definitions for +-- library writers, but they should not be used in application code. +-- +-- Preferably use qualified import, e.g.: +-- +-- > import qualified Data.ConnectionPool.Internal.ConnectionPoolFamily +-- > as Internal +-- +-- This module doesn't depend on +-- and +-- other non-HaskellPlatform packages directly and it is only allowed to import +-- "Data.ConnectionPool.Internal.ConnectionPool" internal module and nothing +-- else from this package. This package uses CPP to get OS specific things +-- right. Most importantly Windows doesn't support UNIX Sockets. +-- +-- Please, bear above in mind when doing modifications. +module Data.ConnectionPool.Internal.ConnectionPoolFamily + ( + -- * Connection Pool Family + ConnectionPool(..) + + -- * Tags For Specialised Connection Pools + , TcpClient +#ifndef WINDOWS + -- Windows doesn't support UNIX Sockets. + , UnixClient +#endif + -- !WINDOWS + ) + where + +import Data.Typeable (Typeable) + +import Network.Socket (SockAddr) + +import qualified Data.ConnectionPool.Internal.ConnectionPool as Internal + (ConnectionPool) + + +-- | Family of connection pools parametrised by transport protocol. +data family ConnectionPool :: * -> * + +#ifdef KIND_POLYMORPHIC_TYPEABLE +deriving instance Typeable ConnectionPool +#endif + +-- | Type tag used to specialize connection pool for TCP clients. +data TcpClient + deriving Typeable + +-- | Connection pool for TCP clients. +newtype instance ConnectionPool TcpClient = + TcpConnectionPool (Internal.ConnectionPool SockAddr) + +#ifndef WINDOWS +-- Windows doesn't support UNIX Sockets. + +-- | Type tag used to specialize connection pool for UNIX Socket clients. +data UnixClient + deriving Typeable + +-- | Connection pool for UNIX Socket clients. +newtype instance ConnectionPool UnixClient = + UnixConnectionPool (Internal.ConnectionPool ()) +#endif + -- !WINDOWS diff --git a/src/Data/ConnectionPool/Internal/ResourcePoolParams.hs b/src/Data/ConnectionPool/Internal/ResourcePoolParams.hs new file mode 100644 --- /dev/null +++ b/src/Data/ConnectionPool/Internal/ResourcePoolParams.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveDataTypeable #-} +-- | +-- Module: $HEADER$ +-- Description: Resource pool construction parameters. +-- Copyright: (c) 2014 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: unstable (internal module) +-- Portability: non-portable (NoImplicitPrelude, DeriveDataTypeable) +-- +-- Internal packages are here to provide access to internal definitions for +-- library writers, but they should not be used in application code. +-- +-- Preferably use qualified import, e.g.: +-- +-- > import qualified Data.ConnectionPool.Internal.ResourcePoolParams +-- > as Internal +-- +-- Surprisingly this module doesn't depend on +-- +-- package and it would be good if it stayed that way, but not at the cost of +-- cripling functionality. +-- +-- Importantly this package should not depend on +-- +-- package or other modules of this package. +-- +-- Please, bear above in mind when doing modifications. +module Data.ConnectionPool.Internal.ResourcePoolParams + ( + -- * ResourcePoolParams + ResourcePoolParams(..) + + -- ** Lenses + , numberOfResourcesPerStripe + , numberOfStripes + , resourceIdleTimeout + ) + where + +import Data.Data (Data) +import Data.Functor (Functor) +import Data.Int (Int) +import Data.Typeable (Typeable) +import Text.Show (Show) + +import Data.Time.Clock (NominalDiffTime) + +import Data.Default.Class (Default(def)) +import Data.Function.Between ((~@@^>)) + + +-- | Parameters of resource pool that describe things like its internal +-- structure. See 'Data.Pool.createPool' for details. +data ResourcePoolParams = ResourcePoolParams + { _numberOfStripes :: !Int + , _resourceIdleTimeout :: !NominalDiffTime + , _numberOfResourcesPerStripe :: !Int + } + deriving (Data, Show, Typeable) + +-- | @ +-- numberOfStripes = 1 +-- resourceIdleTimeout = 0.5 +-- numberOfResourcesPerStripe = 1 +-- @ +instance Default ResourcePoolParams where + def = ResourcePoolParams + { _numberOfStripes = 1 + , _resourceIdleTimeout = 0.5 + , _numberOfResourcesPerStripe = 1 + } + +-- | Lens for accessing stripe count. The number of distinct sub-pools to +-- maintain. The smallest acceptable value is 1 (default). +numberOfStripes + :: Functor f + => (Int -> f Int) + -> ResourcePoolParams -> f ResourcePoolParams +numberOfStripes = + _numberOfStripes ~@@^> \s b -> s {_numberOfStripes = b} + +-- | Lens for accessing amount of time for which an unused resource is kept +-- open. The smallest acceptable value is 0.5 seconds (default). +resourceIdleTimeout + :: Functor f + => (NominalDiffTime -> f NominalDiffTime) + -> ResourcePoolParams -> f ResourcePoolParams +resourceIdleTimeout = _resourceIdleTimeout ~@@^> \s b -> + s {_resourceIdleTimeout = b} + +-- | Lens for accessing maximum number of resources to keep open per stripe. +-- The smallest acceptable value is 1 (default). +numberOfResourcesPerStripe + :: Functor f + => (Int -> f Int) + -> ResourcePoolParams -> f ResourcePoolParams +numberOfResourcesPerStripe = _numberOfResourcesPerStripe ~@@^> \s b -> + s {_numberOfResourcesPerStripe = b} diff --git a/src/Data/ConnectionPool/Internal/Streaming.hs b/src/Data/ConnectionPool/Internal/Streaming.hs new file mode 100644 --- /dev/null +++ b/src/Data/ConnectionPool/Internal/Streaming.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NoImplicitPrelude #-} +-- | +-- Module: $HEADER$ +-- Description: Helper functions that aren't provided by streaming-commons. +-- Copyright: (c) 2014 Peter Trsko +-- License: BSD3 +-- +-- Maintainer: peter.trsko@gmail.com +-- Stability: unstable (internal module) +-- Portability: non-portable (CPP, FlexibleContexts, NoImplicitPrelude) +-- +-- Module defines helper functions that would be ideally provided by +-- +-- package and some wrappers with specialised type signatures. +-- +-- Internal packages are here to provide access to internal definitions for +-- library writers, but they should not be used in application code. +-- +-- Preferably use qualified import, e.g.: +-- +-- > import qualified Data.ConnectionPool.Internal.Streaming as Internal +-- +-- This module doesn't neither depend on +-- package nor +-- any other module of this package, and it shoud stay that way. This package +-- uses CPP to get OS specific things right. Most importantly Windows doesn't +-- support UNIX Sockets. +-- +-- Please, bear above in mind when doing modifications. +module Data.ConnectionPool.Internal.Streaming + ( + -- * TCP + acquireTcpClientConnection + , runTcpApp + , runTcpAppImpl + +#ifndef WINDOWS + -- Windows doesn't support UNIX Sockets. + + -- * Unix Socket + , runUnixApp + , runUnixAppImpl +#endif + -- !WINDOWS + ) + where + +import Data.Maybe (Maybe) +import System.IO (IO) + +import Control.Monad.Trans.Control (MonadBaseControl) +import Network.Socket (Socket, SockAddr) +import Network.Socket.ByteString (sendAll) + +import Data.Streaming.Network (getSocketFamilyTCP, safeRecv) +import Data.Streaming.Network.Internal + ( AppData(AppData) + , AppDataUnix(AppDataUnix) + , ClientSettings(ClientSettings) + ) +import qualified Data.Streaming.Network.Internal as AppData + (AppData(appLocalAddr', appRead', appSockAddr', appWrite')) +import qualified Data.Streaming.Network.Internal as AppDataUnix + (AppDataUnix(appReadUnix, appWriteUnix)) + +-- | Wrapper for 'runTcpAppImpl' with a type signature that is more natural +-- for implementing a TCP specific +-- 'Data.ConnectionPool.Internal.ConnectionPool.withConnection'. +runTcpApp + :: MonadBaseControl IO m + => Maybe SockAddr + -> (AppData -> m r) + -> Socket + -> SockAddr + -> m r +runTcpApp localAddr app sock addr = runTcpAppImpl localAddr sock addr app + +-- | Simplified 'Data.Streaming.Network.runTCPClient' and +-- 'Data.Streaming.Network.runTCPServer' that provides only construction of +-- 'AppData' and passing it to a callback function. +runTcpAppImpl + :: MonadBaseControl IO m + => Maybe SockAddr + -> Socket + -> SockAddr + -> (AppData -> m r) + -> m r +runTcpAppImpl localAddr sock addr app = app AppData + { AppData.appRead' = safeRecv sock 4096 + , AppData.appWrite' = sendAll sock + , AppData.appSockAddr' = addr + , AppData.appLocalAddr' = localAddr + } + +-- | Wrapper for 'getSocketFamilyTCP' that takes 'ClientSettings' instead of +-- individual parameters. +acquireTcpClientConnection :: ClientSettings -> IO (Socket, SockAddr) +acquireTcpClientConnection (ClientSettings port host addrFamily) = + getSocketFamilyTCP host port addrFamily + +#ifndef WINDOWS +-- Windows doesn't support UNIX Sockets. + +-- | Wrapper for 'runUnixAppImpl' with a type signature that is more natural +-- for implementing a UNIX Socket specific +-- 'Data.ConnectionPool.Internal.ConnectionPool.withConnection'. +runUnixApp + :: MonadBaseControl IO m + => (AppDataUnix -> m r) + -> Socket + -> () + -> m r +runUnixApp app sock () = runUnixAppImpl sock app + +-- | Simplified 'Data.Streaming.Network.runUnixClient' and +-- 'Data.Streaming.Network.runUnixServer' that provides only construction of +-- 'AppDataUnix' and passing it to a callback function. +runUnixAppImpl + :: MonadBaseControl IO m + => Socket + -> (AppDataUnix -> m r) + -> m r +runUnixAppImpl sock app = app AppDataUnix + { AppDataUnix.appReadUnix = safeRecv sock 4096 + , AppDataUnix.appWriteUnix = sendAll sock + } +#endif + -- !WINDOWS