postgresql-simple 0.4.0.2 → 0.4.1.0
raw patch · 9 files changed
+225/−26 lines, 9 filesdep +hashabledep +scientificdep ~postgresql-libpq
Dependencies added: hashable, scientific
Dependency ranges changed: postgresql-libpq
Files
- CONTRIBUTORS +2/−0
- postgresql-simple.cabal +5/−3
- src/Database/PostgreSQL/Simple.hs +25/−15
- src/Database/PostgreSQL/Simple/FromField.hs +7/−3
- src/Database/PostgreSQL/Simple/ToField.hs +78/−4
- src/Database/PostgreSQL/Simple/ToField.hs-boot +23/−0
- src/Database/PostgreSQL/Simple/ToRow.hs-boot +2/−1
- src/Database/PostgreSQL/Simple/Types.hs +70/−0
- test/Main.hs +13/−0
CONTRIBUTORS view
@@ -15,3 +15,5 @@ Manuel Gómez <targen@gmail.com> Michael Snoyman <michael@snoyman.com> Adam Bergmark <adam@edea.se>+Tobias Florek <tob@butter.sh>+Francesco Mazzoli <francesco.mazzoli@erudify.com>
postgresql-simple.cabal view
@@ -1,5 +1,5 @@ Name: postgresql-simple-Version: 0.4.0.2+Version: 0.4.1.0 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple.@@ -59,12 +59,14 @@ blaze-textual, bytestring >= 0.9, containers,- postgresql-libpq >= 0.6.2,+ hashable,+ postgresql-libpq >= 0.9, template-haskell, text >= 0.11.1, time, transformers, uuid >= 1.3.1,+ scientific, vector extensions: DoAndIfThenElse, OverloadedStrings, BangPatterns, ViewPatterns@@ -79,7 +81,7 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple- tag: v0.4.0.2+ tag: v0.4.1.0 test-suite test type: exitcode-stdio-1.0
src/Database/PostgreSQL/Simple.hs view
@@ -287,14 +287,21 @@ skipSpace = B.dropWhile isSpace_ascii escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString)-escapeStringConn conn s =- withConnection conn $ \c ->- PQ.escapeStringConn c s >>= checkError c+escapeStringConn = escapeWrap PQ.escapeStringConn +escapeIdentifier :: Connection -> ByteString -> IO (Either ByteString ByteString)+escapeIdentifier = escapeWrap PQ.escapeIdentifier+ escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString)-escapeByteaConn conn s =+escapeByteaConn = escapeWrap PQ.escapeByteaConn++escapeWrap :: (PQ.Connection -> ByteString -> IO (Maybe ByteString))+ -> Connection+ -> ByteString+ -> IO (Either ByteString ByteString)+escapeWrap f conn s = withConnection conn $ \c ->- PQ.escapeByteaConn c s >>= checkError c+ f c s >>= checkError c checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a) checkError _ (Just x) = return $ Right x@@ -302,13 +309,15 @@ buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder buildQuery conn q template xs = zipParams (split template) <$> mapM sub xs- where quote = either (\msg -> fmtError (utf8ToString msg) q xs)- (inQuotes . fromByteString)+ where err' msg = fmtError (utf8ToString msg) q xs+ quote = either err' (inQuotes . fromByteString) utf8ToString = T.unpack . TE.decodeUtf8- sub (Plain b) = pure b- sub (Escape s) = quote <$> escapeStringConn conn s- sub (EscapeByteA s) = quote <$> escapeByteaConn conn s- sub (Many ys) = mconcat <$> mapM sub ys+ sub (Plain b) = pure b+ sub (Escape s) = quote <$> escapeStringConn conn s+ sub (EscapeByteA s) = quote <$> escapeByteaConn conn s+ sub (EscapeIdentifier s) = either err' fromByteString <$>+ escapeIdentifier conn s+ sub (Many ys) = mconcat <$> mapM sub ys split s = fromByteString h : if B.null t then [] else split (B.tail t) where (h,t) = B.break (=='?') s zipParams (t:ts) (p:ps) = t <> p <> zipParams ts ps@@ -606,10 +615,11 @@ , fmtQuery = q , fmtParams = map twiddle xs }- where twiddle (Plain b) = toByteString b- twiddle (Escape s) = s- twiddle (EscapeByteA s) = s- twiddle (Many ys) = B.concat (map twiddle ys)+ where twiddle (Plain b) = toByteString b+ twiddle (Escape s) = s+ twiddle (EscapeByteA s) = s+ twiddle (EscapeIdentifier s) = s+ twiddle (Many ys) = B.concat (map twiddle ys) -- $use --
src/Database/PostgreSQL/Simple/FromField.hs view
@@ -444,9 +444,13 @@ where delim = typdelim (typelem typeInfo) fElem = f{ typeOid = typoid (typelem typeInfo) }- parseIt item = (fromField f' . Just . fmt delim) item- where f' | Arrays.Array _ <- item = f- | otherwise = fElem++ parseIt item =+ fromField f' $ if item' == "NULL" then Nothing else Just item'+ where+ item' = fmt delim item+ f' | Arrays.Array _ <- item = f+ | otherwise = fElem instance (FromField a, Typeable a) => FromField (Vector a) where fromField f v = V.fromList . fromPGArray <$> fromField f v
src/Database/PostgreSQL/Simple/ToField.hs view
@@ -33,6 +33,7 @@ import Data.Time (Day, TimeOfDay, LocalTime, UTCTime, ZonedTime) import Data.Typeable (Typeable) import Data.Word (Word, Word8, Word16, Word32, Word64)+import {-# SOURCE #-} Database.PostgreSQL.Simple.ToRow import Database.PostgreSQL.Simple.Types import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8 import qualified Data.ByteString as SB@@ -61,15 +62,20 @@ | EscapeByteA ByteString -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding -- quotes. This is used by the 'Binary' newtype wrapper.+ | EscapeIdentifier ByteString+ -- ^ Escape before substituting. Use for all sql identifiers like+ -- table, column names, etc. This is used by the 'Identifier' newtype+ -- wrapper. | Many [Action] -- ^ Concatenate a series of rendering actions. deriving (Typeable) instance Show Action where- show (Plain b) = "Plain " ++ show (toByteString b)- show (Escape b) = "Escape " ++ show b- show (EscapeByteA b) = "EscapeByteA " ++ show b- show (Many b) = "Many " ++ show b+ show (Plain b) = "Plain " ++ show (toByteString b)+ show (Escape b) = "Escape " ++ show b+ show (EscapeByteA b) = "EscapeByteA " ++ show b+ show (EscapeIdentifier b) = "EscapeIdentifier " ++ show b+ show (Many b) = "Many " ++ show b -- | A type that may be used as a single parameter to a SQL query. class ToField a where@@ -174,6 +180,18 @@ toField (Binary bs) = (EscapeByteA . SB.concat . LB.toChunks) bs {-# INLINE toField #-} +instance ToField Identifier where+ toField (Identifier bs) = EscapeIdentifier bs+ {-# INLINE toField #-}++instance ToField QualifiedIdentifier where+ toField (QualifiedIdentifier (Just s) t) = Many [ EscapeIdentifier s+ , Plain (fromChar '.')+ , EscapeIdentifier t+ ]+ toField (QualifiedIdentifier Nothing t) = EscapeIdentifier t+ {-# INLINE toField #-}+ instance ToField SB.ByteString where toField = Escape {-# INLINE toField #-}@@ -262,3 +280,59 @@ inQuotes :: Builder -> Builder inQuotes b = quote `mappend` b `mappend` quote where quote = Utf8.fromChar '\''++interleaveFoldr :: (a -> [b] -> [b]) -> b -> [b] -> [a] -> [b]+interleaveFoldr f b bs as = foldr (\a bs -> b : f a bs) bs as+{-# INLINE interleaveFoldr #-}++instance ToRow a => ToField (Values a) where+ toField (Values types rows) =+ case rows of+ [] -> case types of+ [] -> error err+ (_:_) -> values $ typedRow (repeat (lit "null"))+ types+ [lit " LIMIT 0)"]+ (_:_) -> case types of+ [] -> values $ untypedRows rows [litC ')']+ (_:_) -> values $ typedRows rows types [litC ')']+ where+ err = "Database.PostgreSQL.Simple.toField :: Values -> Action either values or types must be non-empty"+ lit = Plain . fromByteString+ litC = Plain . fromChar+ values x = Many (lit "(VALUES ": x)++ typedField :: (Action, QualifiedIdentifier) -> [Action] -> [Action]+ typedField (val,typ) rest = val : lit "::" : toField typ : rest++ typedRow :: [Action] -> [QualifiedIdentifier] -> [Action] -> [Action]+ typedRow (val:vals) (typ:typs) rest =+ litC '(' :+ typedField (val,typ) ( interleaveFoldr+ typedField+ (litC ',')+ (litC ')' : rest)+ (zip vals typs) )++ untypedRow :: [Action] -> [Action] -> [Action]+ untypedRow (val:vals) rest =+ litC '(' : val :+ interleaveFoldr+ (:)+ (litC ',')+ (litC ')' : rest)+ vals++ typedRows :: ToRow a => [a] -> [QualifiedIdentifier] -> [Action] -> [Action]+ typedRows (val:vals) types rest =+ typedRow (toRow val) types (litC ',' : untypedRows vals rest)++ untypedRows :: ToRow a => [a] -> [Action] -> [Action]+ untypedRows [] rest = rest+ untypedRows (val:vals) rest =+ untypedRow (toRow val) $+ interleaveFoldr+ (untypedRow . toRow)+ (litC ',')+ rest+ vals
src/Database/PostgreSQL/Simple/ToField.hs-boot view
@@ -1,6 +1,29 @@ module Database.PostgreSQL.Simple.ToField where import Database.PostgreSQL.Simple.Types+import Blaze.ByteString.Builder(Builder)+import Data.ByteString(ByteString)++-- | How to render an element when substituting it into a query.+data Action =+ Plain Builder+ -- ^ Render without escaping or quoting. Use for non-text types+ -- such as numbers, when you are /certain/ that they will not+ -- introduce formatting vulnerabilities via use of characters such+ -- as spaces or \"@'@\".+ | Escape ByteString+ -- ^ Escape and enclose in quotes before substituting. Use for all+ -- text-like types, and anything else that may contain unsafe+ -- characters when rendered.+ | EscapeByteA ByteString+ -- ^ Escape binary data for use as a @bytea@ literal. Include surrounding+ -- quotes. This is used by the 'Binary' newtype wrapper.+ | EscapeIdentifier ByteString+ -- ^ Escape before substituting. Use for all sql identifiers like+ -- table, column names, etc. This is used by the 'Identifier' newtype+ -- wrapper.+ | Many [Action]+ -- ^ Concatenate a series of rendering actions. class ToField a
src/Database/PostgreSQL/Simple/ToRow.hs-boot view
@@ -3,6 +3,7 @@ import Database.PostgreSQL.Simple.Types import {-# SOURCE #-} Database.PostgreSQL.Simple.ToField -class ToRow a+class ToRow a where+ toRow :: a -> [Action] instance ToField a => ToRow (Only a)
src/Database/PostgreSQL/Simple/Types.hs view
@@ -20,16 +20,20 @@ , Only(..) , In(..) , Binary(..)+ , Identifier(..)+ , QualifiedIdentifier(..) , Query(..) , Oid(..) , (:.)(..) , Savepoint(..) , PGArray(..)+ , Values(..) ) where import Blaze.ByteString.Builder (toByteString) import Control.Arrow (first) import Data.ByteString (ByteString)+import Data.Hashable (Hashable(hashWithSalt)) import Data.Monoid (Monoid(..)) import Data.String (IsString(..)) import Data.Typeable (Typeable)@@ -118,7 +122,32 @@ newtype Binary a = Binary {fromBinary :: a} deriving (Eq, Ord, Read, Show, Typeable, Functor) +-- | Wrap text for use as sql identifier, i.e. a table or column name.+newtype Identifier = Identifier {fromIdentifier :: ByteString}+ deriving (Eq, Ord, Read, Show, Typeable) +instance IsString Identifier where+ fromString = Identifier . toByteString . Utf8.fromString++instance Hashable Identifier where+ hashWithSalt i (Identifier t) = hashWithSalt i t++-- | Wrap text for use as (maybe) qualified identifier, i.e. a table+-- with schema, or column with table.+data QualifiedIdentifier = QualifiedIdentifier (Maybe ByteString) ByteString+ deriving (Eq, Ord, Read, Show, Typeable)++instance Hashable QualifiedIdentifier where+ hashWithSalt i (QualifiedIdentifier q t) = hashWithSalt i (q, t)++instance IsString QualifiedIdentifier where+ fromString str = let (x,y) = B.break (== 46)+ . toByteString+ . Utf8.fromString $ str+ in if B.null y+ then QualifiedIdentifier Nothing x+ else QualifiedIdentifier (Just x) (B.tail y)+ -- | Wrap a list for use as a PostgreSQL array. newtype PGArray a = PGArray {fromPGArray :: [a]} deriving (Eq, Ord, Read, Show, Typeable, Functor)@@ -144,4 +173,45 @@ infixr 3 :. newtype Savepoint = Savepoint Query+ deriving (Eq, Ord, Show, Read, Typeable)++-- | Represents a @VALUES@ table literal, usable as an alternative+-- to @executeMany@ and @returning@. For example:+--+-- > execute c "INSERT INTO table (key,val) ?"+-- > (Only (Values ["int4","text"]+-- > [(1,"hello"),(2,"world")]))+--+-- Issues the following query:+--+-- > INSERT INTO table (key,val) (VALUES (1::"int4",'hello'::"text"),(2,'world'))+--+-- When the list of values is empty, the following query will be issued:+--+-- > INSERT INTO table (key,val) (VALUES (null::"int4",null::"text") LIMIT 0)+--+-- By contrast, @executeMany@ and @returning@ don't issue the query+-- in the empty case, and simply return @0@ and @[]@ respectively.+--+-- The advantage over @executeMany@ is in cases when you want to+-- parameterize table literals in addition to other parameters, as can+-- occur with writable common table expressions, for example.+--+-- The first argument is a list of postgresql type names. Because this+-- is turned into a properly quoted identifier, the type name is case+-- sensitive and must be as it appears in the @pg_type@ table. Thus,+-- you must write @timestamptz@ instead of @timestamp with time zone@,+-- @int4@ instead of @integer@, @_int8@ instead of @bigint[]@, etcetera.+--+-- You may omit the type names, however, if you do so the list+-- of values must be non-empty, and postgresql must be able to infer+-- the types of the columns from the surrounding context. If these+-- conditions are not met, postgresql-simple will throw an exception+-- without issuing the query in the former case, and in the latter+-- the postgres server will return an error which will be turned into+-- a @SqlError@ exception.+--+-- See <http://www.postgresql.org/docs/9.3/static/sql-values.html> for+-- more information.+data Values a = Values [QualifiedIdentifier] [a] deriving (Eq, Ord, Show, Read, Typeable)
test/Main.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} import Common import Database.PostgreSQL.Simple.FromField (FromField)+import Database.PostgreSQL.Simple.Types(Query(..)) import Database.PostgreSQL.Simple.HStore import qualified Database.PostgreSQL.Simple.Transaction as ST import Control.Applicative@@ -13,8 +14,10 @@ import Data.Typeable import qualified Data.ByteString as B import Data.Map (Map)+import Data.List (sort) import qualified Data.Map as Map import Data.Text(Text)+import qualified Data.Text.Encoding as T import System.Exit (exitFailure) import System.IO import qualified Data.Vector as V@@ -36,6 +39,7 @@ , TestLabel "HStore" . testHStore , TestLabel "JSON" . testJSON , TestLabel "Savepoint" . testSavepoint+ , TestLabel "Unicode" . testUnicode ] testBytea :: TestEnv -> Test@@ -242,6 +246,15 @@ [1,2,3] <- getRows return ()++testUnicode :: TestEnv -> Test+testUnicode TestEnv{..} = TestCase $ do+ let q = Query . T.encodeUtf8+ let messages = map Only ["привет","мир"] :: [Only Text]+ execute_ conn (q "CREATE TEMPORARY TABLE ру́сский (сообщение TEXT)")+ executeMany conn "INSERT INTO ру́сский (сообщение) VALUES (?)" messages+ messages' <- query_ conn "SELECT сообщение FROM ру́сский"+ sort messages @?= sort messages' data TestException = TestException