mysql-simple 0.2.2.5 → 0.4.9
raw patch · 15 files changed
Files
- ChangeLog.md +70/−0
- Database/MySQL/Internal/Blaze.hs +275/−0
- Database/MySQL/Simple.hs +80/−13
- Database/MySQL/Simple/Param.hs +36/−7
- Database/MySQL/Simple/QueryParams.hs +125/−1
- Database/MySQL/Simple/QueryResults.hs +163/−2
- Database/MySQL/Simple/Result.hs +88/−27
- Database/MySQL/Simple/Types.hs +20/−2
- README.markdown +6/−11
- mysql-simple.cabal +49/−18
- stack.yaml +7/−0
- test/Common.hs +16/−0
- test/CustomTypeSpec.hs +69/−0
- test/DateTimeSpec.hs +82/−0
- test/main.hs +117/−0
+ ChangeLog.md view
@@ -0,0 +1,70 @@+## 0.4.9++* Additional tuple instances of QueryParams (https://github.com/paul-rouse/mysql-simple/pull/57)++## 0.4.8.1++* Allow build on ghc 8.4.x (https://github.com/paul-rouse/mysql-simple/pull/56)++## 0.4.8++* Provide classes to simplify user-defined encoding and decoding of columns.++## 0.4.7.2++* Fix question marks in string literals causing substitution errors (https://github.com/paul-rouse/mysql-simple/pull/54)++## 0.4.7.1++* Use parseTimeM from Data.Time.Format instead of parseTime (https://github.com/paul-rouse/mysql-simple/pull/53)++## 0.4.7++* Allow JSON fields to be read in as ByteStrings (https://github.com/paul-rouse/mysql-simple/pull/52)++## 0.4.6++* Support GHC-9 via blaze-textual shim (https://github.com/paul-rouse/mysql-simple/pull/51).++## 0.4.5++* Add Semigroup instance for Query+* Add a `(Param a) => Param (In (Set a))` instance.+* Drop testing under GHC 7.8 / lts-2++## 0.4.4++* Report table name and database in the UnexpectedNull case of ResultError, using the previously empty errMessage field++## 0.4.3++* Use Data.Time.Format to parse TimeOfDay results properly (missing in https://github.com/paul-rouse/mysql-simple/pull/37).++## 0.4.2.0++* Handle fractional seconds in parameter substitution (without affecting cases where only whole seconds are used). https://github.com/paul-rouse/mysql-simple/pull/40++## 0.4.1.0++* Add missing tuple instances of QueryResults (https://github.com/paul-rouse/mysql-simple/issues/9)+* Fix `error "foo"` left in code (https://github.com/paul-rouse/mysql-simple/issues/39)+* Allow fractional seconds in to be parsed in date/time results https://github.com/paul-rouse/mysql-simple/pull/37++## 0.4.0.1++* Fix https://github.com/paul-rouse/mysql-simple/issues/35++## 0.4.0.0++* Add type VaArgs for non-parenthesized variable-length list of parameters.+* Include fieldName in other constructors of ResultError.++## 0.3.0.0++* New maintainer and GitHub location - with many thanks to Bryan O'Sullivan for all of the past work on this module, and for facilitating the transfer of maintenance responsibility.+* Extra instances of QueryParams for larger tuples.+* Include fieldName in ResultError in the case of the Incompatible constructor.++The changes to ResultError and QueryParams were previously unreleased,+although present in the GitHub repository. They are the reason for the+major version bump.
+ Database/MySQL/Internal/Blaze.hs view
@@ -0,0 +1,275 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings, UnboxedTuples #-}++-- | This module is designed to provide a shim for @blaze-textual@.+-- @blaze-textual@ does not support GHC 9. A PR has been opened to add that+-- support for GHC 9 here: https://github.com/bos/blaze-textual/pull/14+--+-- When GHC 9 support is merged in, we can delete the CPP in this and+-- re-export the blaze functions directly, which is what we do for older+-- versions of base.+module Database.MySQL.Internal.Blaze+ ( integral+ , double+ , float+ ) where++#if MIN_VERSION_base(4,15,0)++#define PAIR(a,b) (# a,b #)++import Blaze.ByteString.Builder (Builder, fromByteString)+import Blaze.ByteString.Builder.Char8 (fromChar)+import Data.ByteString.Char8 ()+import Data.Monoid (mappend, mconcat, mempty)+import qualified Data.Vector as V++import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.Char8+import Data.ByteString.Char8 ()+import Data.Int (Int8, Int16, Int32, Int64)+import Data.Monoid (mappend, mempty)+import Data.Word (Word, Word8, Word16, Word32, Word64)+import GHC.Base (quotInt, remInt)+import GHC.Num (quotRemInteger)+-- import GHC.Types (Int(..))++#if defined(INTEGER_GMP)+import GHC.Integer.GMP.Internals+#elif defined(INTEGER_SIMPLE)+import GHC.Integer.Simple.Internals+#endif++minus :: Builder+minus = fromWord8 45+data TInt = TInt !Integer !Int+putH :: [Integer] -> Builder+putH (n:ns) = case n `quotRemInteger` maxInt of+ PAIR(x,y)+ | q > 0 -> int q `mappend` pblock r `mappend` putB ns+ | otherwise -> int r `mappend` putB ns+ where q = fromInteger x+ r = fromInteger y+putH _ = error "putH: the impossible happened"+int :: Int -> Builder+int = integral+{-# INLINE int #-}+fstT :: TInt -> Integer+fstT (TInt a _) = a+maxInt :: Integer+maxDigits :: Int+TInt maxInt maxDigits =+ until ((>mi) . (*10) . fstT) (\(TInt n d) -> TInt (n*10) (d+1)) (TInt 10 1)+ where mi = fromIntegral (maxBound :: Int)+integral :: (Integral a, Show a) => a -> Builder+{-# RULES "integral/Int" integral = bounded :: Int -> Builder #-}+{-# RULES "integral/Int8" integral = bounded :: Int8 -> Builder #-}+{-# RULES "integral/Int16" integral = bounded :: Int16 -> Builder #-}+{-# RULES "integral/Int32" integral = bounded :: Int32 -> Builder #-}+{-# RULES "integral/Int64" integral = bounded :: Int64 -> Builder #-}+{-# RULES "integral/Word" integral = nonNegative :: Word -> Builder #-}+{-# RULES "integral/Word8" integral = nonNegative :: Word8 -> Builder #-}+{-# RULES "integral/Word16" integral = nonNegative :: Word16 -> Builder #-}+{-# RULES "integral/Word32" integral = nonNegative :: Word32 -> Builder #-}+{-# RULES "integral/Word64" integral = nonNegative :: Word64 -> Builder #-}+{-# RULES "integral/Integer" integral = integer :: Integer -> Builder #-}++-- This definition of the function is here PURELY to be used by ghci+-- and those rare cases where GHC is being invoked without+-- optimization, as otherwise the rewrite rules above should fire. The+-- test for "-0" catches an overflow if we render minBound.+integral i+ | i >= 0 = nonNegative i+ | toByteString b == "-0" = fromString (show i)+ | otherwise = b+ where b = minus `mappend` nonNegative (-i)++{-# NOINLINE integral #-}++pblock :: Int -> Builder+pblock = go maxDigits+ where+ go !d !n+ | d == 1 = digit n+ | otherwise = go (d-1) q `mappend` digit r+ where q = n `quotInt` 10+ r = n `remInt` 10++putB :: [Integer] -> Builder+putB (n:ns) = case n `quotRemInteger` maxInt of+ PAIR(x,y) -> pblock q `mappend` pblock r `mappend` putB ns+ where q = fromInteger x+ r = fromInteger y+putB _ = mempty++bounded :: (Bounded a, Integral a) => a -> Builder+{-# SPECIALIZE bounded :: Int -> Builder #-}+{-# SPECIALIZE bounded :: Int8 -> Builder #-}+{-# SPECIALIZE bounded :: Int16 -> Builder #-}+{-# SPECIALIZE bounded :: Int32 -> Builder #-}+{-# SPECIALIZE bounded :: Int64 -> Builder #-}+bounded i+ | i >= 0 = nonNegative i+ | i > minBound = minus `mappend` nonNegative (-i)+ | otherwise = minus `mappend`+ nonNegative (negate (k `quot` 10)) `mappend`+ digit (negate (k `rem` 10))+ where k = minBound `asTypeOf` i++nonNegative :: Integral a => a -> Builder+{-# SPECIALIZE nonNegative :: Int -> Builder #-}+{-# SPECIALIZE nonNegative :: Int8 -> Builder #-}+{-# SPECIALIZE nonNegative :: Int16 -> Builder #-}+{-# SPECIALIZE nonNegative :: Int32 -> Builder #-}+{-# SPECIALIZE nonNegative :: Int64 -> Builder #-}+{-# SPECIALIZE nonNegative :: Word -> Builder #-}+{-# SPECIALIZE nonNegative :: Word8 -> Builder #-}+{-# SPECIALIZE nonNegative :: Word16 -> Builder #-}+{-# SPECIALIZE nonNegative :: Word32 -> Builder #-}+{-# SPECIALIZE nonNegative :: Word64 -> Builder #-}+nonNegative = go+ where+ go n | n < 10 = digit n+ | otherwise = go (n `quot` 10) `mappend` digit (n `rem` 10)++digit :: Integral a => a -> Builder+digit n = fromWord8 $! fromIntegral n + 48+{-# INLINE digit #-}++integer :: Integer -> Builder+#if defined(INTEGER_GMP)+integer (S# i#) = int (I# i#)+#endif+integer i+ | i < 0 = minus `mappend` go (-i)+ | otherwise = go i+ where+ go n | n < maxInt = int (fromInteger n)+ | otherwise = putH (splitf (maxInt * maxInt) n)++ splitf p n+ | p > n = [n]+ | otherwise = splith p (splitf (p*p) n)++ splith p (n:ns) = case n `quotRemInteger` p of+ PAIR(q,r) | q > 0 -> q : r : splitb p ns+ | otherwise -> r : splitb p ns+ splith _ _ = error "splith: the impossible happened."++ splitb p (n:ns) = case n `quotRemInteger` p of+ PAIR(q,r) -> q : r : splitb p ns+ splitb _ _ = []+++-- The code below is originally from GHC.Float, but has been optimised+-- in quite a few ways.++data T = T [Int] {-# UNPACK #-} !Int++float :: Float -> Builder+float = double . realToFrac++double :: Double -> Builder+double f+ | isInfinite f = fromByteString $+ if f > 0 then "Infinity" else "-Infinity"+ | f < 0 || isNegativeZero f = minus `mappend` goGeneric (floatToDigits (-f))+ | f >= 0 = goGeneric (floatToDigits f)+ | otherwise = fromByteString "NaN"+ where+ goGeneric p@(T _ e)+ | e < 0 || e > 7 = goExponent p+ | otherwise = goFixed p+ goExponent (T is e) =+ case is of+ [] -> error "putFormattedFloat"+ [0] -> fromByteString "0.0e0"+ [d] -> digit d `mappend` fromByteString ".0e" `mappend` integral (e-1)+ (d:ds) -> digit d `mappend` fromChar '.' `mappend` digits ds `mappend`+ fromChar 'e' `mappend` integral (e-1)+ goFixed (T is e)+ | e <= 0 = fromChar '0' `mappend` fromChar '.' `mappend`+ mconcat (replicate (-e) (fromChar '0')) `mappend`+ digits is+ | otherwise = let g 0 rs = fromChar '.' `mappend` mk0 rs+ g n [] = fromChar '0' `mappend` g (n-1) []+ g n (r:rs) = digit r `mappend` g (n-1) rs+ in g e is+ mk0 [] = fromChar '0'+ mk0 rs = digits rs++digits :: [Int] -> Builder+digits (d:ds) = digit d `mappend` digits ds+digits _ = mempty+{-# INLINE digits #-}++floatToDigits :: Double -> T+floatToDigits 0 = T [0] 0+floatToDigits x = T (reverse rds) k+ where+ (f0, e0) = decodeFloat x+ (minExp0, _) = floatRange (undefined::Double)+ p = floatDigits x+ b = floatRadix x+ minExp = minExp0 - p -- the real minimum exponent+ -- Haskell requires that f be adjusted so denormalized numbers+ -- will have an impossibly low exponent. Adjust for this.+ (# f, e #) =+ let n = minExp - e0 in+ if n > 0 then (# f0 `div` (b^n), e0+n #) else (# f0, e0 #)+ (# r, s, mUp, mDn #) =+ if e >= 0+ then let be = b^ e+ in if f == b^(p-1)+ then (# f*be*b*2, 2*b, be*b, b #)+ else (# f*be*2, 2, be, be #)+ else if e > minExp && f == b^(p-1)+ then (# f*b*2, b^(-e+1)*2, b, 1 #)+ else (# f*2, b^(-e)*2, 1, 1 #)+ k = fixup k0+ where+ k0 | b == 2 = (p - 1 + e0) * 3 `div` 10+ -- logBase 10 2 is slightly bigger than 3/10 so the following+ -- will err on the low side. Ignoring the fraction will make+ -- it err even more. Haskell promises that p-1 <= logBase b f+ -- < p.+ | otherwise = ceiling ((log (fromInteger (f+1) :: Double) ++ fromIntegral e * log (fromInteger b)) / log 10)+ fixup n+ | n >= 0 = if r + mUp <= exp10 n * s then n else fixup (n+1)+ | otherwise = if exp10 (-n) * (r + mUp) <= s then n else fixup (n+1)++ gen ds !rn !sN !mUpN !mDnN =+ let (dn0, rn') = (rn * 10) `divMod` sN+ mUpN' = mUpN * 10+ mDnN' = mDnN * 10+ !dn = fromInteger dn0+ !dn' = dn + 1+ in case (# rn' < mDnN', rn' + mUpN' > sN #) of+ (# True, False #) -> dn : ds+ (# False, True #) -> dn' : ds+ (# True, True #) -> if rn' * 2 < sN then dn : ds else dn' : ds+ (# False, False #) -> gen (dn:ds) rn' sN mUpN' mDnN'++ rds | k >= 0 = gen [] r (s * exp10 k) mUp mDn+ | otherwise = gen [] (r * bk) s (mUp * bk) (mDn * bk)+ where bk = exp10 (-k)++exp10 :: Int -> Integer+exp10 n+ | n >= 0 && n < maxExpt = V.unsafeIndex expts n+ | otherwise = 10 ^ n+ where expts = V.generate maxExpt (10^)+ {-# NOINLINE expts #-}+ maxExpt = 17+{-# INLINE exp10 #-}+++++#else++import Blaze.Text (integral, double, float)++#endif+
Database/MySQL/Simple.hs view
@@ -4,7 +4,7 @@ -- Module: Database.MySQL.Simple -- Copyright: (c) 2011 MailRank, Inc. -- License: BSD3--- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Maintainer: Paul Rouse <pyr@doynton.org> -- Stability: experimental -- Portability: portable --@@ -48,8 +48,11 @@ , Connection , Query , In(..)+ , VaArgs(..) , Binary(..) , Only(..)+ , Param+ , Result -- ** Exceptions , FormatError(fmtMessage, fmtQuery, fmtParams) , QueryError(qeMessage, qeQuery)@@ -79,6 +82,15 @@ -- * Helper functions , formatMany , formatQuery+ , splitQuery++ -- | #extension#++ -- * Extension hooks+ -- $hooks++ , FromField(..)+ , ToField(..) ) where import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)@@ -87,17 +99,19 @@ import Control.Exception (Exception, bracket, onException, throw, throwIO) import Control.Monad.Fix (fix) import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS import Data.Int (Int64) import Data.List (intersperse) import Data.Monoid (mappend, mconcat) import Data.Typeable (Typeable)-import Database.MySQL.Base (Connection, Result)+import Database.MySQL.Base (Connection)+import qualified Database.MySQL.Base as Base (Result) import Database.MySQL.Base.Types (Field)-import Database.MySQL.Simple.Param (Action(..), inQuotes)+import Database.MySQL.Simple.Param (ToField(..), Param, Action(..), inQuotes) import Database.MySQL.Simple.QueryParams (QueryParams(..)) import Database.MySQL.Simple.QueryResults (QueryResults(..))-import Database.MySQL.Simple.Result (ResultError(..))-import Database.MySQL.Simple.Types (Binary(..), In(..), Only(..), Query(..))+import Database.MySQL.Simple.Result (FromField(..), Result, ResultError(..))+import Database.MySQL.Simple.Types (Binary(..), In(..), VaArgs(..), Only(..), Query(..)) import Text.Regex.PCRE.Light (compile, caseless, match) import qualified Data.ByteString.Char8 as B import qualified Database.MySQL.Base as Base@@ -160,7 +174,7 @@ return . toByteString . mconcat $ fromByteString before : intersperse (fromChar ',') bs ++ [fromByteString after]- _ -> error "foo"+ _ -> fmtError "incorrect parameter syntax in query" q [] where re = compile "^([^?]+\\bvalues\\s*)\ \(\\(\\s*[?](?:\\s*,\\s*[?])*\\s*\\))\@@ -168,18 +182,47 @@ [caseless] buildQuery :: Connection -> Query -> ByteString -> [Action] -> IO Builder-buildQuery conn q template xs = zipParams (split template) <$> mapM sub xs+buildQuery conn q template xs = zipParams queryFragments <$> 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) +++ zipParams _ _ = fmtError (show fragmentCount ++ " '?' characters, but " ++ show (length xs) ++ " parameters") q xs+ fragmentCount = length queryFragments - 1+ queryFragments = splitQuery template +-- | Split a query into fragments separated by @?@ characters. Does not+-- break a fragment if the question mark is in a string literal.+splitQuery :: ByteString -> [Builder]+splitQuery s =+ reverse $ fmap (fromByteString . BS.pack . reverse) $+ begin [] (BS.unpack s)+ where+ begin = normal []++ normal ret acc [] =+ acc : ret+ normal ret acc (c : cs) =+ case c of+ '?' ->+ normal (acc : ret) [] cs+ '\'' ->+ quotes ret (c : acc) cs+ _ ->+ normal ret (c : acc) cs++ quotes ret acc [] =+ acc : ret+ quotes ret acc (c : cs) =+ case c of+ '\'' ->+ normal ret (c : acc) cs+ _ ->+ quotes ret (c : acc) cs+ -- | Execute an @INSERT@, @UPDATE@, or other SQL query that is not -- expected to return results. --@@ -326,7 +369,7 @@ [] -> return z _ -> (f z $! convertResults fs row) >>= loop -withResult :: (IO Result) -> Query -> (Result -> [Field] -> IO a) -> IO a+withResult :: (IO Base.Result) -> Query -> (Base.Result -> [Field] -> IO a) -> IO a withResult fetchResult q act = bracket fetchResult Base.freeResult $ \r -> do ncols <- Base.fieldCount (Right r) if ncols == 0@@ -372,7 +415,7 @@ -- 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@@ -617,7 +660,7 @@ -- 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.+-- considered compatible 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@@@ -631,3 +674,27 @@ -- 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.+--+-- When a user-defined type is represented by a @TEXT@, @BLOB@, @JSON@, or+-- similar type of column, it can be encoded and decoded using+-- hooks which take or receive a 'ByteString'. See the classes 'ToField'+-- and 'FromField' in the [Extension hooks](#extension) section below.++-- $hooks+--+-- These classes provide a simple mechanism for encoding and decoding+-- user-defined types in cases where the underlying encoding is a+-- sequence of bytes.+--+-- === __Example__+--+-- Assuming @Foo@ has instances of 'Data.Aeson.FromJSON', 'Data.Aeson.ToJSON',+-- and 'Typeable', its decoding and encoding can be specified like this:+--+-- > instance FromField Foo where+-- > fromField = ([Database.MySQL.Base.Types.Json], Data.Aeson.eitherDecodeStrict')+-- > instance Result Foo+-- >+-- > instance ToField Foo where+-- > toField = Data.ByteString.Lazy.toStrict . Data.Aeson.encode+-- > instance Param Foo
Database/MySQL/Simple/Param.hs view
@@ -1,19 +1,19 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, FlexibleInstances,- OverloadedStrings #-}+ OverloadedStrings, DefaultSignatures #-} -- | -- Module: Database.MySQL.Simple.Param -- Copyright: (c) 2011 MailRank, Inc. -- License: BSD3--- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Maintainer: Paul Rouse <pyr@doynton.org> -- Stability: experimental -- Portability: portable -- -- The 'Param' typeclass, for rendering a parameter to a SQL query. module Database.MySQL.Simple.Param- (- Action(..)+ ( Action(..)+ , ToField(..) , Param(..) , inQuotes ) where@@ -21,20 +21,21 @@ import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, toByteString) import Blaze.ByteString.Builder.Char8 (fromChar)-import Blaze.Text (integral, double, float) import Data.ByteString (ByteString) import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Base16.Lazy as L16 import Data.Int (Int8, Int16, Int32, Int64) import Data.List (intersperse) import Data.Monoid (mappend)+import Data.Set (Set)+import qualified Data.Set as Set 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 (Binary(..), In(..), Null)+import Database.MySQL.Simple.Types (Binary(..), In(..), VaArgs(..), Null) import qualified Blaze.ByteString.Builder.Char.Utf8 as Utf8 import qualified Data.ByteString as SB import qualified Data.ByteString.Lazy as LB@@ -42,6 +43,8 @@ import qualified Data.Text.Encoding as ST import qualified Data.Text.Lazy as LT +import Database.MySQL.Internal.Blaze (integral, double, float)+ #if MIN_VERSION_time(1,5,0) import Data.Time.Format (defaultTimeLocale) #else@@ -68,10 +71,28 @@ show (Escape b) = "Escape " ++ show b show (Many b) = "Many " ++ show b +-- | A type that can be converted to a 'ByteString' for use as a parameter+-- to an SQL query.+--+-- Any type which is an instance of this class can use the default+-- implementation of 'Param', which will wrap encodings with 'Escape'.+--+-- @since 0.4.8+--+class ToField a where+ toField :: a -> ByteString+ -- | A type that may be used as a single parameter to a SQL query.+--+-- A default implementation is provided for any type which is an instance+-- of 'ToField', providing a simple mechanism for user-defined encoding+-- to text- or blob-like fields (including @JSON@).+-- class Param a where render :: a -> Action -- ^ Prepare a value for substitution into a query string.+ default render :: ToField a => a -> Action+ render = Escape . toField instance Param Action where render a = a@@ -89,6 +110,14 @@ (intersperse (Plain (fromChar ',')) . map render $ xs) ++ [Plain (fromChar ')')] +instance (Param a) => Param (In (Set a)) where+ render = render . fmap Set.toList++instance (Param a) => Param (VaArgs [a]) where+ render (VaArgs []) = Plain $ fromByteString "null"+ render (VaArgs xs) = Many $+ intersperse (Plain (fromChar ',')) . map render $ xs+ instance Param (Binary SB.ByteString) where render (Binary bs) = Plain $ fromByteString "x'" `mappend` fromByteString (B16.encode bs) `mappend`@@ -185,7 +214,7 @@ {-# INLINE render #-} instance Param UTCTime where- render = Plain . Utf8.fromString . formatTime defaultTimeLocale "'%F %T'"+ render = Plain . Utf8.fromString . formatTime defaultTimeLocale "'%F %T%Q'" {-# INLINE render #-} instance Param Day where
Database/MySQL/Simple/QueryParams.hs view
@@ -2,7 +2,7 @@ -- Module: Database.MySQL.Simple.QueryParams -- Copyright: (c) 2011 MailRank, Inc. -- License: BSD3--- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Maintainer: Paul Rouse <pyr@doynton.org> -- Stability: experimental -- Portability: portable --@@ -79,6 +79,130 @@ renderParams (a,b,c,d,e,f,g,h,i,j) = [render a, render b, render c, render d, render e, render f, render g, render h, render i, render j]++instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,+ Param h, Param i, Param j, Param k)+ => QueryParams (a,b,c,d,e,f,g,h,i,j,k) where+ renderParams (a,b,c,d,e,f,g,h,i,j,k) =+ [render a, render b, render c, render d, render e, render f, render g,+ render h, render i, render j, render k]++instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,+ Param h, Param i, Param j, Param k, Param l)+ => QueryParams (a,b,c,d,e,f,g,h,i,j,k,l) where+ renderParams (a,b,c,d,e,f,g,h,i,j,k,l) =+ [render a, render b, render c, render d, render e, render f, render g,+ render h, render i, render j, render k, render l]++instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,+ Param h, Param i, Param j, Param k, Param l, Param m)+ => QueryParams (a,b,c,d,e,f,g,h,i,j,k,l,m) where+ renderParams (a,b,c,d,e,f,g,h,i,j,k,l,m) =+ [render a, render b, render c, render d, render e, render f, render g,+ render h, render i, render j, render k, render l, render m]++instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,+ Param h, Param i, Param j, Param k, Param l, Param m, Param n)+ => QueryParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where+ renderParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n) =+ [render a, render b, render c, render d, render e, render f, render g,+ render h, render i, render j, render k, render l, render m, render n]++instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,+ Param h, Param i, Param j, Param k, Param l, Param m, Param n,+ Param o)+ => QueryParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where+ renderParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) =+ [render a, render b, render c, render d, render e, render f, render g,+ render h, render i, render j, render k, render l, render m, render n,+ render o]++instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,+ Param h, Param i, Param j, Param k, Param l, Param m, Param n,+ Param o, Param p)+ => QueryParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where+ renderParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) =+ [render a, render b, render c, render d, render e, render f, render g,+ render h, render i, render j, render k, render l, render m, render n,+ render o, render p]++instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,+ Param h, Param i, Param j, Param k, Param l, Param m, Param n,+ Param o, Param p, Param q)+ => QueryParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where+ renderParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) =+ [render a, render b, render c, render d, render e, render f, render g,+ render h, render i, render j, render k, render l, render m, render n,+ render o, render p, render q]++instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,+ Param h, Param i, Param j, Param k, Param l, Param m, Param n,+ Param o, Param p, Param q, Param r)+ => QueryParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where+ renderParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) =+ [render a, render b, render c, render d, render e, render f, render g,+ render h, render i, render j, render k, render l, render m, render n,+ render o, render p, render q, render r]++instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,+ Param h, Param i, Param j, Param k, Param l, Param m, Param n,+ Param o, Param p, Param q, Param r, Param s)+ => QueryParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where+ renderParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) =+ [render a, render b, render c, render d, render e, render f, render g,+ render h, render i, render j, render k, render l, render m, render n,+ render o, render p, render q, render r, render s]++instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,+ Param h, Param i, Param j, Param k, Param l, Param m, Param n,+ Param o, Param p, Param q, Param r, Param s, Param t)+ => QueryParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where+ renderParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) =+ [render a, render b, render c, render d, render e, render f, render g,+ render h, render i, render j, render k, render l, render m, render n,+ render o, render p, render q, render r, render s, render t]++instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,+ Param h, Param i, Param j, Param k, Param l, Param m, Param n,+ Param o, Param p, Param q, Param r, Param s, Param t, Param u)+ => QueryParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) where+ renderParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) =+ [render a, render b, render c, render d, render e, render f, render g,+ render h, render i, render j, render k, render l, render m, render n,+ render o, render p, render q, render r, render s, render t, render u]++instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,+ Param h, Param i, Param j, Param k, Param l, Param m, Param n,+ Param o, Param p, Param q, Param r, Param s, Param t, Param u,+ Param v)+ => QueryParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) where+ renderParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) =+ [render a, render b, render c, render d, render e, render f, render g,+ render h, render i, render j, render k, render l, render m, render n,+ render o, render p, render q, render r, render s, render t, render u,+ render v]++instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,+ Param h, Param i, Param j, Param k, Param l, Param m, Param n,+ Param o, Param p, Param q, Param r, Param s, Param t, Param u,+ Param v, Param w)+ => QueryParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) where+ renderParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) =+ [render a, render b, render c, render d, render e, render f, render g,+ render h, render i, render j, render k, render l, render m, render n,+ render o, render p, render q, render r, render s, render t, render u,+ render v, render w]++instance (Param a, Param b, Param c, Param d, Param e, Param f, Param g,+ Param h, Param i, Param j, Param k, Param l, Param m, Param n,+ Param o, Param p, Param q, Param r, Param s, Param t, Param u,+ Param v, Param w, Param x)+ => QueryParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) where+ renderParams (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) =+ [render a, render b, render c, render d, render e, render f, render g,+ render h, render i, render j, render k, render l, render m, render n,+ render o, render p, render q, render r, render s, render t, render u,+ render v, render w, render x] instance (Param a) => QueryParams [a] where renderParams = map render
Database/MySQL/Simple/QueryResults.hs view
@@ -4,7 +4,7 @@ -- Module: Database.MySQL.Simpe.QueryResults -- Copyright: (c) 2011 MailRank, Inc. -- License: BSD3--- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Maintainer: Paul Rouse <pyr@doynton.org> -- Stability: experimental -- Portability: portable --@@ -23,7 +23,7 @@ import Control.Exception (throw) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B-import Database.MySQL.Base.Types (Field(fieldType))+import Database.MySQL.Base.Types (Field(fieldType, fieldName)) import Database.MySQL.Simple.Result (ResultError(..), Result(..)) import Database.MySQL.Simple.Types (Only(..)) @@ -219,6 +219,166 @@ !m = convert fm vm; !n = convert fn vn; !o = convert fo vo convertResults fs vs = convertError fs vs 15 +instance (Result a, Result b, Result c, Result d, Result e, Result f,+ Result g, Result h, Result i, Result j, Result k, Result l,+ Result m, Result n, Result o, Result p) =>+ QueryResults (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p) where+ convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj,fk,fl,fm,fn,fo,fp]+ [va,vb,vc,vd,ve,vf,vg,vh,vi,vj,vk,vl,vm,vn,vo,vp] =+ (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p)+ 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; !k = convert fk vk; !l = convert fl vl+ !m = convert fm vm; !n = convert fn vn; !o = convert fo vo+ !p = convert fp vp;+ convertResults fs vs = convertError fs vs 16++instance (Result a, Result b, Result c, Result d, Result e, Result f,+ Result g, Result h, Result i, Result j, Result k, Result l,+ Result m, Result n, Result o, Result p, Result q) =>+ QueryResults (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q) where+ convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj,fk,fl,fm,fn,fo,fp,fq]+ [va,vb,vc,vd,ve,vf,vg,vh,vi,vj,vk,vl,vm,vn,vo,vp,vq] =+ (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q)+ 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; !k = convert fk vk; !l = convert fl vl+ !m = convert fm vm; !n = convert fn vn; !o = convert fo vo+ !p = convert fp vp; !q = convert fq vq;+ convertResults fs vs = convertError fs vs 17++instance (Result a, Result b, Result c, Result d, Result e, Result f,+ Result g, Result h, Result i, Result j, Result k, Result l,+ Result m, Result n, Result o, Result p, Result q, Result r) =>+ QueryResults (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r) where+ convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj,fk,fl,fm,fn,fo,fp,fq,fr]+ [va,vb,vc,vd,ve,vf,vg,vh,vi,vj,vk,vl,vm,vn,vo,vp,vq,vr] =+ (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r)+ 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; !k = convert fk vk; !l = convert fl vl+ !m = convert fm vm; !n = convert fn vn; !o = convert fo vo+ !p = convert fp vp; !q = convert fq vq; !r = convert fr vr+ convertResults fs vs = convertError fs vs 18++instance (Result a, Result b, Result c, Result d, Result e, Result f,+ Result g, Result h, Result i, Result j, Result k, Result l,+ Result m, Result n, Result o, Result p, Result q, Result r,+ Result s) =>+ QueryResults (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s) where+ convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj,fk,fl,fm,fn,fo,fp,fq,fr,fs]+ [va,vb,vc,vd,ve,vf,vg,vh,vi,vj,vk,vl,vm,vn,vo,vp,vq,vr,vs]+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s)+ 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; !k = convert fk vk; !l = convert fl vl+ !m = convert fm vm; !n = convert fn vn; !o = convert fo vo+ !p = convert fp vp; !q = convert fq vq; !r = convert fr vr+ !s = convert fs vs;+ convertResults fs_ vs_ = convertError fs_ vs_ 19++instance (Result a, Result b, Result c, Result d, Result e, Result f,+ Result g, Result h, Result i, Result j, Result k, Result l,+ Result m, Result n, Result o, Result p, Result q, Result r,+ Result s, Result t) =>+ QueryResults (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t) where+ convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj,fk,fl,fm,fn,fo,fp,fq,fr,fs,+ ft]+ [va,vb,vc,vd,ve,vf,vg,vh,vi,vj,vk,vl,vm,vn,vo,vp,vq,vr,vs,+ vt]+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t)+ 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; !k = convert fk vk; !l = convert fl vl+ !m = convert fm vm; !n = convert fn vn; !o = convert fo vo+ !p = convert fp vp; !q = convert fq vq; !r = convert fr vr+ !s = convert fs vs; !t = convert ft vt+ convertResults fs_ vs_ = convertError fs_ vs_ 20++instance (Result a, Result b, Result c, Result d, Result e, Result f,+ Result g, Result h, Result i, Result j, Result k, Result l,+ Result m, Result n, Result o, Result p, Result q, Result r,+ Result s, Result t, Result u) =>+ QueryResults (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u) where+ convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj,fk,fl,fm,fn,fo,fp,fq,fr,fs,+ ft,fu]+ [va,vb,vc,vd,ve,vf,vg,vh,vi,vj,vk,vl,vm,vn,vo,vp,vq,vr,vs,+ vt,vu]+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u)+ 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; !k = convert fk vk; !l = convert fl vl+ !m = convert fm vm; !n = convert fn vn; !o = convert fo vo+ !p = convert fp vp; !q = convert fq vq; !r = convert fr vr+ !s = convert fs vs; !t = convert ft vt; !u = convert fu vu+ convertResults fs_ vs_ = convertError fs_ vs_ 21++instance (Result a, Result b, Result c, Result d, Result e, Result f,+ Result g, Result h, Result i, Result j, Result k, Result l,+ Result m, Result n, Result o, Result p, Result q, Result r,+ Result s, Result t, Result u, Result v) =>+ QueryResults (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v) where+ convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj,fk,fl,fm,fn,fo,fp,fq,fr,fs,+ ft,fu,fv]+ [va,vb,vc,vd,ve,vf,vg,vh,vi,vj,vk,vl,vm,vn,vo,vp,vq,vr,vs,+ vt,vu,vv]+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v)+ 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; !k = convert fk vk; !l = convert fl vl+ !m = convert fm vm; !n = convert fn vn; !o = convert fo vo+ !p = convert fp vp; !q = convert fq vq; !r = convert fr vr+ !s = convert fs vs; !t = convert ft vt; !u = convert fu vu+ !v = convert fv vv;+ convertResults fs_ vs_ = convertError fs_ vs_ 22++instance (Result a, Result b, Result c, Result d, Result e, Result f,+ Result g, Result h, Result i, Result j, Result k, Result l,+ Result m, Result n, Result o, Result p, Result q, Result r,+ Result s, Result t, Result u, Result v, Result w) =>+ QueryResults (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w) where+ convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj,fk,fl,fm,fn,fo,fp,fq,fr,fs,+ ft,fu,fv,fw]+ [va,vb,vc,vd,ve,vf,vg,vh,vi,vj,vk,vl,vm,vn,vo,vp,vq,vr,vs,+ vt,vu,vv,vw]+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w)+ 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; !k = convert fk vk; !l = convert fl vl+ !m = convert fm vm; !n = convert fn vn; !o = convert fo vo+ !p = convert fp vp; !q = convert fq vq; !r = convert fr vr+ !s = convert fs vs; !t = convert ft vt; !u = convert fu vu+ !v = convert fv vv; !w = convert fw vw;+ convertResults fs_ vs_ = convertError fs_ vs_ 23++instance (Result a, Result b, Result c, Result d, Result e, Result f,+ Result g, Result h, Result i, Result j, Result k, Result l,+ Result m, Result n, Result o, Result p, Result q, Result r,+ Result s, Result t, Result u, Result v, Result w, Result x) =>+ QueryResults (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x) where+ convertResults [fa,fb,fc,fd,fe,ff,fg,fh,fi,fj,fk,fl,fm,fn,fo,fp,fq,fr,fs,+ ft,fu,fv,fw,fx]+ [va,vb,vc,vd,ve,vf,vg,vh,vi,vj,vk,vl,vm,vn,vo,vp,vq,vr,vs,+ vt,vu,vv,vw,vx]+ = (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o,p,q,r,s,t,u,v,w,x)+ 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; !k = convert fk vk; !l = convert fl vl+ !m = convert fm vm; !n = convert fn vn; !o = convert fo vo+ !p = convert fp vp; !q = convert fq vq; !r = convert fr vr+ !s = convert fs vs; !t = convert ft vt; !u = convert fu vu+ !v = convert fv vv; !w = convert fw vw; !x = convert fx vx;+ convertResults fs_ vs_ = convertError fs_ vs_ 24+ -- | 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.@@ -235,6 +395,7 @@ (show (length fs) ++ " values: " ++ show (zip (map fieldType fs) (map (fmap ellipsis) vs))) (show n ++ " slots in target type")+ (show (map (B.unpack . fieldName) fs)) "mismatch between number of columns to convert and number in target type" ellipsis :: ByteString -> ByteString
Database/MySQL/Simple/Result.hs view
@@ -1,10 +1,14 @@-{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances #-}+{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, DefaultSignatures #-}+#if MIN_VERSION_time(1,5,0)+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}+#endif -- |--- Module: Database.MySQL.Simpe.QueryResults+-- Module: Database.MySQL.Simple.Result -- Copyright: (c) 2011 MailRank, Inc. -- License: BSD3--- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Maintainer: Paul Rouse <pyr@doynton.org> -- Stability: experimental -- Portability: portable --@@ -19,24 +23,28 @@ -- two are /not/ considered compatible. module Database.MySQL.Simple.Result- (- Result(..)+ ( FromField(..)+ , Result(..) , ResultError(..) ) where #include "MachDeps.h" +#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail (MonadFail(..))+#endif+ import Control.Applicative ((<$>), (<*>), (<*), pure) import Control.Exception (Exception, throw)-import Data.Attoparsec.Char8 hiding (Result)+import Data.Attoparsec.ByteString.Char8 hiding (Result) import Data.Bits ((.&.), (.|.), shiftL) import Data.ByteString (ByteString) import Data.Int (Int8, Int16, Int32, Int64) import Data.List (foldl') import Data.Ratio (Ratio) import Data.Time.Calendar (Day, fromGregorian)-import Data.Time.Clock (UTCTime)-import Data.Time.Format (parseTime)+import Data.Time.Clock (UTCTime(..))+import Data.Time.Format (parseTimeM, ParseTime) import Data.Time.LocalTime (TimeOfDay, makeTimeOfDayValid) import Data.Typeable (TypeRep, Typeable, typeOf) import Data.Word (Word, Word8, Word16, Word32, Word64)@@ -58,15 +66,18 @@ -- value fails. data ResultError = Incompatible { errSQLType :: String , errHaskellType :: String+ , errFieldName :: String , errMessage :: String } -- ^ The SQL and Haskell types are not compatible. | UnexpectedNull { errSQLType :: String , errHaskellType :: String+ , errFieldName :: String , errMessage :: String } -- ^ A SQL @NULL@ was encountered when the Haskell -- type did not permit it. | ConversionFailed { errSQLType :: String , errHaskellType :: String+ , errFieldName :: String , errMessage :: String } -- ^ The SQL value could not be parsed, or could not -- be represented as a valid Haskell value, or an@@ -76,13 +87,44 @@ instance Exception ResultError +-- | A type that can be converted from a 'ByteString'. Any type which is+-- an instance of this class, and is 'Typeable', can use the default+-- implementation of 'Result'. This provides a method of implementing+-- a decoder for any text-like column, such as @TEXT@, @BLOB@, or @JSON@,+-- instead of implementing 'Result' directly.+--+-- The first component of the tuple returned by 'fromField' is a list of+-- acceptable column types, expressed in terms of+-- 'Database.MySQL.Base.Types.Type'.+--+-- @since 0.4.8+--+class FromField a where+ fromField :: ([Type], ByteString -> Either String a)+ -- | A type that may be converted from a SQL type.+--+-- A default implementation is provided for any type which is an instance+-- of both 'FromField' and 'Typeable', providing a simple mechanism for+-- user-defined decoding from text- or blob-like fields (including @JSON@).+-- class Result a where convert :: Field -> Maybe ByteString -> a -- ^ Convert a SQL value to a Haskell value. -- -- Throws a 'ResultError' if conversion fails.+ --+ default convert :: (Typeable a, FromField a)+ => Field -> Maybe ByteString -> a+ convert f =+ doConvert f (mkCompats allowTypes) $ \bs ->+ case cvt bs of+ Right x -> x+ Left err -> conversionFailed f (show (typeOf (cvt undefined))) err+ where+ (allowTypes, cvt) = fromField + instance (Result a) => Result (Maybe a) where convert _ Nothing = Nothing convert f bs = Just (convert f bs)@@ -154,12 +196,16 @@ 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 FromField UTCTime where+ fromField =+ ( [DateTime, Timestamp]+ , \bs -> if "0000-00-00" `SB.isPrefixOf` bs then+ -- https://dev.mysql.com/doc/refman/8.0/en/datetime.html+ Right $ UTCTime (fromGregorian 0 0 0) 0+ else+ parseTimeField "%F %T%Q" (B8.unpack bs)+ )+instance Result UTCTime instance Result Day where convert f = flip (atto ok) f $ case fieldType f of@@ -171,21 +217,27 @@ <*> (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 FromField TimeOfDay where+ fromField = ([Time], parseTimeField "%T%Q" . B8.unpack)+instance Result TimeOfDay +-- A specialised version of parseTimeM which builds in the defaults we want,+-- and produces an Either result. For the latter provide a wrapper for Either,+-- local to this module, to add a MonadFail instance.+--+newtype Failable a = Failable { failable :: Either String a }+ deriving (Functor, Applicative, Monad)+instance MonadFail Failable where+ fail err = Failable (Left err)++parseTimeField :: ParseTime t => String -> String -> Either String t+parseTimeField fmt s = failable $ parseTimeM True defaultTimeLocale fmt s+ 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)@@ -198,7 +250,7 @@ okText, ok8, ok16, ok32, ok64, okWord :: Compat okText = mkCompats [VarChar,TinyBlob,MediumBlob,LongBlob,Blob,VarString,String,- Set,Enum]+ Set,Enum,Json] ok8 = mkCompats [Tiny] ok16 = mkCompats [Tiny,Short] ok32 = mkCompats [Tiny,Short,Int24,Long]@@ -215,13 +267,22 @@ | 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))) ""+ (show (typeOf (cvt undefined)))+ (B8.unpack (fieldName f))+ ("unexpected null in table "+ ++ B8.unpack (fieldTable f)+ ++ " of database "+ ++ B8.unpack (fieldDB f)+ ) incompatible :: Field -> TypeRep -> String -> a-incompatible f r = throw . Incompatible (show (fieldType f)) (show r)+incompatible f r = throw . Incompatible (show (fieldType f))+ (show r)+ (B8.unpack (fieldName f)) conversionFailed :: Field -> String -> String -> a conversionFailed f s = throw . ConversionFailed (show (fieldType f)) s+ (B8.unpack (fieldName f)) atto :: (Typeable a) => Compat -> Parser a -> Field -> Maybe ByteString -> a atto types p0 f = doConvert f types $ go undefined p0
Database/MySQL/Simple/Types.hs view
@@ -4,7 +4,7 @@ -- Module: Database.MySQL.Simple.Types -- Copyright: (c) 2011 MailRank, Inc. -- License: BSD3--- Maintainer: Bryan O'Sullivan <bos@serpentine.com>+-- Maintainer: Paul Rouse <pyr@doynton.org> -- Stability: experimental -- Portability: portable --@@ -15,6 +15,7 @@ Null(..) , Only(..) , In(..)+ , VaArgs(..) , Binary(..) , Query(..) ) where@@ -22,6 +23,7 @@ import Blaze.ByteString.Builder (toByteString) import Control.Arrow (first) import Data.ByteString (ByteString)+import Data.Semigroup (Semigroup(..)) import Data.Monoid (Monoid(..)) import Data.String (IsString(..)) import Data.Typeable (Typeable)@@ -68,9 +70,13 @@ instance IsString Query where fromString = Query . toByteString . Utf8.fromString +instance Semigroup Query where+ (<>) (Query a) (Query b) = Query (B.append a b)+ {-# INLINE (<>) #-}+ instance Monoid Query where mempty = Query B.empty- mappend (Query a) (Query b) = Query (B.append a b)+ mappend = (<>) {-# INLINE mappend #-} -- | A single-value \"collection\".@@ -99,6 +105,18 @@ -- > query c "select * from whatever where id in ?" (Only (In [3,4,5])) newtype In a = In a deriving (Eq, Ord, Read, Show, Typeable, Functor)++-- | Wrap a list of values for use in a function with variable arguments.+-- Replaces a single \"@?@\" character with a non-parenthesized list of+-- rendered values.+--+-- Example:+--+-- > query conn+-- > "SELECT * FROM example_table ORDER BY field(f,?)"+-- > (Only (VaArgs [3,2,1]))+newtype VaArgs a = VaArgs a+ deriving (Eq, Ord, Read, Show, Typeable, Functor) -- | Wrap a mostly-binary string to be escaped in hexadecimal. newtype Binary a = Binary a
README.markdown view
@@ -24,19 +24,14 @@ and other improvements. Please report bugs via the-[github issue tracker](http://github.com/bos/mysql-simple/issues).--Master [git repository](http://github.com/bos/mysql-simple):--* `git clone git://github.com/bos/mysql-simple.git`--There's also a [Mercurial mirror](http://bitbucket.org/bos/mysql-simple):+[github issue tracker](http://github.com/paul-rouse/mysql-simple/issues). -* `hg clone http://bitbucket.org/bos/mysql-simple`+Master [git repository](http://github.com/paul-rouse/mysql-simple): -(You can create and contribute changes using either git or Mercurial.)+* `git clone git://github.com/paul-rouse/mysql-simple.git` # Authors -This library is written and maintained by Bryan O'Sullivan,-<bos@serpentine.com>.+This library was written by Bryan O'Sullivan, <bos@serpentine.com>,+to whom all of the credit is due.+It is now being maintained by Paul Rouse, <pyr@doynton.org>.
mysql-simple.cabal view
@@ -1,7 +1,7 @@ name: mysql-simple-version: 0.2.2.5-homepage: https://github.com/bos/mysql-simple-bug-reports: https://github.com/bos/mysql-simple/issues+version: 0.4.9+homepage: https://github.com/paul-rouse/mysql-simple+bug-reports: https://github.com/paul-rouse/mysql-simple/issues synopsis: A mid-level MySQL client library. description: A mid-level client library for the MySQL database, intended to be@@ -17,13 +17,15 @@ license: BSD3 license-file: LICENSE author: Bryan O'Sullivan <bos@serpentine.com>-maintainer: Bryan O'Sullivan <bos@serpentine.com>+maintainer: Paul Rouse <pyr@doynton.org> copyright: 2011 MailRank, Inc. category: Database build-type: Simple-cabal-version: >= 1.6+cabal-version: >= 1.10 extra-source-files:+ ChangeLog.md README.markdown+ stack.yaml flag developer description: operate in developer mode@@ -38,32 +40,61 @@ Database.MySQL.Simple.QueryResults Database.MySQL.Simple.Result Database.MySQL.Simple.Types+ other-modules:+ Database.MySQL.Internal.Blaze build-depends:- attoparsec >= 0.8.5.3,- base < 5,+ attoparsec >= 0.10.0.0,+ base >= 4.9 && < 5, base16-bytestring, blaze-builder,- blaze-textual, bytestring >= 0.9,- mysql >= 0.1.1.1,+ containers,+ mysql >= 0.1.7, pcre-light, old-locale, text >= 0.11.0.2,- time+ time >= 1.5+ if !impl(ghc >= 8.0)+ build-depends:+ semigroups >= 0.11 && < 0.19 - ghc-options: -Wall- if impl(ghc >= 6.8)- ghc-options: -fwarn-tabs+ -- hack to support GHC 9 for blaze-textual. see Database.MySQL.Internal.Blaze+ -- for reasoning+ if !impl(ghc >= 9.0)+ build-depends:+ blaze-textual+ else+ build-depends:+ vector++ ghc-options: -Wall -fwarn-tabs+ if impl(ghc >= 7.10)+ ghc-options: -fno-warn-unused-imports if flag(developer) ghc-prof-options: -auto-all ghc-options: -Werror cpp-options: -DASSERTS+ default-language: Haskell2010 -source-repository head- type: git- location: http://github.com/bos/mysql-simple+test-suite test+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ other-modules: Common+ CustomTypeSpec+ DateTimeSpec+ ghc-options: -Wall+ default-language: Haskell2010+ build-depends: base >= 4 && < 5+ , bytestring+ , blaze-builder+ , hspec+ , mysql+ , mysql-simple+ , text+ , time source-repository head- type: mercurial- location: http://bitbucket.org/bos/mysql-simple+ type: git+ location: http://github.com/paul-rouse/mysql-simple
+ stack.yaml view
@@ -0,0 +1,7 @@+flags:+ mysql-simple:+ developer: false+packages:+- '.'+extra-deps: []+resolver: lts-19.8
+ test/Common.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# options_ghc -fno-warn-orphans #-}++module Common where++import Data.ByteString.Builder as BS+import Database.MySQL.Simple.Param++-- Declare some (orphan) instances needed for test specs+instance Show BS.Builder where+ show = show . BS.toLazyByteString++instance Eq BS.Builder where+ a == b = BS.toLazyByteString a == BS.toLazyByteString b++deriving instance Eq Action
+ test/CustomTypeSpec.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE OverloadedStrings #-}+module CustomTypeSpec (+ customTypeUnit+ , customTypeSpec+) where++import Control.Monad (void)+import qualified Data.ByteString.Char8 as B8+import Database.MySQL.Simple+import Database.MySQL.Simple.Param (Action(..), render)+import qualified Database.MySQL.Base as MySQL+import Test.Hspec++import Common ()++-- A type which we encode/decode specially (if artificially!) to a Text column+--+data Message = English String | Latin String deriving (Eq, Show)++instance ToField Message where+ toField m = B8.pack ( case m of+ English s -> "English: " <> s+ Latin s -> "Latin: " <> s+ )+instance Param Message++instance FromField Message where+ fromField =+ ( [MySQL.TinyBlob, MySQL.Blob, MySQL.MediumBlob, MySQL.LongBlob]+ , \s -> if "English: " `B8.isPrefixOf` s then+ Right $ English $ B8.unpack $ B8.drop 9 s+ else if "Latin: " `B8.isPrefixOf` s then+ Right $ Latin $ B8.unpack $ B8.drop 7 s+ else Left $ "Can't decode " <> show s <> " as Message"+ )+instance Result Message+++customTypeUnit :: Spec+customTypeUnit =+ describe "Param for custom type" $ do+ it "is correctly encoded" $ do+ render (Latin "nuntium") `shouldBe` Escape "Latin: nuntium"+++customTypeSpec :: Connection -> Spec+customTypeSpec conn =+ beforeAll_+ ( do _ <- execute_ conn "drop table if exists custom"+ _ <- execute_ conn "create table custom (i int, c text)"+ void $ execute_ conn ( "insert into custom (i,c) values "+ <> "(1,'English: a message'),"+ <> "(2,'French: un message')"+ )+ ) $ do+ describe "reading a custom type" $ do+ it "should accept a correctly formatted field" $ do+ result <- query_ conn "select c from custom where i = 1"+ result `shouldBe` [Only (English "a message")]+ it "should reject an improperly formatted field" $ do+ (query_ conn "select c from custom where i = 2" :: IO [Only Message])+ `shouldThrow`+ (\e -> errMessage e == "Can't decode \"French: un message\" as Message")+ describe "writing a custom type" $ do+ it "should work with parameter substitution" $ do+ _ <- execute conn "insert into custom (i,c) values (?,?)"+ ((3::Int), Latin "nuntium")+ result <- query_ conn "select c from custom where i = 3"+ result `shouldBe` [Only (Latin "nuntium")]
+ test/DateTimeSpec.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}+module DateTimeSpec (+ dateTimeUnit+ , dateTimeSpec+) where++import Control.Monad (void)+import Data.Ratio ((%))+import Data.Time.Calendar (Day(..), toGregorian, fromGregorian)+import Data.Time.Clock (UTCTime(..))+import Data.Time.LocalTime (TimeOfDay(..))+import Database.MySQL.Simple+import Database.MySQL.Simple.Param (Action(..), render)+import Test.Hspec++import Common ()++-- An arbitrary date and time: 2022-05-25 13:09:34.375 UTC+testTime :: UTCTime+testTime = UTCTime (ModifiedJulianDay 59724)+ (realToFrac $ (378995 % 8 :: Rational))++testYear :: Day+testYear =+ let (y,_,_) = toGregorian (utctDay testTime)+ in fromGregorian y 1 1+++dateTimeUnit :: Spec+dateTimeUnit =+ describe "Date and time Param types" $ do+ it "UTCTime is correctly encoded" $+ render testTime `shouldBe` Plain "'2022-05-25 13:09:34.375'"+ it "Day is correctly encoded" $+ render (utctDay testTime) `shouldBe` Plain "'2022-05-25'"+ it "TimeOfDay is correctly encoded" $+ render (TimeOfDay 13 9 34.375) `shouldBe` Plain "'13:09:34.375'"+++dateTimeSpec :: Connection -> Spec+dateTimeSpec conn =+ beforeAll_+ ( do _ <- execute_ conn "drop table if exists datetime"+ _ <- execute_ conn ( "create table datetime "+ <> "(i int,"+ <> " dt datetime(6),"+ <> " d date,"+ <> " y year,"+ <> " ts timestamp(6),"+ <> " t time(6))"+ )+ void $ execute_ conn (+ "insert into datetime (i,dt,d,y,ts,t) values "+ <> "(1,'2022-05-25 13:09:34.375','2022-05-25','2022','2022-05-25 13:09:34.375','13:09:34.375'),"+ <> "(2,'0000-00-00 00:00:00','0000-00-00','0000','0000-00-00 00:00:00','00:00:00')"+ )+ ) $ do+ describe "reading date and time" $ do+ it "should read DATETIME correctly" $ do+ result <- query_ conn "select dt from datetime where i = 1"+ result `shouldBe` [Only testTime]+ it "should read DATE correctly" $ do+ result <- query_ conn "select d from datetime where i = 1"+ result `shouldBe` [Only $ utctDay testTime]+ it "should read YEAR correctly" $ do+ result <- query_ conn "select y from datetime where i = 1"+ result `shouldBe` [Only testYear]+ it "should read TIMESTAMP correctly" $ do+ result <- query_ conn "select ts from datetime where i = 1"+ result `shouldBe` [Only testTime]+ it "should read TIME correctly" $ do+ result <- query_ conn "select t from datetime where i = 1"+ result `shouldBe` [Only $ TimeOfDay 13 9 34.375]+ it "should be vaguely reasonable given a zero DATETIME" $ do+ result <- query_ conn "select dt from datetime where i = 2"+ result `shouldBe` [Only $ UTCTime (fromGregorian 0 0 0) 0]+ it "should be vaguely reasonable given a zero DATE" $ do+ result <- query_ conn "select d from datetime where i = 2"+ result `shouldBe` [Only $ fromGregorian 0 0 0]+ it "should be vaguely reasonable given a zero YEAR" $ do+ result <- query_ conn "select y from datetime where i = 2"+ result `shouldBe` [Only $ fromGregorian 0 0 0]
+ test/main.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP, OverloadedStrings #-}++import Control.Applicative ((<|>))+import Control.Exception (bracket)+import Data.Text (Text)+import Database.MySQL.Simple+import Database.MySQL.Simple.Param+import System.Environment (getEnvironment)+import Test.Hspec+import Blaze.ByteString.Builder (toByteString)++import Common ()+import DateTimeSpec (dateTimeUnit, dateTimeSpec)+import CustomTypeSpec (customTypeUnit, customTypeSpec)++isCI :: IO Bool+isCI = do+ env <- getEnvironment+ return $ case lookup "TRAVIS" env <|> lookup "CI" env of+ Just "true" -> True+ _ -> False++-- This is how to connect to our test database+testConn :: Bool -> ConnectInfo+testConn ci = defaultConnectInfo {+ connectHost = "127.0.0.1"+ , connectUser = "test"+ , connectPassword = "test"+ , connectDatabase = "test"+ , connectPort = if ci then 33306 else 3306+ }++-- Allow tests to do things which would be prevented in strict SQL mode+withConnection :: (Connection -> IO()) -> IO()+withConnection action = do+ ci <- isCI+ bracket (do conn <- connect $ testConn ci+ _ <- execute_ conn "set session sql_mode=''"+ return conn+ )+ close+ action++main :: IO ()+main =+ withConnection $ \conn ->+ hspec $ do+ describe "Database.MySQL.Simple.unitSpec" unitSpec+ describe "Database.MySQL.Simple.integrationSpec" $ integrationSpec conn+ describe "Database.MySQL.Simple.DateTimeSpec" $ do+ dateTimeUnit+ dateTimeSpec conn+ describe "Database.MySQL.Simple.CustomTypeSpec" $ do+ customTypeUnit+ customTypeSpec conn++unitSpec :: Spec+unitSpec = do+ describe "Param a => Param (In [a]) instance" $ do+ it "renders an empty list correctly" $ do+ let empty :: [Text]+ empty = mempty++ case render (In empty) of+ Plain a -> toByteString a `shouldBe` "(null)"+ _ -> expectationFailure "expected a Plain"++ it "renders a non-empty list correctly" $ do+ let l :: [Text]+ l = ["foo", "bar"]++ case render (In l) of+ Many [Plain _, Escape "foo", Plain _, Escape "bar", Plain _] -> pure ()+ _ -> expectationFailure "expected a Many with specific contents"++ describe "splitQuery" $ do+ it "works for a single question mark" $ do+ splitQuery "select * from foo where name = ?"+ `shouldBe`+ ["select * from foo where name = ", ""]+ it "works with a question mark in a string literal" $ do+ splitQuery "select 'hello?'"+ `shouldBe`+ ["select 'hello?'"]+ it "works with many question marks" $ do+ splitQuery "select ? + ? + what from foo where bar = ?"+ `shouldBe`+ ["select ", " + ", " + what from foo where bar = ", ""]++integrationSpec :: Connection -> Spec+integrationSpec conn = do+ describe "query_" $ do+ it "can connect to a database" $ do+ result <- query_ conn "select 1 + 1"+ result `shouldBe` [Only (2::Int)]+ it "can have question marks in string literals" $ do+ result <- query_ conn "select 'hello?'"+ result `shouldBe` [Only ("hello?" :: Text)]+ describe "query" $ do+ it "can have question marks in string literals" $ do+ result <- query conn "select 'hello?'" ()+ result `shouldBe` [Only ("hello?" :: Text)]+ describe "with too many query params" $ do+ it "should have the right message" $ do+ (query conn "select 'hello?'" (Only ['a']) :: IO [Only Text])+ `shouldThrow`+ (\e -> fmtMessage e == "0 '?' characters, but 1 parameters")+ describe "with too few query params" $ do+ it "should have the right message" $ do+ (query conn "select 'hello?' = ?" () :: IO [Only Text])+ `shouldThrow`+ (\e -> fmtMessage e == "1 '?' characters, but 0 parameters")+ describe "formatQuery" $ do+ it "should not blow up on a question mark in string literal" $ do+ formatQuery conn "select 'hello?'" ()+ `shouldReturn`+ "select 'hello?'"