snaplet-postgresql-simple 0.3.0.3 → 0.4
raw patch · 3 files changed
+111/−35 lines, 3 filesdep ~clientsessiondep ~postgresql-simpledep ~snap
Dependency ranges changed: clientsession, postgresql-simple, snap, text
Files
- snaplet-postgresql-simple.cabal +5/−5
- src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs +6/−3
- src/Snap/Snaplet/PostgresqlSimple.hs +100/−27
snaplet-postgresql-simple.cabal view
@@ -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
src/Snap/Snaplet/Auth/Backends/PostgresqlSimple.hs view
@@ -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
src/Snap/Snaplet/PostgresqlSimple.hs view
@@ -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)--