module Snap.App.Model
(model
,runDB
,query
,single
,singleNoParams
,queryNoParams
,withPoolConnection
,exec
,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 qualified Database.PostgreSQL.Simple as DB
import Database.PostgreSQL.Simple hiding (query)
import GHC.Int
import Snap.App.Types
runDB :: s -> c -> Pool -> Model c s () -> IO ()
runDB st conf pool mdl = do
withPoolConnection pool $ \conn -> do
let state = ModelState conn st conf
runReaderT (runModel mdl) state
model :: AppLiftModel c s => Model c s a -> Controller c s a
model = liftModel
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)
single :: (ToRow ps,FromRow (Only r)) => [String] -> ps -> Model c s (Maybe r)
single q ps = do
rows <- query q ps
case rows of
[(Only r)] -> return (Just r)
_ -> return Nothing
singleNoParams :: (FromRow (Only r)) => [String] -> Model c s (Maybe r)
singleNoParams q = do
rows <- queryNoParams q
case rows of
[(Only r)] -> return (Just r)
_ -> return Nothing
queryNoParams :: (FromRow r) => [String] -> Model c s [r]
queryNoParams q = do
conn <- env modelStateConn
Model $ ReaderT (\_ -> DB.query_ conn (fromString (unlines q)))
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)
newPool :: MonadIO m
=> ConnectInfo
-> m Pool
newPool info = liftIO $ do
var <- newMVar $ PoolState {
poolConnections = []
, poolConnectInfo = info
}
return $ Pool var
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 :: MonadIO m => Pool -> Connection -> m ()
restore (Pool var) conn = liftIO $ do
modifyMVar_ var $ \state -> do
return state { poolConnections = conn : poolConnections state }
withPoolConnection :: (MonadCatchIO m,MonadIO m) => Pool -> (Connection -> m a) -> m ()
withPoolConnection pool m = do
_ <- E.bracket (pconnect pool) (restore pool) m
return ()
data PoolState = PoolState {
poolConnections :: [Connection]
, poolConnectInfo :: ConnectInfo
}
newtype Pool = Pool { unPool :: MVar PoolState }