diff --git a/Database/SQLite3.hs b/Database/SQLite3.hs --- a/Database/SQLite3.hs +++ b/Database/SQLite3.hs @@ -58,6 +58,29 @@ lastInsertRowId, changes, + -- * Create custom SQL functions + createFunction, + createAggregate, + deleteFunction, + -- ** Extract function arguments + funcArgCount, + funcArgType, + funcArgInt64, + funcArgDouble, + funcArgText, + funcArgBlob, + -- ** Set the result of a function + funcResultSQLData, + funcResultInt64, + funcResultDouble, + funcResultText, + funcResultBlob, + funcResultNull, + + -- * Create custom collations + createCollation, + deleteCollation, + -- * Interrupting a long-running query interrupt, interruptibly, @@ -68,6 +91,8 @@ SQLData(..), SQLError(..), ColumnType(..), + FuncContext, + FuncArgs, -- ** Results and errors StepResult(..), @@ -77,6 +102,8 @@ ParamIndex(..), ColumnIndex(..), ColumnCount, + ArgCount(..), + ArgIndex, ) where import Database.SQLite3.Direct @@ -89,6 +116,10 @@ , ColumnIndex(..) , ColumnCount , Utf8(..) + , FuncContext + , FuncArgs + , ArgCount(..) + , ArgIndex -- Re-exported from Database.SQLite3.Direct without modification. -- Note that if this module were in another package, source links would not @@ -100,6 +131,15 @@ , columnBlob , columnInt64 , columnDouble + , funcArgCount + , funcArgType + , funcArgInt64 + , funcArgDouble + , funcArgBlob + , funcResultInt64 + , funcResultDouble + , funcResultBlob + , funcResultNull , lastInsertRowId , changes , interrupt @@ -488,8 +528,11 @@ -- if an unknown name is used. -- -- Example: --- >> stmt <- prepare conn "SELECT :foo + :bar" --- >> bindNamed stmt [(":foo", SQLInteger 1), (":bar", SQLInteger 2)] +-- +-- @ +-- stmt <- prepare conn \"SELECT :foo + :bar\" +-- bindNamed stmt [(\":foo\", SQLInteger 1), (\":bar\", SQLInteger 2)] +-- @ bindNamed :: Statement -> [(T.Text, SQLData)] -> IO () bindNamed statement params = do ParamIndex nParams <- bindParameterCount statement @@ -544,3 +587,85 @@ f idx theType = case theType of Nothing -> column statement idx Just t -> typedColumn t statement idx + + +-- | +-- +-- Create a custom SQL function or redefine the behavior of an existing +-- function. If the function is deterministic, i.e. if it always returns the +-- same result given the same input, you can set the boolean flag to let +-- @sqlite@ perform additional optimizations. +createFunction + :: Database + -> Text -- ^ Name of the function. + -> Maybe ArgCount -- ^ Number of arguments. 'Nothing' means that the + -- function accepts any number of arguments. + -> Bool -- ^ Is the function deterministic? + -> (FuncContext -> FuncArgs -> IO ()) + -- ^ Implementation of the function. + -> IO () +createFunction db name nArgs isDet fun = + Direct.createFunction db (toUtf8 name) nArgs isDet fun + >>= checkError (DetailDatabase db) ("createFunction " `appendShow` name) + +-- | Like 'createFunction' except that it creates an aggregate function. +createAggregate + :: Database + -> Text -- ^ Name of the function. + -> Maybe ArgCount -- ^ Number of arguments. + -> a -- ^ Initial aggregate state. + -> (FuncContext -> FuncArgs -> a -> IO a) + -- ^ Process one row and update the aggregate state. + -> (FuncContext -> a -> IO ()) + -- ^ Called after all rows have been processed. + -- Can be used to construct the returned value + -- from the aggregate state. + -> IO () +createAggregate db name nArgs initSt xStep xFinal = + Direct.createAggregate db (toUtf8 name) nArgs initSt xStep xFinal + >>= checkError (DetailDatabase db) ("createAggregate " `appendShow` name) + +-- | Delete an SQL function (scalar or aggregate). +deleteFunction :: Database -> Text -> Maybe ArgCount -> IO () +deleteFunction db name nArgs = + Direct.deleteFunction db (toUtf8 name) nArgs + >>= checkError (DetailDatabase db) ("deleteFunction " `appendShow` name) + +funcArgText :: FuncArgs -> ArgIndex -> IO Text +funcArgText args argIndex = + Direct.funcArgText args argIndex + >>= fromUtf8 "Database.SQLite3.funcArgText: Invalid UTF-8" + +funcResultSQLData :: FuncContext -> SQLData -> IO () +funcResultSQLData ctx datum = + case datum of + SQLInteger v -> funcResultInt64 ctx v + SQLFloat v -> funcResultDouble ctx v + SQLText v -> funcResultText ctx v + SQLBlob v -> funcResultBlob ctx v + SQLNull -> funcResultNull ctx + +funcResultText :: FuncContext -> Text -> IO () +funcResultText ctx value = + Direct.funcResultText ctx (toUtf8 value) + + +-- | +createCollation + :: Database + -> Text -- ^ Name of the collation. + -> (Text -> Text -> Ordering) -- ^ Comparison function. + -> IO () +createCollation db name cmp = + Direct.createCollation db (toUtf8 name) cmp' + >>= checkError (DetailDatabase db) ("createCollation " `appendShow` name) + where + cmp' (Utf8 s1) (Utf8 s2) = cmp (fromUtf8'' s1) (fromUtf8'' s2) + -- avoid throwing exceptions as much as possible + fromUtf8'' = decodeUtf8With lenientDecode + +-- | Delete a collation. +deleteCollation :: Database -> Text -> IO () +deleteCollation db name = + Direct.deleteCollation db (toUtf8 name) + >>= checkError (DetailDatabase db) ("deleteCollation " `appendShow` name) diff --git a/Database/SQLite3/Bindings.hs b/Database/SQLite3/Bindings.hs --- a/Database/SQLite3/Bindings.hs +++ b/Database/SQLite3/Bindings.hs @@ -56,8 +56,48 @@ c_sqlite3_changes, c_sqlite3_total_changes, + -- * Create Or Redefine SQL Functions + c_sqlite3_create_function_v2, + CFunc, + CFuncFinal, + CFuncDestroy, + mkCFunc, + mkCFuncFinal, + mkCFuncDestroy, + c_sqlite3_user_data, + c_sqlite3_context_db_handle, + c_sqlite3_aggregate_context, + + -- * Obtaining SQL Function Parameter Values + -- | + c_sqlite3_value_type, + c_sqlite3_value_bytes, + c_sqlite3_value_blob, + c_sqlite3_value_text, + c_sqlite3_value_int64, + c_sqlite3_value_double, + + -- * Setting The Result Of An SQL Function + -- | + c_sqlite3_result_null, + c_sqlite3_result_blob, + c_sqlite3_result_zeroblob, + c_sqlite3_result_text, + c_sqlite3_result_int64, + c_sqlite3_result_double, + c_sqlite3_result_value, + c_sqlite3_result_error, + + -- * Define New Collating Sequences + c_sqlite3_create_collation_v2, + CCompare, + mkCCompare, + -- * Miscellaneous c_sqlite3_free, + + -- * Extensions + c_sqlite3_enable_load_extension ) where import Database.SQLite3.Bindings.Types @@ -276,7 +316,116 @@ foreign import ccall unsafe "sqlite3_total_changes" c_sqlite3_total_changes :: Ptr CDatabase -> IO CInt +-- do not use unsafe import here, it might call back to haskell +-- via the CFuncDestroy argument +-- | +foreign import ccall "sqlite3_create_function_v2" + c_sqlite3_create_function_v2 + :: Ptr CDatabase + -> CString -- ^ Name of the function + -> CArgCount -- ^ Number of arguments + -> CInt -- ^ Preferred text encoding (also used to pass flags) + -> Ptr a -- ^ User data + -> FunPtr CFunc + -> FunPtr CFunc + -> FunPtr CFuncFinal + -> FunPtr (CFuncDestroy a) + -> IO CError +type CFunc = Ptr CContext -> CArgCount -> Ptr (Ptr CValue) -> IO () + +type CFuncFinal = Ptr CContext -> IO () + +type CFuncDestroy a = Ptr a -> IO () + +foreign import ccall "wrapper" + mkCFunc :: CFunc -> IO (FunPtr CFunc) + +foreign import ccall "wrapper" + mkCFuncFinal :: CFuncFinal -> IO (FunPtr CFuncFinal) + +foreign import ccall "wrapper" + mkCFuncDestroy :: CFuncDestroy a -> IO (FunPtr (CFuncDestroy a)) + +-- | +foreign import ccall unsafe "sqlite3_user_data" + c_sqlite3_user_data :: Ptr CContext -> IO (Ptr a) + +-- | +foreign import ccall unsafe "sqlite3_context_db_handle" + c_sqlite3_context_db_handle :: Ptr CContext -> IO (Ptr CDatabase) + +-- | +foreign import ccall unsafe "sqlite3_aggregate_context" + c_sqlite3_aggregate_context :: Ptr CContext -> CNumBytes -> IO (Ptr a) + + +foreign import ccall unsafe "sqlite3_value_type" + c_sqlite3_value_type :: Ptr CValue -> IO CColumnType + +foreign import ccall unsafe "sqlite3_value_bytes" + c_sqlite3_value_bytes :: Ptr CValue -> IO CNumBytes + +foreign import ccall unsafe "sqlite3_value_blob" + c_sqlite3_value_blob :: Ptr CValue -> IO (Ptr a) + +foreign import ccall unsafe "sqlite3_value_text" + c_sqlite3_value_text :: Ptr CValue -> IO CString + +foreign import ccall unsafe "sqlite3_value_int64" + c_sqlite3_value_int64 :: Ptr CValue -> IO Int64 + +foreign import ccall unsafe "sqlite3_value_double" + c_sqlite3_value_double :: Ptr CValue -> IO Double + + +foreign import ccall unsafe "sqlite3_result_null" + c_sqlite3_result_null :: Ptr CContext -> IO () + +foreign import ccall unsafe "sqlite3_result_blob" + c_sqlite3_result_blob :: Ptr CContext -> Ptr a -> CNumBytes -> Ptr CDestructor -> IO () + +foreign import ccall unsafe "sqlite3_result_zeroblob" + c_sqlite3_result_zeroblob :: Ptr CContext -> CNumBytes -> IO () + +foreign import ccall unsafe "sqlite3_result_text" + c_sqlite3_result_text :: Ptr CContext -> CString -> CNumBytes -> Ptr CDestructor -> IO () + +foreign import ccall unsafe "sqlite3_result_int64" + c_sqlite3_result_int64 :: Ptr CContext -> Int64 -> IO () + +foreign import ccall unsafe "sqlite3_result_double" + c_sqlite3_result_double :: Ptr CContext -> Double -> IO () + +foreign import ccall unsafe "sqlite3_result_value" + c_sqlite3_result_value :: Ptr CContext -> Ptr CValue -> IO () + +foreign import ccall unsafe "sqlite3_result_error" + c_sqlite3_result_error :: Ptr CContext -> CString -> CNumBytes -> IO () + + +-- | +foreign import ccall "sqlite3_create_collation_v2" + c_sqlite3_create_collation_v2 + :: Ptr CDatabase + -> CString -- ^ Name of the collation + -> CInt -- ^ Text encoding + -> Ptr a -- ^ User data + -> FunPtr (CCompare a) + -> FunPtr (CFuncDestroy a) + -> IO CError + +type CCompare a = Ptr a -> CNumBytes -> CString -> CNumBytes -> CString -> IO CInt + +foreign import ccall "wrapper" + mkCCompare :: CCompare a -> IO (FunPtr (CCompare a)) + + -- | foreign import ccall "sqlite3_free" c_sqlite3_free :: Ptr a -> IO () + + +-- | +foreign import ccall "sqlite3_enable_load_extension" + c_sqlite3_enable_load_extension :: Ptr CDatabase -> Bool -> IO CError diff --git a/Database/SQLite3/Bindings/Types.hsc b/Database/SQLite3/Bindings/Types.hsc --- a/Database/SQLite3/Bindings/Types.hsc +++ b/Database/SQLite3/Bindings/Types.hsc @@ -7,6 +7,8 @@ -- | CDatabase, CStatement, + CValue, + CContext, -- * Enumerations @@ -36,7 +38,14 @@ CNumBytes(..), CDestructor, c_SQLITE_TRANSIENT, + c_SQLITE_UTF8, + -- * Custom functions + ArgCount(..), + ArgIndex, + CArgCount(..), + c_SQLITE_DETERMINISTIC, + -- * Conversion to and from FFI types FFIType(..), ) where @@ -100,6 +109,16 @@ -- @CStatement@ = @sqlite3_stmt@ data CStatement +-- | +-- +-- @CValue@ = @sqlite3_value@ +data CValue + +-- | +-- +-- @CContext@ = @sqlite3_context@ +data CContext + -- | Index of a parameter in a parameterized query. -- Parameter indices start from 1. -- @@ -173,7 +192,41 @@ c_SQLITE_TRANSIENT :: Ptr CDestructor c_SQLITE_TRANSIENT = intPtrToPtr (-1) +c_SQLITE_UTF8 :: CInt +c_SQLITE_UTF8 = #{const SQLITE_UTF8} + +-- | Number of arguments of a user defined SQL function. +newtype ArgCount = ArgCount Int + deriving (Eq, Ord, Enum, Num, Real, Integral) + +-- | This just shows the underlying integer, without the data constructor. +instance Show ArgCount where + show (ArgCount n) = show n + +instance Bounded ArgCount where + minBound = ArgCount 0 + maxBound = ArgCount (#{const SQLITE_LIMIT_FUNCTION_ARG}) + +-- | Index of an argument to a custom function. Indices start from 0. +type ArgIndex = ArgCount + +newtype CArgCount = CArgCount CInt + deriving (Eq, Ord, Enum, Num, Real, Integral) + +-- | This just shows the underlying integer, without the data constructor. +instance Show CArgCount where + show (CArgCount n) = show n + +instance Bounded CArgCount where + minBound = CArgCount (-1) + maxBound = CArgCount #{const SQLITE_LIMIT_FUNCTION_ARG} + +-- | Tells SQLite3 that the defined custom SQL function is deterministic. +c_SQLITE_DETERMINISTIC :: CInt +c_SQLITE_DETERMINISTIC = #{const SQLITE_DETERMINISTIC} + + -- | newtype CError = CError CInt deriving (Eq, Show) @@ -303,3 +356,7 @@ instance FFIType ColumnType CColumnType where toFFI = encodeColumnType fromFFI = decodeColumnType + +instance FFIType ArgCount CArgCount where + toFFI (ArgCount n) = CArgCount (fromIntegral n) + fromFFI (CArgCount n) = ArgCount (fromIntegral n) diff --git a/Database/SQLite3/Direct.hs b/Database/SQLite3/Direct.hs --- a/Database/SQLite3/Direct.hs +++ b/Database/SQLite3/Direct.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- This API is a slightly lower-level version of "Database.SQLite3". Namely: -- @@ -53,11 +54,36 @@ columnText, columnBlob, + -- * control loading of extensions + setLoadExtensionEnabled, + -- * Result statistics lastInsertRowId, changes, totalChanges, + -- * Create custom SQL functions + createFunction, + createAggregate, + deleteFunction, + -- ** Extract function arguments + funcArgCount, + funcArgType, + funcArgInt64, + funcArgDouble, + funcArgText, + funcArgBlob, + -- ** Set the result of a function + funcResultInt64, + funcResultDouble, + funcResultText, + funcResultBlob, + funcResultNull, + + -- * Create custom collations + createCollation, + deleteCollation, + -- * Interrupting a long-running query interrupt, @@ -65,6 +91,8 @@ Database(..), Statement(..), ColumnType(..), + FuncContext(..), + FuncArgs(..), -- ** Results and errors StepResult(..), @@ -75,6 +103,8 @@ ParamIndex(..), ColumnIndex(..), ColumnCount, + ArgCount(..), + ArgIndex, ) where import Database.SQLite3.Bindings @@ -85,7 +115,7 @@ import qualified Data.Text.Encoding as T import Control.Applicative ((<$>)) import Control.Exception as E -import Control.Monad (join) +import Control.Monad (join, unless) import Data.ByteString (ByteString) import Data.IORef import Data.Monoid @@ -93,6 +123,7 @@ import Data.Text.Encoding.Error (lenientDecode) import Foreign import Foreign.C +import qualified System.IO.Unsafe as IOU newtype Database = Database (Ptr CDatabase) deriving (Eq, Show) @@ -167,6 +198,13 @@ ErrorDone -> Right Done err -> Left err +-- | The context in which a custom SQL function is executed. +newtype FuncContext = FuncContext (Ptr CContext) + deriving (Eq, Show) + +-- | The arguments of a custom SQL function. +data FuncArgs = FuncArgs CArgCount (Ptr (Ptr CValue)) + ------------------------------------------------------------------------ -- | @@ -494,3 +532,240 @@ totalChanges :: Database -> IO Int totalChanges (Database db) = fromIntegral <$> c_sqlite3_total_changes db + +-- We use CFuncPtrs to store the function pointers used in the implementation +-- of custom SQL functions so that sqlite can deallocate those pointers when +-- the function is deleted or overwritten +data CFuncPtrs = CFuncPtrs (FunPtr CFunc) (FunPtr CFunc) (FunPtr CFuncFinal) + +-- Deallocate the function pointers used to implement a custom function +-- This is only called by sqlite so we create one global FunPtr to pass to +-- sqlite +destroyCFuncPtrs :: FunPtr (CFuncDestroy ()) +destroyCFuncPtrs = IOU.unsafePerformIO $ mkCFuncDestroy destroy + where + destroy p = do + let p' = castPtrToStablePtr p + CFuncPtrs p1 p2 p3 <- deRefStablePtr p' + unless (p1 == nullFunPtr) $ freeHaskellFunPtr p1 + unless (p2 == nullFunPtr) $ freeHaskellFunPtr p2 + unless (p3 == nullFunPtr) $ freeHaskellFunPtr p3 + freeStablePtr p' +{-# NOINLINE destroyCFuncPtrs #-} + +-- | +-- +-- Create a custom SQL function or redefine the behavior of an existing +-- function. +createFunction + :: Database + -> Utf8 -- ^ Name of the function. + -> Maybe ArgCount -- ^ Number of arguments. 'Nothing' means that the + -- function accepts any number of arguments. + -> Bool -- ^ Is the function deterministic? + -> (FuncContext -> FuncArgs -> IO ()) + -- ^ Implementation of the function. + -> IO (Either Error ()) +createFunction (Database db) (Utf8 name) nArgs isDet fun = mask_ $ do + funPtr <- mkCFunc fun' + u <- newStablePtr $ CFuncPtrs funPtr nullFunPtr nullFunPtr + BS.useAsCString name $ \namePtr -> + toResult () <$> + c_sqlite3_create_function_v2 + db namePtr (maybeArgCount nArgs) flags (castStablePtrToPtr u) + funPtr nullFunPtr nullFunPtr destroyCFuncPtrs + where + flags = if isDet then c_SQLITE_DETERMINISTIC else 0 + fun' ctx nArgs' cvals = + catchAsResultError ctx $ + fun (FuncContext ctx) (FuncArgs nArgs' cvals) + +-- | Like 'createFunction' except that it creates an aggregate function. +createAggregate + :: Database + -> Utf8 -- ^ Name of the function. + -> Maybe ArgCount -- ^ Number of arguments. + -> a -- ^ Initial aggregate state. + -> (FuncContext -> FuncArgs -> a -> IO a) + -- ^ Process one row and update the aggregate state. + -> (FuncContext -> a -> IO ()) + -- ^ Called after all rows have been processed. + -- Can be used to construct the returned value + -- from the aggregate state. + -> IO (Either Error ()) +createAggregate (Database db) (Utf8 name) nArgs initSt xStep xFinal = mask_ $ do + stepPtr <- mkCFunc xStep' + finalPtr <- mkCFuncFinal xFinal' + u <- newStablePtr $ CFuncPtrs nullFunPtr stepPtr finalPtr + BS.useAsCString name $ \namePtr -> + toResult () <$> + c_sqlite3_create_function_v2 + db namePtr (maybeArgCount nArgs) 0 (castStablePtrToPtr u) + nullFunPtr stepPtr finalPtr destroyCFuncPtrs + where + -- we store the aggregate state in the buffer returned by + -- c_sqlite3_aggregate_context as a StablePtr pointing to an IORef that + -- contains the actual aggregate state + xStep' ctx nArgs' cvals = + catchAsResultError ctx $ do + aggCtx <- getAggregateContext ctx + aggStPtr <- peek aggCtx + aggStRef <- + if castStablePtrToPtr aggStPtr /= nullPtr then + deRefStablePtr aggStPtr + else do + aggStRef <- newIORef initSt + aggStPtr' <- newStablePtr aggStRef + poke aggCtx aggStPtr' + return aggStRef + aggSt <- readIORef aggStRef + aggSt' <- xStep (FuncContext ctx) (FuncArgs nArgs' cvals) aggSt + writeIORef aggStRef aggSt' + xFinal' ctx = do + aggCtx <- getAggregateContext ctx + aggStPtr <- peek aggCtx + if castStablePtrToPtr aggStPtr == nullPtr then + catchAsResultError ctx $ + xFinal (FuncContext ctx) initSt + else do + catchAsResultError ctx $ do + aggStRef <- deRefStablePtr aggStPtr + aggSt <- readIORef aggStRef + xFinal (FuncContext ctx) aggSt + freeStablePtr aggStPtr + getAggregateContext ctx = + c_sqlite3_aggregate_context ctx stPtrSize + stPtrSize = fromIntegral $ sizeOf (undefined :: StablePtr ()) + +-- call c_sqlite3_result_error in the event of an error +catchAsResultError :: Ptr CContext -> IO () -> IO () +catchAsResultError ctx action = catch action $ \exn -> do + let msg = show (exn :: SomeException) + withCAStringLen msg $ \(ptr, len) -> + c_sqlite3_result_error ctx ptr (fromIntegral len) + +-- | Delete an SQL function (scalar or aggregate). +deleteFunction :: Database -> Utf8 -> Maybe ArgCount -> IO (Either Error ()) +deleteFunction (Database db) (Utf8 name) nArgs = + BS.useAsCString name $ \namePtr -> + toResult () <$> + c_sqlite3_create_function_v2 + db namePtr (maybeArgCount nArgs) 0 nullPtr + nullFunPtr nullFunPtr nullFunPtr nullFunPtr + +maybeArgCount :: Maybe ArgCount -> CArgCount +maybeArgCount (Just n) = toFFI n +maybeArgCount Nothing = -1 + + +funcArgCount :: FuncArgs -> ArgCount +funcArgCount (FuncArgs nArgs _) = fromIntegral nArgs + +funcArgType :: FuncArgs -> ArgIndex -> IO ColumnType +funcArgType = + extractFuncArg NullColumn (fmap decodeColumnType . c_sqlite3_value_type) + +funcArgInt64 :: FuncArgs -> ArgIndex -> IO Int64 +funcArgInt64 = extractFuncArg 0 c_sqlite3_value_int64 + +funcArgDouble :: FuncArgs -> ArgIndex -> IO Double +funcArgDouble = extractFuncArg 0 c_sqlite3_value_double + +funcArgText :: FuncArgs -> ArgIndex -> IO Utf8 +funcArgText = extractFuncArg mempty $ \cval -> do + ptr <- c_sqlite3_value_text cval + len <- c_sqlite3_value_bytes cval + Utf8 <$> packCStringLen ptr len + +funcArgBlob :: FuncArgs -> ArgIndex -> IO ByteString +funcArgBlob = extractFuncArg mempty $ \cval -> do + ptr <- c_sqlite3_value_blob cval + len <- c_sqlite3_value_bytes cval + packCStringLen ptr len + +-- the c_sqlite3_value_* family of functions don't handle null pointers, so +-- we must use a wrapper to guarantee that a sensible value is returned if +-- we are out of bounds +extractFuncArg :: a -> (Ptr CValue -> IO a) -> FuncArgs -> ArgIndex -> IO a +extractFuncArg defVal extract (FuncArgs nArgs p) idx + | 0 <= idx && idx < fromIntegral nArgs = do + cval <- peekElemOff p (fromIntegral idx) + extract cval + | otherwise = return defVal + + +funcResultInt64 :: FuncContext -> Int64 -> IO () +funcResultInt64 (FuncContext ctx) value = + c_sqlite3_result_int64 ctx value + +funcResultDouble :: FuncContext -> Double -> IO () +funcResultDouble (FuncContext ctx) value = + c_sqlite3_result_double ctx value + +funcResultText :: FuncContext -> Utf8 -> IO () +funcResultText (FuncContext ctx) (Utf8 value) = + unsafeUseAsCStringLenNoNull value $ \ptr len -> + c_sqlite3_result_text ctx ptr len c_SQLITE_TRANSIENT + +funcResultBlob :: FuncContext -> ByteString -> IO () +funcResultBlob (FuncContext ctx) value = + unsafeUseAsCStringLenNoNull value $ \ptr len -> + c_sqlite3_result_blob ctx ptr len c_SQLITE_TRANSIENT + +funcResultNull :: FuncContext -> IO () +funcResultNull (FuncContext ctx) = + c_sqlite3_result_null ctx + + +-- Deallocate the function pointer to the comparison function used to +-- implement a custom collation +destroyCCompare :: CFuncDestroy () +destroyCCompare ptr = freeHaskellFunPtr ptr' + where + ptr' = castPtrToFunPtr ptr :: FunPtr (CCompare ()) + +-- This is called by sqlite so we create one global FunPtr to pass to sqlite +destroyCComparePtr :: FunPtr (CFuncDestroy ()) +destroyCComparePtr = IOU.unsafePerformIO $ mkCFuncDestroy destroyCCompare +{-# NOINLINE destroyCComparePtr #-} + +-- | +createCollation + :: Database + -> Utf8 -- ^ Name of the collation. + -> (Utf8 -> Utf8 -> Ordering) -- ^ Comparison function. + -> IO (Either Error ()) +createCollation (Database db) (Utf8 name) cmp = mask_ $ do + cmpPtr <- mkCCompare cmp' + let u = castFunPtrToPtr cmpPtr + BS.useAsCString name $ \namePtr -> + toResult () <$> do + r <- c_sqlite3_create_collation_v2 + db namePtr c_SQLITE_UTF8 u cmpPtr destroyCComparePtr + -- sqlite does not call the destructor for us in case of an + -- error + unless (r == CError 0) $ + destroyCCompare $ castFunPtrToPtr cmpPtr + return r + where + cmp' _ len1 ptr1 len2 ptr2 = handle exnHandler $ do + s1 <- Utf8 <$> packCStringLen ptr1 len1 + s2 <- Utf8 <$> packCStringLen ptr2 len2 + let c = cmp s1 s2 + evaluate (fromIntegral $ fromEnum c - 1) + exnHandler (_ :: SomeException) = return (-1) + +-- | Delete a collation. +deleteCollation :: Database -> Utf8 -> IO (Either Error ()) +deleteCollation (Database db) (Utf8 name) = + BS.useAsCString name $ \namePtr -> + toResult () <$> do + c_sqlite3_create_collation_v2 + db namePtr c_SQLITE_UTF8 nullPtr nullFunPtr nullFunPtr + +-- | +-- +-- Enable or disable extension loading. +setLoadExtensionEnabled :: Database -> Bool -> IO (Either Error ()) +setLoadExtensionEnabled (Database db) enabled = do + toResult () <$> c_sqlite3_enable_load_extension db enabled diff --git a/cbits/sqlite3.c b/cbits/sqlite3.c # file too large to diff: cbits/sqlite3.c diff --git a/cbits/sqlite3.h b/cbits/sqlite3.h --- a/cbits/sqlite3.h +++ b/cbits/sqlite3.h @@ -107,9 +107,9 @@ ** [sqlite3_libversion_number()], [sqlite3_sourceid()], ** [sqlite_version()] and [sqlite_source_id()]. */ -#define SQLITE_VERSION "3.8.4.1" -#define SQLITE_VERSION_NUMBER 3008004 -#define SQLITE_SOURCE_ID "2014-03-11 15:27:36 018d317b1257ce68a92908b05c9c7cf1494050d0" +#define SQLITE_VERSION "3.8.5" +#define SQLITE_VERSION_NUMBER 3008005 +#define SQLITE_SOURCE_ID "2014-06-04 14:06:34 b1ed4f2a34ba66c29b130f8d13e9092758019212" /* ** CAPI3REF: Run-Time Library Version Numbers @@ -560,7 +560,10 @@ ** file that were written at the application level might have changed ** and that adjacent bytes, even bytes within the same sector are ** guaranteed to be unchanged. The SQLITE_IOCAP_UNDELETABLE_WHEN_OPEN -** flag indicate that a file cannot be deleted when open. +** flag indicate that a file cannot be deleted when open. The +** SQLITE_IOCAP_IMMUTABLE flag indicates that the file is on +** read-only media and cannot be changed even by processes with +** elevated privileges. */ #define SQLITE_IOCAP_ATOMIC 0x00000001 #define SQLITE_IOCAP_ATOMIC512 0x00000002 @@ -575,6 +578,7 @@ #define SQLITE_IOCAP_SEQUENTIAL 0x00000400 #define SQLITE_IOCAP_UNDELETABLE_WHEN_OPEN 0x00000800 #define SQLITE_IOCAP_POWERSAFE_OVERWRITE 0x00001000 +#define SQLITE_IOCAP_IMMUTABLE 0x00002000 /* ** CAPI3REF: File Locking Levels @@ -943,6 +947,12 @@ ** on whether or not the file has been renamed, moved, or deleted since it ** was first opened. ** +**
  • [[SQLITE_FCNTL_WIN32_SET_HANDLE]] +** The [SQLITE_FCNTL_WIN32_SET_HANDLE] opcode is used for debugging. This +** opcode causes the xFileControl method to swap the file handle with the one +** pointed to by the pArg argument. This capability is used during testing +** and only needs to be supported when SQLITE_TEST is defined. +** ** */ #define SQLITE_FCNTL_LOCKSTATE 1 @@ -966,6 +976,7 @@ #define SQLITE_FCNTL_HAS_MOVED 20 #define SQLITE_FCNTL_SYNC 21 #define SQLITE_FCNTL_COMMIT_PHASETWO 22 +#define SQLITE_FCNTL_WIN32_SET_HANDLE 23 /* ** CAPI3REF: Mutex Handle @@ -2779,6 +2790,30 @@ ** ^If sqlite3_open_v2() is used and the "cache" parameter is present in ** a URI filename, its value overrides any behavior requested by setting ** SQLITE_OPEN_PRIVATECACHE or SQLITE_OPEN_SHAREDCACHE flag. +** +**
  • psow: ^The psow parameter may be "true" (or "on" or "yes" or +** "1") or "false" (or "off" or "no" or "0") to indicate that the +** [powersafe overwrite] property does or does not apply to the +** storage media on which the database file resides. ^The psow query +** parameter only works for the built-in unix and Windows VFSes. +** +**
  • nolock: ^The nolock parameter is a boolean query parameter +** which if set disables file locking in rollback journal modes. This +** is useful for accessing a database on a filesystem that does not +** support locking. Caution: Database corruption might result if two +** or more processes write to the same database and any one of those +** processes uses nolock=1. +** +**
  • immutable: ^The immutable parameter is a boolean query +** parameter that indicates that the database file is stored on +** read-only media. ^When immutable is set, SQLite assumes that the +** database file cannot be changed, even by a process with higher +** privilege, and so the database is opened read-only and all locking +** and change detection is disabled. Caution: Setting the immutable +** property on a database file that does in fact change can result +** in incorrect query results and/or [SQLITE_CORRUPT] errors. +** See also: [SQLITE_IOCAP_IMMUTABLE]. +** ** ** ** ^Specifying an unknown parameter in the query component of a URI is not an @@ -2808,8 +2843,9 @@ ** Open file "data.db" in the current directory for read-only access. ** Regardless of whether or not shared-cache mode is enabled by ** default, use a private cache. -** file:/home/fred/data.db?vfs=unix-nolock -** Open file "/home/fred/data.db". Use the special VFS "unix-nolock". +** file:/home/fred/data.db?vfs=unix-dotfile +** Open file "/home/fred/data.db". Use the special VFS "unix-dotfile" +** that uses dot-files in place of posix advisory locking. ** file:data.db?mode=readonly ** An error. "readonly" is not a valid option for the "mode" parameter. ** @@ -6123,7 +6159,8 @@ #define SQLITE_TESTCTRL_EXPLAIN_STMT 19 #define SQLITE_TESTCTRL_NEVER_CORRUPT 20 #define SQLITE_TESTCTRL_VDBE_COVERAGE 21 -#define SQLITE_TESTCTRL_LAST 21 +#define SQLITE_TESTCTRL_BYTEORDER 22 +#define SQLITE_TESTCTRL_LAST 22 /* ** CAPI3REF: SQLite Runtime Status @@ -7346,7 +7383,17 @@ #endif typedef struct sqlite3_rtree_geometry sqlite3_rtree_geometry; +typedef struct sqlite3_rtree_query_info sqlite3_rtree_query_info; +/* The double-precision datatype used by RTree depends on the +** SQLITE_RTREE_INT_ONLY compile-time option. +*/ +#ifdef SQLITE_RTREE_INT_ONLY + typedef sqlite3_int64 sqlite3_rtree_dbl; +#else + typedef double sqlite3_rtree_dbl; +#endif + /* ** Register a geometry callback named zGeom that can be used as part of an ** R-Tree geometry query as follows: @@ -7356,11 +7403,7 @@ SQLITE_API int sqlite3_rtree_geometry_callback( sqlite3 *db, const char *zGeom, -#ifdef SQLITE_RTREE_INT_ONLY - int (*xGeom)(sqlite3_rtree_geometry*, int n, sqlite3_int64 *a, int *pRes), -#else - int (*xGeom)(sqlite3_rtree_geometry*, int n, double *a, int *pRes), -#endif + int (*xGeom)(sqlite3_rtree_geometry*, int, sqlite3_rtree_dbl*,int*), void *pContext ); @@ -7372,10 +7415,59 @@ struct sqlite3_rtree_geometry { void *pContext; /* Copy of pContext passed to s_r_g_c() */ int nParam; /* Size of array aParam[] */ - double *aParam; /* Parameters passed to SQL geom function */ + sqlite3_rtree_dbl *aParam; /* Parameters passed to SQL geom function */ void *pUser; /* Callback implementation user data */ void (*xDelUser)(void *); /* Called by SQLite to clean up pUser */ }; + +/* +** Register a 2nd-generation geometry callback named zScore that can be +** used as part of an R-Tree geometry query as follows: +** +** SELECT ... FROM WHERE MATCH $zQueryFunc(... params ...) +*/ +SQLITE_API int sqlite3_rtree_query_callback( + sqlite3 *db, + const char *zQueryFunc, + int (*xQueryFunc)(sqlite3_rtree_query_info*), + void *pContext, + void (*xDestructor)(void*) +); + + +/* +** A pointer to a structure of the following type is passed as the +** argument to scored geometry callback registered using +** sqlite3_rtree_query_callback(). +** +** Note that the first 5 fields of this structure are identical to +** sqlite3_rtree_geometry. This structure is a subclass of +** sqlite3_rtree_geometry. +*/ +struct sqlite3_rtree_query_info { + void *pContext; /* pContext from when function registered */ + int nParam; /* Number of function parameters */ + sqlite3_rtree_dbl *aParam; /* value of function parameters */ + void *pUser; /* callback can use this, if desired */ + void (*xDelUser)(void*); /* function to free pUser */ + sqlite3_rtree_dbl *aCoord; /* Coordinates of node or entry to check */ + unsigned int *anQueue; /* Number of pending entries in the queue */ + int nCoord; /* Number of coordinates */ + int iLevel; /* Level of current node or entry */ + int mxLevel; /* The largest iLevel value in the tree */ + sqlite3_int64 iRowid; /* Rowid for current entry */ + sqlite3_rtree_dbl rParentScore; /* Score of parent node */ + int eParentWithin; /* Visibility of parent node */ + int eWithin; /* OUT: Visiblity */ + sqlite3_rtree_dbl rScore; /* OUT: Write the score here */ +}; + +/* +** Allowed values for sqlite3_rtree_query.eWithin and .eParentWithin. +*/ +#define NOT_WITHIN 0 /* Object completely outside of query region */ +#define PARTLY_WITHIN 1 /* Object partially overlaps query region */ +#define FULLY_WITHIN 2 /* Object fully contained within query region */ #ifdef __cplusplus diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,6 +1,17 @@ +v2.3.14 + * Add custom functions, aggregates and collations. + + * Upgrade the bundled SQLite3 library to 3.8.5. + + * Add bindings for controlling whether extension loading is + enabled or disabled. + + * Bump text and bytestring versions (actually, risking it and + removing upper bounds) + v2.3.13 - * Add support for named parameters to queries. Split this changelog into - a separate file (preserving its history). + * Add support for named parameters to queries. Split this changelog into + a separate file (preserving its history). v2.3.12 * Upgrade bundled SQLite3 to 3.8.4.1. diff --git a/direct-sqlite.cabal b/direct-sqlite.cabal --- a/direct-sqlite.cabal +++ b/direct-sqlite.cabal @@ -1,12 +1,12 @@ name: direct-sqlite -version: 2.3.13 +version: 2.3.14 build-type: Simple license: BSD3 license-file: LICENSE copyright: Copyright (c) 2012, 2013 Irene Knapp author: Irene Knapp -maintainer: irene.knapp@icloud.com -homepage: http://ireneknapp.com/software/ +maintainer: Janne Hellsten +homepage: https://github.com/IreneKnapp/direct-sqlite bug-reports: https://github.com/IreneKnapp/direct-sqlite/issues/new category: Database synopsis: Low-level binding to SQLite3. Includes UTF8 and BLOB support. @@ -74,8 +74,8 @@ include-dirs: . build-depends: base >= 4.1 && < 5, - bytestring >= 0.9.2.1 && < 1, - text >= 0.11 && < 1.2 + bytestring >= 0.9.2.1, + text >= 0.11 ghc-options: -Wall -fwarn-tabs default-language: Haskell2010 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -9,6 +9,7 @@ import Data.Text (Text) import Data.Text.Encoding.Error (UnicodeException(..)) import Data.Typeable +import Data.Monoid import System.Directory import System.Exit (exitFailure) import System.IO @@ -55,6 +56,10 @@ , TestLabel "GetAutoCommit" . testGetAutoCommit , TestLabel "Debug" . testStatementSql , TestLabel "Debug" . testTracing + , TestLabel "CustomFunc" . testCustomFunction + , TestLabel "CustomFuncErr" . testCustomFunctionError + , TestLabel "CustomAggr" . testCustomAggragate + , TestLabel "CustomColl" . testCustomCollation ] ++ (if rtsSupportsBoundThreads then [ TestLabel "Interrupt" . testInterrupt @@ -718,6 +723,80 @@ withStmt conn q1 $ \stmt -> do Just (Direct.Utf8 sql1) <- Direct.statementSql stmt T.encodeUtf8 q1 @=? sql1 + +testCustomFunction :: TestEnv -> Test +testCustomFunction TestEnv{..} = TestCase $ do + withConn $ \conn -> do + createFunction conn "repeat" (Just 2) True repeatString + withStmt conn "SELECT repeat(3,'abc')" $ \stmt -> do + Row <- step stmt + [SQLText "abcabcabc"] <- columns stmt + Done <- step stmt + return () + deleteFunction conn "repeat" (Just 2) + Left SQLError{sqlError = ErrorError} <- + try $ exec conn "SELECT repeat(3,'abc')" + return () + where + repeatString ctx args = do + n <- funcArgInt64 args 0 + s <- funcArgText args 1 + funcResultText ctx $ T.concat $ replicate (fromIntegral n) s + +testCustomFunctionError :: TestEnv -> Test +testCustomFunctionError TestEnv{..} = TestCase $ do + withConn $ \conn -> do + createFunction conn "fail" (Just 0) True throwError + Left SQLError{..} <- try $ exec conn "SELECT fail()" + assertBool "Catch exception" + (sqlError == ErrorError && sqlErrorDetails == "error message") + where + throwError _ _ = error "error message" + +testCustomAggragate :: TestEnv -> Test +testCustomAggragate TestEnv{..} = TestCase $ do + withConn $ \conn -> do + exec conn "CREATE TABLE tbl (n INT)" + exec conn "INSERT INTO tbl(n) VALUES (12), (-3), (7)" + createAggregate conn "mysum" (Just 1) 0 mySumStep funcResultInt64 + withStmt conn "SELECT mysum(n) FROM tbl" $ \stmt -> do + Row <- step stmt + [SQLInteger 16] <- columns stmt + Done <- step stmt + return () + deleteFunction conn "mysum" (Just 1) + Left SQLError{sqlError = ErrorError} <- + try $ exec conn "SELECT mysum(n) FROM tbl" + return () + where + mySumStep _ args s = do + n <- funcArgInt64 args 0 + return (s + n) + +testCustomCollation :: TestEnv -> Test +testCustomCollation TestEnv{..} = TestCase $ do + withConn $ \conn -> do + exec conn "CREATE TABLE tbl (n TEXT)" + exec conn "INSERT INTO tbl(n) VALUES ('dog'),('mouse'),('ox'),('cat')" + createCollation conn "len" cmpLen + withStmt conn "SELECT * FROM tbl ORDER BY n COLLATE len" $ \stmt -> do + Row <- step stmt + [SQLText "ox"] <- columns stmt + Row <- step stmt + [SQLText "cat"] <- columns stmt + Row <- step stmt + [SQLText "dog"] <- columns stmt + Row <- step stmt + [SQLText "mouse"] <- columns stmt + Done <- step stmt + return () + deleteCollation conn "len" + Left SQLError{sqlError = ErrorError} <- + try $ exec conn "SELECT * FROM tbl ORDER BY n COLLATE len" + return () + where + -- order by length first, then by lexicographical order + cmpLen s1 s2 = compare (T.length s1) (T.length s2) <> compare s1 s2 testInterrupt :: TestEnv -> Test testInterrupt TestEnv{..} = TestCase $