Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

First commit, mysql-simple source with commented out code so that it …

…builds without the mysql dependency.
  • Loading branch information...
commit 4e1aced0f0090efd788d7e43b3f400085703816b 0 parents
@chrisdone chrisdone authored
4 .gitignore
@@ -0,0 +1,4 @@
+.hi
+.o
+dist
+cabal-dev
618 Database/PostgreSQL/Simple.hs
@@ -0,0 +1,618 @@
+{-# LANGUAGE BangPatterns, DeriveDataTypeable, OverloadedStrings #-}
+
+-- |
+-- Module: Database.PostgreSQL.Simple
+-- Copyright: (c) 2011 Chris Done, 2011 MailRank, Inc.
+-- License: BSD3
+-- Maintainer: Chris Done <chrisdone@gmail.com>
+-- Stability: experimental
+-- Portability: portable
+--
+-- A mid-level client library for the MySQL 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
+ -- FIXME:
+ -- Base.ConnectInfo(..)
+ -- , Connection
+ -- , Query
+ -- , In(..)
+ -- , Binary(..)
+ -- , Only(..)
+ -- FIXME:
+ -- -- ** Exceptions
+ -- , FormatError(fmtMessage, fmtQuery, fmtParams)
+ -- , QueryError(qeMessage, qeQuery)
+ -- , ResultError(errSQLType, errHaskellType, errMessage)
+ -- -- * Connection management
+ -- , Base.connect
+ -- , 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
+ -- , Base.commit
+ -- , Base.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.Exception (Exception, bracket, onException, throw, throwIO)
+import Control.Monad.Fix (fix)
+import Data.ByteString (ByteString)
+import Data.Int (Int64)
+import Data.List (intersperse)
+import Data.Monoid (mappend, mconcat)
+import Data.Typeable (Typeable)
+-- FIXME:
+-- import Database.PostgreSQL.Base (Connection, Result)
+-- import Database.PostgreSQL.Base.Types (Field)
+import Database.PostgreSQL.Simple.Param (Action(..), inQuotes)
+import Database.PostgreSQL.Simple.QueryParams (QueryParams(..))
+-- FIXME:
+-- import Database.PostgreSQL.Simple.QueryResults (QueryResults(..))
+-- FIXME:
+-- import Database.PostgreSQL.Simple.Result (ResultError(..))
+import Database.PostgreSQL.Simple.Types (Binary(..), In(..), Only(..), Query(..))
+import Text.Regex.PCRE.Light (compile, caseless, match)
+import qualified Data.ByteString.Char8 as B
+-- FIXME:
+-- 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
+
+-- FIXME:
+-- | 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]
+
+-- buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder
+-- buildQuery conn q template xs = zipParams (split template) <$> mapM sub xs
+-- where sub (Plain b) = pure b
+-- sub (Escape s) = (inQuotes . fromByteString) <$> Base.escape 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
+-- Base.query conn =<< formatQuery conn template qs
+-- finishExecute conn template
+
+-- -- | A version of 'execute' that does not perform query substitution.
+-- execute_ :: Connection -> Query -> IO Int64
+-- execute_ conn q@(Query stmt) = do
+-- Base.query conn stmt
+-- finishExecute conn q
+
+-- -- | 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
+-- Base.query conn =<< formatMany conn q qs
+-- finishExecute conn q
+
+-- finishExecute :: Connection -> Query -> IO Int64
+-- finishExecute conn q = do
+-- ncols <- Base.fieldCount (Left conn)
+-- if ncols /= 0
+-- then throwIO $ QueryError ("execute resulted in " ++ show ncols ++
+-- "-column result") q
+-- else Base.affectedRows conn
+
+-- -- | 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
+-- Base.query conn =<< formatQuery conn template qs
+-- finishQuery conn template
+
+-- -- | A version of 'query' that does not perform query substitution.
+-- query_ :: (QueryResults r) => Connection -> Query -> IO [r]
+-- query_ conn q@(Query que) = do
+-- Base.query conn que
+-- finishQuery conn q
+
+-- -- | 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_ #-}
+
+-- finishQuery :: (QueryResults r) => Connection -> Query -> IO [r]
+-- finishQuery conn q = withResult (Base.storeResult conn) q $ \r fs ->
+-- 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
+-- -- MySQL-related exception), the transaction will be rolled back using
+-- -- 'Base.rollback', then the exception will be rethrown.
+-- withTransaction :: Connection -> IO a -> IO a
+-- withTransaction conn act = do
+-- _ <- execute_ conn "start transaction"
+-- r <- act `onException` Base.rollback conn
+-- Base.commit conn
+-- return r
+
+-- 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.MySQL.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 MySQL type is considered \"compatible\".
+-- -- For instance, you can always extract a MySQL @TINYINT@ column to
+-- -- a Haskell 'Int'. The Haskell 'Float' type can accurately
+-- -- represent MySQL integer types of size up to @INT24@, 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 MySQL @LONG_LONG@
+-- -- column will be considered incompatible with a Haskell 'Int8',
+-- -- 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.
199 Database/PostgreSQL/Simple/Param.hs
@@ -0,0 +1,199 @@
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, FlexibleInstances,
+ OverloadedStrings #-}
+
+-- |
+-- Module: Database.PostgreSQL.Simple.Param
+-- Copyright: (c) 2011 Chris Done, 2011 MailRank, Inc.
+-- License: BSD3
+-- Maintainer: Chris Done <chrisdone@gmail.com>
+-- 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
+
+-- | 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 = Plain . integral . fromEnum
+ {-# 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 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'"
+ {-# 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 '\''
84 Database/PostgreSQL/Simple/QueryParams.hs
@@ -0,0 +1,84 @@
+-- |
+-- Module: Database.PostgreSQL.Simple.QueryParams
+-- Copyright: (c) 2011 Chris Done, 2011 MailRank, Inc.
+-- License: BSD3
+-- Maintainer: Chris Done <chrisdone@gmail.com>
+-- 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
171 Database/PostgreSQL/Simple/QueryResults.hs
@@ -0,0 +1,171 @@
+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
+
+-- |
+-- Module: Database.PostgreSQL.Simple.QueryResults
+-- Copyright: (c) 2011 Chris Done, 2011 MailRank, Inc.
+-- License: BSD3
+-- Maintainer: Chris Done <chrisdone@gmail.com>
+-- 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
+ (
+ -- FIXME: Add these back.
+ -- QueryResults(..)
+ -- , convertError
+ ) where
+
+import Control.Exception (throw)
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as B
+-- FIXME: Add these back.
+-- import Database.PostgreSQL.Base.Types (Field(fieldType))
+-- import Database.PostgreSQL.Simple.Result (ResultError(..), Result(..))
+-- import Database.PostgreSQL.Simple.Types (Only(..))
+-- FIXME: Uncomment all below.
+-- | 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
+-- @
+--
+-- 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] -> 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] = Only a
+-- where !a = convert fa va
+-- convertResults fs vs = convertError fs vs 1
+
+-- 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
+
+-- instance (Result a, Result b, Result c) => QueryResults (a,b,c) where
+-- convertResults [fa,fb,fc] [va,vb,vc] = (a,b,c)
+-- where !a = convert fa va; !b = convert fb vb; !c = convert fc vc
+-- 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] = (a,b,c,d)
+-- where !a = convert fa va; !b = convert fb vb; !c = convert fc vc
+-- !d = convert fd vd
+-- 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] = (a,b,c,d,e)
+-- where !a = convert fa va; !b = convert fb vb; !c = convert fc vc
+-- !d = convert fd vd; !e = convert fe ve
+-- 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] = (a,b,c,d,e,f)
+-- where !a = convert fa va; !b = convert fb vb; !c = convert fc vc
+-- !d = convert fd vd; !e = convert fe ve; !f = convert ff vf
+-- 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] =
+-- (a,b,c,d,e,f,g)
+-- where !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
+-- 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] =
+-- (a,b,c,d,e,f,g,h)
+-- where !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
+-- 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] =
+-- (a,b,c,d,e,f,g,h,i)
+-- where !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
+-- 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] =
+-- (a,b,c,d,e,f,g,h,i,j)
+-- where !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
+-- 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] -> [Maybe ByteString] -> Int -> a
+-- convertError fs vs n = throw $ ConversionFailed
+-- (show (length fs) ++ " values: " ++ show (zip (map fieldType 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
228 Database/PostgreSQL/Simple/Result.hs
@@ -0,0 +1,228 @@
+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances #-}
+
+-- |
+-- Module: Database.PostgreSQL.Simpe.QueryResults
+-- Copyright: (c) 2011 Chris Done, 2011 MailRank, Inc.
+-- License: BSD3
+-- Maintainer: Chris Done <chrisdone@gmail.com>
+-- 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
+-- MySQL numeric types that are less accurate than it. For instance,
+-- the Haskell 'Double' type is compatible with the MySQL 'Long' type
+-- because it can represent a 'Long' exactly. On the other hand, since
+-- a 'Double' might lose precision if representing a 'LongLong', the
+-- two are /not/ considered compatible.
+
+module Database.PostgreSQL.Simple.Result
+ ( -- FIXME: Add these back.
+ -- Result(..)
+ -- , ResultError(..)
+ ) where
+
+#include "MachDeps.h"
+
+import Control.Applicative ((<$>), (<*>), (<*), pure)
+import Control.Exception (Exception, throw)
+import Data.Attoparsec.Char8 hiding (Result)
+import Data.Bits ((.&.), (.|.), shiftL)
+import Data.ByteString (ByteString)
+import Data.Int (Int8, 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 (Word, Word8, Word16, Word32, Word64)
+-- import Database.MySQL.Base.Types (Field(..), Type(..))
+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.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)
+-- FIXME: All below.
+-- instance Exception ResultError
+
+-- -- | A type that may be converted from a SQL type.
+-- class Result a where
+-- convert :: Field -> Maybe ByteString -> a
+-- -- ^ Convert a SQL value to a Haskell value.
+-- --
+-- -- Throws a 'ResultError' if conversion fails.
+
+-- instance (Result a) => Result (Maybe a) where
+-- convert _ Nothing = Nothing
+-- convert f bs = Just (convert f bs)
+
+-- instance Result Bool where
+-- convert = atto ok8 ((/=(0::Int)) <$> decimal)
+
+-- instance Result Int8 where
+-- convert = atto ok8 $ signed decimal
+
+-- instance Result Int16 where
+-- convert = atto ok16 $ signed decimal
+
+-- instance Result Int32 where
+-- convert = atto ok32 $ signed decimal
+
+-- instance Result Int where
+-- convert = atto okWord $ signed decimal
+
+-- instance Result Int64 where
+-- convert = atto ok64 $ signed decimal
+
+-- instance Result Integer where
+-- convert = atto ok64 $ signed decimal
+
+-- instance Result Word8 where
+-- convert = atto ok8 decimal
+
+-- instance Result Word16 where
+-- convert = atto ok16 decimal
+
+-- instance Result Word32 where
+-- convert = atto ok32 decimal
+
+-- instance Result Word where
+-- convert = atto okWord decimal
+
+-- instance Result Word64 where
+-- convert = atto ok64 decimal
+
+-- instance Result Float where
+-- convert = atto ok ((fromRational . toRational) <$> double)
+-- where ok = mkCompats [Float,Double,Decimal,NewDecimal,Tiny,Short,Int24]
+
+-- instance Result Double where
+-- convert = atto ok double
+-- where ok = mkCompats [Float,Double,Decimal,NewDecimal,Tiny,Short,Int24,
+-- Long]
+
+-- instance Result (Ratio Integer) where
+-- convert = atto ok rational
+-- where ok = mkCompats [Float,Double,Decimal,NewDecimal,Tiny,Short,Int24,
+-- Long,LongLong]
+
+-- instance Result SB.ByteString where
+-- convert f = doConvert f okText $ id
+
+-- instance Result LB.ByteString where
+-- convert f = LB.fromChunks . (:[]) . convert f
+
+-- instance Result ST.Text where
+-- convert f | isText f = doConvert f okText $ ST.decodeUtf8
+-- | otherwise = incompatible f (typeOf ST.empty)
+-- "attempt to mix binary and text"
+
+-- instance Result LT.Text where
+-- convert f = LT.fromStrict . convert f
+
+-- instance Result [Char] where
+-- convert f = ST.unpack . convert f
+
+-- instance Result UTCTime where
+-- convert f = doConvert f ok $ \bs ->
+-- case parseTime defaultTimeLocale "%F %T" (B8.unpack bs) of
+-- Just t -> t
+-- Nothing -> conversionFailed f "UTCTime" "could not parse"
+-- where ok = mkCompats [DateTime,Timestamp]
+
+-- 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 Word32
+
+-- mkCompats :: [Type] -> Compat
+-- mkCompats = foldl' f (Compat 0) . map mkCompat
+-- where f (Compat a) (Compat b) = Compat (a .|. b)
+
+-- mkCompat :: Type -> Compat
+-- mkCompat = Compat . shiftL 1 . fromEnum
+
+-- compat :: Compat -> Compat -> Bool
+-- compat (Compat a) (Compat b) = a .&. b /= 0
+
+-- okText, ok8, ok16, ok32, ok64, okWord :: Compat
+-- okText = mkCompats [VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,
+-- Set,Enum]
+-- ok8 = mkCompats [Tiny]
+-- ok16 = mkCompats [Tiny,Short]
+-- ok32 = mkCompats [Tiny,Short,Int24,Long]
+-- ok64 = mkCompats [Tiny,Short,Int24,Long,LongLong]
+-- #if WORD_SIZE_IN_BITS < 64
+-- okWord = ok32
+-- #else
+-- okWord = ok64
+-- #endif
+
+-- doConvert :: (Typeable a) =>
+-- Field -> Compat -> (ByteString -> a) -> Maybe ByteString -> a
+-- doConvert f types cvt (Just bs)
+-- | mkCompat (fieldType f) `compat` types = cvt bs
+-- | otherwise = incompatible f (typeOf (cvt undefined)) "types incompatible"
+-- doConvert f _ cvt _ = throw $ UnexpectedNull (show (fieldType f))
+-- (show (typeOf (cvt undefined))) ""
+
+-- incompatible :: Field -> TypeRep -> String -> a
+-- incompatible f r = throw . Incompatible (show (fieldType f)) (show r)
+
+-- conversionFailed :: Field -> String -> String -> a
+-- conversionFailed f s = throw . ConversionFailed (show (fieldType f)) s
+
+-- atto :: (Typeable a) => Compat -> Parser a -> Field -> Maybe ByteString -> a
+-- atto types p0 f = doConvert f types $ go undefined p0
+-- where
+-- go :: (Typeable a) => a -> Parser a -> ByteString -> a
+-- go dummy p s =
+-- case parseOnly p s of
+-- Left err -> conversionFailed f (show (typeOf dummy)) err
+-- Right v -> v
105 Database/PostgreSQL/Simple/Types.hs
@@ -0,0 +1,105 @@
+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-}
+
+-- |
+-- Module: Database.PostgreSQL.Simple.Types
+-- Copyright: (c) 2011 Chris Done, 2011 MailRank, Inc.
+-- License: BSD3
+-- Maintainer: Chris Done <chrisdone@gmail.com>
+-- Stability: experimental
+-- Portability: portable
+--
+-- Basic types.
+
+module Database.PostgreSQL.Simple.Types
+ (
+ Null(..)
+ , Only(..)
+ , In(..)
+ , Binary(..)
+ , Query(..)
+ ) 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
+
+-- | 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.MySQL.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)
143 Database/PostgreSQL/TAGS
@@ -0,0 +1,143 @@
+
+./Simple/Types.hs,360
+module Database.MySQL.Simple.Types12,13
+data Null =31,32
+data Null = Null31,32
+instance Eq34,35
+newtype Query =57,58
+newtype Query = Query {57,58
+ fromQuery ::58,59
+newtype Only a88,89
+newtype Only a = Only {88,89
+ fromOnly ::89,90
+newtype In a99,100
+newtype In a = In a99,100
+newtype Binary a103,104
+newtype Binary a = Binary a103,104
+
+./Simple/QueryParams.hs,126
+module Database.MySQL.Simple.QueryParams14,15
+class QueryParams a27,28
+ renderParams ::28,29
+instance QueryParams31,32
+
+./Simple/Result.hs,1533
+module Database.MySQL.Simple.Result20,21
+data ResultError =53,54
+data ResultError = Incompatible {53,54
+data ResultError = Incompatible { errSQLType ::53,54
+ , errHaskellType ::54,55
+ , errMessage ::55,56
+ | UnexpectedNull {57,58
+ | UnexpectedNull { errSQLType ::57,58
+ , errHaskellType ::58,59
+ , errMessage ::59,60
+ | ConversionFailed {62,63
+ | ConversionFailed { errSQLType ::62,63
+ , errHaskellType ::63,64
+ , errMessage ::64,65
+class Result a74,75
+ convert ::75,76
+instance (Result80,81
+isText ::178,179
+isText f179,180
+newtype Compat =181,182
+newtype Compat = Compat Word32181,182
+mkCompats ::183,184
+mkCompats =184,185
+mkCompat ::187,188
+mkCompat =188,189
+compat ::190,191
+compat (Compat191,192
+okText, ok8, ok16, ok32, ok64, okWord :: Compat193,194
+okText, ok8, ok16, ok32, ok64, okWord :: Compat193,194
+okText, ok8, ok16, ok32, ok64, okWord :: Compat193,194
+okText, ok8, ok16, ok32, ok64, okWord193,194
+okText, ok8, ok16, ok32,193,194
+okText, ok8,193,194
+okText =194,195
+ok8 =196,197
+ok16 =197,198
+ok32 =198,199
+ok64 =199,200
+okWord =201,202
+doConvert ::206,207
+doConvert f211,212
+incompatible ::214,215
+incompatible f215,216
+conversionFailed ::217,218
+conversionFailed f218,219
+atto ::220,221
+atto types221,222
+
+./Simple/QueryResults.hs,214
+module Database.MySQL.Simple.QueryResults16,17
+class QueryResults a70,71
+ convertResults ::71,72
+instance (Result77,78
+convertError ::158,159
+convertError fs159,160
+ellipsis ::165,166
+ellipsis bs166,167
+
+./Simple/Param.hs,275
+module Database.MySQL.Simple.Param13,14
+data Action =46,47
+ Plain Builder47,48
+ | Escape ByteString52,53
+ | Many [Action]56,57
+instance Show60,61
+class Param a66,67
+ render ::67,68
+renderNull ::96,97
+renderNull =97,98
+inQuotes ::196,197
+inQuotes b197,198
+
+./Simple.hs,1114
+module Database.MySQL.Simple13,14
+data FormatError =107,108
+data FormatError = FormatError {107,108
+ fmtMessage ::108,109
+ , fmtQuery ::109,110
+ , fmtParams ::110,111
+data QueryError =117,118
+data QueryError = QueryError {117,118
+ qeMessage ::118,119
+ , qeQuery ::119,120
+formatQuery ::134,135
+ | null xs && '?' `B.notElem` template =136,137
+formatMany ::153,154
+formatMany _154,155
+buildQuery ::169,170
+buildQuery conn170,171
+execute ::188,189
+execute conn189,190
+execute_ ::194,195
+execute_ conn195,196
+executeMany ::205,206
+executeMany _206,207
+finishExecute ::211,212
+finishExecute conn212,213
+query ::234,235
+query conn236,237
+query_ ::241,242
+query_ conn242,243
+fold ::269,270
+fold conn276,277
+fold_ ::281,282
+fold_ conn287,288
+forEach ::292,293
+forEach conn298,299
+forEach_ ::302,303
+forEach_ conn307,308
+finishQuery ::310,311
+finishQuery conn311,312
+finishFold ::319,320
+finishFold conn321,322
+withResult ::328,329
+withResult fetchResult329,330
+withTransaction ::345,346
+withTransaction conn346,347
+fmtError ::352,353
+fmtError msg353,354
30 LICENSE
@@ -0,0 +1,30 @@
+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.
22 README.markdown
@@ -0,0 +1,22 @@
+# Work in progress
+
+I am currently porting the MySQL parts to PostgreSQL, hoping to
+maintain the rest of the API verbatim.
+
+# pgsql-simple: mid-level bindings to PostgreSQL servers
+
+This library is a mid-level Haskell binding to PostgreSQL servers. It
+is aimed at speed and ease of use.
+
+# Licensing
+
+This library is BSD-licensed.
+
+# Authors
+
+This library is written and maintained by Chris Done,
+<chrisdone@gmail.com>.
+
+This library is also directly forked from mysql-simple, written and
+maintained by Bryan O'Sullivan, <bos@mailrank.com>, with the MySQL
+parts changed to PostgreSQL, in order to have a consistent API.
3  Setup.lhs
@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain
90 TAGS
@@ -0,0 +1,90 @@
+
+./dist/build/autogen/Paths_pgsql_simple.hs,652
+module Paths_pgsql_simple (0,1
+version ::9,10
+version =10,11
+bindir, libdir, datadir, libexecdir :: FilePath12,13
+bindir, libdir, datadir, libexecdir :: FilePath12,13
+bindir, libdir, datadir, libexecdir12,13
+bindir, libdir,12,13
+bindir =14,15
+libdir =15,16
+datadir =16,17
+libexecdir =17,18
+getBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath19,20
+getBinDir, getLibDir, getDataDir, getLibexecDir :: IO19,20
+getBinDir, getLibDir, getDataDir, getLibexecDir19,20
+getBinDir, getLibDir,19,20
+getBinDir =20,21
+getLibDir =21,22
+getDataDir =22,23
+getLibexecDir =23,24
+getDataFileName ::25,26
+getDataFileName name26,27
+
+./Database/PostgreSQL/Simple/Types.hs,365
+module Database.PostgreSQL.Simple.Types12,13
+data Null =31,32
+data Null = Null31,32
+instance Eq34,35
+newtype Query =57,58
+newtype Query = Query {57,58
+ fromQuery ::58,59
+newtype Only a88,89
+newtype Only a = Only {88,89
+ fromOnly ::89,90
+newtype In a99,100
+newtype In a = In a99,100
+newtype Binary a103,104
+newtype Binary a = Binary a103,104
+
+./Database/PostgreSQL/Simple/QueryParams.hs,131
+module Database.PostgreSQL.Simple.QueryParams14,15
+class QueryParams a27,28
+ renderParams ::28,29
+instance QueryParams31,32
+
+./Database/PostgreSQL/Simple/Result.hs,714
+module Database.PostgreSQL.Simple.Result20,21
+data ResultError =53,54
+data ResultError = Incompatible {53,54
+data ResultError = Incompatible { errSQLType ::53,54
+ , errHaskellType ::54,55
+ , errMessage ::55,56
+ | UnexpectedNull {57,58
+ | UnexpectedNull { errSQLType ::57,58
+ , errHaskellType ::58,59
+ , errMessage ::59,60
+ | ConversionFailed {62,63
+ | ConversionFailed { errSQLType ::62,63
+ , errHaskellType ::63,64
+ , errMessage ::64,65
+
+./Database/PostgreSQL/Simple/QueryResults.hs,53
+module Database.PostgreSQL.Simple.QueryResults16,17
+
+./Database/PostgreSQL/Simple/Param.hs,280
+module Database.PostgreSQL.Simple.Param13,14
+data Action =46,47
+ Plain Builder47,48
+ | Escape ByteString52,53
+ | Many [Action]56,57
+instance Show60,61
+class Param a66,67
+ render ::67,68
+renderNull ::96,97
+renderNull =97,98
+inQuotes ::196,197
+inQuotes b197,198
+
+./Database/PostgreSQL/Simple.hs,306
+module Database.PostgreSQL.Simple13,14
+data FormatError =113,114
+data FormatError = FormatError {113,114
+ fmtMessage ::114,115
+ , fmtQuery ::115,116
+ , fmtParams ::116,117
+data QueryError =123,124
+data QueryError = QueryError {123,124
+ qeMessage ::124,125
+ , qeQuery ::125,126
47 pgsql-simple.cabal
@@ -0,0 +1,47 @@
+name: pgsql-simple
+version: 0.0
+homepage: https://github.com/chrisdone/pgsql-simple
+bug-reports: https://github.com/chrisdone/pgsql-simple/issues
+synopsis: A mid-level PostgreSQL client library.
+description:
+ A mid-level client library for the PostgreSQL database, intended to be
+ fast and easy to use.
+license: BSD3
+license-file: LICENSE
+author: Chris Done <chrisdone@gmail.com>, Bryan O'Sullivan <bos@mailrank.com>
+maintainer: Chris Done <chrisdone@gmail.com>
+copyright: 2011 Chris Done, 2011 MailRank, Inc.
+category: Database
+build-type: Simple
+cabal-version: >= 1.6
+extra-source-files:
+ README.markdown
+
+library
+ exposed-modules:
+ Database.PostgreSQL.Simple
+ Database.PostgreSQL.Simple.Param
+ Database.PostgreSQL.Simple.QueryParams
+ Database.PostgreSQL.Simple.QueryResults
+ Database.PostgreSQL.Simple.Result
+ Database.PostgreSQL.Simple.Types
+
+ build-depends:
+ attoparsec >= 0.8.5.3,
+ base < 5,
+ base16-bytestring,
+ blaze-builder,
+ blaze-textual,
+ bytestring >= 0.9,
+ pcre-light,
+ old-locale,
+ text >= 0.11.0.2,
+ time
+
+ ghc-options: -Wall
+ if impl(ghc >= 6.8)
+ ghc-options: -fwarn-tabs
+
+source-repository head
+ type: git
+ location: http://github.com/chrisdone/pgsql-simple
Please sign in to comment.
Something went wrong with that request. Please try again.