diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/Database/MySQL/Simple.hs b/Database/MySQL/Simple.hs --- a/Database/MySQL/Simple.hs +++ b/Database/MySQL/Simple.hs @@ -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 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,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 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,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 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.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 diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -4,4 +4,4 @@ packages: - '.' extra-deps: [] -resolver: lts-18.28 +resolver: lts-19.8 diff --git a/test/Common.hs b/test/Common.hs new file mode 100644 --- /dev/null +++ b/test/Common.hs @@ -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 diff --git a/test/CustomTypeSpec.hs b/test/CustomTypeSpec.hs new file mode 100644 --- /dev/null +++ b/test/CustomTypeSpec.hs @@ -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")] diff --git a/test/DateTimeSpec.hs b/test/DateTimeSpec.hs new file mode 100644 --- /dev/null +++ b/test/DateTimeSpec.hs @@ -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] diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -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