snap-app 0.2.2 → 0.3.0
raw patch · 4 files changed
+61/−32 lines, 4 filesdep +postgresql-simpledep −pgsql-simple
Dependencies added: postgresql-simple
Dependencies removed: pgsql-simple
Files
- snap-app.cabal +3/−2
- src/Snap/App/Controller.hs +2/−3
- src/Snap/App/Migrate.hs +1/−1
- src/Snap/App/Model.hs +55/−26
snap-app.cabal view
@@ -1,5 +1,5 @@ name: snap-app-version: 0.2.2+version: 0.3.0 synopsis: Simple modules for writing apps with Snap, abstracted from hpaste. homepage: Simple modules for writing apps with Snap, abstracted from hpaste. license: BSD3@@ -11,6 +11,7 @@ cabal-version: >=1.8 library+ ghc-options: -O2 hs-source-dirs: src exposed-modules: Snap.App, Snap.App.Types, Snap.App.Controller, Snap.App.Model, Snap.App.Migrate, Data.Pagination, Text.Blaze.Extra, Text.Blaze.Pagination,@@ -20,7 +21,7 @@ build-depends: base >= 4 && <5, snap-core, network,- pgsql-simple >= 0.1.2,+ postgresql-simple, mtl, blaze-html == 0.4.3.4, safe,
src/Snap/App/Controller.hs view
@@ -18,6 +18,7 @@ where import Snap.Core+import Snap.App.Model (Pool,withPoolConnection) import Snap.App.Types import Control.Applicative@@ -29,8 +30,7 @@ import Data.Pagination import Network.URI import Data.Text.Lazy (Text,toStrict)-import Database.PostgreSQL.Base (withPoolConnection,withTransaction)-import Database.PostgreSQL.Simple (Pool)+import Database.PostgreSQL.Simple import Safe (readMay) import Text.Blaze (Html) import Text.Blaze.Renderer.Text (renderHtml)@@ -40,7 +40,6 @@ runHandler :: s -> c -> Pool -> Controller c s () -> Snap () runHandler st conf pool ctrl = do withPoolConnection pool $ \conn -> do- withTransaction conn $ do let state = ControllerState conf conn st -- Default to HTML, can be overridden. modifyResponse $ setContentType "text/html"
src/Snap/App/Migrate.hs view
@@ -10,7 +10,7 @@ import GHC.Int -- | Migrate the DB to the latest version.-migrate :: Bool -> [(Int,Model c s Integer)] -> Model c s ()+migrate :: Bool -> [(Int,Model c s Int64)] -> Model c s () migrate create versions = go where go = do when create $ void $ ensureExists
src/Snap/App/Model.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-} {-# OPTIONS -Wall #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}@@ -11,28 +12,27 @@ ,single ,singleNoParams ,queryNoParams- ,processQuery- ,queryProcessed+ ,withPoolConnection ,exec- ,DB.Only(..))+ ,DB.Only(..)+ ,newPool+ ,Pool) where +import Control.Concurrent+import Control.Monad.CatchIO as E import Control.Monad.Env (env) import Control.Monad.Reader import Data.String-import Database.PostgreSQL.Base (withPoolConnection,withTransaction)-import Database.PostgreSQL.Simple (Only(..),ProcessedQuery,Query)-import qualified Database.PostgreSQL.Simple as DB-import Database.PostgreSQL.Simple (Pool)-import Database.PostgreSQL.Simple.QueryParams-import Database.PostgreSQL.Simple.QueryResults+import qualified Database.PostgreSQL.Simple as DB+import Database.PostgreSQL.Simple hiding (query)+import GHC.Int import Snap.App.Types -- | Run a model action at the top-level. runDB :: s -> c -> Pool -> Model c s () -> IO () runDB st conf pool mdl = do withPoolConnection pool $ \conn -> do- withTransaction conn $ do let state = ModelState conn st conf -- Default to HTML, can be overridden. runReaderT (runModel mdl) state@@ -41,25 +41,14 @@ model :: AppLiftModel c s => Model c s a -> Controller c s a model = liftModel --- | A version of 'query' that does not perform query substitution.-queryProcessed :: (QueryResults r) => ProcessedQuery r -> Model c s [r]-queryProcessed pq = do- conn <- env modelStateConn- Model $ ReaderT (\_ -> DB.queryProcessed conn pq)---- | Process a query for later use.-processQuery :: (QueryParams q,QueryResults r) => Query -> q -> Model c s (ProcessedQuery r)-processQuery template qs = do- Model $ ReaderT (\_ -> DB.processQuery template qs)- -- | Query with some parameters.-query :: (QueryParams ps,QueryResults r) => [String] -> ps -> Model c s [r]+query :: (ToRow ps,FromRow r) => [String] -> ps -> Model c s [r] query q ps = do conn <- env modelStateConn Model $ ReaderT (\_ -> DB.query conn (fromString (unlines q)) ps) -- | Query a single field from a single result.-single :: (QueryParams ps,QueryResults (Only r)) => [String] -> ps -> Model c s (Maybe r)+single :: (ToRow ps,FromRow (Only r)) => [String] -> ps -> Model c s (Maybe r) single q ps = do rows <- query q ps case rows of@@ -67,7 +56,7 @@ _ -> return Nothing -- | Query a single field from a single result (no params).-singleNoParams :: (QueryResults (Only r)) => [String] -> Model c s (Maybe r)+singleNoParams :: (FromRow (Only r)) => [String] -> Model c s (Maybe r) singleNoParams q = do rows <- queryNoParams q case rows of@@ -75,13 +64,53 @@ _ -> return Nothing -- | Query with no parameters.-queryNoParams :: (QueryResults r) => [String] -> Model c s [r]+queryNoParams :: (FromRow r) => [String] -> Model c s [r] queryNoParams q = do conn <- env modelStateConn Model $ ReaderT (\_ -> DB.query_ conn (fromString (unlines q))) -- | Execute some SQL returning the rows affected.-exec :: (QueryParams ps) => [String] -> ps -> Model c s Integer+exec :: (ToRow ps) => [String] -> ps -> Model c s Int64 exec q ps = do conn <- env modelStateConn Model $ ReaderT (\_ -> DB.execute conn (fromString (unlines q)) ps)++-- | Create a new connection pool.+newPool :: MonadIO m+ => ConnectInfo -- ^ Connect info.+ -> m Pool+newPool info = liftIO $ do+ var <- newMVar $ PoolState {+ poolConnections = []+ , poolConnectInfo = info+ }+ return $ Pool var++-- | Connect using the connection pool.+pconnect :: MonadIO m => Pool -> m Connection+pconnect (Pool var) = liftIO $ do+ modifyMVar var $ \state@PoolState{..} -> do+ case poolConnections of+ [] -> do conn <- connect poolConnectInfo+ return (state,conn)+ (conn:conns) -> return (state { poolConnections = conns },conn)++-- | Restore a connection to the pool.+restore :: MonadIO m => Pool -> Connection -> m ()+restore (Pool var) conn = liftIO $ do+ modifyMVar_ var $ \state -> do+ return state { poolConnections = conn : poolConnections state }++-- | Use the connection pool.+withPoolConnection :: (MonadCatchIO m,MonadIO m) => Pool -> (Connection -> m a) -> m ()+withPoolConnection pool m = do+ _ <- E.bracket (pconnect pool) (restore pool) m+ return ()++-- | A connection pool.+data PoolState = PoolState {+ poolConnections :: [Connection]+ , poolConnectInfo :: ConnectInfo+ }++newtype Pool = Pool { unPool :: MVar PoolState }