diff --git a/snaplet-postgresql-simple.cabal b/snaplet-postgresql-simple.cabal --- a/snaplet-postgresql-simple.cabal +++ b/snaplet-postgresql-simple.cabal @@ -1,5 +1,5 @@ name: snaplet-postgresql-simple -version: 0.3.0.3 +version: 0.4 synopsis: postgresql-simple snaplet for the Snap Framework description: This snaplet contains support for using the Postgresql database with a Snap Framework application via the @@ -37,15 +37,15 @@ build-depends: base >= 4 && < 5, bytestring >= 0.9.1 && < 0.11, - clientsession >= 0.7.2 && < 0.9, + clientsession >= 0.7.2 && < 0.10, configurator >= 0.2 && < 0.3, errors >= 1.4 && < 1.5, MonadCatchIO-transformers >= 0.3 && < 0.4, mtl >= 2 && < 3, - postgresql-simple >= 0.2 && < 0.3, + postgresql-simple >= 0.3 && < 0.4, resource-pool-catchio >= 0.2 && < 0.3, - snap >= 0.10 && < 0.12, - text >= 0.11 && < 0.12, + snap >= 0.10 && < 0.13, + text >= 0.11.2 && < 0.12, transformers >= 0.2 && < 0.4, unordered-containers >= 0.2 && < 0.3 diff --git a/src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs b/src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs --- a/src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs +++ b/src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs @@ -314,33 +314,36 @@ lookupByUserId PostgresAuthManager{..} uid = do let q = Query $ T.encodeUtf8 $ T.concat - [ "select * from " + [ "select ", T.intercalate "," cols, " from " , tblName pamTable , " where " , fst (colId pamTable) , " = ?" ] querySingle pamConnPool q [unUid uid] + where cols = map (fst . ($pamTable) . fst) colDef lookupByLogin PostgresAuthManager{..} login = do let q = Query $ T.encodeUtf8 $ T.concat - [ "select * from " + [ "select ", T.intercalate "," cols, " from " , tblName pamTable , " where " , fst (colLogin pamTable) , " = ?" ] querySingle pamConnPool q [login] + where cols = map (fst . ($pamTable) . fst) colDef lookupByRememberToken PostgresAuthManager{..} token = do let q = Query $ T.encodeUtf8 $ T.concat - [ "select * from " + [ "select ", T.intercalate "," cols, " from " , tblName pamTable , " where " , fst (colRememberToken pamTable) , " = ?" ] querySingle pamConnPool q [token] + where cols = map (fst . ($pamTable) . fst) colDef destroy PostgresAuthManager{..} AuthUser{..} = do let q = Query $ T.encodeUtf8 $ T.concat diff --git a/src/Snap/Snaplet/PostgresqlSimple.hs b/src/Snap/Snaplet/PostgresqlSimple.hs --- a/src/Snap/Snaplet/PostgresqlSimple.hs +++ b/src/Snap/Snaplet/PostgresqlSimple.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} {-| @@ -86,7 +88,6 @@ , formatQuery -- Re-exported from postgresql-simple - , P.ConnectInfo(..) , P.Query , P.In(..) , P.Binary(..) @@ -110,26 +111,37 @@ ) where +import Prelude hiding ((++)) import Control.Applicative import Control.Monad.CatchIO (MonadCatchIO) import qualified Control.Monad.CatchIO as CIO import Control.Monad.IO.Class import Control.Monad.State import Control.Monad.Trans.Reader -import Control.Monad.Trans.Writer import Data.ByteString (ByteString) +import Data.Monoid(Monoid(..)) import qualified Data.Configurator as C +import qualified Data.Configurator.Types as C +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as TB +import qualified Data.Text.Lazy.Builder.Int as TB +import qualified Data.Text.Lazy.Builder.RealFloat as TB import Data.Int -import Data.List -import Data.Maybe +import Data.Ratio import Data.Pool import Database.PostgreSQL.Simple.ToRow import Database.PostgreSQL.Simple.FromRow import qualified Database.PostgreSQL.Simple as P +import qualified Database.PostgreSQL.Simple.Transaction as P import Snap import Paths_snaplet_postgresql_simple - +-- This is actually more portable than using <> +(++) :: Monoid a => a -> a -> a +(++) = mappend +infixr 5 ++ ------------------------------------------------------------------------------ -- | The state for the postgresql-simple snaplet. To use it in your app @@ -174,33 +186,96 @@ ------------------------------------------------------------------------------ --- | Convenience function allowing easy collection of config file errors. -logErr :: MonadIO m - => t -> IO (Maybe a) -> WriterT [t] m (Maybe a) -logErr err m = do - res <- liftIO m - when (isNothing res) (tell [err]) - return res +-- | Produce a connection string from a config +getConnectionString :: C.Config -> IO ByteString +getConnectionString config = do + let params = + [ ["host"] + , ["hostaddr"] + , ["port"] + , ["dbname","db"] + , ["user"] + , ["password","pass"] + , ["connection_timeout"] + , ["client_encoding"] + , ["options"] + , ["application_name"] + , ["fallback_application_name"] + , ["keepalives"] + , ["keepalives_idle"] + , ["keepalives_interval"] + , ["keepalives_count"] + , ["sslmode"] + , ["sslcompression"] + , ["sslcert"] + , ["sslkey"] + , ["sslrootcert"] + , ["sslcrl"] + , ["requirepeer"] + , ["krbsrvname"] + , ["gsslib"] + , ["service"] + ] + connstr <- mconcat <$> mapM showParam params + extra <- TB.fromText <$> C.lookupDefault "" config "connectionString" + return $! T.encodeUtf8 (TL.toStrict (TB.toLazyText (connstr ++ extra))) + where + qt = TB.singleton '\'' + bs = TB.singleton '\\' + sp = TB.singleton ' ' + eq = TB.singleton '=' + lookupConfig = foldr (\name names -> do + mval <- C.lookup config name + case mval of + Nothing -> names + Just _ -> return mval) + (return Nothing) + showParam [] = undefined + showParam names@(name:_) = do + mval :: Maybe C.Value <- lookupConfig names + let key = TB.fromText name ++ eq + case mval of + Nothing -> return mempty + Just (C.Bool x) -> return (key ++ showBool x ++ sp) + Just (C.String x) -> return (key ++ showText x ++ sp) + Just (C.Number x) -> return (key ++ showNum x ++ sp) + Just (C.List _) -> return mempty + + showBool x = TB.decimal (fromEnum x) + + showNum x = TB.formatRealFloat TB.Fixed Nothing + ( fromIntegral (numerator x) + / fromIntegral (denominator x) :: Double ) + + showText x = qt ++ loop x + where + loop (T.break escapeNeeded -> (a,b)) + = TB.fromText a ++ + case T.uncons b of + Nothing -> qt + Just (c,b') -> escapeChar c ++ loop b' + + escapeNeeded c = c == '\'' || c == '\\' + + escapeChar c = case c of + '\'' -> bs ++ qt + '\\' -> bs ++ bs + _ -> TB.singleton c + + + ------------------------------------------------------------------------------ -- | Initialize the snaplet pgsInit :: SnapletInit b Postgres pgsInit = makeSnaplet "postgresql-simple" description datadir $ do config <- getSnapletUserConfig - (mci,errs) <- runWriterT $ do - host <- logErr "Must specify postgres host" $ C.lookup config "host" - port <- logErr "Must specify postgres port" $ C.lookup config "port" - user <- logErr "Must specify postgres user" $ C.lookup config "user" - pwd <- logErr "Must specify postgres pass" $ C.lookup config "pass" - db <- logErr "Must specify postgres db" $ C.lookup config "db" - return $ P.ConnectInfo <$> host <*> port <*> user <*> pwd <*> db - let ci = fromMaybe (error $ intercalate "\n" errs) mci - + connstr <- liftIO $ getConnectionString config stripes <- liftIO $ C.lookupDefault 1 config "numStripes" idle <- liftIO $ C.lookupDefault 5 config "idleTime" resources <- liftIO $ C.lookupDefault 20 config "maxResourcesPerStripe" - pool <- liftIO $ createPool (P.connect ci) P.close stripes + pool <- liftIO $ createPool (P.connectPostgreSQL connstr) P.close stripes (realToFrac (idle :: Double)) resources return $ Postgres pool where @@ -376,5 +451,3 @@ formatQuery :: (ToRow q, HasPostgres m, MonadCatchIO m) => P.Query -> q -> m ByteString formatQuery q qs = withPG (\c -> P.formatQuery c q qs) - -