diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -15,3 +15,5 @@ Manuel Gómez Michael Snoyman Adam Bergmark +Tobias Florek +Francesco Mazzoli diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -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 diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs --- a/src/Database/PostgreSQL/Simple.hs +++ b/src/Database/PostgreSQL/Simple.hs @@ -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 -- diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs --- a/src/Database/PostgreSQL/Simple/FromField.hs +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -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 diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs --- a/src/Database/PostgreSQL/Simple/ToField.hs +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -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 diff --git a/src/Database/PostgreSQL/Simple/ToField.hs-boot b/src/Database/PostgreSQL/Simple/ToField.hs-boot --- a/src/Database/PostgreSQL/Simple/ToField.hs-boot +++ b/src/Database/PostgreSQL/Simple/ToField.hs-boot @@ -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 diff --git a/src/Database/PostgreSQL/Simple/ToRow.hs-boot b/src/Database/PostgreSQL/Simple/ToRow.hs-boot --- a/src/Database/PostgreSQL/Simple/ToRow.hs-boot +++ b/src/Database/PostgreSQL/Simple/ToRow.hs-boot @@ -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) diff --git a/src/Database/PostgreSQL/Simple/Types.hs b/src/Database/PostgreSQL/Simple/Types.hs --- a/src/Database/PostgreSQL/Simple/Types.hs +++ b/src/Database/PostgreSQL/Simple/Types.hs @@ -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 for +-- more information. +data Values a = Values [QualifiedIdentifier] [a] deriving (Eq, Ord, Show, Read, Typeable) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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