diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,62 @@ +Copyright (c) 2011, Leon P Smith + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Leon P Smith nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +Copyright (c) 2011, MailRank, Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal new file mode 100644 --- /dev/null +++ b/postgresql-simple.cabal @@ -0,0 +1,56 @@ +Name: postgresql-simple +Version: 0.0 +Synopsis: Mid-Level PostgreSQL client library +Description: + Mid-Level PostgreSQL client library, forked from mysql-simple. +License: BSD3 +License-file: LICENSE +Author: Bryan O'Sullivan, Leon P Smith +Maintainer: Leon P Smith +Copyright: (c) 2011 MailRank, Inc. + (c) 2011 Leon P Smith +Category: Database +Build-type: Simple + +Cabal-version: >=1.6 + +Library + hs-source-dirs: src + Exposed-modules: + Database.PostgreSQL.Simple + Database.PostgreSQL.Simple.BuiltinTypes + Database.PostgreSQL.Simple.Field + Database.PostgreSQL.Simple.LargeObjects + Database.PostgreSQL.Simple.Notification + Database.PostgreSQL.Simple.Param + Database.PostgreSQL.Simple.QueryParams + Database.PostgreSQL.Simple.QueryResults + Database.PostgreSQL.Simple.Result + Database.PostgreSQL.Simple.SqlQQ + Database.PostgreSQL.Simple.Types +-- Other-modules: + Database.PostgreSQL.Simple.Internal + + Build-depends: + attoparsec >= 0.8.5.3, + base < 5, + base16-bytestring, + blaze-builder, + blaze-textual, + bytestring >= 0.9, + containers, + postgresql-libpq >= 0.6, + pcre-light, + old-locale, + template-haskell, + text >= 0.11.0.2, + time + +source-repository head + type: git + location: http://github.com/lpsmith/postgresql-simple + +source-repository this + type: git + location: http://github.com/lpsmith/postgresql-simple + tag: v0.0 diff --git a/src/Database/PostgreSQL/Simple.hs b/src/Database/PostgreSQL/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple.hs @@ -0,0 +1,749 @@ +{-# LANGUAGE BangPatterns, DeriveDataTypeable, OverloadedStrings #-} +{-# LANGUAGE DoAndIfThenElse, RecordWildCards, NamedFieldPuns #-} +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- Portability: portable +-- +-- A mid-level client library for the PostgreSQL database, aimed at ease of +-- use and high performance. +-- +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple + ( + -- * Writing queries + -- $use + + -- ** The Query type + -- $querytype + + -- ** Parameter substitution + -- $subst + + -- *** Type inference + -- $inference + + -- ** Substituting a single parameter + -- $only_param + + -- ** Representing a list of values + -- $in + + -- ** Modifying multiple rows at once + -- $many + + -- * Extracting results + -- $result + + -- ** Handling null values + -- $null + + -- ** Type conversions + -- $types + + -- * Types + Base.ConnectInfo(..) + , Connection + , Query + , In(..) + , Binary(..) + , Only(..) + -- ** Exceptions + , FormatError(fmtMessage, fmtQuery, fmtParams) + , QueryError(qeMessage, qeQuery) + , ResultError(errSQLType, errHaskellType, errMessage) + -- * Connection management + , Base.connect + , Base.connectPostgreSQL + , Base.postgreSQLConnectionString + , Base.defaultConnectInfo + , Base.close + -- * Queries that return results + , query + , query_ +{-- + -- * Queries that stream results + , fold + , fold_ + , forEach + , forEach_ +--} + -- * Statements that do not return results + , execute + , execute_ + , executeMany +-- , Base.insertID + -- * Transaction handling + , withTransaction +-- , Base.autocommit + , begin + , commit + , rollback + -- * Helper functions + , formatMany + , formatQuery + ) where + +import Blaze.ByteString.Builder (Builder, fromByteString, toByteString) +import Blaze.ByteString.Builder.Char8 (fromChar) +import Control.Applicative ((<$>), pure) +import Control.Concurrent.MVar +import Control.Exception (Exception, bracket, onException, throw, throwIO) +import Control.Monad (forM) +import Control.Monad.Fix (fix) +import Data.ByteString (ByteString) +-- import qualified Data.ByteString as B (unpack) +import Data.Char(ord) +import Data.Int (Int64) +import qualified Data.IntMap as IntMap +import Data.List (intersperse) +import Data.Monoid (mappend, mconcat) +import Data.Typeable (Typeable) +--import Database.MySQL.Base (Connection, Result) +--import Database.MySQL.Base.Types (Field) +import Database.PostgreSQL.Simple.BuiltinTypes (oid2builtin, builtin2typname) +import Database.PostgreSQL.Simple.Param (Action(..), inQuotes) +import Database.PostgreSQL.Simple.QueryParams (QueryParams(..)) +import Database.PostgreSQL.Simple.Result (ResultError(..)) +import Database.PostgreSQL.Simple.QueryResults (QueryResults(..)) +-- import Database.PostgreSQL.Simple.Result (ResultError(..)) +import Database.PostgreSQL.Simple.Types (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 Database.MySQL.Base as Base + +-- | Exception thrown if a 'Query' could not be formatted correctly. +-- This may occur if the number of \'@?@\' characters in the query +-- string does not match the number of parameters provided. +data FormatError = FormatError { + fmtMessage :: String + , fmtQuery :: Query + , fmtParams :: [ByteString] + } deriving (Eq, Show, Typeable) + +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 +-- use it to prepare queries for execution. +-- +-- String parameters are escaped according to the character set in use +-- on the 'Connection'. +-- +-- Throws 'FormatError' if the query string could not be formatted +-- correctly. +formatQuery :: QueryParams q => Connection -> Query -> q -> IO ByteString +formatQuery conn q@(Query template) qs + | null xs && '?' `B.notElem` template = return template + | otherwise = toByteString <$> buildQuery conn q template xs + where xs = renderParams qs + +-- | Format a query string with a variable number of rows. +-- +-- This function is exposed to help with debugging and logging. Do not +-- use it to prepare queries for execution. +-- +-- The query string must contain exactly one substitution group, +-- identified by the SQL keyword \"@VALUES@\" (case insensitive) +-- followed by an \"@(@\" character, a series of one or more \"@?@\" +-- characters separated by commas, and a \"@)@\" character. White +-- space in a substitution group is permitted. +-- +-- Throws 'FormatError' if the query string could not be formatted +-- correctly. +formatMany :: (QueryParams q) => Connection -> Query -> [q] -> IO ByteString +formatMany _ q [] = fmtError "no rows supplied" q [] +formatMany conn q@(Query template) qs = do + case match re template [] of + Just [_,before,qbits,after] -> do + bs <- mapM (buildQuery conn q qbits . renderParams) qs + return . toByteString . mconcat $ fromByteString before : + intersperse (fromChar ',') bs ++ + [fromByteString after] + _ -> error "foo" + where + re = compile "^([^?]+\\bvalues\\s*)\ + \(\\(\\s*[?](?:\\s*,\\s*[?])*\\s*\\))\ + \([^?]*)$" + [caseless] + +escapeStringConn conn s = withConnection conn $ \c -> do + PQ.escapeStringConn c s + +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 + 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 + zipParams [t] [] = t + zipParams _ _ = fmtError (show (B.count '?' template) ++ + " '?' characters, but " ++ + show (length xs) ++ " parameters") q xs + +-- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not +-- expected to return results. +-- +-- Returns the number of rows affected. +-- +-- Throws 'FormatError' if the query could not be formatted correctly. +execute :: (QueryParams q) => Connection -> Query -> q -> IO Int64 +execute conn template qs = do + 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. +-- +-- Returns the number of rows affected. +-- +-- Throws 'FormatError' if the query could not be formatted correctly. +executeMany :: (QueryParams q) => Connection -> Query -> [q] -> IO Int64 +executeMany _ _ [] = return 0 +executeMany conn q qs = do + 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. +-- +-- When processing large results, this function will consume a lot of +-- client-side memory. Consider using 'fold' instead. +-- +-- Exceptions that may be thrown: +-- +-- * 'FormatError': the query string could not be formatted correctly. +-- +-- * 'QueryError': the result contains no columns (i.e. you should be +-- using 'execute' instead of 'query'). +-- +-- * 'ResultError': result conversion failed. +query :: (QueryParams q, QueryResults r) + => Connection -> Query -> q -> IO [r] +query conn template qs = do + result <- exec conn =<< formatQuery conn template qs + finishQuery conn template result + +-- | A version of 'query' that does not perform query substitution. +query_ :: (QueryResults r) => Connection -> Query -> IO [r] +query_ conn q@(Query que) = do + result <- exec conn que + finishQuery conn q result +{-- +-- | Perform a @SELECT@ or other SQL query that is expected to return +-- results. Results are streamed incrementally from the server, and +-- consumed via a left fold. +-- +-- The result consumer must be carefully written to execute +-- quickly. If the consumer is slow, server resources will be tied up, +-- and other clients may not be able to update the tables from which +-- the results are being streamed. +-- +-- When dealing with small results, it may be simpler (and perhaps +-- faster) to use 'query' instead. +-- +-- This fold is /not/ strict. The stream consumer is responsible for +-- forcing the evaluation of its result to avoid space leaks. +-- +-- Exceptions that may be thrown: +-- +-- * 'FormatError': the query string could not be formatted correctly. +-- +-- * 'QueryError': the result contains no columns (i.e. you should be +-- using 'execute' instead of 'query'). +-- +-- * 'ResultError': result conversion failed. +fold :: (QueryParams q, QueryResults r) => + Connection + -> Query -- ^ Query template. + -> q -- ^ Query parameters. + -> a -- ^ Initial state for result consumer. + -> (a -> r -> IO a) -- ^ Result consumer. + -> IO a +fold conn template qs z f = do + Base.query conn =<< formatQuery conn template qs + finishFold conn template z f +--} +{-- +-- | A version of 'fold' that does not perform query substitution. +fold_ :: (QueryResults r) => + Connection + -> Query -- ^ Query. + -> a -- ^ Initial state for result consumer. + -> (a -> r -> IO a) -- ^ Result consumer. + -> IO a +fold_ conn q@(Query que) z f = do + Base.query conn que + finishFold conn q z f +--} +{-- +-- | A version of 'fold' that does not transform a state value. +forEach :: (QueryParams q, QueryResults r) => + Connection + -> Query -- ^ Query template. + -> q -- ^ Query parameters. + -> (r -> IO ()) -- ^ Result consumer. + -> IO () +forEach conn template qs = fold conn template qs () . const +{-# INLINE forEach #-} + +-- | A version of 'forEach' that does not perform query substitution. +forEach_ :: (QueryResults r) => + Connection + -> Query -- ^ Query template. + -> (r -> IO ()) -- ^ Result consumer. + -> IO () +forEach_ conn template = fold_ conn template () . const +{-# INLINE forEach_ #-} +--} + +forM' :: (Ord n, Num n) => n -> n -> (n -> IO a) -> IO [a] +forM' lo hi m = loop hi [] + where + loop !n !as + | n < lo = return as + | otherwise = do + a <- m n + loop (n-1) (a:as) + +finishQuery :: (QueryResults r) => Connection -> Query -> PQ.Result -> IO [r] +finishQuery conn q result = do + status <- PQ.resultStatus result + case status of + PQ.CommandOk -> do + throwIO $ QueryError "query resulted in a command response" q + PQ.TuplesOk -> do + ncols <- PQ.nfields result + fields <- forM' 0 (ncols-1) $ \column -> do + type_oid <- PQ.ftype result column + typename <- getTypename conn type_oid + return Field{..} + nrows <- PQ.ntuples result + forM' 0 (nrows-1) $ \row -> do + values <- forM' 0 (ncols-1) (\col -> PQ.getvalue' result row col) + case convertResults fields values of + Left err -> throwIO err + Right a -> return a + 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 [ "query: ", statusmsg + , ": ", errormsg ]} + +{-- +withResult (Base.storeResult conn) q $ \r fs -> do + status <- +/ flip fix [] $ \loop acc -> do + row <- Base.fetchRow r + case row of + [] -> return (reverse acc) + _ -> let !c = convertResults fs row + in loop (c:acc) +--} +{-- +finishFold :: (QueryResults r) => + Connection -> Query -> a -> (a -> r -> IO a) -> IO a +finishFold conn q z0 f = withResult (Base.useResult conn) q $ \r fs -> + flip fix z0 $ \loop z -> do + row <- Base.fetchRow r + case row of + [] -> return z + _ -> (f z $! convertResults fs row) >>= loop +--} +{-- +withResult :: (IO Result) -> Query -> (Result -> [Field] -> IO a) -> IO a +withResult fetchResult q act = bracket fetchResult Base.freeResult $ \r -> do + ncols <- Base.fieldCount (Right r) + if ncols == 0 + then throwIO $ QueryError "query resulted in zero-column result" q + else act r =<< Base.fetchFields r +--} +-- | Execute an action inside a SQL transaction. +-- +-- This function initiates a transaction with a \"@begin +-- transaction@\" statement, then executes the supplied action. If +-- the action succeeds, the transaction will be completed with +-- 'Base.commit' before this function returns. +-- +-- If the action throws /any/ kind of exception (not just a +-- PostgreSQL-related exception), the transaction will be rolled back using +-- 'rollback', then the exception will be rethrown. +withTransaction :: Connection -> IO a -> IO a +withTransaction conn act = do + _ <- begin conn + r <- act `onException` rollback conn + commit conn + return r + +-- | Rollback a transaction. +-- rollback :: (MonadCatchIO m,MonadIO m) => Connection -> m () +rollback :: Connection -> IO () +rollback conn = do + _ <- execute_ conn "ABORT" + return () + +-- | Commit a transaction. +-- commit :: (MonadCatchIO m,MonadIO m) => Connection -> m () +commit :: Connection -> IO () +commit conn = do + _ <- execute_ conn "COMMIT" + return () + +-- | Begin a transaction. +-- begin :: (MonadCatchIO m,MonadIO m) => Connection -> m () +begin :: Connection -> IO () +begin conn = do + _ <- execute_ conn "BEGIN" + return () + +fmtError :: String -> Query -> [Action] -> a +fmtError msg q xs = throw FormatError { + fmtMessage = msg + , fmtQuery = q + , fmtParams = map twiddle xs + } + where twiddle (Plain b) = toByteString b + twiddle (Escape s) = s + twiddle (Many ys) = B.concat (map twiddle ys) + +-- $use +-- +-- SQL-based applications are somewhat notorious for their +-- susceptibility to attacks through the injection of maliciously +-- crafted data. The primary reason for widespread vulnerability to +-- SQL injections is that many applications are sloppy in handling +-- user data when constructing SQL queries. +-- +-- This library provides a 'Query' type and a parameter substitution +-- facility to address both ease of use and security. + +-- $querytype +-- +-- A 'Query' is a @newtype@-wrapped 'ByteString'. It intentionally +-- exposes a tiny API that is not compatible with the 'ByteString' +-- API; this makes it difficult to construct queries from fragments of +-- strings. The 'query' and 'execute' functions require queries to be +-- of type 'Query'. +-- +-- To most easily construct a query, enable GHC's @OverloadedStrings@ +-- language extension and write your query as a normal literal string. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Database.PostgreSQL.Simple +-- > +-- > hello = do +-- > conn <- connect defaultConnectInfo +-- > query conn "select 2 + 2" +-- +-- A 'Query' value does not represent the actual query that will be +-- executed, but is a template for constructing the final query. + +-- $subst +-- +-- Since applications need to be able to construct queries with +-- parameters that change, this library provides a query substitution +-- capability. +-- +-- The 'Query' template accepted by 'query' and 'execute' can contain +-- any number of \"@?@\" characters. Both 'query' and 'execute' +-- accept a third argument, typically a tuple. When constructing the +-- real query to execute, these functions replace the first \"@?@\" in +-- the template with the first element of the tuple, the second +-- \"@?@\" with the second element, and so on. If necessary, each +-- tuple element will be quoted and escaped prior to substitution; +-- this defeats the single most common injection vector for malicious +-- data. +-- +-- For example, given the following 'Query' template: +-- +-- > select * from user where first_name = ? and age > ? +-- +-- And a tuple of this form: +-- +-- > ("Boris" :: String, 37 :: Int) +-- +-- The query to be executed will look like this after substitution: +-- +-- > select * from user where first_name = 'Boris' and age > 37 +-- +-- If there is a mismatch between the number of \"@?@\" characters in +-- your template and the number of elements in your tuple, a +-- 'FormatError' will be thrown. +-- +-- Note that the substitution functions do not attempt to parse or +-- validate your query. It's up to you to write syntactically valid +-- SQL, and to ensure that each \"@?@\" in your query template is +-- matched with the right tuple element. + +-- $inference +-- +-- Automated type inference means that you will often be able to avoid +-- supplying explicit type signatures for the elements of a tuple. +-- However, sometimes the compiler will not be able to infer your +-- types. Consider a care where you write a numeric literal in a +-- parameter tuple: +-- +-- > query conn "select ? + ?" (40,2) +-- +-- The above query will be rejected by the compiler, because it does +-- not know the specific numeric types of the literals @40@ and @2@. +-- This is easily fixed: +-- +-- > query conn "select ? + ?" (40 :: Double, 2 :: Double) +-- +-- The same kind of problem can arise with string literals if you have +-- the @OverloadedStrings@ language extension enabled. Again, just +-- use an explicit type signature if this happens. + +-- $only_param +-- +-- Haskell lacks a single-element tuple type, so if you have just one +-- value you want substituted into a query, what should you do? +-- +-- The obvious approach would appear to be something like this: +-- +-- > instance (Param a) => QueryParam a where +-- > ... +-- +-- Unfortunately, this wreaks havoc with type inference, so we take a +-- different tack. To represent a single value @val@ as a parameter, write +-- a singleton list @[val]@, use 'Just' @val@, or use 'Only' @val@. +-- +-- Here's an example using a singleton list: +-- +-- > execute conn "insert into users (first_name) values (?)" +-- > ["Nuala"] + +-- $in +-- +-- Suppose you want to write a query using an @IN@ clause: +-- +-- > select * from users where first_name in ('Anna', 'Boris', 'Carla') +-- +-- In such cases, it's common for both the elements and length of the +-- list after the @IN@ keyword to vary from query to query. +-- +-- To address this case, use the 'In' type wrapper, and use a single +-- \"@?@\" character to represent the list. Omit the parentheses +-- around the list; these will be added for you. +-- +-- Here's an example: +-- +-- > query conn "select * from users where first_name in ?" $ +-- > In ["Anna", "Boris", "Carla"] +-- +-- If your 'In'-wrapped list is empty, the string @\"(null)\"@ will be +-- substituted instead, to ensure that your clause remains +-- syntactically valid. + +-- $many +-- +-- If you know that you have many rows of data to insert into a table, +-- it is much more efficient to perform all the insertions in a single +-- multi-row @INSERT@ statement than individually. +-- +-- The 'executeMany' function is intended specifically for helping +-- with multi-row @INSERT@ and @UPDATE@ statements. Its rules for +-- query substitution are different than those for 'execute'. +-- +-- What 'executeMany' searches for in your 'Query' template is a +-- single substring of the form: +-- +-- > values (?,?,?) +-- +-- The rules are as follows: +-- +-- * The keyword @VALUES@ is matched case insensitively. +-- +-- * There must be no other \"@?@\" characters anywhere in your +-- template. +-- +-- * There must one or more \"@?@\" in the parentheses. +-- +-- * Extra white space is fine. +-- +-- The last argument to 'executeMany' is a list of parameter +-- tuples. These will be substituted into the query where the @(?,?)@ +-- string appears, in a form suitable for use in a multi-row @INSERT@ +-- or @UPDATE@. +-- +-- Here is an example: +-- +-- > executeMany conn +-- > "insert into users (first_name,last_name) values (?,?)" +-- > [("Boris","Karloff"),("Ed","Wood")] +-- +-- The query that will be executed here will look like this +-- (reformatted for tidiness): +-- +-- > insert into users (first_name,last_name) values +-- > ('Boris','Karloff'),('Ed','Wood') + +-- $result +-- +-- The 'query' and 'query_' functions return a list of values in the +-- 'QueryResults' typeclass. This class performs automatic extraction +-- and type conversion of rows from a query result. +-- +-- Here is a simple example of how to extract results: +-- +-- > import qualified Data.Text as Text +-- > +-- > xs <- query_ conn "select name,age from users" +-- > forM_ xs $ \(name,age) -> +-- > putStrLn $ Text.unpack name ++ " is " ++ show (age :: Int) +-- +-- Notice two important details about this code: +-- +-- * The number of columns we ask for in the query template must +-- exactly match the number of elements we specify in a row of the +-- result tuple. If they do not match, a 'ResultError' exception +-- will be thrown. +-- +-- * Sometimes, the compiler needs our help in specifying types. It +-- can infer that @name@ must be a 'Text', due to our use of the +-- @unpack@ function. However, we have to tell it the type of @age@, +-- as it has no other information to determine the exact type. + +-- $null +-- +-- The type of a result tuple will look something like this: +-- +-- > (Text, Int, Int) +-- +-- Although SQL can accommodate @NULL@ as a value for any of these +-- types, Haskell cannot. If your result contains columns that may be +-- @NULL@, be sure that you use 'Maybe' in those positions of of your +-- tuple. +-- +-- > (Text, Maybe Int, Int) +-- +-- If 'query' encounters a @NULL@ in a row where the corresponding +-- Haskell type is not 'Maybe', it will throw a 'ResultError' +-- exception. + +-- $only_result +-- +-- To specify that a query returns a single-column result, use the +-- 'Only' type. +-- +-- > xs <- query_ conn "select id from users" +-- > forM_ xs $ \(Only dbid) -> {- ... -} + +-- $types +-- +-- Conversion of SQL values to Haskell values is somewhat +-- permissive. Here are the rules. +-- +-- * For numeric types, any Haskell type that can accurately represent +-- all values of the given PostgreSQL type is considered \"compatible\". +-- For instance, you can always extract a PostgreSQL 16-bit @SMALLINT@ +-- column to a Haskell 'Int'. The Haskell 'Float' type can accurately +-- represent a @SMALLINT@, so it is considered compatble with those types. +-- +-- * A numeric compatibility check is based only on the type of a +-- column, /not/ on its values. For instance, a PostgreSQL 64-bit +-- @BIGINT@ column will be considered incompatible with a Haskell +-- 'Int16', even if it contains the value @1@. +-- +-- * If a numeric incompatibility is found, 'query' will throw a +-- 'ResultError'. +-- +-- * The 'String' and 'Text' types are assumed to be encoded as +-- UTF-8. If you use some other encoding, decoding may fail or give +-- wrong results. In such cases, write a @newtype@ wrapper and a +-- custom 'Result' instance to handle your encoding. + +getTypename :: Connection -> PQ.Oid -> IO ByteString +getTypename conn@Connection{..} oid = + case oid2builtin oid of + Just builtin -> return $! builtin2typname builtin + Nothing -> modifyMVar connectionObjects $ \oidmap -> do + case IntMap.lookup (oid2int oid) oidmap of + Just name -> return (oidmap, name) + Nothing -> do + names <- query conn "SELECT typname FROM pg_type WHERE oid=?" + (Only oid) + name <- case names of + [] -> return $ throw SqlError { + sqlNativeError = -1, + sqlErrorMsg = "invalid type oid", + sqlState = "" + } + [Only x] -> return x + _ -> fail "typename query returned more than one result" + -- oid is a primary key, so the query should + -- never return more than one result + return (IntMap.insert (oid2int oid) name oidmap, name) diff --git a/src/Database/PostgreSQL/Simple/BuiltinTypes.hs b/src/Database/PostgreSQL/Simple/BuiltinTypes.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/BuiltinTypes.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.BuiltinTypes +-- Copyright: (c) 2011 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +------------------------------------------------------------------------------ + +-- Note that this file is generated by tools/GenBuiltinTypes.hs, and should +-- not be edited directly + +module Database.PostgreSQL.Simple.BuiltinTypes + ( BuiltinType (..) + , builtin2oid + , oid2builtin + , builtin2typname + , oid2typname + ) where + +import Data.Typeable +import Data.ByteString (ByteString) +import qualified Database.PostgreSQL.LibPQ as PQ + +data BuiltinType + = Bool + | Bytea + | Char + | Name + | Int8 + | Int2 + | Int4 + | Regproc + | Text + | Oid + | Tid + | Xid + | Cid + | Xml + | Point + | Lseg + | Path + | Box + | Polygon + | Line + | Cidr + | Float4 + | Float8 + | Abstime + | Reltime + | Tinterval + | Unknown + | Circle + | Money + | Macaddr + | Inet + | Bpchar + | Varchar + | Date + | Time + | Timestamp + | TimestampWithTimeZone + | Interval + | TimeWithTimeZone + | Bit + | Varbit + | Numeric + | Refcursor + | Record + | Void + deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable) + +builtin2oid :: BuiltinType -> PQ.Oid +builtin2oid typ = PQ.Oid $ case typ of + Bool -> 16 + Bytea -> 17 + Char -> 18 + Name -> 19 + Int8 -> 20 + Int2 -> 21 + Int4 -> 23 + Regproc -> 24 + Text -> 25 + Oid -> 26 + Tid -> 27 + Xid -> 28 + Cid -> 29 + Xml -> 142 + Point -> 600 + Lseg -> 601 + Path -> 602 + Box -> 603 + Polygon -> 604 + Line -> 628 + Cidr -> 650 + Float4 -> 700 + Float8 -> 701 + Abstime -> 702 + Reltime -> 703 + Tinterval -> 704 + Unknown -> 705 + Circle -> 718 + Money -> 790 + Macaddr -> 829 + Inet -> 869 + Bpchar -> 1042 + Varchar -> 1043 + Date -> 1082 + Time -> 1083 + Timestamp -> 1114 + TimestampWithTimeZone -> 1184 + Interval -> 1186 + TimeWithTimeZone -> 1266 + Bit -> 1560 + Varbit -> 1562 + Numeric -> 1700 + Refcursor -> 1790 + Record -> 2249 + Void -> 2278 + +oid2builtin :: PQ.Oid -> Maybe BuiltinType +oid2builtin (PQ.Oid x) = case x of + 16 -> Just Bool + 17 -> Just Bytea + 18 -> Just Char + 19 -> Just Name + 20 -> Just Int8 + 21 -> Just Int2 + 23 -> Just Int4 + 24 -> Just Regproc + 25 -> Just Text + 26 -> Just Oid + 27 -> Just Tid + 28 -> Just Xid + 29 -> Just Cid + 142 -> Just Xml + 600 -> Just Point + 601 -> Just Lseg + 602 -> Just Path + 603 -> Just Box + 604 -> Just Polygon + 628 -> Just Line + 650 -> Just Cidr + 700 -> Just Float4 + 701 -> Just Float8 + 702 -> Just Abstime + 703 -> Just Reltime + 704 -> Just Tinterval + 705 -> Just Unknown + 718 -> Just Circle + 790 -> Just Money + 829 -> Just Macaddr + 869 -> Just Inet + 1042 -> Just Bpchar + 1043 -> Just Varchar + 1082 -> Just Date + 1083 -> Just Time + 1114 -> Just Timestamp + 1184 -> Just TimestampWithTimeZone + 1186 -> Just Interval + 1266 -> Just TimeWithTimeZone + 1560 -> Just Bit + 1562 -> Just Varbit + 1700 -> Just Numeric + 1790 -> Just Refcursor + 2249 -> Just Record + 2278 -> Just Void + _ -> Nothing + +builtin2typname :: BuiltinType -> ByteString +builtin2typname typ = case typ of + Bool -> bool + Bytea -> bytea + Char -> char + Name -> name + Int8 -> int8 + Int2 -> int2 + Int4 -> int4 + Regproc -> regproc + Text -> text + Oid -> oid + Tid -> tid + Xid -> xid + Cid -> cid + Xml -> xml + Point -> point + Lseg -> lseg + Path -> path + Box -> box + Polygon -> polygon + Line -> line + Cidr -> cidr + Float4 -> float4 + Float8 -> float8 + Abstime -> abstime + Reltime -> reltime + Tinterval -> tinterval + Unknown -> unknown + Circle -> circle + Money -> money + Macaddr -> macaddr + Inet -> inet + Bpchar -> bpchar + Varchar -> varchar + Date -> date + Time -> time + Timestamp -> timestamp + TimestampWithTimeZone -> timestamptz + Interval -> interval + TimeWithTimeZone -> timetz + Bit -> bit + Varbit -> varbit + Numeric -> numeric + Refcursor -> refcursor + Record -> record + Void -> void + +oid2typname :: PQ.Oid -> Maybe ByteString +oid2typname (PQ.Oid x) = case x of + 16 -> Just bool + 17 -> Just bytea + 18 -> Just char + 19 -> Just name + 20 -> Just int8 + 21 -> Just int2 + 23 -> Just int4 + 24 -> Just regproc + 25 -> Just text + 26 -> Just oid + 27 -> Just tid + 28 -> Just xid + 29 -> Just cid + 142 -> Just xml + 600 -> Just point + 601 -> Just lseg + 602 -> Just path + 603 -> Just box + 604 -> Just polygon + 628 -> Just line + 650 -> Just cidr + 700 -> Just float4 + 701 -> Just float8 + 702 -> Just abstime + 703 -> Just reltime + 704 -> Just tinterval + 705 -> Just unknown + 718 -> Just circle + 790 -> Just money + 829 -> Just macaddr + 869 -> Just inet + 1042 -> Just bpchar + 1043 -> Just varchar + 1082 -> Just date + 1083 -> Just time + 1114 -> Just timestamp + 1184 -> Just timestamptz + 1186 -> Just interval + 1266 -> Just timetz + 1560 -> Just bit + 1562 -> Just varbit + 1700 -> Just numeric + 1790 -> Just refcursor + 2249 -> Just record + 2278 -> Just void + _ -> Nothing + +bool :: ByteString +bool = "bool" + +bytea :: ByteString +bytea = "bytea" + +char :: ByteString +char = "char" + +name :: ByteString +name = "name" + +int8 :: ByteString +int8 = "int8" + +int2 :: ByteString +int2 = "int2" + +int4 :: ByteString +int4 = "int4" + +regproc :: ByteString +regproc = "regproc" + +text :: ByteString +text = "text" + +oid :: ByteString +oid = "oid" + +tid :: ByteString +tid = "tid" + +xid :: ByteString +xid = "xid" + +cid :: ByteString +cid = "cid" + +xml :: ByteString +xml = "xml" + +point :: ByteString +point = "point" + +lseg :: ByteString +lseg = "lseg" + +path :: ByteString +path = "path" + +box :: ByteString +box = "box" + +polygon :: ByteString +polygon = "polygon" + +line :: ByteString +line = "line" + +cidr :: ByteString +cidr = "cidr" + +float4 :: ByteString +float4 = "float4" + +float8 :: ByteString +float8 = "float8" + +abstime :: ByteString +abstime = "abstime" + +reltime :: ByteString +reltime = "reltime" + +tinterval :: ByteString +tinterval = "tinterval" + +unknown :: ByteString +unknown = "unknown" + +circle :: ByteString +circle = "circle" + +money :: ByteString +money = "money" + +macaddr :: ByteString +macaddr = "macaddr" + +inet :: ByteString +inet = "inet" + +bpchar :: ByteString +bpchar = "bpchar" + +varchar :: ByteString +varchar = "varchar" + +date :: ByteString +date = "date" + +time :: ByteString +time = "time" + +timestamp :: ByteString +timestamp = "timestamp" + +timestamptz :: ByteString +timestamptz = "timestamptz" + +interval :: ByteString +interval = "interval" + +timetz :: ByteString +timetz = "timetz" + +bit :: ByteString +bit = "bit" + +varbit :: ByteString +varbit = "varbit" + +numeric :: ByteString +numeric = "numeric" + +refcursor :: ByteString +refcursor = "refcursor" + +record :: ByteString +record = "record" + +void :: ByteString +void = "void" diff --git a/src/Database/PostgreSQL/Simple/Field.hs b/src/Database/PostgreSQL/Simple/Field.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Field.hs @@ -0,0 +1,15 @@ +module Database.PostgreSQL.Simple.Field + ( Field + , typename + , name + , tableOid + , tableColumn + , format + , typeOid + , Oid + , Format(..) + , RawResult(..) + ) where + +import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.LibPQ (Format(..), Oid) diff --git a/src/Database/PostgreSQL/Simple/Internal.hs b/src/Database/PostgreSQL/Simple/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Internal.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE OverloadedStrings, NamedFieldPuns, RecordWildCards #-} +{-# LANGUAGE DeriveDataTypeable #-} +module Database.PostgreSQL.Simple.Internal where + +import Prelude hiding (catch) + +import Control.Applicative +import Control.Exception +import Control.Concurrent.MVar +import Data.ByteString(ByteString) +import qualified Data.IntMap as IntMap +import Data.String +import Data.Typeable +import Data.Word +import Database.PostgreSQL.LibPQ(Oid(..)) +import qualified Database.PostgreSQL.LibPQ as PQ +import Database.PostgreSQL.Simple.BuiltinTypes (BuiltinType) +import System.IO.Unsafe (unsafePerformIO) + +-- | A Field represents metadata about a particular field +-- +-- You don't particularly want to retain these structures for a long +-- period of time, as they will retain the entire query result, not +-- just the field metadata + +data Field = Field { + result :: PQ.Result + , column :: PQ.Column + , typename :: ByteString + } + +name :: Field -> Maybe ByteString +name Field{..} = unsafePerformIO (PQ.fname result column) + +tableOid :: Field -> PQ.Oid +tableOid Field{..} = unsafePerformIO (PQ.ftable result column) + +tableColumn :: Field -> Int +tableColumn Field{..} = fromCol (unsafePerformIO (PQ.ftablecol result column)) + where + fromCol (PQ.Col x) = fromIntegral x + + +format :: Field -> PQ.Format +format Field{..} = unsafePerformIO (PQ.fformat result column) + +typeOid :: Field -> PQ.Oid +typeOid Field{..} = unsafePerformIO (PQ.ftype result column) + + +data Connection = Connection { + connectionHandle :: MVar (Maybe PQ.Connection) + , connectionObjects :: MVar (IntMap.IntMap ByteString) + } + +data SqlType + = Builtin BuiltinType + | Other Oid + +data SqlError = SqlError { + sqlState :: ByteString + , sqlNativeError :: Int + , sqlErrorMsg :: ByteString + } deriving (Show, Typeable) + +instance Exception SqlError + +data ConnectInfo = ConnectInfo { + connectHost :: String + , connectPort :: Word16 + , connectUser :: String + , connectPassword :: String + , connectDatabase :: String + } deriving (Eq,Read,Show,Typeable) + +defaultConnectInfo :: ConnectInfo +defaultConnectInfo = ConnectInfo { + connectHost = "127.0.0.1" + , connectPort = 5432 + , connectUser = "postgres" + , connectPassword = "" + , connectDatabase = "" + } + +-- | Connect with the given username to the given database. Will throw +-- an exception if it cannot connect. +connect :: ConnectInfo -> IO Connection +connect = connectPostgreSQL . postgreSQLConnectionString + +connectPostgreSQL :: ByteString -> IO Connection +connectPostgreSQL connstr = do + conn <- PQ.connectdb connstr + connectionHandle <- newMVar (Just conn) + connectionObjects <- newMVar (IntMap.empty) + return Connection{..} + +postgreSQLConnectionString :: ConnectInfo -> ByteString +postgreSQLConnectionString connectInfo = fromString connstr + where + connstr = str "host=" connectHost + $ num "port=" connectPort + $ str "user=" connectUser + $ str "password=" connectPassword + $ str "dbname=" connectDatabase + $ [] + + str name field + | null value = id + | otherwise = (name ++) . quote value . space + where value = field connectInfo + + num name field + | value <= 0 = id + | otherwise = (name ++) . (show value ++) . space + where value = field connectInfo + + quote str rest = '\'' : foldr delta ('\'' : rest) str + where + delta c cs = case c of + '\\' -> '\\' : '\\' : cs + '\'' -> '\\' : '\'' : cs + _ -> c : cs + + space [] = [] + space xs = ' ':xs + + + +oid2int :: Oid -> Int +oid2int (Oid x) = fromIntegral x +{-# INLINE oid2int #-} + +exec :: Connection + -> ByteString + -> IO PQ.Result +exec conn sql = + withConnection conn $ \h -> do + mres <- PQ.exec h sql + case mres of + Nothing -> do + msg <- maybe "execute error" id <$> PQ.errorMessage h + throwIO $ SqlError { sqlNativeError = -1 -- FIXME? + , sqlErrorMsg = msg + , sqlState = "" } + Just res -> do + return res + +disconnectedError = SqlError { + sqlNativeError = -1, + sqlErrorMsg = "connection disconnected", + sqlState = "" + } + + +-- | Atomically perform an action with the database handle, if there is one. +withConnection :: Connection -> (PQ.Connection -> IO a) -> IO a +withConnection Connection{..} m = do + withMVar connectionHandle $ \h -> do + case h of + Just h -> m h + -- TODO: Use extensible exceptions. + Nothing -> throwIO disconnectedError + +close :: Connection -> IO () +close Connection{..} = do + mconn <- takeMVar connectionHandle + case mconn of + Just conn -> PQ.finish conn + Nothing -> return () + `finally` putMVar connectionHandle Nothing + +data RawResult = RawResult { rawField :: Field, rawData :: Maybe ByteString } diff --git a/src/Database/PostgreSQL/Simple/LargeObjects.hs b/src/Database/PostgreSQL/Simple/LargeObjects.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/LargeObjects.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Database.PostgreSQL.Simple.LargeObjects +-- Copyright : (c) 2011 Leon P Smith +-- License : BSD3 +-- +-- Maintainer : leon@melding-monads.com +-- +----------------------------------------------------------------------------- + +module Database.PostgreSQL.Simple.LargeObjects + ( loImport + , loExport + , Oid(..) + ) where + +import Control.Applicative ((<$>)) +import Control.Exception (throwIO) +import Database.PostgreSQL.LibPQ (Oid(..)) +import qualified Database.PostgreSQL.LibPQ as PQ +import Database.PostgreSQL.Simple.Internal +import Foreign.C.Types(CInt) + +loImport :: Connection -> FilePath -> IO Oid +loImport conn path = withConnection conn $ \c -> do + res <- PQ.loImport c path + case res of + Nothing -> do + msg <- maybe "loImport error" id <$> PQ.errorMessage c + throwIO $ SqlError { sqlNativeError = -1 -- FIXME? + , sqlErrorMsg = msg + , sqlState = "" } + Just x -> return x + + +loExport :: Connection -> Oid -> FilePath -> IO () +loExport conn oid path = withConnection conn $ \c -> do + res <- PQ.loExport c oid path + case res of + Nothing -> do + msg <- maybe "loExport error" id <$> PQ.errorMessage c + throwIO $ SqlError { sqlNativeError = -1 -- FIXME? + , sqlErrorMsg = msg + , sqlState = "" } + Just x -> return x diff --git a/src/Database/PostgreSQL/Simple/Notification.hs b/src/Database/PostgreSQL/Simple/Notification.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Notification.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Database.PostgreSQL.Simple.Notification +-- Copyright : (c) 2011 Leon P Smith +-- License : BSD3 +-- +-- Maintainer : leon@melding-monads.com +-- Stability : experimental +-- +----------------------------------------------------------------------------- + +module Database.PostgreSQL.Simple.Notification + ( Notification(..) + , getNotification + ) where + +import Control.Concurrent ( threadWaitRead ) +import Control.Concurrent.MVar ( takeMVar, putMVar ) +import qualified Data.ByteString as B +import Database.PostgreSQL.Simple.Internal +import qualified Database.PostgreSQL.LibPQ as PQ +import System.Posix.Types ( CPid ) + +data Notification = Notification + { notificationPid :: CPid + , notificationChannel :: B.ByteString + , notificationData :: B.ByteString + } + +errfd = "Database.PostgreSQL.Simple.Notification.getNotification: \ + \failed to fetch file descriptor" +errconn = "Database.PostgreSQL.Simple.Notification.getNotification: \ + \not connected" + +lockConn :: Connection -> IO (PQ.Connection) +lockConn Connection{..} = do + mconn <- takeMVar connectionHandle + case mconn of + Nothing -> do + putMVar connectionHandle mconn + fail errconn + Just conn -> return conn + +unlockConn :: Connection -> PQ.Connection -> IO () +unlockConn Connection{..} c = putMVar connectionHandle (Just c) + +getNotification :: Connection -> IO Notification +getNotification conn = do + c <- lockConn conn + loop conn c + where + -- now, I believe the only ways that this code throws an exception is: + -- 1. lockConn/unlockConn when we are blocked on a GC'd MVar + -- 2. threadWaitRead when closeFdWith gets called + -- 3. and if we raise it ourself + -- If 1 happens, then it doesn't matter if the MVar is locked or not, + -- and if 2 or 3 happens then the connection should be unlocked. + -- + -- Note, however, that this function is not safe from asynchronous + -- exceptions, which probably ought to be fixed. + loop conn c = do + mmsg <- PQ.notifies c + case mmsg of + Nothing -> do + mfd <- PQ.socket c + unlockConn conn c + case mfd of + Nothing -> fail errfd + Just fd -> do + threadWaitRead fd + c <- lockConn conn + _ <- PQ.consumeInput c + -- FIXME? error handling + loop conn c + Just PQ.Notify{..} -> do + unlockConn conn c + return Notification { notificationPid = notifyBePid + , notificationChannel = notifyRelname + , notificationData = notifyExtra } diff --git a/src/Database/PostgreSQL/Simple/Param.hs b/src/Database/PostgreSQL/Simple/Param.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Param.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, FlexibleInstances, + OverloadedStrings #-} + +-- | +-- Module: Database.PostgreSQL.Simple.Param +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- Portability: portable +-- +-- The 'Param' typeclass, for rendering a parameter to a SQL query. + +module Database.PostgreSQL.Simple.Param + ( + Action(..) + , Param(..) + , inQuotes + ) where + +import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, + 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) +import Data.Time.Calendar (Day, showGregorian) +import Data.Time.Clock (UTCTime) +import Data.Time.Format (formatTime) +import Data.Time.LocalTime (TimeOfDay) +import Data.Typeable (Typeable) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import Database.PostgreSQL.Simple.Types (Binary(..), In(..), Null) +import System.Locale (defaultTimeLocale) +import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8 +import qualified Data.ByteString as SB +import qualified Data.ByteString.Lazy as LB +import qualified Data.Text as ST +import qualified Data.Text.Encoding as ST +import qualified Data.Text.Lazy as LT +import qualified Database.PostgreSQL.LibPQ as PQ + +-- | 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. + | 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 + +-- | A type that may be used as a single parameter to a SQL query. +class Param a where + render :: a -> Action + -- ^ Prepare a value for substitution into a query string. + +instance Param Action where + render a = a + {-# INLINE render #-} + +instance (Param a) => Param (Maybe a) where + render Nothing = renderNull + render (Just a) = render a + {-# INLINE render #-} + +instance (Param a) => Param (In [a]) where + render (In []) = Plain $ fromByteString "(null)" + render (In xs) = Many $ + Plain (fromChar '(') : + (intersperse (Plain (fromChar ',')) . map render $ xs) ++ + [Plain (fromChar ')')] + +instance Param (Binary SB.ByteString) where + render (Binary bs) = Plain $ fromByteString "'\\x" `mappend` + fromByteString (B16.encode bs) `mappend` + fromChar '\'' + +instance Param (Binary LB.ByteString) where + render (Binary bs) = Plain $ fromByteString "'\\x" `mappend` + fromLazyByteString (L16.encode bs) `mappend` + fromChar '\'' + +renderNull :: Action +renderNull = Plain (fromByteString "null") + +instance Param Null where + render _ = renderNull + {-# INLINE render #-} + +instance Param Bool where + render True = Plain (fromByteString "true") + render False = Plain (fromByteString "false") + {-# INLINE render #-} + +instance Param Int8 where + render = Plain . integral + {-# INLINE render #-} + +instance Param Int16 where + render = Plain . integral + {-# INLINE render #-} + +instance Param Int32 where + render = Plain . integral + {-# INLINE render #-} + +instance Param Int where + render = Plain . integral + {-# INLINE render #-} + +instance Param Int64 where + render = Plain . integral + {-# INLINE render #-} + +instance Param Integer where + render = Plain . integral + {-# INLINE render #-} + +instance Param Word8 where + render = Plain . integral + {-# INLINE render #-} + +instance Param Word16 where + render = Plain . integral + {-# INLINE render #-} + +instance Param Word32 where + render = Plain . integral + {-# INLINE render #-} + +instance Param Word where + render = Plain . integral + {-# INLINE render #-} + +instance Param Word64 where + render = Plain . integral + {-# INLINE render #-} + +instance Param PQ.Oid where + render = Plain . integral . \(PQ.Oid x) -> x + {-# INLINE render #-} + +instance Param Float where + render v | isNaN v || isInfinite v = renderNull + | otherwise = Plain (float v) + {-# INLINE render #-} + +instance Param Double where + render v | isNaN v || isInfinite v = renderNull + | otherwise = Plain (double v) + {-# INLINE render #-} + +instance Param SB.ByteString where + render = Escape + {-# INLINE render #-} + +instance Param LB.ByteString where + render = render . SB.concat . LB.toChunks + {-# INLINE render #-} + +instance Param ST.Text where + render = Escape . ST.encodeUtf8 + {-# INLINE render #-} + +instance Param [Char] where + render = Escape . toByteString . Utf8.fromString + {-# INLINE render #-} + +instance Param LT.Text where + render = render . LT.toStrict + {-# INLINE render #-} + +instance Param UTCTime where + render = Plain . Utf8.fromString . formatTime defaultTimeLocale "'%F %T%Q+00'" + {-# INLINE render #-} + +instance Param Day where + render = Plain . inQuotes . Utf8.fromString . showGregorian + {-# INLINE render #-} + +instance Param TimeOfDay where + render = Plain . inQuotes . Utf8.fromString . show + {-# INLINE render #-} + +-- | Surround a string with single-quote characters: \"@'@\" +-- +-- This function /does not/ perform any other escaping. +inQuotes :: Builder -> Builder +inQuotes b = quote `mappend` b `mappend` quote + where quote = Utf8.fromChar '\'' diff --git a/src/Database/PostgreSQL/Simple/QueryParams.hs b/src/Database/PostgreSQL/Simple/QueryParams.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/QueryParams.hs @@ -0,0 +1,85 @@ +-- | +-- Module: Database.PostgreSQL.Simple.QueryParams +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- Portability: portable +-- +-- The 'QueryParams' typeclass, for rendering a collection of +-- parameters to a SQL query. +-- +-- Predefined instances are provided for tuples containing up to ten +-- elements. + +module Database.PostgreSQL.Simple.QueryParams + ( + QueryParams(..) + ) where + +import Database.PostgreSQL.Simple.Param (Action(..), Param(..)) +import Database.PostgreSQL.Simple.Types (Only(..)) + +-- | A collection type that can be turned into a list of rendering +-- 'Action's. +-- +-- Instances should use the 'render' method of the 'Param' class +-- to perform conversion of each element of the collection. +class QueryParams a where + renderParams :: a -> [Action] + -- ^ Render a collection of values. + +instance QueryParams () where + renderParams _ = [] + +instance (Param a) => QueryParams (Only a) where + renderParams (Only v) = [render v] + +instance (Param a, Param b) => QueryParams (a,b) where + renderParams (a,b) = [render a, render b] + +instance (Param a, Param b, Param c) => QueryParams (a,b,c) where + renderParams (a,b,c) = [render a, render b, render c] + +instance (Param a, Param b, Param c, Param d) => QueryParams (a,b,c,d) where + renderParams (a,b,c,d) = [render a, render b, render c, render d] + +instance (Param a, Param b, Param c, Param d, Param e) + => QueryParams (a,b,c,d,e) where + renderParams (a,b,c,d,e) = + [render a, render b, render c, render d, render e] + +instance (Param a, Param b, Param c, Param d, Param e, Param f) + => QueryParams (a,b,c,d,e,f) where + renderParams (a,b,c,d,e,f) = + [render a, render b, render c, render d, render e, render f] + +instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g) + => QueryParams (a,b,c,d,e,f,g) where + renderParams (a,b,c,d,e,f,g) = + [render a, render b, render c, render d, render e, render f, render g] + +instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g, + Param h) + => QueryParams (a,b,c,d,e,f,g,h) where + renderParams (a,b,c,d,e,f,g,h) = + [render a, render b, render c, render d, render e, render f, render g, + render h] + +instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g, + Param h, Param i) + => QueryParams (a,b,c,d,e,f,g,h,i) where + renderParams (a,b,c,d,e,f,g,h,i) = + [render a, render b, render c, render d, render e, render f, render g, + render h, render i] + +instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g, + Param h, Param i, Param j) + => QueryParams (a,b,c,d,e,f,g,h,i,j) where + renderParams (a,b,c,d,e,f,g,h,i,j) = + [render a, render b, render c, render d, render e, render f, render g, + render h, render i, render j] + +instance (Param a) => QueryParams [a] where + renderParams = map render diff --git a/src/Database/PostgreSQL/Simple/QueryResults.hs b/src/Database/PostgreSQL/Simple/QueryResults.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/QueryResults.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} + +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.QueryResults +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- Portability: portable +-- +-- The 'QueryResults' typeclass, for converting a row of results +-- returned by a SQL query into a more useful Haskell representation. +-- +-- Predefined instances are provided for tuples containing up to ten +-- elements. +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.QueryResults + ( + QueryResults(..) + , convertError + ) where + +import Control.Exception (SomeException(..), throw) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Either() +import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.Simple.Result (ResultError(..), Result(..)) +import Database.PostgreSQL.Simple.Types (Only(..)) + +-- | A collection type that can be converted from a list of strings. +-- +-- Instances should use the 'convert' method of the 'Result' class +-- to perform conversion of each element of the collection. +-- +-- This example instance demonstrates how to convert a two-column row +-- into a Haskell pair. Each field in the metadata is paired up with +-- each value from the row, and the two are passed to 'convert'. +-- +-- @ +-- instance ('Result' a, 'Result' b) => 'QueryResults' (a,b) where +-- 'convertResults' [fa,fb] [va,vb] = (a,b) +-- where !a = 'convert' fa va +-- !b = 'convert' fb vb +-- 'convertResults' fs vs = 'convertError' fs vs 2 +-- @ +-- +-- Notice that this instance evaluates each element to WHNF before +-- constructing the pair. By doing this, we guarantee two important +-- properties: +-- +-- * Keep resource usage under control by preventing the construction +-- of potentially long-lived thunks. +-- +-- * Ensure that any 'ResultError' that might arise is thrown +-- immediately, rather than some place later in application code +-- that cannot handle it. +-- +-- You can also declare Haskell types of your own to be instances of +-- 'QueryResults'. +-- +-- @ +--data User { firstName :: String, lastName :: String } +-- +--instance 'QueryResults' User where +-- 'convertResults' [fa,fb] [va,vb] = User a b +-- where !a = 'convert' fa va +-- !b = 'convert' fb vb +-- 'convertResults' fs vs = 'convertError' fs vs +-- @ + +class QueryResults a where + convertResults :: [Field] -> [Maybe ByteString] -> Either SomeException a + -- ^ Convert values from a row into a Haskell collection. + -- + -- This function will throw a 'ResultError' if conversion of the + -- collection fails. + +instance (Result a) => QueryResults (Only a) where + convertResults [fa] [va] = do + !a <- convert fa va + return (Only a) + convertResults fs vs = convertError fs vs 1 + +instance (Result a, Result b) => QueryResults (a,b) where + convertResults [fa,fb] [va,vb] = do + !a <- convert fa va + !b <- convert fb vb + return (a,b) + convertResults fs vs = convertError fs vs 2 + +instance (Result a, Result b, Result c) => QueryResults (a,b,c) where + convertResults [fa,fb,fc] [va,vb,vc] = do + !a <- convert fa va + !b <- convert fb vb + !c <- convert fc vc + return (a,b,c) + convertResults fs vs = convertError fs vs 3 + +instance (Result a, Result b, Result c, Result d) => + QueryResults (a,b,c,d) where + convertResults [fa,fb,fc,fd] [va,vb,vc,vd] = do + !a <- convert fa va + !b <- convert fb vb + !c <- convert fc vc + !d <- convert fd vd + return (a,b,c,d) + convertResults fs vs = convertError fs vs 4 + +instance (Result a, Result b, Result c, Result d, Result e) => + QueryResults (a,b,c,d,e) where + convertResults [fa,fb,fc,fd,fe] [va,vb,vc,vd,ve] = do + !a <- convert fa va + !b <- convert fb vb + !c <- convert fc vc + !d <- convert fd vd + !e <- convert fe ve + return (a,b,c,d,e) + convertResults fs vs = convertError fs vs 5 + +instance (Result a, Result b, Result c, Result d, Result e, Result f) => + QueryResults (a,b,c,d,e,f) where + convertResults [fa,fb,fc,fd,fe,ff] [va,vb,vc,vd,ve,vf] = do + !a <- convert fa va + !b <- convert fb vb + !c <- convert fc vc + !d <- convert fd vd + !e <- convert fe ve + !f <- convert ff vf + return (a,b,c,d,e,f) + convertResults fs vs = convertError fs vs 6 + +instance (Result a, Result b, Result c, Result d, Result e, Result f, + Result g) => + QueryResults (a,b,c,d,e,f,g) where + convertResults [fa,fb,fc,fd,fe,ff,fg] [va,vb,vc,vd,ve,vf,vg] = do + !a <- convert fa va + !b <- convert fb vb + !c <- convert fc vc + !d <- convert fd vd + !e <- convert fe ve + !f <- convert ff vf + !g <- convert fg vg + return (a,b,c,d,e,f,g) + convertResults fs vs = convertError fs vs 7 + +instance (Result a, Result b, Result c, Result d, Result e, Result f, + Result g, Result h) => + QueryResults (a,b,c,d,e,f,g,h) where + convertResults [fa,fb,fc,fd,fe,ff,fg,fh] [va,vb,vc,vd,ve,vf,vg,vh] = do + !a <- convert fa va + !b <- convert fb vb + !c <- convert fc vc + !d <- convert fd vd + !e <- convert fe ve + !f <- convert ff vf + !g <- convert fg vg + !h <- convert fh vh + return (a,b,c,d,e,f,g,h) + convertResults fs vs = convertError fs vs 8 + +instance (Result a, Result b, Result c, Result d, Result e, Result f, + Result g, Result h, Result i) => + QueryResults (a,b,c,d,e,f,g,h,i) where + convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi] [va,vb,vc,vd,ve,vf,vg,vh,vi] = + do + !a <- convert fa va + !b <- convert fb vb + !c <- convert fc vc + !d <- convert fd vd + !e <- convert fe ve + !f <- convert ff vf + !g <- convert fg vg + !h <- convert fh vh + !i <- convert fi vi + return (a,b,c,d,e,f,g,h,i) + convertResults fs vs = convertError fs vs 9 + +instance (Result a, Result b, Result c, Result d, Result e, Result f, + Result g, Result h, Result i, Result j) => + QueryResults (a,b,c,d,e,f,g,h,i,j) where + convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj] + [va,vb,vc,vd,ve,vf,vg,vh,vi,vj] = + do + !a <- convert fa va + !b <- convert fb vb + !c <- convert fc vc + !d <- convert fd vd + !e <- convert fe ve + !f <- convert ff vf + !g <- convert fg vg + !h <- convert fh vh + !i <- convert fi vi + !j <- convert fj vj + return (a,b,c,d,e,f,g,h,i,j) + convertResults fs vs = convertError fs vs 10 + +-- | Throw a 'ConversionFailed' exception, indicating a mismatch +-- between the number of columns in the 'Field' and row, and the +-- number in the collection to be converted to. +convertError :: [Field] + -- ^ Descriptors of fields to be converted. + -> [Maybe ByteString] + -- ^ Contents of the row to be converted. + -> Int + -- ^ Number of columns expected for conversion. For + -- instance, if converting to a 3-tuple, the number to + -- provide here would be 3. + -> Either SomeException a +convertError fs vs n = Left . SomeException $ ConversionFailed + (show (length fs) ++ " values: " ++ show (zip (map typename fs) + (map (fmap ellipsis) vs))) + (show n ++ " slots in target type") + "mismatch between number of columns to convert and number in target type" + +ellipsis :: ByteString -> ByteString +ellipsis bs + | B.length bs > 15 = B.take 10 bs `B.append` "[...]" + | otherwise = bs diff --git a/src/Database/PostgreSQL/Simple/Result.hs b/src/Database/PostgreSQL/Simple/Result.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Result.hs @@ -0,0 +1,259 @@ +{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, FlexibleInstances #-} +{-# LANGUAGE PatternGuards, ScopedTypeVariables, OverloadedStrings #-} +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.QueryResults +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- Portability: portable +-- +-- The 'Result' typeclass, for converting a single value in a row +-- returned by a SQL query into a more useful Haskell representation. +-- +-- A Haskell numeric type is considered to be compatible with all +-- PostgreSQL numeric types that are less accurate than it. For instance, +-- the Haskell 'Double' type is compatible with the PostgreSQL's 32-bit +-- @Int@ type because it can represent a @Int@ exactly. On the other hand, +-- since a 'Double' might lose precision if representing a 64-bit @BigInt@, +-- the two are /not/ considered compatible. +-- +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.Result + ( + Result(..) + , ResultError(..) + ) where + +#include "MachDeps.h" + +import Control.Applicative (Applicative, (<$>), (<*>), (<*), pure) +import Control.Exception (SomeException(..), Exception, throw) +import Data.Attoparsec.Char8 hiding (Result) +import Data.Bits ((.&.), (.|.), shiftL) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Int (Int16, Int32, Int64) +import Data.List (foldl') +import Data.Ratio (Ratio) +import Data.Time.Calendar (Day, fromGregorian) +import Data.Time.Clock (UTCTime) +import Data.Time.Format (parseTime) +import Data.Time.LocalTime (TimeOfDay, makeTimeOfDayValid) +import Data.Typeable (TypeRep, Typeable, typeOf) +import Data.Word (Word64) +import Database.PostgreSQL.Simple.Internal +import Database.PostgreSQL.Simple.Field (Field(..), RawResult(..)) +import Database.PostgreSQL.Simple.BuiltinTypes +import Database.PostgreSQL.Simple.Types (Binary(..)) +import qualified Database.PostgreSQL.LibPQ as PQ +import System.IO.Unsafe (unsafePerformIO) +import System.Locale (defaultTimeLocale) +import qualified Data.ByteString as SB +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as LB +import qualified Data.Text as ST +import qualified Data.Text.Encoding as ST +import qualified Data.Text.Encoding.Error (UnicodeException) +import qualified Data.Text.Lazy as LT + +-- | Exception thrown if conversion from a SQL value to a Haskell +-- value fails. +data ResultError = Incompatible { errSQLType :: String + , errHaskellType :: String + , errMessage :: String } + -- ^ The SQL and Haskell types are not compatible. + | UnexpectedNull { errSQLType :: String + , errHaskellType :: String + , errMessage :: String } + -- ^ A SQL @NULL@ was encountered when the Haskell + -- type did not permit it. + | ConversionFailed { errSQLType :: String + , errHaskellType :: String + , errMessage :: String } + -- ^ The SQL value could not be parsed, or could not + -- be represented as a valid Haskell value, or an + -- unexpected low-level error occurred (e.g. mismatch + -- between metadata and actual data in a row). + deriving (Eq, Show, Typeable) + +instance Exception ResultError + +left :: Exception a => a -> Either SomeException b +left = Left . SomeException + +-- | A type that may be converted from a SQL type. +class Result a where + convert :: Field -> Maybe ByteString -> Either SomeException a + -- ^ Convert a SQL value to a Haskell value. + -- + -- Returns an exception if the conversion fails. In the case of + -- library instances, this will usually be a 'ResultError', but may + -- be a 'UnicodeException'. + +instance (Result a) => Result (Maybe a) where + convert _ Nothing = pure Nothing + convert f bs = Just <$> convert f bs + +instance Result Bool where + convert f bs + | typeOid f /= builtin2oid Bool = returnError Incompatible f "" + | bs == Nothing = returnError UnexpectedNull f "" + | bs == Just "t" = pure True + | bs == Just "f" = pure False + | otherwise = returnError ConversionFailed f "" + +instance Result Int16 where + convert = atto ok16 $ signed decimal + +instance Result Int32 where + convert = atto ok32 $ signed decimal + +instance Result Int where + convert = atto okInt $ signed decimal + +instance Result Int64 where + convert = atto ok64 $ signed decimal + +instance Result Integer where + convert = atto ok64 $ signed decimal + +instance Result Float where + convert = atto ok (realToFrac <$> double) + where ok = mkCompats [Float4,Int2] + +instance Result Double where + convert = atto ok double + where ok = mkCompats [Float4,Float8,Int2,Int4] + +instance Result (Ratio Integer) where + convert = atto ok rational + where ok = mkCompats [Float4,Float8,Int2,Int4,Numeric] + +unBinary (Binary x) = x + +instance Result SB.ByteString where + convert f dat = if typeOid f == builtin2oid Bytea + then unBinary <$> convert f dat + else doConvert f okText' pure dat + +instance Result PQ.Oid where + convert f dat = PQ.Oid <$> atto (mkCompat Oid) decimal f dat + +instance Result LB.ByteString where + convert f dat = LB.fromChunks . (:[]) <$> convert f dat + +unescapeBytea :: Field -> SB.ByteString + -> Either SomeException (Binary SB.ByteString) +unescapeBytea f str = case unsafePerformIO (PQ.unescapeBytea str) of + Nothing -> returnError ConversionFailed f "unescapeBytea failed" + Just str -> pure (Binary str) + +instance Result (Binary SB.ByteString) where + convert f dat = case format f of + PQ.Text -> doConvert f okBinary (unescapeBytea f) dat + PQ.Binary -> doConvert f okBinary (pure . Binary) dat + +instance Result (Binary LB.ByteString) where + convert f dat = Binary . LB.fromChunks . (:[]) . unBinary <$> convert f dat + +instance Result ST.Text where + convert f = doConvert f okText $ (either left Right . ST.decodeUtf8') +{- | isText f = doConvert f okText $ (Right . ST.decodeUtf8) + | otherwise = incompatible f (typeOf ST.empty) + "attempt to mix binary and text" -} + -- FIXME: check character encoding + +instance Result LT.Text where + convert f dat = LT.fromStrict <$> convert f dat + +instance Result [Char] where + convert f dat = ST.unpack <$> convert f dat + +instance Result UTCTime where + convert f = doConvert f ok $ \bs -> + case parseTime defaultTimeLocale "%F %T%Q%z" (B8.unpack bs ++ "00") of + Just t -> Right t + Nothing -> returnError ConversionFailed f "could not parse" + where ok = mkCompats [TimestampWithTimeZone] +{-- +instance Result Day where + convert f = flip (atto ok) f $ case fieldType f of + Year -> year + _ -> date + where ok = mkCompats [Year,Date,NewDate] + year = fromGregorian <$> decimal <*> pure 1 <*> pure 1 + date = fromGregorian <$> (decimal <* char '-') + <*> (decimal <* char '-') + <*> decimal + +instance Result TimeOfDay where + convert f = flip (atto ok) f $ do + hours <- decimal <* char ':' + mins <- decimal <* char ':' + secs <- decimal :: Parser Int + case makeTimeOfDayValid hours mins (fromIntegral secs) of + Just t -> return t + _ -> conversionFailed f "TimeOfDay" "could not parse" + where ok = mkCompats [Time] + +isText :: Field -> Bool +isText f = fieldCharSet f /= 63 +--} +newtype Compat = Compat Word64 + +mkCompats :: [BuiltinType] -> Compat +mkCompats = foldl' f (Compat 0) . map mkCompat + where f (Compat a) (Compat b) = Compat (a .|. b) + +mkCompat :: BuiltinType -> Compat +mkCompat = Compat . shiftL 1 . fromEnum + +compat :: Compat -> Compat -> Bool +compat (Compat a) (Compat b) = a .&. b /= 0 + +okText, okText', ok16, ok32, ok64 :: Compat +okText = mkCompats [Name,Text,Char,Bpchar,Varchar] +okText' = mkCompats [Name,Text,Char,Bpchar,Varchar,Unknown] +okBinary = mkCompats [Bytea] +ok16 = mkCompats [Int2] +ok32 = mkCompats [Int2,Int4] +ok64 = mkCompats [Int2,Int4,Int8] +#if WORD_SIZE_IN_BITS < 64 +okInt = ok32 +#else +okInt = ok64 +#endif + +doConvert :: forall a . (Typeable a) + => Field -> Compat -> (ByteString -> Either SomeException a) + -> Maybe ByteString -> Either SomeException a +doConvert f types cvt (Just bs) + | Just typ <- oid2builtin (typeOid f) + , mkCompat typ `compat` types = cvt bs + | otherwise = returnError Incompatible f "types incompatible" +doConvert f _ _ _ = returnError UnexpectedNull f "" + + +returnError :: forall a err . (Typeable a, Exception err) + => (String -> String -> String -> err) + -> Field -> String -> Either SomeException a +returnError mkErr f = left . mkErr (B.unpack (typename f)) + (show (typeOf (undefined :: a))) + +atto :: forall a. (Typeable a) + => Compat -> Parser a -> Field -> Maybe ByteString + -> Either SomeException a +atto types p0 f dat = doConvert f types (go p0) dat + where + go :: Parser a -> ByteString -> Either SomeException a + go p s = + case parseOnly p s of + Left err -> returnError ConversionFailed f err + Right v -> Right v + +instance Result RawResult where + convert field rawData = Right (RawResult field rawData) diff --git a/src/Database/PostgreSQL/Simple/SqlQQ.hs b/src/Database/PostgreSQL/Simple/SqlQQ.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/SqlQQ.hs @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Database.PostgreSQL.Simple.SqlQQ +-- Copyright: (c) 2011 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- +------------------------------------------------------------------------------ + +module Database.PostgreSQL.Simple.SqlQQ (sql) where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Data.Char + +-- | 'sql' is a quasiquoter that eases the syntactic burden +-- of writing big sql statements in Haskell source code. It attempts +-- to minimize whitespace. Note that this implementation is incomplete +-- and can mess up your syntax; it only really understands standard +-- sql string literals (default in PostgreSQL 9) and not the extended +-- escape syntax or other situations where white space should be +-- preserved as is. + +sql :: QuasiQuoter +sql = QuasiQuoter + { quotePat = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ + \ quasiquoter used in pattern context" + , quoteType = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ + \ quasiquoter used in type context" + , quoteExp = sqlExp + , quoteDec = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ + \ quasiquoter used in declaration context" + } + +sqlExp :: String -> Q Exp +sqlExp = stringE . outstring . dropSpace + where + dropSpace = dropWhile isSpace + + outstring ('\'':xs) = '\'' : instring xs + outstring (x:xs) | isSpace x = case dropSpace xs of + [] -> [] + ys -> ' ' : outstring ys + | otherwise = x : outstring xs + outstring [] = [] + + instring ('\'':'\'':xs) = '\'':'\'': instring xs + instring ('\'':xs) = '\'': outstring xs + instring (x:xs) = x : instring xs + instring [] = error "Database.PostgreSQL.Simple.SqlQQ.sql:\ + \ string literal not terminated" diff --git a/src/Database/PostgreSQL/Simple/Types.hs b/src/Database/PostgreSQL/Simple/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Types.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-} + +-- | +-- Module: Database.PostgreSQL.Simple.Types +-- Copyright: (c) 2011 MailRank, Inc. +-- (c) 2011 Leon P Smith +-- License: BSD3 +-- Maintainer: Leon P Smith +-- Stability: experimental +-- Portability: portable +-- +-- Basic types. + +module Database.PostgreSQL.Simple.Types + ( + Null(..) + , Only(..) + , In(..) + , Binary(..) + , Query(..) + , Oid(..) + ) where + +import Blaze.ByteString.Builder (toByteString) +import Control.Arrow (first) +import Data.ByteString (ByteString) +import Data.Monoid (Monoid(..)) +import Data.String (IsString(..)) +import Data.Typeable (Typeable) +import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8 +import qualified Data.ByteString as B +import Database.PostgreSQL.LibPQ (Oid(..)) + +-- | A placeholder for the SQL @NULL@ value. +data Null = Null + deriving (Read, Show, Typeable) + +instance Eq Null where + _ == _ = False + _ /= _ = False + +-- | A query string. This type is intended to make it difficult to +-- construct a SQL query by concatenating string fragments, as that is +-- an extremely common way to accidentally introduce SQL injection +-- vulnerabilities into an application. +-- +-- This type is an instance of 'IsString', so the easiest way to +-- construct a query is to enable the @OverloadedStrings@ language +-- extension and then simply write the query in double quotes. +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Database.PostgreSQL.Simple +-- > +-- > q :: Query +-- > q = "select ?" +-- +-- The underlying type is a 'ByteString', and literal Haskell strings +-- that contain Unicode characters will be correctly transformed to +-- UTF-8. +newtype Query = Query { + fromQuery :: ByteString + } deriving (Eq, Ord, Typeable) + +instance Show Query where + show = show . fromQuery + +instance Read Query where + readsPrec i = fmap (first Query) . readsPrec i + +instance IsString Query where + fromString = Query . toByteString . Utf8.fromString + +instance Monoid Query where + mempty = Query B.empty + mappend (Query a) (Query b) = Query (B.append a b) + {-# INLINE mappend #-} + +-- | A single-value \"collection\". +-- +-- This is useful if you need to supply a single parameter to a SQL +-- query, or extract a single column from a SQL result. +-- +-- Parameter example: +-- +-- @query c \"select x from scores where x > ?\" ('Only' (42::Int))@ +-- +-- Result example: +-- +-- @xs <- query_ c \"select id from users\" +--forM_ xs $ \\('Only' id) -> {- ... -}@ +newtype Only a = Only { + fromOnly :: a + } deriving (Eq, Ord, Read, Show, Typeable, Functor) + +-- | Wrap a list of values for use in an @IN@ clause. Replaces a +-- single \"@?@\" character with a parenthesized list of rendered +-- values. +-- +-- Example: +-- +-- > query c "select * from whatever where id in ?" (In [3,4,5]) +newtype In a = In a + deriving (Eq, Ord, Read, Show, Typeable, Functor) + +-- | Wrap a mostly-binary string to be escaped in hexadecimal. +newtype Binary a = Binary a + deriving (Eq, Ord, Read, Show, Typeable, Functor)