mysql-simple 0.4.7.2 → 0.4.8
raw patch · 10 files changed
+326/−41 lines, 10 filesdep ~basedep ~mysqldep ~time
Dependency ranges changed: base, mysql, time
Files
- ChangeLog.md +4/−0
- Database/MySQL/Simple.hs +39/−4
- Database/MySQL/Simple/Param.hs +21/−3
- Database/MySQL/Simple/Result.hs +64/−18
- mysql-simple.cabal +7/−2
- stack.yaml +1/−1
- test/Common.hs +16/−0
- test/CustomTypeSpec.hs +69/−0
- test/DateTimeSpec.hs +82/−0
- test/main.hs +23/−13
ChangeLog.md view
@@ -1,3 +1,7 @@+## 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)
Database/MySQL/Simple.hs view
@@ -51,6 +51,8 @@ , VaArgs(..) , Binary(..) , Only(..)+ , Param+ , Result -- ** Exceptions , FormatError(fmtMessage, fmtQuery, fmtParams) , QueryError(qeMessage, qeQuery)@@ -81,6 +83,14 @@ , formatMany , formatQuery , splitQuery++ -- | #extension#++ -- * Extension hooks+ -- $hooks++ , FromField(..)+ , ToField(..) ) where import Blaze.ByteString.Builder (Builder, fromByteString, toByteString)@@ -94,12 +104,13 @@ 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.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@@ -358,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@@ -663,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,5 +1,5 @@ {-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor, FlexibleInstances,- OverloadedStrings #-}+ OverloadedStrings, DefaultSignatures #-} -- | -- Module: Database.MySQL.Simple.Param@@ -12,8 +12,8 @@ -- The 'Param' typeclass, for rendering a parameter to a SQL query. module Database.MySQL.Simple.Param- (- Action(..)+ ( Action(..)+ , ToField(..) , Param(..) , inQuotes ) where@@ -71,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
Database/MySQL/Simple/Result.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, DeriveDataTypeable, FlexibleInstances, OverloadedStrings #-}+{-# LANGUAGE GeneralisedNewtypeDeriving, DefaultSignatures #-} #if MIN_VERSION_time(1,5,0) {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} #endif@@ -22,13 +23,17 @@ -- 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.ByteString.Char8 hiding (Result)@@ -39,7 +44,7 @@ import Data.Ratio (Ratio) import Data.Time.Calendar (Day, fromGregorian) import Data.Time.Clock (UTCTime(..))-import Data.Time.Format (parseTimeM)+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)@@ -82,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)@@ -160,15 +196,16 @@ instance Result [Char] where convert f = ST.unpack . convert f -instance Result UTCTime where- convert f = doConvert f ok $ \bs ->- case parseTimeM True defaultTimeLocale "%F %T%Q" (B8.unpack bs) of- Just t -> t- Nothing- | SB.isPrefixOf "0000-00-00" bs ->- UTCTime (fromGregorian 0 0 0) 0- | otherwise -> 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@@ -180,12 +217,21 @@ <*> (decimal <* char '-') <*> decimal -instance Result TimeOfDay where- convert f = doConvert f ok $ \bs ->- case parseTimeM True defaultTimeLocale "%T%Q" (B8.unpack bs) of- Just t -> 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
mysql-simple.cabal view
@@ -1,5 +1,5 @@ name: mysql-simple-version: 0.4.7.2+version: 0.4.8 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.@@ -45,7 +45,7 @@ build-depends: attoparsec >= 0.10.0.0,- base < 5,+ base >= 4.9 && < 5, base16-bytestring, blaze-builder, bytestring >= 0.9,@@ -81,14 +81,19 @@ 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: git
stack.yaml view
@@ -4,4 +4,4 @@ packages: - '.' extra-deps: []-resolver: lts-18.28+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
@@ -1,9 +1,5 @@ {-# LANGUAGE CPP, OverloadedStrings #-} --{-# options_ghc -fno-warn-orphans #-}--import Data.ByteString.Builder as BS import Control.Applicative ((<|>)) import Control.Exception (bracket) import Data.Text (Text)@@ -13,6 +9,10 @@ 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@@ -30,13 +30,29 @@ , connectPort = if ci then 33306 else 3306 } -main :: IO ()-main = do+-- Allow tests to do things which would be prevented in strict SQL mode+withConnection :: (Connection -> IO()) -> IO()+withConnection action = do ci <- isCI- bracket (connect $ testConn ci) close $ \conn ->+ 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@@ -70,12 +86,6 @@ splitQuery "select ? + ? + what from foo where bar = ?" `shouldBe` ["select ", " + ", " + what from foo where bar = ", ""]--instance Show BS.Builder where- show = show . BS.toLazyByteString--instance Eq BS.Builder where- a == b = BS.toLazyByteString a == BS.toLazyByteString b integrationSpec :: Connection -> Spec integrationSpec conn = do