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.1.1 +Version: 0.1.2 Synopsis: Mid-Level PostgreSQL client library Description: Mid-Level PostgreSQL client library, forked from mysql-simple. @@ -12,7 +12,7 @@ Category: Database Build-type: Simple -Cabal-version: >=1.6 +Cabal-version: >= 1.9.2 Library hs-source-dirs: src @@ -37,7 +37,6 @@ Build-depends: attoparsec >= 0.8.5.3, base < 5, - base16-bytestring, blaze-builder, blaze-textual, bytestring >= 0.9, @@ -63,4 +62,20 @@ source-repository this type: git location: http://github.com/lpsmith/postgresql-simple - tag: v0.1.1 + tag: v0.1.2 + +test-suite test + type: exitcode-stdio-1.0 + + hs-source-dirs: test + main-is: Main.hs + other-modules: + Bytea + + build-depends: base + , base16-bytestring + , bytestring + , cryptohash + , HUnit + , postgresql-simple + , text 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 @@ -54,6 +54,7 @@ , In(..) , Binary(..) , Only(..) + , (:.)(..) -- ** Exceptions , SqlError(..) , FormatError(fmtMessage, fmtQuery, fmtParams) @@ -113,7 +114,6 @@ ( Exception, onException, throw, throwIO, finally ) import Control.Monad (foldM) import Data.ByteString (ByteString) -import Data.Char(ord) import Data.Int (Int64) import qualified Data.IntMap as IntMap import Data.List (intersperse) @@ -128,11 +128,13 @@ import Database.PostgreSQL.Simple.ToField (Action(..), inQuotes) import Database.PostgreSQL.Simple.ToRow (ToRow(..)) import Database.PostgreSQL.Simple.Types - ( Binary(..), In(..), Only(..), Query(..) ) + ( Binary(..), In(..), Only(..), Query(..), (:.)(..) ) import Database.PostgreSQL.Simple.Internal as Base import qualified Database.PostgreSQL.LibPQ as PQ import Text.Regex.PCRE.Light (compile, caseless, match) import qualified Data.ByteString.Char8 as B +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE import qualified Data.Vector as V import Control.Monad.Trans.Reader import Control.Monad.Trans.State.Strict @@ -148,15 +150,6 @@ instance Exception FormatError --- | Exception thrown if 'query' is used to perform an @INSERT@-like --- operation, or 'execute' is used to perform a @SELECT@-like operation. -data QueryError = QueryError { - qeMessage :: String - , qeQuery :: Query - } deriving (Eq, Show, Typeable) - -instance Exception QueryError - -- | Format a query string. -- -- This function is exposed to help with debugging and logging. Do not @@ -202,16 +195,29 @@ \([^?]*)$" [caseless] -escapeStringConn :: Connection -> ByteString -> IO (Maybe ByteString) -escapeStringConn conn s = withConnection conn $ \c -> do - PQ.escapeStringConn c s +escapeStringConn :: Connection -> ByteString -> IO (Either ByteString ByteString) +escapeStringConn conn s = + withConnection conn $ \c -> + PQ.escapeStringConn c s >>= checkError c +escapeByteaConn :: Connection -> ByteString -> IO (Either ByteString ByteString) +escapeByteaConn conn s = + withConnection conn $ \c -> + PQ.escapeByteaConn c s >>= checkError c + +checkError :: PQ.Connection -> Maybe a -> IO (Either ByteString a) +checkError _ (Just x) = return $ Right x +checkError c Nothing = Left . maybe "" id <$> PQ.errorMessage c + buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder buildQuery conn q template xs = zipParams (split template) <$> mapM sub xs - where quote = inQuotes . fromByteString . maybe undefined id - sub (Plain b) = pure b - sub (Escape s) = quote <$> escapeStringConn conn s - sub (Many ys) = mconcat <$> mapM sub ys + where quote = either (\msg -> fmtError (utf8ToString msg) q xs) + (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 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 `mappend` p `mappend` zipParams ts ps @@ -231,12 +237,6 @@ result <- exec conn =<< formatQuery conn template qs finishExecute conn template result --- | A version of 'execute' that does not perform query substitution. -execute_ :: Connection -> Query -> IO Int64 -execute_ conn q@(Query stmt) = do - result <- exec conn stmt - finishExecute conn q result - -- | Execute a multi-row @INSERT@, @UPDATE@, or other SQL query that is not -- expected to return results. -- @@ -249,44 +249,6 @@ result <- exec conn =<< formatMany conn q qs finishExecute conn q result -finishExecute :: Connection -> Query -> PQ.Result -> IO Int64 -finishExecute _conn q result = do - status <- PQ.resultStatus result - case status of - PQ.CommandOk -> do - ncols <- PQ.nfields result - if ncols /= 0 - then throwIO $ QueryError ("execute resulted in " ++ show ncols ++ - "-column result") q - else do - nstr <- PQ.cmdTuples result - return $ case nstr of - Nothing -> 0 -- is this appropriate? - Just str -> toInteger str - PQ.TuplesOk -> do - ncols <- PQ.nfields result - throwIO $ QueryError ("execute resulted in " ++ show ncols ++ - "-column result") q - PQ.CopyIn -> fail "FIXME: postgresql-simple does not currently support COPY IN" - PQ.CopyOut -> fail "FIXME: postgresql-simple does not currently support COPY OUT" - _ -> do - errormsg <- maybe "" id <$> PQ.resultErrorMessage result - statusmsg <- PQ.resStatus status - state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate - throwIO $ SqlError { sqlState = state - , sqlNativeError = fromEnum status - , sqlErrorMsg = B.concat [ "execute: ", statusmsg - , ": ", errormsg ]} - where - toInteger str = B.foldl' delta 0 str - where - delta acc c = - if '0' <= c && c <= '9' - then 10 * acc + fromIntegral (ord c - ord '0') - else error ("finishExecute: not an int: " ++ B.unpack str) - - - -- | Perform a @SELECT@ or other SQL query that is expected to return -- results. All results are retrieved and converted before this -- function returns. @@ -467,6 +429,8 @@ finishQuery conn q result = do status <- PQ.resultStatus result case status of + PQ.EmptyQuery -> + throwIO $ QueryError "query: Empty query" q PQ.CommandOk -> do throwIO $ QueryError "query resulted in a command response" q PQ.TuplesOk -> do @@ -494,6 +458,13 @@ Errors [] -> throwIO $ ConversionFailed "" "" "unknown error" Errors [x] -> throwIO x Errors xs -> throwIO $ ManyErrors xs + PQ.CopyOut -> + throwIO $ QueryError "query: COPY TO is not supported" q + PQ.CopyIn -> + throwIO $ QueryError "query: COPY FROM is not supported" q + PQ.BadResponse -> throwResultError "query" result status + PQ.NonfatalError -> throwResultError "query" result status + PQ.FatalError -> throwResultError "query" result status ellipsis :: ByteString -> ByteString ellipsis bs @@ -611,9 +582,10 @@ , fmtQuery = q , fmtParams = map twiddle xs } - where twiddle (Plain b) = toByteString b - twiddle (Escape 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 (Many ys) = B.concat (map twiddle ys) -- $use -- diff --git a/src/Database/PostgreSQL/Simple/FromRow.hs b/src/Database/PostgreSQL/Simple/FromRow.hs --- a/src/Database/PostgreSQL/Simple/FromRow.hs +++ b/src/Database/PostgreSQL/Simple/FromRow.hs @@ -33,7 +33,7 @@ import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.Internal import Database.PostgreSQL.Simple.FromField -import Database.PostgreSQL.Simple.Types +import Database.PostgreSQL.Simple.Types ((:.)(..)) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader diff --git a/src/Database/PostgreSQL/Simple/Internal.hs b/src/Database/PostgreSQL/Simple/Internal.hs --- a/src/Database/PostgreSQL/Simple/Internal.hs +++ b/src/Database/PostgreSQL/Simple/Internal.hs @@ -25,6 +25,10 @@ import Control.Exception import Control.Concurrent.MVar import Data.ByteString(ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import Data.Char (ord) +import Data.Int (Int64) import qualified Data.IntMap as IntMap import Data.String import Data.Typeable @@ -33,6 +37,7 @@ import qualified Database.PostgreSQL.LibPQ as PQ import Database.PostgreSQL.Simple.BuiltinTypes (BuiltinType) import Database.PostgreSQL.Simple.Ok +import Database.PostgreSQL.Simple.Types (Query(..)) import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader import qualified Data.Vector as V @@ -86,6 +91,15 @@ instance Exception SqlError +-- | Exception thrown if 'query' is used to perform an @INSERT@-like +-- operation, or 'execute' is used to perform a @SELECT@-like operation. +data QueryError = QueryError { + qeMessage :: String + , qeQuery :: Query + } deriving (Eq, Show, Typeable) + +instance Exception QueryError + data ConnectInfo = ConnectInfo { connectHost :: String , connectPort :: Word16 @@ -138,6 +152,8 @@ PQ.ConnectionOk -> do connectionHandle <- newMVar conn connectionObjects <- newMVar (IntMap.empty) + let wconn = Connection{..} + _ <- execute_ wconn "SET standard_conforming_strings TO on" return Connection{..} _ -> do msg <- maybe "connectPostgreSQL error" id <$> PQ.errorMessage conn @@ -197,6 +213,56 @@ , sqlState = "" } Just res -> do return res + +-- | A version of 'execute' that does not perform query substitution. +execute_ :: Connection -> Query -> IO Int64 +execute_ conn q@(Query stmt) = do + result <- exec conn stmt + finishExecute conn q result + +finishExecute :: Connection -> Query -> PQ.Result -> IO Int64 +finishExecute _conn q result = do + status <- PQ.resultStatus result + case status of + PQ.EmptyQuery -> throwIO $ QueryError "execute: Empty query" q + PQ.CommandOk -> do + ncols <- PQ.nfields result + if ncols /= 0 + then throwIO $ QueryError ("execute resulted in " ++ show ncols ++ + "-column result") q + else do + nstr <- PQ.cmdTuples result + return $ case nstr of + Nothing -> 0 -- is this appropriate? + Just str -> toInteger str + PQ.TuplesOk -> do + ncols <- PQ.nfields result + throwIO $ QueryError ("execute resulted in " ++ show ncols ++ + "-column result") q + PQ.CopyOut -> + throwIO $ QueryError "execute: COPY TO is not supported" q + PQ.CopyIn -> + throwIO $ QueryError "execute: COPY FROM is not supported" q + PQ.BadResponse -> throwResultError "execute" result status + PQ.NonfatalError -> throwResultError "execute" result status + PQ.FatalError -> throwResultError "execute" result status + where + toInteger str = B8.foldl' delta 0 str + where + delta acc c = + if '0' <= c && c <= '9' + then 10 * acc + fromIntegral (ord c - ord '0') + else error ("finishExecute: not an int: " ++ B8.unpack str) + +throwResultError :: ByteString -> PQ.Result -> PQ.ExecStatus -> IO a +throwResultError context result status = do + errormsg <- maybe "" id <$> PQ.resultErrorMessage result + statusmsg <- PQ.resStatus status + state <- maybe "" id <$> PQ.resultErrorField result PQ.DiagSqlstate + throwIO $ SqlError { sqlState = state + , sqlNativeError = fromEnum status + , sqlErrorMsg = B.concat [ context, ": ", statusmsg + , ": ", errormsg ]} disconnectedError :: SqlError disconnectedError = SqlError { 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 @@ -21,13 +21,10 @@ , inQuotes ) where -import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, - toByteString) +import Blaze.ByteString.Builder (Builder, fromByteString, toByteString) import Blaze.ByteString.Builder.Char8 (fromChar) import Blaze.Text (integral, double, float) import Data.ByteString (ByteString) -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString.Base16.Lazy as L16 import Data.Int (Int8, Int16, Int32, Int64) import Data.List (intersperse) import Data.Monoid (mappend) @@ -58,14 +55,18 @@ -- ^ 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. | 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 (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 (Many b) = "Many " ++ show b -- | A type that may be used as a single parameter to a SQL query. class ToField a where @@ -88,16 +89,6 @@ (intersperse (Plain (fromChar ',')) . map toField $ xs) ++ [Plain (fromChar ')')] -instance ToField (Binary SB.ByteString) where - toField (Binary bs) = Plain $ fromByteString "'\\x" `mappend` - fromByteString (B16.encode bs) `mappend` - fromChar '\'' - -instance ToField (Binary LB.ByteString) where - toField (Binary bs) = Plain $ fromByteString "'\\x" `mappend` - fromLazyByteString (L16.encode bs) `mappend` - fromChar '\'' - renderNull :: Action renderNull = Plain (fromByteString "null") @@ -166,6 +157,14 @@ instance ToField Double where toField v | isNaN v || isInfinite v = Plain (inQuotes (double v)) | otherwise = Plain (double v) + {-# INLINE toField #-} + +instance ToField (Binary SB.ByteString) where + toField (Binary bs) = EscapeBytea bs + {-# INLINE toField #-} + +instance ToField (Binary LB.ByteString) where + toField (Binary bs) = (EscapeBytea . SB.concat . LB.toChunks) bs {-# INLINE toField #-} instance ToField SB.ByteString where 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 @@ -107,7 +107,7 @@ newtype In a = In a deriving (Eq, Ord, Read, Show, Typeable, Functor) --- | Wrap a mostly-binary string to be escaped in hexadecimal. +-- | Wrap binary data for use as a @bytea@ value. newtype Binary a = Binary a deriving (Eq, Ord, Read, Show, Typeable, Functor)