diff --git a/Database/MySQL/Simple.hs b/Database/MySQL/Simple.hs --- a/Database/MySQL/Simple.hs +++ b/Database/MySQL/Simple.hs @@ -1,32 +1,73 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns, DeriveDataTypeable, OverloadedStrings #-} +-- | +-- Module: Database.MySQL.Simple +-- Copyright: (c) 2011 MailRank, Inc. +-- License: BSD3 +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- A mid-level client library for the MySQL database, aimed at ease of +-- use and high performance. + module Database.MySQL.Simple ( - FormatError(fmtMessage, fmtQuery, fmtParams) + -- * Types + Base.ConnectInfo(..) + , Connection + , Query + , In(..) , Only(..) - , execute + -- ** 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_ + -- * 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 (fromByteString, toByteString) +import Blaze.ByteString.Builder (Builder, fromByteString, toByteString) +import Blaze.ByteString.Builder.Char8 (fromChar) import Control.Applicative ((<$>), pure) -import Control.DeepSeq (NFData(..)) -import Control.Exception (Exception, throw) +import Control.Exception (Exception, onException, throw) import Control.Monad.Fix (fix) import Data.ByteString (ByteString) import Data.Int (Int64) -import Data.Monoid (mappend) +import Data.List (intersperse) +import Data.Monoid (mappend, mconcat) import Data.Typeable (Typeable) import Database.MySQL.Base (Connection) import Database.MySQL.Simple.Param (Action(..), inQuotes) import Database.MySQL.Simple.QueryParams (QueryParams(..)) import Database.MySQL.Simple.QueryResults (QueryResults(..)) -import Database.MySQL.Simple.Types (Only(..), Query(..)) +import Database.MySQL.Simple.Result (ResultError(..)) +import Database.MySQL.Simple.Types (In(..), Only(..), Query(..)) +import Text.Regex.PCRE.Light (compile, caseless, match) import qualified Data.ByteString.Char8 as B import qualified Database.MySQL.Base as Base +-- | Exception thrown if a 'Query' could not be formatted correctly. +-- This may occur if the number of \'@?@\' characters in the query +-- string does not match the number of parameters provided. data FormatError = FormatError { fmtMessage :: String , fmtQuery :: Query @@ -35,13 +76,57 @@ instance Exception FormatError +-- | Exception thrown if 'query' is used to perform an @INSERT@-like +-- operation, or 'execute' is used to perform a @SELECT@-like operation. +data QueryError = QueryError { + qeMessage :: String + , qeQuery :: Query + } deriving (Eq, Show, Typeable) + +instance Exception QueryError + +-- | Format a query string. +-- +-- 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 . zipParams (split template) <$> mapM sub xs + | otherwise = toByteString <$> buildQuery conn q template xs where xs = renderParams qs - sub (Plain b) = pure b + +-- | Format a query string with a variable number of rows. +-- +-- 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 @@ -50,39 +135,100 @@ " '?' 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 template conn + +-- | 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 q conn + +-- | 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 q conn + +finishExecute :: Query -> Connection -> IO Int64 +finishExecute q conn = do ncols <- Base.fieldCount (Left conn) if ncols /= 0 - then error "execute: executed a select!" + then throw $ QueryError ("execute resulted in " ++ show ncols ++ + "-column result") q else Base.affectedRows conn - -query :: (QueryParams q, QueryResults r) => Connection -> Query -> q -> IO [r] + +-- | Perform a @SELECT@ or other SQL query that is expected to return +-- results. +-- +-- All results are retrieved and converted before this function +-- returns. +-- +-- 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 - + finishQuery template conn + +-- | A version of 'query' that does not perform query substitution. query_ :: (QueryResults r) => Connection -> Query -> IO [r] -query_ conn (Query q) = do - Base.query conn q - finishQuery conn +query_ conn q@(Query que) = do + Base.query conn que + finishQuery q conn -finishQuery :: (QueryResults r) => Connection -> IO [r] -finishQuery conn = do +finishQuery :: (QueryResults r) => Query -> Connection -> IO [r] +finishQuery q conn = do r <- Base.storeResult conn ncols <- Base.fieldCount (Right r) if ncols == 0 - then return [] + then throw $ QueryError "query resulted in zero-column result" q else do fs <- Base.fetchFields r flip fix [] $ \loop acc -> do row <- Base.fetchRow r case row of [] -> return (reverse acc) - _ -> let c = convertResults fs row - in rnf c `seq` loop (c:acc) + _ -> let !c = convertResults fs row + in loop (c:acc) +-- | Execute an action inside a SQL transaction. +-- +-- You are assumed to have started the transaction yourself. +-- +-- If your action succeeds, the transaction will be 'Base.commit'ted +-- before this function returns. +-- +-- If your action throws any exception (not just a SQL exception), the +-- transaction will be rolled back 'Base.rollback' before the +-- exception is propagated. +withTransaction :: Connection -> IO a -> IO a +withTransaction conn act = do + r <- act `onException` Base.rollback conn + Base.commit conn + return r + fmtError :: String -> Query -> [Action] -> a fmtError msg q xs = throw FormatError { fmtMessage = msg @@ -91,3 +237,4 @@ } where twiddle (Plain b) = toByteString b twiddle (Escape s) = s + twiddle (Many ys) = B.concat (map twiddle ys) diff --git a/Database/MySQL/Simple/Orphans.hs b/Database/MySQL/Simple/Orphans.hs deleted file mode 100644 --- a/Database/MySQL/Simple/Orphans.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Database.MySQL.Simple.Orphans () where - -import Control.DeepSeq (NFData(..)) -import Data.Time.Calendar (Day(..)) -import Data.Time.Clock (UTCTime(..)) -import Data.Time.LocalTime (TimeOfDay(..)) -import qualified Data.ByteString.Internal as SB -import qualified Data.ByteString.Lazy.Internal as LB - -instance NFData SB.ByteString where - rnf (SB.PS _ _ _) = () - {-# INLINE rnf #-} - -instance NFData LB.ByteString where - rnf (LB.Chunk (SB.PS _ _ _) cs) = rnf cs - rnf LB.Empty = () - -instance NFData Day where - rnf (ModifiedJulianDay !_) = () - {-# INLINE rnf #-} - -instance NFData TimeOfDay where - rnf (TimeOfDay !_ !_ !_) = () - {-# INLINE rnf #-} - -instance NFData UTCTime where - rnf (UTCTime !_ !_) = () - {-# INLINE rnf #-} - -instance (NFData a, NFData b, NFData c, NFData d, NFData e, NFData f, - NFData g, NFData h, NFData i, NFData j) => - NFData (a,b,c,d,e,f,g,h,i,j) - where - rnf (a,b,c,d,e,f,g,h,i,j) = - rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e `seq` - rnf f `seq` rnf g `seq` rnf h `seq` rnf i `seq` rnf j - {-# INLINE rnf #-} diff --git a/Database/MySQL/Simple/Param.hs b/Database/MySQL/Simple/Param.hs --- a/Database/MySQL/Simple/Param.hs +++ b/Database/MySQL/Simple/Param.hs @@ -1,5 +1,16 @@ -{-# LANGUAGE FlexibleInstances, OverloadedStrings #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, FlexibleInstances, + OverloadedStrings #-} +-- | +-- Module: Database.MySQL.Simple.Param +-- Copyright: (c) 2011 MailRank, Inc. +-- License: BSD3 +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- The 'Param' typeclass, for rendering a parameter to a SQL query. + module Database.MySQL.Simple.Param ( Action(..) @@ -8,16 +19,19 @@ ) where import Blaze.ByteString.Builder (Builder, fromByteString, toByteString) +import Blaze.ByteString.Builder.Char8 (fromChar) import Blaze.Text (integral, double, float) import Data.ByteString (ByteString) 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.MySQL.Simple.Types (Null) +import Database.MySQL.Simple.Types (In(..), Null) import System.Locale (defaultTimeLocale) import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8 import qualified Data.ByteString as SB @@ -26,11 +40,30 @@ import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT -data Action = Plain Builder - | Escape ByteString +-- | How to render an element when substituting it into a query. +data Action = + Plain Builder + -- ^ Render without escaping or quoting. Use for non-text types + -- such as numbers, when you are /certain/ that they will not + -- introduce formatting vulnerabilities via use of characters such + -- as spaces or \"@'@\". + | Escape ByteString + -- ^ Escape and enclose in quotes before substituting. Use for all + -- text-like types, and anything else that may contain unsafe + -- characters when rendered. + | 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 @@ -41,6 +74,13 @@ 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 ')')] + renderNull :: Action renderNull = Plain (fromByteString "null") @@ -138,6 +178,9 @@ render = Plain . inQuotes . Utf8.fromString . show {-# INLINE render #-} +-- | Surround a string with single-quote characters: \"@'@\" +-- +-- This function /does not/ perform any other escaping. inQuotes :: Builder -> Builder inQuotes b = quote `mappend` b `mappend` quote where quote = Utf8.fromChar '\'' diff --git a/Database/MySQL/Simple/QueryParams.hs b/Database/MySQL/Simple/QueryParams.hs --- a/Database/MySQL/Simple/QueryParams.hs +++ b/Database/MySQL/Simple/QueryParams.hs @@ -1,3 +1,14 @@ +-- | +-- Module: Database.MySQL.Simple.QueryParams +-- Copyright: (c) 2011 MailRank, Inc. +-- License: BSD3 +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- The 'QueryParams' typeclass, for rendering a collection of +-- parameters to a SQL query. + module Database.MySQL.Simple.QueryParams ( QueryParams(..) @@ -6,8 +17,11 @@ import Database.MySQL.Simple.Param (Action(..), Param(..)) import Database.MySQL.Simple.Types (Only(..)) +-- | A collection type that can be turned into a list of rendering +-- 'Action's. class QueryParams a where renderParams :: a -> [Action] + -- ^ Render a collection of values. instance QueryParams () where renderParams _ = [] diff --git a/Database/MySQL/Simple/QueryResults.hs b/Database/MySQL/Simple/QueryResults.hs --- a/Database/MySQL/Simple/QueryResults.hs +++ b/Database/MySQL/Simple/QueryResults.hs @@ -1,101 +1,152 @@ +{-# LANGUAGE BangPatterns, OverloadedStrings #-} + +-- | +-- Module: Database.MySQL.Simpe.QueryResults +-- Copyright: (c) 2011 MailRank, Inc. +-- License: BSD3 +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- The 'QueryResults' typeclass, for converting a row of results +-- returned by a SQL query into a more useful Haskell representation. + module Database.MySQL.Simple.QueryResults ( QueryResults(..) + , convertError ) where -import Control.DeepSeq (NFData(..)) import Control.Exception (throw) import Data.ByteString (ByteString) -import Database.MySQL.Base.Types (Field) +import qualified Data.ByteString.Char8 as B +import Database.MySQL.Base.Types (Field(fieldType)) import Database.MySQL.Simple.Result (ResultError(..), Result(..)) import Database.MySQL.Simple.Types (Only(..)) -class (NFData a) => QueryResults a where +-- | 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. +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 (NFData a, Result a) => QueryResults (Only a) where - convertResults [fa] [va] = Only (convert fa va) - convertResults fs vs = convError fs vs +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 (NFData a, NFData b, - Result a, Result b) => QueryResults (a,b) where - convertResults [fa,fb] [va,vb] = (convert fa va, convert fb vb) - convertResults fs vs = convError fs vs +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 (NFData a, NFData b, NFData c, - Result a, Result b, Result c) => QueryResults (a,b,c) where - convertResults [fa,fb,fc] [va,vb,vc] = - (convert fa va, convert fb vb, convert fc vc) - convertResults fs vs = convError fs vs +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 (NFData a, NFData b, NFData c, NFData d, - Result a, Result b, Result c, Result d) => +instance (Result a, Result b, Result c, Result d) => QueryResults (a,b,c,d) where - convertResults [fa,fb,fc,fd] [va,vb,vc,vd] = - (convert fa va, convert fb vb, convert fc vc, convert fd vd) - convertResults fs vs = convError fs vs + 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 (NFData a, NFData b, NFData c, NFData d, NFData e, - Result a, Result b, Result c, Result d, Result e) => +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] = - (convert fa va, convert fb vb, convert fc vc, convert fd vd, - convert fe ve) - convertResults fs vs = convError fs vs + 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 (NFData a, NFData b, NFData c, NFData d, NFData e, NFData f, - Result a, Result b, Result c, Result d, Result e, Result f) => +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] = - (convert fa va, convert fb vb, convert fc vc, convert fd vd, - convert fe ve, convert ff vf) - convertResults fs vs = convError fs vs + 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 (NFData a, NFData b, NFData c, NFData d, NFData e, NFData f, - NFData g, - Result a, Result b, Result c, Result d, Result e, Result f, +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] = - (convert fa va, convert fb vb, convert fc vc, convert fd vd, - convert fe ve, convert ff vf, convert fg vg) - convertResults fs vs = convError fs vs + (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 (NFData a, NFData b, NFData c, NFData d, NFData e, NFData f, - NFData g, NFData h, - Result a, Result b, Result c, Result d, Result e, Result f, +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] = - (convert fa va, convert fb vb, convert fc vc, convert fd vd, - convert fe ve, convert ff vf, convert fg vg, convert fh vh) - convertResults fs vs = convError fs vs + (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 (NFData a, NFData b, NFData c, NFData d, NFData e, NFData f, - NFData g, NFData h, NFData i, - Result a, Result b, Result c, Result d, Result e, Result f, +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] = - (convert fa va, convert fb vb, convert fc vc, convert fd vd, - convert fe ve, convert ff vf, convert fg vg, convert fh vh, - convert fi vi) - convertResults fs vs = convError fs vs + (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 (NFData a, NFData b, NFData c, NFData d, NFData e, NFData f, - NFData g, NFData h, NFData i, NFData j, - Result a, Result b, Result c, Result d, Result e, Result f, +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] = - (convert fa va, convert fb vb, convert fc vc, convert fd vd, - convert fe ve, convert ff vf, convert fg vg, convert fh vh, - convert fi vi, convert fj vj) - convertResults fs vs = convError fs vs + (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 -convError :: [Field] -> [Maybe ByteString] -> a -convError fs vs = throw $ ConversionFailed - (show (length fs) ++ " columns left in result") - (show (length vs) ++ " values left in row") - "mismatch between number of columns to convert" +-- | 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 diff --git a/Database/MySQL/Simple/Result.hs b/Database/MySQL/Simple/Result.hs --- a/Database/MySQL/Simple/Result.hs +++ b/Database/MySQL/Simple/Result.hs @@ -1,5 +1,23 @@ {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances #-} +-- | +-- Module: Database.MySQL.Simpe.QueryResults +-- Copyright: (c) 2011 MailRank, Inc. +-- License: BSD3 +-- Maintainer: Bryan O'Sullivan +-- 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.MySQL.Simple.Result ( Result(..) @@ -9,7 +27,6 @@ #include "MachDeps.h" import Control.Applicative ((<$>), (<*>), (<*), pure) -import Control.DeepSeq (NFData) import Control.Exception (Exception, throw) import Data.Attoparsec.Char8 hiding (Result) import Data.Bits ((.&.), (.|.), shiftL) @@ -24,7 +41,6 @@ import Data.Typeable (TypeRep, Typeable, typeOf) import Data.Word (Word, Word8, Word16, Word32, Word64) import Database.MySQL.Base.Types (Field(..), Type(..)) -import Database.MySQL.Simple.Orphans () import System.Locale (defaultTimeLocale) import qualified Data.ByteString as SB import qualified Data.ByteString.Char8 as B8 @@ -33,21 +49,34 @@ import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT -data ResultError = Incompatible { errSourceType :: String - , errDestType :: String +-- | Exception thrown if conversion from a SQL value to a Haskell +-- value fails. +data ResultError = Incompatible { errSQLType :: String + , errHaskellType :: String , errMessage :: String } - | UnexpectedNull { errSourceType :: String - , errDestType :: String + -- ^ The SQL and Haskell types are not compatible. + | UnexpectedNull { errSQLType :: String + , errHaskellType :: String , errMessage :: String } - | ConversionFailed { errSourceType :: String - , errDestType :: String + -- ^ A SQL @NULL@ was encountered when the Haskell + -- type did not permit it. + | ConversionFailed { errSQLType :: String + , errHaskellType :: String , errMessage :: String } + -- ^ The SQL value could not be parsed, or could not + -- be represented as a valid Haskell value, or an + -- unexpected low-level error occurred (e.g. mismatch + -- between metadata and actual data in a row). deriving (Eq, Show, Typeable) instance Exception ResultError -class (NFData a) => Result a where +-- | 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 @@ -91,15 +120,17 @@ instance Result Float where convert = atto ok ((fromRational . toRational) <$> double) - where ok = mkCompats [Float,Double,Decimal,NewDecimal] + 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] + 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] + where ok = mkCompats [Float,Double,Decimal,NewDecimal,Tiny,Short,Int24, + Long,LongLong] instance Result SB.ByteString where convert f = doConvert f okText $ id diff --git a/Database/MySQL/Simple/Types.hs b/Database/MySQL/Simple/Types.hs --- a/Database/MySQL/Simple/Types.hs +++ b/Database/MySQL/Simple/Types.hs @@ -1,24 +1,58 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GeneralizedNewtypeDeriving #-} +-- | +-- Module: Database.MySQL.Simple.Types +-- Copyright: (c) 2011 MailRank, Inc. +-- License: BSD3 +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Basic types. + module Database.MySQL.Simple.Types ( Null(..) , Only(..) + , In(..) , Query(..) ) where -import Control.Arrow -import Control.DeepSeq (NFData) -import Blaze.ByteString.Builder +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 Data.ByteString (ByteString) +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 ?" newtype Query = Query { fromQuery :: ByteString - } deriving (Eq, Ord) + } deriving (Eq, Ord, Typeable) instance Show Query where show = show . fromQuery @@ -29,5 +63,29 @@ instance IsString Query where fromString = Query . toByteString . Utf8.fromString -newtype Only a = Only a - deriving (Eq, Ord, Read, Show, NFData) +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 can be handy if you need to supply a single parameter to a SQL +-- query. +-- +-- Example: +-- +-- @query \"select x from scores where x > ?\" ('Only' (42::Int))@ +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 "select * from whatever where id in ?" (In [3,4,5]) +newtype In a = In a + deriving (Eq, Ord, Read, Show, Typeable, Functor) diff --git a/mysql-simple.cabal b/mysql-simple.cabal --- a/mysql-simple.cabal +++ b/mysql-simple.cabal @@ -1,5 +1,5 @@ name: mysql-simple -version: 0.1.0.1 +version: 0.2.0.0 homepage: https://github.com/mailrank/mysql-simple bug-reports: https://github.com/mailrank/mysql-simple/issues synopsis: A mid-level MySQL client library. @@ -38,17 +38,14 @@ Database.MySQL.Simple.Result Database.MySQL.Simple.Types - other-modules: - Database.MySQL.Simple.Orphans - build-depends: attoparsec >= 0.8.5.3, base < 5, blaze-builder, blaze-textual, bytestring >= 0.9, - deepseq, - mysql, + mysql >= 0.1.0.1, + pcre-light, old-locale, text >= 0.11.0.2, time