diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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) diff --git a/mysql-haskell.cabal b/mysql-haskell.cabal --- a/mysql-haskell.cabal +++ b/mysql-haskell.cabal @@ -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 diff --git a/src/Database/MySQL/Field.hs b/src/Database/MySQL/Field.hs new file mode 100644 --- /dev/null +++ b/src/Database/MySQL/Field.hs @@ -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 diff --git a/test/FieldRoundtrip.hs b/test/FieldRoundtrip.hs new file mode 100644 --- /dev/null +++ b/test/FieldRoundtrip.hs @@ -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']) + ] + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 ]