Browse files

A snap extension for pooling HDBC database connections, rescued from …

…my old snap-extensions package.
  • Loading branch information...
0 parents commit 8c409bdec183527fafaf5c681ae48949250a4829 @duairc committed Jan 5, 2011
Showing with 193 additions and 0 deletions.
  1. +1 −0 .gitignore
  2. +2 −0 CONTRIBUTORS
  3. +13 −0 LICENSE
  4. +3 −0 Setup.hs
  5. +30 −0 snap-connectionpool.cabal
  6. +35 −0 src/Snap/Extension/ConnectionPool.hs
  7. +109 −0 src/Snap/Extension/ConnectionPool/Impl.hs
1 .gitignore
@@ -0,0 +1 @@
+dist/*
2 CONTRIBUTORS
@@ -0,0 +1,2 @@
+Shane O'Brien <shane@duairc.com>
+Carl Howells <chowells79@gmail.com>
13 LICENSE
@@ -0,0 +1,13 @@
+            DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
+                    Version 2, December 2004
+
+ Copyright (C) 2004 Sam Hocevar <sam@hocevar.net>
+
+ Everyone is permitted to copy and distribute verbatim or modified
+ copies of this license document, and changing it is allowed as long
+ as the name is changed.
+
+            DO WHAT THE FUCK YOU WANT TO PUBLIC LICENSE
+   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+  0. You just DO WHAT THE FUCK YOU WANT TO.
3 Setup.hs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+import Distribution.Simple
+main = defaultMain
30 snap-connectionpool.cabal
@@ -0,0 +1,30 @@
+name: snap-connectionpool
+version: 0.1
+synopsis: A snap extension for pooling HDBC database connections
+homepage: http://github.com/duairc/snap-connectionpool
+license: OtherLicense
+license-file: LICENSE
+author: Shane O'Brien
+maintainer: shane@duairc.com
+stability: Experimental
+category: Web
+cabal-version: >= 1.2
+build-type: Simple
+
+extra-source-files:
+ CONTRIBUTORS,
+ LICENSE
+
+Library
+ hs-source-dirs: src
+
+ exposed-modules:
+ Snap.Extension.ConnectionPool,
+ Snap.Extension.ConnectionPool.Impl
+
+ build-depends:
+ base >= 4 && < 5,
+ HDBC >= 2,
+ mtl >= 2,
+ snap >= 0.3 && < 0.5,
+ snap-core >= 0.3 && < 0.5
35 src/Snap/Extension/ConnectionPool.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE Rank2Types #-}
+
+{-|
+
+'Snap.Extension.ConnectionPool' exports the 'MonadConnectionPool' interface
+which allows you to use HDBC connections in your application. These
+connections are pooled and only created once. The interface's only operation
+is 'withConnection'.
+
+'Snap.Extension.ConnectionPool.Impl' contains the only implementation of
+this interface and can be used to turn your application's monad into a
+'MonadConnectionPool'.
+
+-}
+
+module Snap.Extension.ConnectionPool
+ ( MonadConnectionPool(..)
+ , IsConnectionPoolState(..)) where
+
+import Control.Monad.Trans
+import Database.HDBC
+import Snap.Types
+
+------------------------------------------------------------------------------
+-- | The 'MonadConnectionPool' type class. Minimal complete definition:
+-- 'withConnection'.
+class MonadIO m => MonadConnectionPool m where
+ -- | Given an action, wait for an available connection from the pool and
+ -- execute the action. Return the result.
+ withConnection :: (forall c. IConnection c => c -> IO a) -> m a
+
+
+------------------------------------------------------------------------------
+class IsConnectionPoolState a where
+ withConnectionFromPool :: MonadIO m => (forall c. IConnection c => c -> IO b) -> a -> m b
109 src/Snap/Extension/ConnectionPool/Impl.hs
@@ -0,0 +1,109 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+{-|
+
+'Snap.Extension.ConnectionPool.Impl' is an implementation of the
+'MonadConnectionPool' interface defined in 'Snap.Extension.ConnectionPool'.
+
+As always, to use, add 'ConnectionPoolState' to your application's state,
+along with an instance of 'HasConnectionPoolState' for your application's
+state, making sure to use a 'connectionPoolInitializer' in your application's
+'Initializer', and then you're ready to go.
+
+The 'ConnectionPoolState' has a maximum size associated with it, but it won't
+not get filled up until necessary. It will not create actual connections until
+requested, it will go round-robin through the connection pool to create them.
+This should suffice for both production (one pool for all requests until
+server shutdown) and development (one pool per request) cases.
+
+This implementation does not require that your application's monad implement
+interfaces from any other Snap Extension.
+
+-}
+
+module Snap.Extension.ConnectionPool.Impl
+ ( HasConnectionPoolState(..)
+ , ConnectionPoolState
+ , connectionPoolInitializer
+  ) where
+
+import Control.Concurrent.Chan
+import Control.Monad
+import Control.Monad.Reader
+import Control.Monad.Trans
+import Control.Exception
+import Database.HDBC
+import Snap.Extension
+import Snap.Extension.ConnectionPool
+import Snap.Types
+
+
+------------------------------------------------------------------------------
+-- | An existential type, inside which can be put any instance of
+-- 'IConnection'. This greatly simplifies the interface to
+-- 'HasConnectionPoolState', but means that 'withConnection', defined in
+-- 'Snap.Extension.ConnectionPool', must have a Rank 2 type
+-- @forall c. IConnection c => c -> IO a@.
+data Connection = forall c. IConnection c => Connection c
+
+
+------------------------------------------------------------------------------
+-- | Your application's state must include a 'ConnectionPoolState' in order
+-- for your application to be a 'MonadConnectionPoolState'.
+data ConnectionPoolState = ConnectionPoolState
+ { _mkConn :: IO Connection
+ , _chan :: Chan (Maybe Connection)
+ , _size :: Int
+ }
+
+
+------------------------------------------------------------------------------
+-- | For you appliaction's monad to be a 'MonadConnectionPool', your
+-- application's state needs to be an instance of 'HasConnectionPoolState'.
+-- Minimal complete definition: 'getConnectionPoolState',
+-- 'setConnectionPoolState'.
+class HasConnectionPoolState s where
+ getConnectionPoolState :: s -> ConnectionPoolState
+ setConnectionPoolState :: ConnectionPoolState -> s -> s
+
+
+------------------------------------------------------------------------------
+-- | The 'Initializer' for 'ConnectionPoolState'. It takes two arguments, an
+-- 'IO' action which creates an instance of 'IConnection', and the desired
+-- maximum size of the pool.
+connectionPoolInitializer :: IConnection a
+ => IO a -> Int -> Initializer ConnectionPoolState
+connectionPoolInitializer mkConn size = do
+ chan <- liftIO newChan
+ liftIO $ replicateM_ size $ writeChan chan Nothing
+ mkInitializer $ ConnectionPoolState (mkConn >>= return . Connection) chan size
+
+
+------------------------------------------------------------------------------
+instance InitializerState ConnectionPoolState where
+ extensionId = const "ConnectionPool/ConnectionPool"
+
+ mkCleanup (ConnectionPoolState _ chan size) = replicateM_ size $ do
+ readChan chan >>= maybe (return ()) (\(Connection c) -> disconnect c)
+
+ mkReload (ConnectionPoolState _ chan size) = replicateM_ size $ do
+ readChan chan >>= maybe (return ()) (\(Connection c) -> disconnect c)
+ writeChan chan Nothing
+
+
+------------------------------------------------------------------------------
+instance HasConnectionPoolState s => MonadConnectionPool (SnapExtend s) where
+ withConnection f = asks getConnectionPoolState >>= withConnectionFromPool f
+
+
+------------------------------------------------------------------------------
+instance (MonadSnap m, HasConnectionPoolState s) => MonadConnectionPool (ReaderT s m) where
+ withConnection f = asks getConnectionPoolState >>= withConnectionFromPool f
+
+
+------------------------------------------------------------------------------
+instance IsConnectionPoolState ConnectionPoolState where
+ withConnectionFromPool f (ConnectionPoolState mkConn chan _) = liftIO $ do
+ conn@(Connection c) <- readChan chan >>= maybe mkConn return
+     f c `finally` (commit c >> writeChan chan (Just conn))

0 comments on commit 8c409bd

Please sign in to comment.