Skip to content
Browse files

Sufficient types and dummy functions to build with mysql replaced by …

…pgsql lib.
  • Loading branch information...
1 parent 6a2936e commit a77e39a4b832b71a0734b351a8d970badbf1090d @chrisdone committed Jun 2, 2011
View
342 Database/PostgreSQL/Base.hs
@@ -1 +1,343 @@
+{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-}
+{-# LANGUAGE RecordWildCards, OverloadedStrings, ScopedTypeVariables, FlexibleContexts #-}
+
+-- | A front-end implementation for the PostgreSQL database protocol
+-- version 3.0 (implemented in PostgreSQL 7.4 and later).
+
module Database.PostgreSQL.Base where
+
+import Database.PostgreSQL.Base.Types
+
+import Control.Concurrent
+import Control.Monad
+import Control.Monad.State (MonadState,execStateT,modify)
+import Control.Monad.Fix
+import Control.Monad.CatchIO (MonadCatchIO -- ,onException
+ )
+import qualified Control.Monad.CatchIO as E
+import Control.Monad.Trans
+import Data.Binary
+import Data.Binary.Get
+import Data.Binary.Put
+import qualified Data.ByteString as B
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Lazy as L
+-- import qualified Data.ByteString.Lazy.UTF8 as UTF8
+-- import Data.ByteString.UTF8 (toString)
+import Data.Int
+import Data.List
+import Data.Maybe
+import Data.Monoid
+import Network
+import Prelude
+import System.IO hiding (hPutStr)
+
+-- FIXME: Proper escape function.
+escape :: String -> String
+escape str = undefined
+
+-- FIXME:
+insertID :: Connection -> IO Word64
+insertID _ = return 0
+
+-- FIXME:
+-- | Turn autocommit on or off.
+--
+-- By default, PostgreSQL runs with autocommit mode enabled. In this
+-- mode, as soon as you modify a table, PostgreSQL stores your
+-- modification permanently.
+autocommit :: Connection -> Bool -> IO ()
+autocommit conn onOff = return () -- withConnection conn $ \ptr ->
+ -- mysql_autocommit ptr b >>= check "autocommit" conn
+ -- where b = if onOff then 1 else 0
+
+--------------------------------------------------------------------------------
+-- Exported values
+
+-- | Default information for setting up a connection.
+--
+-- Defaults are as follows:
+--
+-- * Server on @localhost@
+--
+-- * User @root@
+--
+-- * No password
+--
+-- * Database @test@
+--
+-- * Character set @utf8@
+--
+-- Use as in the following example:
+--
+-- > connect defaultConnectInfo { connectHost = "db.example.com" }
+defaultConnectInfo :: ConnectInfo
+defaultConnectInfo = ConnectInfo {
+ connectHost = "localhost"
+ , connectPort = 5432
+ , connectUser = "root"
+ , connectPassword = ""
+ , connectDatabase = "test"
+ }
+
+-- | Connect with the given username to the given database. Will throw
+-- an exception if it cannot connect.
+connect :: MonadIO m => ConnectInfo -> m Connection -- ^ The datase connection.
+connect connectInfo@ConnectInfo{..} = liftIO $ withSocketsDo $ do
+ var <- newEmptyMVar
+ h <- connectTo connectHost (PortNumber $ fromIntegral connectPort)
+ hSetBuffering h NoBuffering
+ putMVar var $ Just h
+ let conn = Connection var
+ authenticate conn connectInfo
+ return conn
+
+withDB :: (MonadCatchIO m,MonadIO m) => ConnectInfo -> (Connection -> m a) -> m a
+withDB connectInfo m = E.bracket (liftIO $ connect connectInfo) (liftIO . close) m
+
+rollback :: (MonadCatchIO m,MonadIO m) => Connection -> m ()
+rollback conn = do
+ query conn (fromString ("ABORT;" :: String))
+ return ()
+
+commit :: (MonadCatchIO m,MonadIO m) => Connection -> m ()
+commit conn = do
+ query conn (fromString ("COMMIT;" :: String))
+ return ()
+
+-- | Close a connection. Can safely be called any number of times.
+close :: MonadIO m => Connection -- ^ The connection.
+ -> m ()
+close (Connection v) = liftIO$ do
+ modifyMVar_ v $ \h -> do
+ case h of
+ Just h -> hClose h
+ Nothing -> return ()
+ return Nothing
+
+-- | Run a simple query on a connection.
+query :: MonadIO m => Connection -- ^ The connection.
+ -> ByteString -- ^ The query.
+ -> m [a]
+query conn sql = liftIO $ do
+ withConnection conn $ \h -> do
+ Result{..} <- sendQuery h sql
+ case resultType of
+ ErrorResponse -> error "TODO: query.ErrorResponse"
+ _ -> return $ [] -- resultRows -- FIXME:
+
+-- | PostgreSQL protocol version supported by this library.
+protocolVersion :: Int32
+protocolVersion = 196608
+
+--------------------------------------------------------------------------------
+-- Authentication
+
+-- | Run the connectInfoentication procedure.
+authenticate :: Connection -> ConnectInfo -> IO ()
+authenticate conn connectInfo = do
+ withConnection conn $ \h -> do
+ sendStartUp h connectInfo
+ getConnectInfoResponse h
+ return ()
+
+-- | Send the start-up message.
+sendStartUp :: Handle -> ConnectInfo -> IO ()
+sendStartUp h ConnectInfo{..} = do
+ sendBlock h Nothing $ do
+ int32 protocolVersion
+ string (fromString "user") ; string (fromString connectUser)
+ string (fromString "database") ; string (fromString connectDatabase)
+ zero
+
+-- | Wait for and process the connectInfoentication response from the server.
+getConnectInfoResponse :: Handle -> IO ()
+getConnectInfoResponse h = do
+ (typ,block) <- getMessage h
+ case typ of
+ AuthenticationOk | param == 0 -> waitForReady h
+ where param = decode block :: Int32
+ -- TODO: Handle connectInfo failure. Handle information messages that are
+ -- sent, maybe store in the connection value for later
+ -- inspection.
+ _ -> return ()
+
+--------------------------------------------------------------------------------
+-- Initialization
+
+typeObjectIds :: Connection -> IO [(String,Int32)]
+typeObjectIds conn = do
+ withConnection conn $ \h -> do
+ Result{..} <- sendQuery h (fromString ("SELECT typname, oid FROM pg_type" :: String))
+ case resultType of
+ ErrorResponse -> return [] -- TODO: Throw an error in some nice way.
+ -- FIXME:
+ -- _ -> return $ catMaybes $ flip map resultRows $ \row ->
+ -- case map toString $ catMaybes row of
+ -- [typ,objId] -> Just $ (typ,read objId)
+ -- _ -> Nothing
+
+--------------------------------------------------------------------------------
+-- Queries and commands
+
+-- | Send a simple query.
+sendQuery :: Handle -> ByteString -> IO Result
+sendQuery h sql = do
+ sendMessage h Query $ string sql
+ listener $ \continue -> do
+ (typ,block) <- liftIO $ getMessage h
+ let done = modify $ \r -> r { resultType = typ }
+ case typ of
+ CommandComplete -> done
+ EmptyQueryResponse -> done
+ ReadyForQuery -> done
+ ErrorResponse -> do
+ modify $ \r -> r { resultError = Just block }
+ done
+
+ listenFor -> do
+ case listenFor of
+ RowDescription -> getRowDesc block
+ DataRow -> getDataRow block
+ NoticeResponse -> getNotice block
+ _ -> return ()
+ continue
+
+ where emptyResponse = Result Nothing Nothing [] UnknownMessageType
+ listener m = execStateT (fix m) emptyResponse
+
+-- | Update the row description of the result.
+getRowDesc :: MonadState Result m => L.ByteString -> m ()
+getRowDesc block =
+ modify $ \r -> r { resultDesc = Just (runGet parseMsg block) }
+ where parseMsg = do
+ fieldCount :: Int16 <- getInt16
+ forM [1..fieldCount] $ \_ -> do
+ name <- getString
+ objid <- getInt32
+ colid <- getInt16
+ dtype <- getInt32
+ size <- getInt16
+ modifier <- getInt32
+ code <- getInt16
+ return (name,objid,colid,dtype,size,modifier)
+
+-- | Add a data row to the response.
+getDataRow :: MonadState Result m => L.ByteString -> m ()
+getDataRow block =
+ return ()
+-- modify $ \r -> r { resultRows = runGet parseMsg block : resultRows r }
+ where parseMsg = do
+ values :: Int16 <- getInt16
+ forM [1..values] $ \_ -> do
+ size <- getInt32
+ if size == -1
+ then return Nothing
+ else do v <- getByteString (fromIntegral size)
+ return (Just v)
+
+-- TODO:
+getNotice :: MonadState Result m => L.ByteString -> m ()
+getNotice block =
+ return ()
+-- modify $ \r -> r { responseNotices = runGet parseMsg block : responseNotices r }
+-- where parseMsg = return ""
+
+typeFromChar :: Char -> Maybe MessageType
+typeFromChar c = lookup c types
+
+charFromType :: MessageType -> Maybe Char
+charFromType typ = fmap fst $ find ((==typ).snd) types
+
+types = [('C',CommandComplete)
+ ,('T',RowDescription)
+ ,('D',DataRow)
+ ,('I',EmptyQueryResponse)
+ ,('E',ErrorResponse)
+ ,('Z',ReadyForQuery)
+ ,('N',NoticeResponse)
+ ,('R',AuthenticationOk)
+ ,('Q',Query)]
+
+-- | Blocks until receives ReadyForQuery.
+waitForReady :: Handle -> IO ()
+waitForReady h = loop where
+ loop = do
+ (typ,block) <- getMessage h
+ case typ of
+ ReadyForQuery | decode block == 'I' -> return ()
+ diff -> loop
+
+--------------------------------------------------------------------------------
+-- Connections
+
+-- | Atomically perform an action with the database handle, if there is one.
+withConnection :: Connection -> (Handle -> IO a) -> IO a
+withConnection Connection{..} m = do
+ withMVar connectionHandle $ \h -> do
+ case h of
+ Just h -> m h
+ -- TODO: Use extensible exceptions.
+ Nothing -> error "Database.PostgreSQL.withConnection: Connection is lost."
+
+-- | Send a block of bytes on a handle, prepending the message type
+-- and complete length.
+sendMessage :: Handle -> MessageType -> Put -> IO ()
+sendMessage h typ output =
+ case charFromType typ of
+ Just char -> sendBlock h (Just char) output
+ Nothing -> return () -- TODO: Possibly throw an error. Or just ignore?
+
+-- | Send a block of bytes on a handle, prepending the complete length.
+sendBlock :: Handle -> Maybe Char -> Put -> IO ()
+sendBlock h typ output = do
+ L.hPutStr h bytes
+ where bytes = start `mappend` out
+ start = runPut $ do
+ maybe (return ()) (put . toByte) typ
+ int32 $ fromIntegral int32Size +
+ fromIntegral (L.length out)
+ out = runPut output
+ toByte c = fromIntegral (fromEnum c) :: Word8
+
+-- | Get a message (block) from the stream.
+getMessage :: Handle -> IO (MessageType,L.ByteString)
+getMessage h = do
+ messageType <- L.hGet h 1
+ blockLength <- L.hGet h int32Size
+ let typ = decode messageType
+ rest = fromIntegral (decode blockLength :: Int32) - int32Size
+ block <- L.hGet h rest
+ return (maybe UnknownMessageType id $ typeFromChar typ,block)
+
+--------------------------------------------------------------------------------
+-- Binary input/output
+
+-- | Put a Haskell string, encoding it to UTF-8, and null-terminating it.
+-- TODO: Make this not terrible.
+string :: ByteString -> Put
+string s = do put s; zero
+fromString = const (undefined :: ByteString)
+-- FIXME:
+toString = const ""
+
+-- | Put a Haskell 32-bit integer.
+int32 :: Int32 -> Put
+int32 = put
+
+-- | Put zero-byte terminator.
+zero :: Put
+zero = put (0 :: Word8)
+
+-- | To avoid magic numbers, size of a 32-bit integer in bytes.
+int32Size :: Int
+int32Size = 4
+
+getInt16 :: Get Int16
+getInt16 = get
+
+getInt32 :: Get Int32
+getInt32 = get
+
+getString :: Get L.ByteString
+getString = getLazyByteStringNul
View
57 Database/PostgreSQL/Base/Types.hs
@@ -1,9 +1,11 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Database.PostgreSQL.Base.Types
- (ConnectInfo
- ,Connection
- ,Field
- ,Result)
+ (ConnectInfo(..)
+ ,Connection(..)
+ ,Field(..)
+ ,Result(..)
+ ,Type(..)
+ ,MessageType(..))
where
import Control.Concurrent.MVar (MVar)
@@ -18,6 +20,7 @@ import Data.Word
import Network (PortID)
import System.IO (Handle)
+-- | Connection configuration.
data ConnectInfo = ConnectInfo {
connectHost :: String
, connectPort :: Word16
@@ -32,15 +35,15 @@ data Connection = Connection {
}
-- | Result of a database query.
-data Result a =
+data Result =
Result {
- resultRows :: [a]
- ,resultDesc :: Maybe RowDescription
+ resultDesc :: Maybe RowDescription
,resultError :: Maybe L.ByteString
,resultNotices :: [String]
,resultType :: MessageType
} deriving Show
+-- | An internal message type.
data MessageType =
CommandComplete
| RowDescription
@@ -49,16 +52,52 @@ data MessageType =
| ErrorResponse
| ReadyForQuery
| NoticeResponse
- | UnknownMessageType
| AuthenticationOk
| Query
+ | UnknownMessageType
deriving (Show,Eq)
+-- | Description of a postgres row.
type RowDescription = [(L.ByteString
,Int32
,Int16
,Int32
,Int16
,Int32)]
-data Field = Field
+-- | FIXME: Come up with something for this based on postgres's features.
+data Field = Field {
+ fieldType :: Type
+ ,fieldCharSet :: Word -- FIXME: Get the right value for this.
+ }
+
+-- FIXME: Update to proper supported types.
+-- | Column types supported by PostgreSQL.
+data Type = Decimal
+ | Tiny
+ | Short
+ | Long
+ | Float
+ | Double
+ | Null
+ | Timestamp
+ | LongLong
+ | Int24
+ | Date
+ | Time
+ | DateTime
+ | Year
+ | NewDate
+ | VarChar
+ | Bit
+ | NewDecimal
+ | Enum
+ | Set
+ | TinyBlob
+ | MediumBlob
+ | LongBlob
+ | Blob
+ | VarString
+ | String
+ | Geometry
+ deriving (Enum, Eq, Show, Typeable)
View
1,051 Database/PostgreSQL/Simple.hs
@@ -44,43 +44,41 @@ module Database.PostgreSQL.Simple
-- $types
-- * Types
- -- FIXME:
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
+ , Query
+ , In(..)
+ , Binary(..)
+ , Only(..)
+ -- ** 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)
@@ -96,10 +94,8 @@ import Data.Typeable (Typeable)
import Database.PostgreSQL.Base.Types (ConnectInfo,Connection,Result,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.QueryResults (QueryResults(..))
+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
@@ -125,491 +121,496 @@ data QueryError = QueryError {
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) = pure $ (inQuotes . fromByteString . xxx) 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
+-- FIXME:
+xxx = undefined
+
+-- | 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
+ return 0
+ -- 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_ #-}
+
+--FIXME:
+finishQuery :: (QueryResults r) => Connection -> Query -> IO [r]
+finishQuery conn q = return [] -- 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)
+
+--FIXME:
+finishFold :: (QueryResults r) =>
+ Connection -> Query -> a -> (a -> r -> IO a) -> IO a
+finishFold conn q z0 f = undefined -- 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
+
+--FIXME:
+withResult :: (IO Result) -> Query -> (Result -> [Field] -> IO a) -> IO a
+withResult fetchResult q act = return undefined -- 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'.
--
--- -- 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.
+-- * 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.
View
219 Database/PostgreSQL/Simple/QueryResults.hs
@@ -15,20 +15,17 @@
-- elements.
module Database.PostgreSQL.Simple.QueryResults
- (
- -- FIXME: Add these back.
- -- QueryResults(..)
- -- , convertError
+ ( 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.
+import Database.PostgreSQL.Base.Types (Field(fieldType))
+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
@@ -61,111 +58,111 @@ import qualified Data.ByteString.Char8 as B
-- 'QueryResults'.
--
-- @
---data User { firstName :: String, lastName :: String }
---
---instance 'QueryResults' User where
+-- 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
+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
View
317 Database/PostgreSQL/Simple/Result.hs
@@ -19,12 +19,11 @@
-- two are /not/ considered compatible.
module Database.PostgreSQL.Simple.Result
- ( -- FIXME: Add these back.
- -- Result(..)
- -- , ResultError(..)
+ ( Result(..)
+ , ResultError(..)
) where
-#include "MachDeps.h"
+-- #include "MachDeps.h" -- FIXME: What's this for?
import Control.Applicative ((<$>), (<*>), (<*), pure)
import Control.Exception (Exception, throw)
@@ -40,7 +39,7 @@ 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 Database.PostgreSQL.Base.Types (Field(..), Type(..))
import System.Locale (defaultTimeLocale)
import qualified Data.ByteString as SB
import qualified Data.ByteString.Char8 as B8
@@ -68,161 +67,161 @@ data ResultError = Incompatible { errSQLType :: String
-- 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]
+instance Exception ResultError
--- isText :: Field -> Bool
--- isText f = fieldCharSet f /= 63
+-- | 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.
--- newtype Compat = Compat Word32
+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
+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
View
5 pgsql-simple.cabal
@@ -37,7 +37,10 @@ library
old-locale,
text >= 0.11.0.2,
time,
- network >= 2.2
+ network >= 2.2,
+ binary >= 0.5,
+ mtl >= 2.0,
+ MonadCatchIO-mtl >= 0.3
ghc-options: -Wall
if impl(ghc >= 6.8)

0 comments on commit a77e39a

Please sign in to comment.
Something went wrong with that request. Please try again.