diff --git a/Database/MySQL/Base.hs b/Database/MySQL/Base.hs index f98ee5b..6dd56c2 100644 --- a/Database/MySQL/Base.hs +++ b/Database/MySQL/Base.hs @@ -82,6 +82,10 @@ module Database.MySQL.Base , initLibrary , initThread , endThread + -- * Prepared Statements + , prepare + , Statement.bindParams + , Statement.execute ) where import Control.Applicative ((<$>), (<*>)) @@ -96,6 +100,8 @@ import Data.Int (Int64) import Data.List (foldl') import Data.Typeable (Typeable) import Data.Word (Word, Word16, Word64) +import Data.Text (Text) +import qualified Database.MySQL.PreparedStatement as Statement import Database.MySQL.Base.C import Database.MySQL.Base.Types import Foreign.C.String (CString, peekCString, withCString) @@ -648,3 +654,7 @@ connectionError_ func ptr =do errno <- mysql_errno ptr msg <- peekCString =<< mysql_error ptr throw $ ConnectionError func (fromIntegral errno) msg + +prepare :: Connection -> Text -> IO Statement.Statement +prepare conn q = do + Statement.prepare (connFP conn) q diff --git a/Database/MySQL/Base/C.hsc b/Database/MySQL/Base/C.hsc index 7c985c0..030e735 100644 --- a/Database/MySQL/Base/C.hsc +++ b/Database/MySQL/Base/C.hsc @@ -48,6 +48,7 @@ module Database.MySQL.Base.C -- * Working with results , mysql_free_result , mysql_free_result_nonblock + , mysql_num_fields , mysql_fetch_fields , mysql_fetch_fields_nonblock , mysql_data_seek @@ -68,6 +69,19 @@ module Database.MySQL.Base.C , mysql_library_init , mysql_thread_init , mysql_thread_end + + + , mysql_stmt_init + , mysql_stmt_close + , mysql_stmt_prepare + , mysql_stmt_bind_param + , mysql_stmt_bind_result + , mysql_stmt_execute + , mysql_stmt_fetch + , mysql_stmt_store_result + , mysql_stmt_result_metadata + , mysql_stmt_free_result + , mysql_stmt_error ) where #include "mysql_signals.h" @@ -242,6 +256,9 @@ foreign import ccall safe "mysql_signals.h _hs_mysql_free_result" mysql_free_res foreign import ccall safe "mysql.h mysql_free_result" mysql_free_result_nonblock :: Ptr MYSQL_RES -> IO () +foreign import ccall safe mysql_num_fields + :: Ptr MYSQL_RES -> IO CUInt + foreign import ccall safe mysql_fetch_fields :: Ptr MYSQL_RES -> IO (Ptr Field) @@ -299,3 +316,50 @@ foreign import ccall safe "mysql.h" mysql_thread_init foreign import ccall safe "mysql.h" mysql_thread_end :: IO () + + +-- Prepared Statements +foreign import ccall safe mysql_stmt_init + :: Ptr MYSQL -> IO (Ptr MYSQL_STMT) + +foreign import ccall safe mysql_stmt_close + :: Ptr MYSQL_STMT -> IO MyBool + +foreign import ccall safe mysql_stmt_bind_param + :: Ptr MYSQL_STMT -> Ptr MYSQL_BIND -> IO MyBool + +foreign import ccall safe mysql_stmt_bind_result + :: Ptr MYSQL_STMT -> Ptr MYSQL_BIND -> IO MyBool + +foreign import ccall safe mysql_stmt_errno + :: Ptr MYSQL_STMT -> IO CInt + +foreign import ccall safe mysql_stmt_error + :: Ptr MYSQL_STMT -> IO CString + +foreign import ccall safe mysql_stmt_prepare + :: Ptr MYSQL_STMT -> CString -> CULong -> IO CInt + +foreign import ccall safe mysql_stmt_execute + :: Ptr MYSQL_STMT -> IO CInt + +foreign import ccall safe mysql_stmt_fetch + :: Ptr MYSQL_STMT -> IO CInt + +foreign import ccall safe mysql_stmt_store_result + :: Ptr MYSQL_STMT -> IO CInt + +foreign import ccall safe mysql_stmt_insert_id + :: Ptr MYSQL_STMT -> IO CULLong + +foreign import ccall safe mysql_stmt_field_count + :: Ptr MYSQL_STMT -> IO CUInt + +foreign import ccall safe mysql_stmt_affected_rows + :: Ptr MYSQL_STMT -> IO CULLong + +foreign import ccall safe mysql_stmt_result_metadata + :: Ptr MYSQL_STMT -> IO (Ptr MYSQL_RES) + +foreign import ccall safe mysql_stmt_free_result + :: Ptr MYSQL_STMT -> IO MyBool diff --git a/Database/MySQL/Base/Types.hsc b/Database/MySQL/Base/Types.hsc index 595ce3c..7e74f12 100644 --- a/Database/MySQL/Base/Types.hsc +++ b/Database/MySQL/Base/Types.hsc @@ -28,6 +28,9 @@ module Database.MySQL.Base.Types , MYSQL_ROW , MYSQL_ROWS , MYSQL_ROW_OFFSET + , MYSQL_STMT + , MYSQL_BIND(..) + , MYSQL_TIME(..) , MyBool -- * Field flags , hasAllFlags @@ -60,10 +63,12 @@ import Data.Word (Word, Word8) import Foreign.C.Types (CChar, CInt, CUInt, CULong) import Foreign.Ptr (Ptr) import Foreign.Storable (Storable(..), peekByteOff) +import qualified Foreign as Foreign import qualified Data.IntMap as IntMap data MYSQL data MYSQL_RES +data MYSQL_STMT data MYSQL_ROWS type MYSQL_ROW = Ptr (Ptr CChar) type MYSQL_ROW_OFFSET = Ptr MYSQL_ROWS @@ -109,6 +114,39 @@ data Type = Decimal | Json deriving (Enum, Eq, Show, Typeable) +fromType :: Type -> CInt +fromType t = + case t of + Decimal -> #const MYSQL_TYPE_DECIMAL + Tiny -> #const MYSQL_TYPE_TINY + Short -> #const MYSQL_TYPE_SHORT + Int24 -> #const MYSQL_TYPE_INT24 + Long -> #const MYSQL_TYPE_LONG + Float -> #const MYSQL_TYPE_FLOAT + Double -> #const MYSQL_TYPE_DOUBLE + Null -> #const MYSQL_TYPE_NULL + Timestamp -> #const MYSQL_TYPE_TIMESTAMP + LongLong -> #const MYSQL_TYPE_LONGLONG + Date -> #const MYSQL_TYPE_DATE + Time -> #const MYSQL_TYPE_TIME + DateTime -> #const MYSQL_TYPE_DATETIME + Year -> #const MYSQL_TYPE_YEAR + NewDate -> #const MYSQL_TYPE_NEWDATE + VarChar -> #const MYSQL_TYPE_VARCHAR + Bit -> #const MYSQL_TYPE_BIT + NewDecimal -> #const MYSQL_TYPE_NEWDECIMAL + Enum -> #const MYSQL_TYPE_ENUM + Set -> #const MYSQL_TYPE_SET + TinyBlob -> #const MYSQL_TYPE_TINY_BLOB + MediumBlob -> #const MYSQL_TYPE_MEDIUM_BLOB + LongBlob -> #const MYSQL_TYPE_LONG_BLOB + Blob -> #const MYSQL_TYPE_BLOB + VarString -> #const MYSQL_TYPE_VAR_STRING + String -> #const MYSQL_TYPE_STRING + Geometry -> #const MYSQL_TYPE_GEOMETRY + Json -> mysql_type_json + + toType :: CInt -> Type toType v = IntMap.findWithDefault oops (fromIntegral v) typeMap where @@ -144,6 +182,71 @@ toType v = IntMap.findWithDefault oops (fromIntegral v) typeMap , (mysql_type_json, Json) ] +data MYSQL_BIND = MYSQL_BIND + { mysqlBindBufferType :: Type + , mysqlBindBuffer :: Ptr () + , mysqlBindBufferLength :: CULong + , mysqlBindLength :: Ptr CULong + , mysqlBindIsNull :: Ptr MyBool + , mysqlBindIsUnsigned :: MyBool + , mysqlBindError :: Ptr MyBool + } + +instance Storable MYSQL_BIND where + sizeOf _ = #{size MYSQL_BIND} + alignment _ = #{alignment MYSQL_BIND} + peek ptr = + MYSQL_BIND + <$> (toType <$> (#peek MYSQL_BIND, buffer_type) ptr) + <*> (#peek MYSQL_BIND, buffer) ptr + <*> (#peek MYSQL_BIND, buffer_length) ptr + <*> (#peek MYSQL_BIND, length) ptr + <*> (#peek MYSQL_BIND, is_null) ptr + <*> (#peek MYSQL_BIND, is_unsigned) ptr + <*> (#peek MYSQL_BIND, error) ptr + poke ptr val = do + (#poke MYSQL_BIND, buffer_type) ptr $ fromType $ mysqlBindBufferType val + (#poke MYSQL_BIND, buffer) ptr $ mysqlBindBuffer val + (#poke MYSQL_BIND, buffer_length) ptr $ mysqlBindBufferLength val + (#poke MYSQL_BIND, length) ptr $ mysqlBindLength val + (#poke MYSQL_BIND, is_null) ptr $ mysqlBindIsNull val + (#poke MYSQL_BIND, is_unsigned) ptr $ mysqlBindIsUnsigned val + (#poke MYSQL_BIND, error) ptr $ mysqlBindError val + +data MYSQL_TIME = MYSQL_TIME + { mysqlTimeYear :: CUInt + , mysqlTimeMonth :: CUInt + , mysqlTimeDay :: CUInt + , mysqlTimeHour :: CUInt + , mysqlTimeMinute :: CUInt + , mysqlTimeSecond :: CUInt + , mysqlTimeNeg :: Bool + , mysqlTimeSecondPart :: CULong + } + +instance Storable MYSQL_TIME where + sizeOf _ = #{size MYSQL_TIME} + alignment _ = #{alignment MYSQL_TIME} + peek ptr = + MYSQL_TIME + <$> (#peek MYSQL_TIME, year) ptr + <*> (#peek MYSQL_TIME, month) ptr + <*> (#peek MYSQL_TIME, day) ptr + <*> (#peek MYSQL_TIME, hour) ptr + <*> (#peek MYSQL_TIME, minute) ptr + <*> (#peek MYSQL_TIME, second) ptr + <*> (Foreign.toBool <$> ((#peek MYSQL_TIME, neg) ptr :: IO MyBool)) + <*> (#peek MYSQL_TIME, second_part) ptr + poke ptr val = do + (#poke MYSQL_TIME, year) ptr $ mysqlTimeYear val + (#poke MYSQL_TIME, month) ptr $ mysqlTimeMonth val + (#poke MYSQL_TIME, day) ptr $ mysqlTimeDay val + (#poke MYSQL_TIME, hour) ptr $ mysqlTimeHour val + (#poke MYSQL_TIME, minute) ptr $ mysqlTimeMinute val + (#poke MYSQL_TIME, second) ptr $ mysqlTimeSecond val + (#poke MYSQL_TIME, neg) ptr $ ((Foreign.fromBool $ mysqlTimeNeg val) :: MyBool) + (#poke MYSQL_TIME, second_part) ptr $ mysqlTimeSecondPart val + -- | A description of a field (column) of a table. data Field = Field { fieldName :: ByteString -- ^ Name of column. @@ -239,7 +342,7 @@ peekField ptr = do instance Storable Field where sizeOf _ = #{size MYSQL_FIELD} - alignment _ = alignment (undefined :: Ptr CChar) + alignment _ = #{alignment MYSQL_FIELD} peek = peekField poke _ _ = return () -- Unused, but define it to avoid a warning diff --git a/Database/MySQL/PreparedStatement.hs b/Database/MySQL/PreparedStatement.hs new file mode 100644 index 0000000..e90b9bc --- /dev/null +++ b/Database/MySQL/PreparedStatement.hs @@ -0,0 +1,485 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Database.MySQL.PreparedStatement + where + +import Control.Monad (void, when) +import Data.ByteString.Char8 +import Data.ByteString.Internal (create) +import Data.ByteString.Unsafe (unsafeUseAsCStringLen) +import qualified Data.Fixed as Fixed +import Data.Text (Text) +import qualified Data.Text.Foreign as Text +import Data.Time.Calendar (Day, fromGregorian, toGregorian) +import Data.Time.LocalTime (LocalTime (..), TimeOfDay (..), + makeTimeOfDayValid) +import Database.MySQL.Base.C +import Database.MySQL.Base.Types hiding (Type (..)) +import qualified Database.MySQL.Base.Types as Types +import Foreign hiding (newForeignPtr, void) +import Foreign.C.Error +import Foreign.C.String (peekCString) +import Foreign.Concurrent (newForeignPtr) + +data Statement = Statement + { connectionPtr :: ForeignPtr MYSQL + , statementPtr :: ForeignPtr MYSQL_STMT + } + +prepare :: ForeignPtr MYSQL -> Text -> IO Statement +prepare mysql q = + withForeignPtr mysql $ \mysql' -> do + mysqlStmt <- throwIfNull "mysql_stmt_init" $ mysql_stmt_init mysql' + stmt <- newForeignPtr mysqlStmt (void $ mysql_stmt_close mysqlStmt) + Text.withCStringLen q $ \(p,l) -> do + res <- mysql_stmt_prepare mysqlStmt p (fromIntegral l) + when (res > 0) $ do + err <- peekCString =<< mysql_stmt_error mysqlStmt + error err + pure $ Statement mysql stmt + +withConn :: Statement -> (Ptr MYSQL -> IO a) -> IO a +withConn statement = + withForeignPtr (connectionPtr statement) + +withStatement :: Statement -> (Ptr MYSQL_STMT -> IO a) -> IO a +withStatement statement = + withForeignPtr (statementPtr statement) + +data Value + = Null + | TinyInt Int8 + | Short Int16 + | MediumInt Int32 + | Long Int32 + | LongLong Int64 + | UnsignedTinyInt Word8 + | UnsignedShort Word16 + | UnsignedMediumInt Word32 + | UnsignedLong Word32 + | UnsignedLongLong Word64 + | Float Float + | Double Double + | Decimal ByteString + | Time TimeOfDay + | Date Day + | DateTime LocalTime + | Timestamp LocalTime + | String Text + | Blob ByteString + deriving (Eq, Show) + +withValue :: Value -> (MYSQL_BIND -> IO a) -> IO a +withValue v k = + case v of + Null -> + k defaultBind + TinyInt i -> + with i $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.Tiny + , mysqlBindBuffer = castPtr ptr + } + Short i -> + with i $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.Short + , mysqlBindBuffer = castPtr ptr + } + + MediumInt i -> + with i $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.Long + , mysqlBindBuffer = castPtr ptr + } + + Long i -> + with i $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.Long + , mysqlBindBuffer = castPtr ptr + } + LongLong i -> + with i $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.LongLong + , mysqlBindBuffer = castPtr ptr + } + UnsignedTinyInt i -> + with i $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.Tiny + , mysqlBindBuffer = castPtr ptr + , mysqlBindIsUnsigned = 1 + } + UnsignedShort i -> + with i $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.Short + , mysqlBindBuffer = castPtr ptr + , mysqlBindIsUnsigned = 1 + } + + UnsignedMediumInt i -> + with i $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.Long + , mysqlBindBuffer = castPtr ptr + , mysqlBindIsUnsigned = 1 + } + + UnsignedLong i -> + with i $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.Long + , mysqlBindBuffer = castPtr ptr + , mysqlBindIsUnsigned = 1 + } + UnsignedLongLong i -> + with i $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.LongLong + , mysqlBindBuffer = castPtr ptr + , mysqlBindIsUnsigned = 1 + } + Float f -> + with f $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.Float + , mysqlBindBuffer = castPtr ptr + } + Double d -> + with d $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.Double + , mysqlBindBuffer = castPtr ptr + } + + Decimal _ -> + error "Unsupported input type: Decimal" + + String t -> + Text.withCStringLen t $ \(ptr, l) -> + with (fromIntegral l) $ \lPtr -> + k $ defaultBind + { mysqlBindBufferType = Types.String + , mysqlBindBuffer = castPtr ptr + , mysqlBindBufferLength = fromIntegral l + , mysqlBindLength = lPtr + } + + Blob b -> + unsafeUseAsCStringLen b $ \(ptr, l) -> + with (fromIntegral l) $ \lPtr -> + k $ defaultBind + { mysqlBindBufferType = Types.Blob + , mysqlBindBuffer = castPtr ptr + , mysqlBindBufferLength = fromIntegral l + , mysqlBindLength = lPtr + } + + Date day -> + let (year, month, dayOfMonth) = toGregorian day + myTime = MYSQL_TIME + { mysqlTimeYear = fromIntegral year + , mysqlTimeMonth = fromIntegral month + , mysqlTimeDay = fromIntegral dayOfMonth + , mysqlTimeHour = 0 + , mysqlTimeMinute = 0 + , mysqlTimeSecond = 0 + , mysqlTimeNeg = False + , mysqlTimeSecondPart = 0 + } + in + with myTime $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.Date + , mysqlBindBuffer = castPtr ptr + } + + Time t -> + let (seconds, secondParts) = picoToSecondsAndMicroseconds (todSec t) + myTime = MYSQL_TIME + { mysqlTimeYear = 0 + , mysqlTimeMonth = 0 + , mysqlTimeDay = 0 + , mysqlTimeHour = fromIntegral $ todHour t + , mysqlTimeMinute = fromIntegral $ todMin t + , mysqlTimeSecond = fromInteger seconds + , mysqlTimeNeg = False + , mysqlTimeSecondPart = fromInteger secondParts + } + in + with myTime $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.Time + , mysqlBindBuffer = castPtr ptr + } + DateTime dt -> + with (localTime dt) $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.DateTime + , mysqlBindBuffer = castPtr ptr + } + + Timestamp ts -> + with (localTime ts) $ \ptr -> + k $ defaultBind + { mysqlBindBufferType = Types.Timestamp + , mysqlBindBuffer = castPtr ptr + } + + where + localTime t = + let (year, month, dayOfMonth) = toGregorian $ localDay t + tod = localTimeOfDay t + (seconds, secondParts) = picoToSecondsAndMicroseconds (todSec tod) + in + MYSQL_TIME + { mysqlTimeYear = fromIntegral year + , mysqlTimeMonth = fromIntegral month + , mysqlTimeDay = fromIntegral dayOfMonth + , mysqlTimeHour = fromIntegral $ todHour tod + , mysqlTimeMinute = fromIntegral $ todMin tod + , mysqlTimeSecond = fromInteger seconds + , mysqlTimeNeg = False + , mysqlTimeSecondPart = fromInteger secondParts + } + + defaultBind = + MYSQL_BIND + { mysqlBindBufferType = Types.Null + , mysqlBindBuffer = nullPtr + , mysqlBindBufferLength = 0 + , mysqlBindLength = nullPtr + , mysqlBindIsNull = nullPtr + , mysqlBindIsUnsigned = 0 + , mysqlBindError = nullPtr + } + +bindParams :: Statement -> [Value] -> IO () +bindParams statement args = + withStatement statement $ \mysqlStmt -> do + throwErrnoIf_ (> 0) "mysql_stmt_bind_param" $ + withMany withValue args $ \binds -> + withArray binds $ mysql_stmt_bind_param mysqlStmt + +execute :: Statement -> IO () +execute statement = + withStatement statement $ \mysqlStmt -> do + throwErrnoIf_ (> 0) "mysql_stmt_execute" $ mysql_stmt_execute mysqlStmt + +storeResult :: Statement -> IO () +storeResult statement = + withStatement statement $ \mysqlStmt -> do + throwErrnoIf_ (> 0) "mysql_stmt_store_result" $ mysql_stmt_store_result mysqlStmt + +fetchFieldMetadata :: Ptr MYSQL_STMT -> IO [Field] +fetchFieldMetadata mysqlStmt = do + mysqlRes <- mysql_stmt_result_metadata mysqlStmt + if mysqlRes == nullPtr then do + err <- peekCString =<< mysql_stmt_error mysqlStmt + error err + else do + numFields <- mysql_num_fields mysqlRes + fields <- peekArray (fromIntegral numFields) =<< mysql_fetch_fields mysqlRes + mysql_free_result mysqlRes + pure fields + +withField :: Field -> (MYSQL_BIND -> IO a) -> IO a +withField field k = + let len = if fieldMaxLength field /= 0 then fieldMaxLength field else fieldLength field + isUnsigned = fromBool $ hasAllFlags (flagNumeric <> flagUnsigned) (fieldFlags field) + in + alloca $ \isNull -> + alloca $ \lenPtr -> + allocaBytes (fromIntegral len) $ \buffer -> + k $ MYSQL_BIND + { mysqlBindBufferType = fieldType field + , mysqlBindBuffer = buffer + , mysqlBindBufferLength = fromIntegral len + , mysqlBindLength = lenPtr + , mysqlBindIsNull = isNull + , mysqlBindIsUnsigned = isUnsigned + , mysqlBindError = nullPtr + } + +withBoundResultFields :: Ptr MYSQL_STMT -> [Field] -> ([MYSQL_BIND] -> IO a) -> IO a +withBoundResultFields mysqlStmt fields k = + withMany withField fields $ \binds -> + withArray binds $ \bindsPtr -> do + throwErrnoIf_ (> 0) "mysql_stmt_bind_result" $ mysql_stmt_bind_result mysqlStmt bindsPtr + k binds + +toValue :: MYSQL_BIND -> IO (Maybe Value) +toValue bind = do + isNull <- peek $ mysqlBindIsNull bind + if toBool isNull then + pure Nothing + else do + case mysqlBindBufferType bind of + Types.Null -> + pure Nothing + + Types.Tiny -> do + if toBool $ mysqlBindIsUnsigned bind then do + i <- peek $ castPtr $ mysqlBindBuffer bind + pure $ Just $ UnsignedTinyInt i + else do + i <- peek $ castPtr $ mysqlBindBuffer bind + pure $ Just $ TinyInt i + + Types.Short -> do + if toBool $ mysqlBindIsUnsigned bind then do + i <- peek $ castPtr $ mysqlBindBuffer bind + pure $ Just $ UnsignedShort i + else do + i <- peek $ castPtr $ mysqlBindBuffer bind + pure $ Just $ Short i + + Types.Int24 -> do + if toBool $ mysqlBindIsUnsigned bind then do + i <- peek $ castPtr $ mysqlBindBuffer bind + pure $ Just $ UnsignedMediumInt i + else do + i <- peek $ castPtr $ mysqlBindBuffer bind + pure $ Just $ MediumInt i + + Types.Long -> do + if toBool $ mysqlBindIsUnsigned bind then do + i <- peek $ castPtr $ mysqlBindBuffer bind + pure $ Just $ UnsignedLong i + else do + i <- peek $ castPtr $ mysqlBindBuffer bind + pure $ Just $ Long i + + Types.LongLong -> do + if toBool $ mysqlBindIsUnsigned bind then do + i <- peek $ castPtr $ mysqlBindBuffer bind + pure $ Just $ UnsignedLongLong i + else do + i <- peek $ castPtr $ mysqlBindBuffer bind + pure $ Just $ LongLong i + + Types.Float -> do + f <- peek $ castPtr $ mysqlBindBuffer bind + pure $ Just $ Float f + + Types.Double -> do + d <- peek $ castPtr $ mysqlBindBuffer bind + pure $ Just $ Double d + + Types.NewDecimal -> do + length' <- peek $ mysqlBindLength bind + blob <- create (fromIntegral length') $ \d -> + copyBytes d (castPtr $ mysqlBindBuffer bind) (fromIntegral length') + pure $ Just $ Decimal blob + + Types.String -> do + length' <- peek $ mysqlBindLength bind + blob <- Text.peekCStringLen (castPtr $ mysqlBindBuffer bind, fromIntegral length') + pure $ Just $ String blob + + Types.VarString -> do + length' <- peek $ mysqlBindLength bind + blob <- Text.peekCStringLen (castPtr $ mysqlBindBuffer bind, fromIntegral length') + pure $ Just $ String blob + + Types.Date -> do + day <- peekDay $ castPtr (mysqlBindBuffer bind) + pure $ Just $ Date day + + Types.Time -> do + tod <- peekTimeOfDay $ castPtr (mysqlBindBuffer bind) + pure $ fmap Time tod + + Types.DateTime -> do + localTime <- peekLocalTime $ castPtr (mysqlBindBuffer bind) + pure $ fmap DateTime localTime + + Types.Timestamp -> do + localTime <- peekLocalTime $ castPtr (mysqlBindBuffer bind) + pure $ fmap Timestamp localTime + + _ -> do + length' <- peek $ mysqlBindLength bind + blob <- create (fromIntegral length') $ \d -> + copyBytes d (castPtr $ mysqlBindBuffer bind) (fromIntegral length') + pure $ Just $ Blob blob + +peekLocalTime :: Ptr MYSQL_TIME -> IO (Maybe LocalTime) +peekLocalTime = + fmap mysqlTimeToLocalTime . peek + +mysqlTimeToLocalTime :: MYSQL_TIME -> Maybe LocalTime +mysqlTimeToLocalTime myTime = + LocalTime (mysqlTimeToDay myTime) <$> mysqlTimeToTimeOfDay myTime + +peekDay :: Ptr MYSQL_TIME -> IO Day +peekDay = + fmap mysqlTimeToDay . peek + +mysqlTimeToDay :: MYSQL_TIME -> Day +mysqlTimeToDay myTime = + fromGregorian (fromIntegral $ mysqlTimeYear myTime) + (fromIntegral $ mysqlTimeMonth myTime) + (fromIntegral $ mysqlTimeDay myTime) + +peekTimeOfDay :: Ptr MYSQL_TIME -> IO (Maybe TimeOfDay) +peekTimeOfDay = + fmap mysqlTimeToTimeOfDay . peek + +mysqlTimeToTimeOfDay :: MYSQL_TIME -> Maybe TimeOfDay +mysqlTimeToTimeOfDay myTime = + let pico = picoFromSecondsAndMicroseconds + (fromIntegral $ mysqlTimeSecond myTime) + (Fixed.MkFixed $ fromIntegral $ mysqlTimeSecondPart myTime) + in makeTimeOfDayValid (fromIntegral $ mysqlTimeHour myTime) + (fromIntegral $ mysqlTimeMinute myTime) + pico + +unFixed :: Fixed.Fixed a -> Integer +unFixed (Fixed.MkFixed i) = i + +scaleFixed :: forall a b. + (Fixed.HasResolution a, Fixed.HasResolution b) + => Fixed.Fixed a -> Fixed.Fixed b +scaleFixed x = + let inputRes = Fixed.resolution x + outputRes = Fixed.resolution (undefined :: Fixed.Fixed b) + in Fixed.MkFixed (unFixed x * outputRes `div` inputRes) + +picoToSecondsAndMicroseconds :: Fixed.Pico -> (Integer, Integer) +picoToSecondsAndMicroseconds picos = + let (seconds, rest) = properFraction picos + micros = scaleFixed rest :: Fixed.Micro + in (seconds, unFixed micros) + +picoFromSecondsAndMicroseconds :: Integer -> Fixed.Micro -> Fixed.Pico +picoFromSecondsAndMicroseconds seconds micro = + scaleFixed $ fromInteger seconds + micro + +withRow :: Ptr MYSQL_STMT -> [MYSQL_BIND] -> ([Maybe Value] -> IO a) -> IO a +withRow mysqlStmt binds k = do + res <- mysql_stmt_fetch mysqlStmt + if res == 0 then do + vals <- traverse toValue binds + k vals + else + k [] + +withRows :: Ptr MYSQL_STMT -> [MYSQL_BIND] -> ([[Maybe Value]] -> IO a) -> IO a +withRows mysqlStmt binds k = do + withRow mysqlStmt binds $ \row -> + if Prelude.null row then + k [] + else + withRows mysqlStmt binds $ \rows -> + k $ row : rows + +fetchResults :: Statement -> IO [[Maybe Value]] +fetchResults statement = + withStatement statement $ \mysqlStmt -> do + fields <- fetchFieldMetadata mysqlStmt + withBoundResultFields mysqlStmt fields $ \binds -> + withRows mysqlStmt binds pure diff --git a/mysql.cabal b/mysql.cabal index 4a574e7..a126cb2 100644 --- a/mysql.cabal +++ b/mysql.cabal @@ -44,12 +44,15 @@ library exposed-modules: Database.MySQL.Base + Database.MySQL.PreparedStatement Database.MySQL.Base.C Database.MySQL.Base.Types build-depends: base < 5, bytestring >= 0.9 && < 1.0, + text, + time, containers if !impl(ghc >= 8.0) build-depends: @@ -73,6 +76,7 @@ test-suite test build-depends: base >= 4 && < 5 , bytestring , hspec + , time , mysql source-repository head diff --git a/test/main.hs b/test/main.hs index 1f5304b..b734f80 100644 --- a/test/main.hs +++ b/test/main.hs @@ -1,18 +1,28 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} -import Control.Exception (bracket) -import Database.MySQL.Base (ConnectInfo (..), defaultConnectInfo, Option (..), - connect, close, - query, useResult, fetchRow) -import Test.Hspec +import Control.Exception (bracket) +import Data.Time.Calendar (fromGregorian) +import Data.Time.LocalTime (LocalTime (..), + TimeOfDay (..)) +import Database.MySQL.Base (ConnectInfo (..), + Option (..), bindParams, + close, connect, + defaultConnectInfo, execute, + fetchRow, freeResult, + initLibrary, initThread, + prepare, query, storeResult) +import Database.MySQL.PreparedStatement (Value (..), fetchResults) +import Test.Hspec -- This is how to connect to our test database -- Options with bytestring values are given to partially test #17 and #23 testConn :: ConnectInfo testConn = defaultConnectInfo { connectHost = "127.0.0.1", - connectUser = "test", - connectDatabase = "test", + connectPort = 33306, + connectUser = "travis", + connectPassword = "esqutest", + connectDatabase = "esqutest", connectOptions = [ InitCommand "SET SESSION sql_mode = 'STRICT_ALL_TABLES';" , ReadDefaultGroup "client" @@ -28,6 +38,28 @@ main = bracket (connect testConn) close $ \conn -> hspec $ do describe "Database" $ do it "seems to be connected" $ do query conn "select 1 + 1" - result <- useResult conn + result <- storeResult conn row <- fetchRow result row `shouldBe` [Just "2"] + + it "supports prepared statements" $ do + stmt <- prepare conn "select 1 where ? = 1" + bindParams stmt [Long 1] + execute stmt + rows <- fetchResults stmt + rows `shouldBe` [[Just $ LongLong 1]] + + it "supports prepared statements executing multiple times" $ do + stmt <- prepare conn "select 1 where ? = 1" + + bindParams stmt [Long 2] + execute stmt + rows <- fetchResults stmt + rows `shouldBe` [] + + bindParams stmt [Long 1] + execute stmt + rows' <- fetchResults stmt + rows' `shouldBe` [[Just $ LongLong 1]] + +