mysql-haskell 1.2.5 → 1.3.0

raw patch · 5 files changed

+517/−1 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• ChangeLog.md +7/−0
• mysql-haskell.cabal +3/−1
• src/Database/MySQL/Field.hs +414/−0
• test/FieldRoundtrip.hs +91/−0
• test/Main.hs +2/−0

@@ -1,5 +1,12 @@ # Revision history for mysql-haskell +## 1.3.0 -- 2026.07.22++ Add `Database.MySQL.Field` with a `Field` typeclass for converting+  individual Haskell values to and from `MySQLValue` (#86). One combined+  class in the style of persistent's `PersistField`, with a `DecodeError`+  sum type for decode failures and named top-level encode/decode functions+  backing every instance.+ ## 1.2.5 -- 2026.05.04 + Replace abandoned `pem` dependency with `crypton-pem` (#84) 

@@ -1,6 +1,6 @@ cabal-version:      3.4 name:               mysql-haskell-version:            1.2.5+version:            1.3.0 synopsis:           pure haskell MySQL driver description:        pure haskell MySQL driver. license:            BSD-3-Clause@@ -75,6 +75,7 @@     Database.MySQL.BinLogProtocol.BinLogMeta     Database.MySQL.BinLogProtocol.BinLogValue     Database.MySQL.Connection+    Database.MySQL.Field     Database.MySQL.Protocol.Auth     Database.MySQL.Protocol.ColumnDef     Database.MySQL.Protocol.Command@@ -136,6 +137,7 @@     Aeson     AesonBP     BoundsCheck+    FieldRoundtrip     JSON     QC.ByteString     QC.Combinator

@@ -0,0 +1,414 @@+{-|+Module      : Database.MySQL.Field+Description : Convert between Haskell values and 'MySQLValue' fields+Copyright   : (c) Jappie Klooster, 2026+License     : BSD3+Maintainer  : hi@jappie.me+Stability   : experimental+Portability : PORTABLE++A single typeclass, 'Field', for converting an individual Haskell value+to and from a 'MySQLValue'. This is the extension point libraries such as+@beam-mysql@ need to marshal user column types generically: encoding is+total ('toField'), decoding returns 'DecodeError' on the 'Left'+('fromField').++Every instance must obey the roundtrip law:++@+'fromField' ('toField' x) == 'Right' x+@++Two caveats:++* 'Maybe' wrapped around a type that itself encodes to @MySQLNull@+  (@Maybe (Maybe a)@, @Maybe MySQLValue@): SQL cannot represent a+  @Just NULL@ distinct from @NULL@, so both collapse to 'Nothing' on the+  way back. Nullable columns want exactly one 'Maybe'.++* IEEE @NaN@ fails the equation literally because @NaN /= NaN@; the+  'Float' and 'Double' encodings are still lossless and decoding returns+  the same @NaN@.++All instances delegate to named top-level functions (@encodeInt8@,+@decodeInt8@, ...) so the conversions can be used, tested and grepped+without the class.++Decoding is strict and canonical: each Haskell type decodes only from the+constructor(s) carrying exactly its payload, with no implicit numeric+widening or narrowing. There are no instances for 'Int' and 'Word'+because their width is platform dependent; use 'Data.Int.Int64' or+'Data.Word.Word64'.+-}+module Database.MySQL.Field+    ( -- * The Field class+      Field (..)+      -- * Conversion errors+    , DecodeError (..)+    , ExpectedTypeName (..)+    , EncodeStringError (..)+      -- * Named conversions backing the instances+    , encodeInt8, decodeInt8+    , encodeWord8, decodeWord8+    , encodeInt16, decodeInt16+    , encodeWord16, decodeWord16+    , encodeInt32, decodeInt32+    , encodeWord32, decodeWord32+    , encodeInt64, decodeInt64+    , encodeWord64, decodeWord64+    , encodeFloat', decodeFloat'+    , encodeDouble, decodeDouble+    , encodeScientific, decodeScientific+    , encodeText, decodeText+    , encodeLazyText, decodeLazyText+    , encodeString, encodeStringOrCrash, decodeString+    , encodeByteString, decodeByteString+    , encodeLazyByteString, decodeLazyByteString+    , encodeDay, decodeDay+    , encodeLocalTime, decodeLocalTime+    , encodeTimeOfDay, decodeTimeOfDay+    , encodeBool, decodeBool+    , encodeMaybe, decodeMaybe+    ) where++import           Control.Exception                  (Exception)+import           Data.ByteString                    (ByteString)+import qualified Data.ByteString.Lazy               as LazyByteString+import           Data.Int                           (Int16, Int32, Int64, Int8)+import           Data.Scientific                    (Scientific)+import           Data.Text                          (Text)+import qualified Data.Text                          as Text+import qualified Data.Text.Lazy                     as LazyText+import           Data.Time.Calendar                 (Day)+import           Data.Time.LocalTime                (LocalTime, TimeOfDay)+import           Data.Word                          (Word16, Word32, Word64,+                                                     Word8)+import           Database.MySQL.Protocol.MySQLValue (MySQLValue (..))++-- | The name of the Haskell type a decoder was trying to produce,+-- carried inside 'DecodeError' for error reporting.+newtype ExpectedTypeName = ExpectedTypeName Text+    deriving (Show, Eq)++-- | All the ways decoding a single field can fail.+data DecodeError+    = DecodeTypeMismatch !ExpectedTypeName !MySQLValue+      -- ^ The value's constructor does not match the requested Haskell+      -- type, e.g. asking for 'Int32' from a @MySQLText@.+    | DecodeUnexpectedNull !ExpectedTypeName+      -- ^ The value was @MySQLNull@ but the requested type is not+      -- 'Maybe'; wrap the type in 'Maybe' for nullable columns.+    deriving (Show, Eq)++instance Exception DecodeError++-- | Convert a single Haskell value to and from a 'MySQLValue'.+--+-- Instances must obey: @'fromField' ('toField' x) == 'Right' x@.+-- (Caveats: nested 'Maybe' collapses through @NULL@, and IEEE @NaN@+-- fails the literal equation; see the module header.)+class Field a where+    toField :: a -> MySQLValue+    fromField :: MySQLValue -> Either DecodeError a++-- | Build the error for a value whose constructor does not match,+-- mapping @MySQLNull@ to 'DecodeUnexpectedNull' and everything else to+-- 'DecodeTypeMismatch'.+decodeFailure :: ExpectedTypeName -> MySQLValue -> Either DecodeError a+decodeFailure expected MySQLNull = Left (DecodeUnexpectedNull expected)+decodeFailure expected value     = Left (DecodeTypeMismatch expected value)++encodeInt8 :: Int8 -> MySQLValue+encodeInt8 = MySQLInt8++decodeInt8 :: MySQLValue -> Either DecodeError Int8+decodeInt8 (MySQLInt8 n) = Right n+decodeInt8 value         = decodeFailure (ExpectedTypeName "Int8") value++instance Field Int8 where+    toField = encodeInt8+    fromField = decodeInt8++encodeWord8 :: Word8 -> MySQLValue+encodeWord8 = MySQLInt8U++decodeWord8 :: MySQLValue -> Either DecodeError Word8+decodeWord8 (MySQLInt8U n) = Right n+decodeWord8 value          = decodeFailure (ExpectedTypeName "Word8") value++instance Field Word8 where+    toField = encodeWord8+    fromField = decodeWord8++encodeInt16 :: Int16 -> MySQLValue+encodeInt16 = MySQLInt16++decodeInt16 :: MySQLValue -> Either DecodeError Int16+decodeInt16 (MySQLInt16 n) = Right n+decodeInt16 value          = decodeFailure (ExpectedTypeName "Int16") value++instance Field Int16 where+    toField = encodeInt16+    fromField = decodeInt16++encodeWord16 :: Word16 -> MySQLValue+encodeWord16 = MySQLInt16U++decodeWord16 :: MySQLValue -> Either DecodeError Word16+decodeWord16 (MySQLInt16U n) = Right n+decodeWord16 value           = decodeFailure (ExpectedTypeName "Word16") value++instance Field Word16 where+    toField = encodeWord16+    fromField = decodeWord16++encodeInt32 :: Int32 -> MySQLValue+encodeInt32 = MySQLInt32++decodeInt32 :: MySQLValue -> Either DecodeError Int32+decodeInt32 (MySQLInt32 n) = Right n+decodeInt32 value          = decodeFailure (ExpectedTypeName "Int32") value++instance Field Int32 where+    toField = encodeInt32+    fromField = decodeInt32++encodeWord32 :: Word32 -> MySQLValue+encodeWord32 = MySQLInt32U++decodeWord32 :: MySQLValue -> Either DecodeError Word32+decodeWord32 (MySQLInt32U n) = Right n+decodeWord32 value           = decodeFailure (ExpectedTypeName "Word32") value++instance Field Word32 where+    toField = encodeWord32+    fromField = decodeWord32++encodeInt64 :: Int64 -> MySQLValue+encodeInt64 = MySQLInt64++decodeInt64 :: MySQLValue -> Either DecodeError Int64+decodeInt64 (MySQLInt64 n) = Right n+decodeInt64 value          = decodeFailure (ExpectedTypeName "Int64") value++instance Field Int64 where+    toField = encodeInt64+    fromField = decodeInt64++encodeWord64 :: Word64 -> MySQLValue+encodeWord64 = MySQLInt64U++decodeWord64 :: MySQLValue -> Either DecodeError Word64+decodeWord64 (MySQLInt64U n) = Right n+decodeWord64 value           = decodeFailure (ExpectedTypeName "Word64") value++instance Field Word64 where+    toField = encodeWord64+    fromField = decodeWord64++-- | Named with a prime because "Prelude" already exports+-- 'Prelude.encodeFloat'.+encodeFloat' :: Float -> MySQLValue+encodeFloat' = MySQLFloat++decodeFloat' :: MySQLValue -> Either DecodeError Float+decodeFloat' (MySQLFloat x) = Right x+decodeFloat' value          = decodeFailure (ExpectedTypeName "Float") value++instance Field Float where+    toField = encodeFloat'+    fromField = decodeFloat'++encodeDouble :: Double -> MySQLValue+encodeDouble = MySQLDouble++decodeDouble :: MySQLValue -> Either DecodeError Double+decodeDouble (MySQLDouble x) = Right x+decodeDouble value           = decodeFailure (ExpectedTypeName "Double") value++instance Field Double where+    toField = encodeDouble+    fromField = decodeDouble++encodeScientific :: Scientific -> MySQLValue+encodeScientific = MySQLDecimal++decodeScientific :: MySQLValue -> Either DecodeError Scientific+decodeScientific (MySQLDecimal n) = Right n+decodeScientific value            = decodeFailure (ExpectedTypeName "Scientific") value++instance Field Scientific where+    toField = encodeScientific+    fromField = decodeScientific++-- Decision: 'Text' decodes only from @MySQLText@, not from @MySQLBytes@.+-- A @MySQLBytes@ comes from a binary-collated column and need not be valid+-- UTF-8; guessing an encoding here would be a silent failure waiting to+-- happen. Read binary columns as 'ByteString' and decode explicitly.+encodeText :: Text -> MySQLValue+encodeText = MySQLText++decodeText :: MySQLValue -> Either DecodeError Text+decodeText (MySQLText t) = Right t+decodeText value         = decodeFailure (ExpectedTypeName "Text") value++instance Field Text where+    toField = encodeText+    fromField = decodeText++encodeLazyText :: LazyText.Text -> MySQLValue+encodeLazyText = MySQLText . LazyText.toStrict++decodeLazyText :: MySQLValue -> Either DecodeError LazyText.Text+decodeLazyText (MySQLText t) = Right (LazyText.fromStrict t)+decodeLazyText value         = decodeFailure (ExpectedTypeName "lazy Text") value++instance Field LazyText.Text where+    toField = encodeLazyText+    fromField = decodeLazyText++-- | All the ways encoding a 'String' can fail.+data EncodeStringError+    = EncodeStringLoneSurrogate !String+      -- ^ The 'String' contained a lone surrogate code point (@\\xD800@+      -- to @\\xDFFF@), which is not valid Unicode text and cannot be+      -- represented in MySQL's UTF-8 wire format. @Text.pack@ would+      -- silently replace it with @U+FFFD@, corrupting the data.+    deriving (Show, Eq)++instance Exception EncodeStringError++encodeString :: String -> Either EncodeStringError MySQLValue+encodeString string =+    if any isLoneSurrogate string+        then Left (EncodeStringLoneSurrogate string)+        else Right (MySQLText (Text.pack string))++isLoneSurrogate :: Char -> Bool+isLoneSurrogate character = '\xD800' <= character && character <= '\xDFFF'++-- | Backs the 'Field' 'String' instance: the class fixes+-- @toField :: a -> MySQLValue@, so the 'EncodeStringLoneSurrogate'+-- failure from 'encodeString' crashes here instead of being returned.+encodeStringOrCrash :: String -> MySQLValue+encodeStringOrCrash string = case encodeString string of+    Right value -> value+    Left (EncodeStringLoneSurrogate offending) ->+        error ("Database.MySQL.Field.encodeString: \+               \lone surrogate code point in String: " <> show offending+               <> ". This String is not valid Unicode, so the bug is \+                  \in whatever produced it (truncated UTF-16 or bad \+                  \decoding upstream). Fix that producer, or filter \+                  \the surrogates out before calling toField.")++decodeString :: MySQLValue -> Either DecodeError String+decodeString (MySQLText t) = Right (Text.unpack t)+decodeString value         = decodeFailure (ExpectedTypeName "String") value++instance Field String where+    toField = encodeStringOrCrash+    fromField = decodeString++encodeByteString :: ByteString -> MySQLValue+encodeByteString = MySQLBytes++decodeByteString :: MySQLValue -> Either DecodeError ByteString+decodeByteString (MySQLBytes bs) = Right bs+decodeByteString value           = decodeFailure (ExpectedTypeName "ByteString") value++instance Field ByteString where+    toField = encodeByteString+    fromField = decodeByteString++encodeLazyByteString :: LazyByteString.ByteString -> MySQLValue+encodeLazyByteString = MySQLBytes . LazyByteString.toStrict++decodeLazyByteString :: MySQLValue -> Either DecodeError LazyByteString.ByteString+decodeLazyByteString (MySQLBytes bs) = Right (LazyByteString.fromStrict bs)+decodeLazyByteString value           = decodeFailure (ExpectedTypeName "lazy ByteString") value++instance Field LazyByteString.ByteString where+    toField = encodeLazyByteString+    fromField = decodeLazyByteString++encodeDay :: Day -> MySQLValue+encodeDay = MySQLDate++decodeDay :: MySQLValue -> Either DecodeError Day+decodeDay (MySQLDate d) = Right d+decodeDay value         = decodeFailure (ExpectedTypeName "Day") value++instance Field Day where+    toField = encodeDay+    fromField = decodeDay++-- Decision: 'LocalTime' decodes from both @MySQLDateTime@ and+-- @MySQLTimeStamp@, since both carry a 'LocalTime' payload and which one+-- arrives depends on the column type, not on the Haskell type. Encoding+-- canonically produces @MySQLDateTime@; the roundtrip law still holds.+encodeLocalTime :: LocalTime -> MySQLValue+encodeLocalTime = MySQLDateTime++decodeLocalTime :: MySQLValue -> Either DecodeError LocalTime+decodeLocalTime (MySQLDateTime t)  = Right t+decodeLocalTime (MySQLTimeStamp t) = Right t+decodeLocalTime value              = decodeFailure (ExpectedTypeName "LocalTime") value++instance Field LocalTime where+    toField = encodeLocalTime+    fromField = decodeLocalTime++-- | A 'TimeOfDay' is only the non-negative, less-than-a-day fragment of+-- MySQL's @TIME@ type; a negative @TIME@ value fails to decode. For the+-- full range (intervals up to +-838:59:59) match on @MySQLTime@ directly.+encodeTimeOfDay :: TimeOfDay -> MySQLValue+encodeTimeOfDay = MySQLTime 0++decodeTimeOfDay :: MySQLValue -> Either DecodeError TimeOfDay+decodeTimeOfDay (MySQLTime sign t) =+    if sign == 0+        then Right t+        else decodeFailure (ExpectedTypeName "TimeOfDay") (MySQLTime sign t)+decodeTimeOfDay value = decodeFailure (ExpectedTypeName "TimeOfDay") value++instance Field TimeOfDay where+    toField = encodeTimeOfDay+    fromField = decodeTimeOfDay++-- Decision: 'Bool' maps to @TINYINT@, mirroring MySQL itself where+-- @BOOLEAN@ is an alias for @TINYINT(1)@ and any nonzero value is true.+-- Both the signed and unsigned tiny constructors are accepted because the+-- column may be declared either way.+encodeBool :: Bool -> MySQLValue+encodeBool True  = MySQLInt8 1+encodeBool False = MySQLInt8 0++decodeBool :: MySQLValue -> Either DecodeError Bool+decodeBool (MySQLInt8 n)  = Right (n /= 0)+decodeBool (MySQLInt8U n) = Right (n /= 0)+decodeBool value          = decodeFailure (ExpectedTypeName "Bool") value++instance Field Bool where+    toField = encodeBool+    fromField = decodeBool++encodeMaybe :: Field a => Maybe a -> MySQLValue+encodeMaybe Nothing      = MySQLNull+encodeMaybe (Just value) = toField value++decodeMaybe :: Field a => MySQLValue -> Either DecodeError (Maybe a)+decodeMaybe MySQLNull = Right Nothing+decodeMaybe value     = fmap Just (fromField value)++-- | @NULL@ maps to 'Nothing'; use this instance for nullable columns.+-- Do not nest it: SQL cannot distinguish @Just NULL@ from @NULL@, so+-- @Just Nothing@ decodes back as 'Nothing' and the roundtrip law breaks.+instance Field a => Field (Maybe a) where+    toField = encodeMaybe+    fromField = decodeMaybe++-- | The identity instance, an escape hatch for code that wants to handle+-- the raw protocol value in an otherwise 'Field'-polymorphic setting.+instance Field MySQLValue where+    toField = id+    fromField = Right

@@ -0,0 +1,91 @@+{-# LANGUAGE TypeApplications #-}++-- | Roundtrip law for every 'Field' instance+-- (@fromField (toField x) == Right x@), plus the decode-failure behaviour+-- that a roundtrip cannot exercise.+module FieldRoundtrip (tests) where++import           Data.ByteString                    (ByteString)+import qualified Data.ByteString.Lazy               as LazyByteString+import           Data.Int                           (Int16, Int32, Int64, Int8)+import           Data.Scientific                    (Scientific)+import           Data.Text                          (Text)+import qualified Data.Text.Lazy                     as LazyText+import           Data.Time.Calendar                 (Day)+import           Data.Time.LocalTime                (LocalTime,+                                                     TimeOfDay (..))+import           Data.Word                          (Word16, Word32, Word64,+                                                     Word8)+import           Database.MySQL.Field+import           Database.MySQL.Protocol.MySQLValue (MySQLValue (..))+import           Test.QuickCheck.Instances          ()+import           Test.Tasty+import           Test.Tasty.HUnit                   (testCase, (@?=))+import           Test.Tasty.QuickCheck              (Property, testProperty,+                                                     (===))++roundtrips :: (Field a, Eq a, Show a) => a -> Property+roundtrips value = fromField (toField value) === Right value++tests :: TestTree+tests = testGroup "Field"+    [ testGroup "roundtrip"+        [ testProperty "Int8" (roundtrips @Int8)+        , testProperty "Word8" (roundtrips @Word8)+        , testProperty "Int16" (roundtrips @Int16)+        , testProperty "Word16" (roundtrips @Word16)+        , testProperty "Int32" (roundtrips @Int32)+        , testProperty "Word32" (roundtrips @Word32)+        , testProperty "Int64" (roundtrips @Int64)+        , testProperty "Word64" (roundtrips @Word64)+        , testProperty "Float" (roundtrips @Float)+        , testProperty "Double" (roundtrips @Double)+        , testProperty "Scientific" (roundtrips @Scientific)+        , testProperty "Text" (roundtrips @Text)+        , testProperty "lazy Text" (roundtrips @LazyText.Text)+        , testProperty "String" (roundtrips @String)+        , testProperty "ByteString" (roundtrips @ByteString)+        , testProperty "lazy ByteString" (roundtrips @LazyByteString.ByteString)+        , testProperty "Day" (roundtrips @Day)+        , testProperty "LocalTime" (roundtrips @LocalTime)+        , testProperty "TimeOfDay" (roundtrips @TimeOfDay)+        , testProperty "Bool" (roundtrips @Bool)+        , testProperty "Maybe Int32" (roundtrips @(Maybe Int32))+        , testProperty "Maybe Text" (roundtrips @(Maybe Text))+        ]+    , testGroup "decode failures"+        [ testCase "NULL into a non-Maybe type is DecodeUnexpectedNull" $+            decodeText MySQLNull+                @?= Left (DecodeUnexpectedNull (ExpectedTypeName "Text"))+        , testCase "wrong constructor is DecodeTypeMismatch" $+            decodeInt8 (MySQLText "hi")+                @?= Left (DecodeTypeMismatch (ExpectedTypeName "Int8")+                                             (MySQLText "hi"))+        , testCase "no implicit widening: INT32 value into Int64 fails" $+            decodeInt64 (MySQLInt32 42)+                @?= Left (DecodeTypeMismatch (ExpectedTypeName "Int64")+                                             (MySQLInt32 42))+        , testCase "negative TIME into TimeOfDay fails" $+            decodeTimeOfDay (MySQLTime 1 (TimeOfDay 1 2 3))+                @?= Left (DecodeTypeMismatch (ExpectedTypeName "TimeOfDay")+                                             (MySQLTime 1 (TimeOfDay 1 2 3)))+        ]+    , testGroup "decode alternatives"+        [ testCase "NULL into Maybe is Nothing" $+            decodeMaybe @Int32 MySQLNull @?= Right Nothing+        , testCase "TIMESTAMP decodes into LocalTime" $+            decodeLocalTime (MySQLTimeStamp (read "2026-07-21 12:00:00"))+                @?= Right (read "2026-07-21 12:00:00")+        , testCase "nonzero TINYINT decodes as True" $+            decodeBool (MySQLInt8 5) @?= Right True+        , testCase "unsigned TINYINT decodes into Bool" $+            decodeBool (MySQLInt8U 0) @?= Right False+        , testCase "nested Maybe collapses Just Nothing to Nothing (documented NULL lossiness)" $+            fromField @(Maybe (Maybe Int32)) (toField (Just (Nothing :: Maybe Int32)))+                @?= Right Nothing+        , testCase "NaN encodes losslessly (roundtrip == fails only since NaN /= NaN)" $+            fmap isNaN (decodeDouble (encodeDouble (0 / 0))) @?= Right True+        , testCase "lone surrogate in String is rejected by encodeString" $+            encodeString ['\xD800'] @?= Left (EncodeStringLoneSurrogate ['\xD800'])+        ]+    ]

@@ -9,6 +9,7 @@ import qualified Word24 import qualified TCPStreams import qualified BoundsCheck+import qualified FieldRoundtrip  main :: IO () main = do@@ -28,4 +29,5 @@       , Sha1Scramble.tests       , Sha256Scramble.tests       , BoundsCheck.tests+      , FieldRoundtrip.tests       ]