1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE ForeignFunctionInterface #-}
3{-# LANGUAGE OverloadedStrings #-}
4-- | A port of the direct-sqlite package for dealing directly with
5-- 'PersistValue's.
6module Database.Sqlite  (
7                         Connection,
8                         Statement,
9                         Error(..),
10                         SqliteException(..),
11                         StepResult(Row, Done),
12                         Config(ConfigLogFn),
13                         LogFunction,
14                         SqliteStatus (..),
15                         SqliteStatusVerb (..),
16    -- * Basic usage guide
17    -- |
18    --
19    -- Note that the example code shown here is a low level interface
20    -- usage. Let's create a small demo sqlite3 database which we will
21    -- use in our program:
22    --
23    -- > $ sqlite3 ~/test.db
24    -- > sqlite> create table t1(a,b);
25    -- > sqlite> insert into t1(a,b) values (1,1);
26    -- > sqlite> insert into t1(a,b) values (2,2);
27    -- > sqlite> select * from t1;
28    -- > 1|1
29    -- > 2|2
30    --
31    -- Now let's write code using the functions in this module to
32    -- fetch the rows from the table:
33    --
34    -- > {-#LANGUAGE OverloadedStrings#-}
35    -- >
36    -- > import Database.Sqlite
37    -- > import Data.Text
38    -- >
39    -- > main :: IO ()
40    -- > main = do
41    -- >   conn <- open "/home/sibi/test.db"
42    -- >   smt <- prepare conn "select * from t1;"
43    -- >   row1 <- step smt >> columns smt
44    -- >   row2 <- step smt >> columns smt
45    -- >   print (row1, row2)
46    -- >   finalize smt
47    -- >   close conn
48    --
49    -- On executing the above code:
50    --
51    -- > $ ./demo-program
52    -- > $ ([PersistInt64 1,PersistInt64 1],[PersistInt64 2,PersistInt64 2])
53
54                         open,
55                         close,
56                         prepare,
57                         step,
58                         stepConn,
59                         reset,
60                         finalize,
61                         bindBlob,
62                         bindDouble,
63                         bindInt,
64                         bindInt64,
65                         bindNull,
66                         bindText,
67                         bind,
68                         column,
69                         columns,
70                         changes,
71                         mkLogFunction,
72                         freeLogFunction,
73                         config,
74                         status,
75                         softHeapLimit,
76                         enableExtendedResultCodes,
77                         disableExtendedResultCodes
78                        )
79    where
80
81import Prelude hiding (error)
82import qualified Prelude as P
83
84import Control.Exception (Exception, throwIO)
85import qualified Data.ByteString as BS
86import qualified Data.ByteString.Unsafe as BSU
87import qualified Data.ByteString.Internal as BSI
88import Data.Fixed (Pico)
89import Data.IORef (newIORef, readIORef, writeIORef)
90import Data.Monoid (mappend, mconcat)
91import Data.Text (Text, pack, unpack)
92import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
93import Data.Text.Encoding.Error (lenientDecode)
94import Data.Time (defaultTimeLocale, formatTime, UTCTime)
95import Data.Typeable (Typeable)
96import Database.Sqlite.Internal (Connection(..), Connection'(..), Statement(..))
97import Foreign
98import Foreign.C
99
100import Database.Persist (PersistValue (..), listToJSON, mapToJSON)
101
102-- | A custom exception type to make it easier to catch exceptions.
103--
104-- @since 2.1.3
105data SqliteException = SqliteException
106    { seError        :: !Error
107    , seFunctionName :: !Text
108    , seDetails      :: !Text
109    }
110    deriving (Typeable)
111instance Show SqliteException where
112    show (SqliteException error functionName details) = unpack $ Data.Monoid.mconcat
113        ["SQLite3 returned "
114        , pack $ show error
115        , " while attempting to perform "
116        , functionName
117        , details
118        ]
119instance Exception SqliteException
120
121data Error = ErrorOK
122           | ErrorError
123           | ErrorInternal
124           | ErrorPermission
125           | ErrorAbort
126           | ErrorBusy
127           | ErrorLocked
128           | ErrorNoMemory
129           | ErrorReadOnly
130           | ErrorInterrupt
131           | ErrorIO
132           | ErrorNotFound
133           | ErrorCorrupt
134           | ErrorFull
135           | ErrorCan'tOpen
136           | ErrorProtocol
137           | ErrorEmpty
138           | ErrorSchema
139           | ErrorTooBig
140           | ErrorConstraint
141           | ErrorMismatch
142           | ErrorMisuse
143           | ErrorNoLargeFileSupport
144           | ErrorAuthorization
145           | ErrorFormat
146           | ErrorRange
147           | ErrorNotAConnection
148           | ErrorRow
149           | ErrorDone
150             deriving (Eq, Show)
151
152data StepResult = Row | Done deriving (Eq, Show)
153
154data ColumnType = IntegerColumn
155                | FloatColumn
156                | TextColumn
157                | BlobColumn
158                | NullColumn
159                  deriving (Eq, Show)
160
161decodeError :: Int -> Error
162decodeError 0 = ErrorOK
163decodeError 1 = ErrorError
164decodeError 2 = ErrorInternal
165decodeError 3 = ErrorPermission
166decodeError 4 = ErrorAbort
167decodeError 5 = ErrorBusy
168decodeError 6 = ErrorLocked
169decodeError 7 = ErrorNoMemory
170decodeError 8 = ErrorReadOnly
171decodeError 9 = ErrorInterrupt
172decodeError 10 = ErrorIO
173decodeError 11 = ErrorNotFound
174decodeError 12 = ErrorCorrupt
175decodeError 13 = ErrorFull
176decodeError 14 = ErrorCan'tOpen
177decodeError 15 = ErrorProtocol
178decodeError 16 = ErrorEmpty
179decodeError 17 = ErrorSchema
180decodeError 18 = ErrorTooBig
181decodeError 19 = ErrorConstraint
182decodeError 20 = ErrorMismatch
183decodeError 21 = ErrorMisuse
184decodeError 22 = ErrorNoLargeFileSupport
185decodeError 23 = ErrorAuthorization
186decodeError 24 = ErrorFormat
187decodeError 25 = ErrorRange
188decodeError 26 = ErrorNotAConnection
189decodeError 100 = ErrorRow
190decodeError 101 = ErrorDone
191decodeError i = P.error $ "decodeError " ++ show i
192
193decodeColumnType :: Int -> ColumnType
194decodeColumnType 1 = IntegerColumn
195decodeColumnType 2 = FloatColumn
196decodeColumnType 3 = TextColumn
197decodeColumnType 4 = BlobColumn
198decodeColumnType 5 = NullColumn
199decodeColumnType i = P.error $ "decodeColumnType " ++ show i
200
201foreign import ccall "sqlite3_errmsg"
202  errmsgC :: Ptr () -> IO CString
203errmsg :: Connection -> IO Text
204errmsg (Connection _ (Connection' database)) = do
205  message <- errmsgC database
206  byteString <- BS.packCString message
207  return $ decodeUtf8With lenientDecode byteString
208
209sqlError :: Maybe Connection -> Text -> Error -> IO a
210sqlError maybeConnection functionName error = do
211  details <- case maybeConnection of
212               Just database -> do
213                 details <- errmsg database
214                 return $ ": " `Data.Monoid.mappend` details
215               Nothing -> return "."
216  throwIO SqliteException
217    { seError = error
218    , seFunctionName = functionName
219    , seDetails = details
220    }
221
222foreign import ccall "sqlite3_open_v2"
223  openC :: CString -> Ptr (Ptr ()) -> Int -> CString -> IO Int
224
225openError :: Text -> IO (Either Connection Error)
226openError path' = do
227    let flag = sqliteFlagReadWrite .|. sqliteFlagCreate .|. sqliteFlagUri
228    BS.useAsCString (encodeUtf8 path') $ \path -> alloca $ \database -> do
229        err <- decodeError <$> openC path database flag nullPtr
230        case err of
231            ErrorOK -> do database' <- peek database
232                          active <- newIORef True
233                          return $ Left $ Connection active $ Connection' database'
234            _ -> return $ Right err
235  where
236    -- for all sqlite flags, check out https://www.sqlite.org/c3ref/open.html
237    sqliteFlagReadWrite = 0x2
238    sqliteFlagCreate    = 0x4
239    sqliteFlagUri       = 0x40
240
241open :: Text -> IO Connection
242open path = do
243  databaseOrError <- openError path
244  case databaseOrError of
245    Left database -> return database
246    Right error -> sqlError Nothing ("open " `mappend` (pack $ show path)) error
247
248foreign import ccall "sqlite3_close"
249  closeC :: Ptr () -> IO Int
250closeError :: Connection -> IO Error
251closeError (Connection iactive (Connection' database)) = do
252  writeIORef iactive False
253  error <- closeC database
254  return $ decodeError error
255close :: Connection -> IO ()
256close database = do
257  error <- closeError database
258  case error of
259    ErrorOK -> return ()
260    _ -> sqlError (Just database) "close" error
261
262foreign import ccall "sqlite3_extended_result_codes"
263  sqlite3_extended_result_codesC :: Ptr () -> Int -> IO Int
264
265
266-- @since 2.9.2
267enableExtendedResultCodes :: Connection -> IO ()
268enableExtendedResultCodes con@(Connection _ (Connection' database)) =  do
269  error <- sqlite3_extended_result_codesC database 1
270  let err = decodeError error
271  case err of
272    ErrorOK -> return ()
273    _ -> sqlError (Just con) "enableExtendedResultCodes" err
274
275-- @since 2.9.2
276disableExtendedResultCodes :: Connection -> IO ()
277disableExtendedResultCodes con@(Connection _ (Connection' database)) =  do
278  error <- sqlite3_extended_result_codesC database 0
279  let err = decodeError error
280  case err of
281    ErrorOK -> return ()
282    _ -> sqlError (Just con) "disableExtendedResultCodes" err
283
284foreign import ccall "sqlite3_prepare_v2"
285  prepareC :: Ptr () -> CString -> Int -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> IO Int
286prepareError :: Connection -> Text -> IO (Either Statement Error)
287prepareError (Connection _ (Connection' database)) text' = do
288  BS.useAsCString (encodeUtf8 text')
289                  (\text -> do
290                     alloca (\statement -> do
291                               error' <- prepareC database text (-1) statement nullPtr
292                               error <- return $ decodeError error'
293                               case error of
294                                 ErrorOK -> do
295                                            statement' <- peek statement
296                                            return $ Left $ Statement statement'
297                                 _ -> return $ Right error))
298prepare :: Connection -> Text -> IO Statement
299prepare database text = do
300  statementOrError <- prepareError database text
301  case statementOrError of
302    Left statement -> return statement
303    Right error -> sqlError (Just database) ("prepare " `mappend` (pack $ show text)) error
304
305foreign import ccall "sqlite3_step"
306  stepC :: Ptr () -> IO Int
307stepError :: Statement -> IO Error
308stepError (Statement statement) = do
309  error <- stepC statement
310  return $ decodeError error
311
312-- | Execute a database statement. It's recommended to use 'stepConn' instead, because it gives better error messages.
313step :: Statement -> IO StepResult
314step statement = do
315  error <- stepError statement
316  case error of
317    ErrorRow -> return Row
318    ErrorDone -> return Done
319    _ -> sqlError Nothing "step" error
320
321-- | Execute a database statement. This function uses the 'Connection' passed to it to give better error messages than 'step'.
322--
323-- @since 2.6.4
324stepConn :: Connection -> Statement -> IO StepResult
325stepConn database statement = do
326  error <- stepError statement
327  case error of
328    ErrorRow -> return Row
329    ErrorDone -> return Done
330    _ -> sqlError (Just database) "step" error
331
332foreign import ccall "sqlite3_reset"
333  resetC :: Ptr () -> IO Int
334resetError :: Statement -> IO Error
335resetError (Statement statement) = do
336  error <- resetC statement
337  return $ decodeError error
338reset :: Connection -> Statement -> IO ()
339reset (Connection iactive _) statement = do
340  active <- readIORef iactive
341  if active
342      then do
343          error <- resetError statement
344          case error of
345            ErrorOK -> return ()
346            _ -> return () -- FIXME confirm this is correct sqlError Nothing "reset" error
347      else return ()
348
349foreign import ccall "sqlite3_finalize"
350  finalizeC :: Ptr () -> IO Int
351finalizeError :: Statement -> IO Error
352finalizeError (Statement statement) = do
353  error <- finalizeC statement
354  return $ decodeError error
355finalize :: Statement -> IO ()
356finalize statement = do
357  error <- finalizeError statement
358  case error of
359    ErrorOK -> return ()
360    _ -> return () -- sqlError Nothing "finalize" error
361
362-- Taken from: https://github.com/IreneKnapp/direct-sqlite/blob/master/Database/SQLite3/Direct.hs
363-- | Like 'unsafeUseAsCStringLen', but if the string is empty,
364-- never pass the callback a null pointer.
365unsafeUseAsCStringLenNoNull
366    :: BS.ByteString
367    -> (CString -> Int -> IO a)
368    -> IO a
369unsafeUseAsCStringLenNoNull bs cb
370    | BS.null bs = cb (intPtrToPtr 1) 0
371    | otherwise = BSU.unsafeUseAsCStringLen bs $ \(ptr, len) ->
372        cb ptr (fromIntegral len)
373
374foreign import ccall "sqlite3_bind_blob"
375  bindBlobC :: Ptr () -> Int -> Ptr () -> Int -> Ptr () -> IO Int
376bindBlobError :: Statement -> Int -> BS.ByteString -> IO Error
377bindBlobError (Statement statement) parameterIndex byteString =
378  unsafeUseAsCStringLenNoNull byteString $ \dataC size -> do
379    error <- bindBlobC statement parameterIndex (castPtr dataC) size
380                                        (intPtrToPtr (-1))
381    return $ decodeError error
382bindBlob :: Statement -> Int -> BS.ByteString -> IO ()
383bindBlob statement parameterIndex byteString = do
384  error <- bindBlobError statement parameterIndex byteString
385  case error of
386    ErrorOK -> return ()
387    _ -> sqlError Nothing "bind blob" error
388
389foreign import ccall "sqlite3_bind_double"
390  bindDoubleC :: Ptr () -> Int -> Double -> IO Int
391bindDoubleError :: Statement -> Int -> Double -> IO Error
392bindDoubleError (Statement statement) parameterIndex datum = do
393  error <- bindDoubleC statement parameterIndex datum
394  return $ decodeError error
395bindDouble :: Statement -> Int -> Double -> IO ()
396bindDouble statement parameterIndex datum = do
397  error <- bindDoubleError statement parameterIndex datum
398  case error of
399    ErrorOK -> return ()
400    _ -> sqlError Nothing "bind double" error
401
402foreign import ccall "sqlite3_bind_int"
403  bindIntC :: Ptr () -> Int -> Int -> IO Int
404bindIntError :: Statement -> Int -> Int -> IO Error
405bindIntError (Statement statement) parameterIndex datum = do
406  error <- bindIntC statement parameterIndex datum
407  return $ decodeError error
408bindInt :: Statement -> Int -> Int -> IO ()
409bindInt statement parameterIndex datum = do
410  error <- bindIntError statement parameterIndex datum
411  case error of
412    ErrorOK -> return ()
413    _ -> sqlError Nothing "bind int" error
414
415foreign import ccall "sqlite3_bind_int64"
416  bindInt64C :: Ptr () -> Int -> Int64 -> IO Int
417bindInt64Error :: Statement -> Int -> Int64 -> IO Error
418bindInt64Error (Statement statement) parameterIndex datum = do
419  error <- bindInt64C statement parameterIndex datum
420  return $ decodeError error
421bindInt64 :: Statement -> Int -> Int64 -> IO ()
422bindInt64 statement parameterIndex datum = do
423  error <- bindInt64Error statement parameterIndex datum
424  case error of
425    ErrorOK -> return ()
426    _ -> sqlError Nothing "bind int64" error
427
428foreign import ccall "sqlite3_bind_null"
429  bindNullC :: Ptr () -> Int -> IO Int
430bindNullError :: Statement -> Int -> IO Error
431bindNullError (Statement statement) parameterIndex = do
432  error <- bindNullC statement parameterIndex
433  return $ decodeError error
434bindNull :: Statement -> Int -> IO ()
435bindNull statement parameterIndex = do
436  error <- bindNullError statement parameterIndex
437  case error of
438    ErrorOK -> return ()
439    _ -> sqlError Nothing "bind null" error
440
441foreign import ccall "sqlite3_bind_text"
442  bindTextC :: Ptr () -> Int -> CString -> Int -> Ptr () -> IO Int
443bindTextError :: Statement -> Int -> Text -> IO Error
444bindTextError (Statement statement) parameterIndex text =
445  unsafeUseAsCStringLenNoNull (encodeUtf8 text) $ \dataC size -> do
446    error <- bindTextC statement parameterIndex dataC size (intPtrToPtr (-1))
447    return $ decodeError error
448bindText :: Statement -> Int -> Text -> IO ()
449bindText statement parameterIndex text = do
450  error <- bindTextError statement parameterIndex text
451  case error of
452    ErrorOK -> return ()
453    _ -> sqlError Nothing "bind text" error
454
455bind :: Statement -> [PersistValue] -> IO ()
456bind statement sqlData = do
457  mapM_ (\(parameterIndex, datum) -> do
458          case datum of
459            PersistInt64 int64 -> bindInt64 statement parameterIndex int64
460            PersistDouble double -> bindDouble statement parameterIndex double
461            PersistRational rational -> bindText statement parameterIndex $ pack $ show (fromRational rational :: Pico)
462            PersistBool b -> bindInt64 statement parameterIndex $
463                                if b then 1 else 0
464            PersistText text -> bindText statement parameterIndex text
465            PersistByteString blob -> bindBlob statement parameterIndex blob
466            PersistNull -> bindNull statement parameterIndex
467            PersistDay d -> bindText statement parameterIndex $ pack $ show d
468            PersistTimeOfDay d -> bindText statement parameterIndex $ pack $ show d
469            PersistUTCTime d -> bindText statement parameterIndex $ pack $ format8601 d
470            PersistList l -> bindText statement parameterIndex $ listToJSON l
471            PersistMap m -> bindText statement parameterIndex $ mapToJSON m
472            PersistDbSpecific s -> bindText statement parameterIndex $ decodeUtf8With lenientDecode s
473            PersistArray a -> bindText statement parameterIndex $ listToJSON a -- copy of PersistList's definition
474            PersistObjectId _ -> P.error "Refusing to serialize a PersistObjectId to a SQLite value"
475            )
476       $ zip [1..] sqlData
477  return ()
478
479format8601 :: UTCTime -> String
480format8601 = formatTime defaultTimeLocale "%FT%T%Q"
481
482foreign import ccall "sqlite3_column_type"
483  columnTypeC :: Ptr () -> Int -> IO Int
484columnType :: Statement -> Int -> IO ColumnType
485columnType (Statement statement) columnIndex = do
486  result <- columnTypeC statement columnIndex
487  return $ decodeColumnType result
488
489foreign import ccall "sqlite3_column_bytes"
490  columnBytesC :: Ptr () -> Int -> IO Int
491
492foreign import ccall "sqlite3_column_blob"
493  columnBlobC :: Ptr () -> Int -> IO (Ptr ())
494columnBlob :: Statement -> Int -> IO BS.ByteString
495columnBlob (Statement statement) columnIndex = do
496  size <- columnBytesC statement columnIndex
497  BSI.create size (\resultPtr -> do
498                     dataPtr <- columnBlobC statement columnIndex
499                     if dataPtr /= nullPtr
500                        then BSI.memcpy resultPtr (castPtr dataPtr) (fromIntegral size)
501                        else return ())
502
503foreign import ccall "sqlite3_column_int64"
504  columnInt64C :: Ptr () -> Int -> IO Int64
505columnInt64 :: Statement -> Int -> IO Int64
506columnInt64 (Statement statement) columnIndex = do
507  columnInt64C statement columnIndex
508
509foreign import ccall "sqlite3_column_double"
510  columnDoubleC :: Ptr () -> Int -> IO Double
511columnDouble :: Statement -> Int -> IO Double
512columnDouble (Statement statement) columnIndex = do
513  columnDoubleC statement columnIndex
514
515foreign import ccall "sqlite3_column_text"
516  columnTextC :: Ptr () -> Int -> IO CString
517columnText :: Statement -> Int -> IO Text
518columnText (Statement statement) columnIndex = do
519  text <- columnTextC statement columnIndex
520  len <- columnBytesC statement columnIndex
521  byteString <- BS.packCStringLen (text, len)
522  return $ decodeUtf8With lenientDecode byteString
523
524foreign import ccall "sqlite3_column_count"
525  columnCountC :: Ptr () -> IO Int
526columnCount :: Statement -> IO Int
527columnCount (Statement statement) = do
528  columnCountC statement
529
530column :: Statement -> Int -> IO PersistValue
531column statement columnIndex = do
532  theType <- columnType statement columnIndex
533  case theType of
534    IntegerColumn -> do
535                 int64 <- columnInt64 statement columnIndex
536                 return $ PersistInt64 int64
537    FloatColumn -> do
538                 double <- columnDouble statement columnIndex
539                 return $ PersistDouble double
540    TextColumn -> do
541                 text <- columnText statement columnIndex
542                 return $ PersistText text
543    BlobColumn -> do
544                 byteString <- columnBlob statement columnIndex
545                 return $ PersistByteString byteString
546    NullColumn -> return PersistNull
547
548columns :: Statement -> IO [PersistValue]
549columns statement = do
550  count <- columnCount statement
551  mapM (\i -> column statement i) [0..count-1]
552
553foreign import ccall "sqlite3_changes"
554  changesC :: Connection' -> IO Int
555
556changes :: Connection -> IO Int64
557changes (Connection _ c) = fmap fromIntegral $ changesC c
558
559-- | Log function callback. Arguments are error code and log message.
560--
561-- @since 2.1.4
562type RawLogFunction = Ptr () -> Int -> CString -> IO ()
563
564foreign import ccall "wrapper"
565  mkRawLogFunction :: RawLogFunction -> IO (FunPtr RawLogFunction)
566
567-- |
568-- @since 2.1.4
569newtype LogFunction = LogFunction (FunPtr RawLogFunction)
570
571-- | Wraps a given function to a 'LogFunction' to be further used with 'ConfigLogFn'.
572-- First argument of given function will take error code, second - log message.
573-- Returned value should be released with 'freeLogFunction' when no longer required.
574mkLogFunction :: (Int -> String -> IO ()) -> IO LogFunction
575mkLogFunction fn = fmap LogFunction . mkRawLogFunction $ \_ errCode cmsg -> do
576  msg <- peekCString cmsg
577  fn errCode msg
578
579-- | Releases a native FunPtr for the 'LogFunction'.
580--
581-- @since 2.1.4
582freeLogFunction :: LogFunction -> IO ()
583freeLogFunction (LogFunction fn) = freeHaskellFunPtr fn
584
585-- | Configuration option for SQLite to be used together with the 'config' function.
586--
587-- @since 2.1.4
588data Config
589  -- | A function to be used for logging
590  = ConfigLogFn LogFunction
591
592foreign import ccall "persistent_sqlite_set_log"
593  set_logC :: FunPtr RawLogFunction -> Ptr () -> IO Int
594
595-- | Sets SQLite global configuration parameter. See SQLite documentation for the <https://www.sqlite.org/c3ref/config.html sqlite3_config> function.
596-- In short, this must be called prior to any other SQLite function if you want the call to succeed.
597--
598-- @since 2.1.4
599config :: Config -> IO ()
600config c = case c of
601  ConfigLogFn (LogFunction rawLogFn) -> do
602    e <- fmap decodeError $ set_logC rawLogFn nullPtr
603    case e of
604      ErrorOK -> return ()
605      _ -> sqlError Nothing "sqlite3_config" e
606
607-- | Return type of the 'status' function
608--
609-- @since 2.6.1
610data SqliteStatus = SqliteStatus
611  { sqliteStatusCurrent   :: Maybe Int
612  -- ^ The current value of the parameter. Some parameters do not record current value.
613  , sqliteStatusHighwater :: Maybe Int
614  -- ^ The highest recorded value. Some parameters do not record the highest value.
615  } deriving (Eq, Show)
616
617-- | Run-time status parameter that can be returned by 'status' function.
618--
619-- @since 2.6.1
620data SqliteStatusVerb
621  -- | This parameter is the current amount of memory checked out using sqlite3_malloc(),
622  -- either directly or indirectly. The figure includes calls made to sqlite3_malloc()
623  -- by the application and internal memory usage by the SQLite library. Scratch memory
624  -- controlled by SQLITE_CONFIG_SCRATCH and auxiliary page-cache memory controlled by
625  -- SQLITE_CONFIG_PAGECACHE is not included in this parameter. The amount returned is
626  -- the sum of the allocation sizes as reported by the xSize method in sqlite3_mem_methods.
627  = SqliteStatusMemoryUsed
628  -- | This parameter returns the number of pages used out of the pagecache memory
629  -- allocator that was configured using SQLITE_CONFIG_PAGECACHE. The value returned
630  -- is in pages, not in bytes.
631  | SqliteStatusPagecacheUsed
632  -- | This parameter returns the number of bytes of page cache allocation which
633  -- could not be satisfied by the SQLITE_CONFIG_PAGECACHE buffer and where forced
634  -- to overflow to sqlite3_malloc(). The returned value includes allocations that
635  -- overflowed because they where too large (they were larger than the "sz"
636  -- parameter to SQLITE_CONFIG_PAGECACHE) and allocations that overflowed because
637  -- no space was left in the page cache.
638  | SqliteStatusPagecacheOverflow
639  -- | This parameter returns the number of allocations used out of the scratch
640  -- memory allocator configured using SQLITE_CONFIG_SCRATCH. The value returned
641  -- is in allocations, not in bytes. Since a single thread may only have one
642  -- scratch allocation outstanding at time, this parameter also reports the
643  -- number of threads using scratch memory at the same time.
644  | SqliteStatusScratchUsed
645  -- | This parameter returns the number of bytes of scratch memory allocation
646  -- which could not be satisfied by the SQLITE_CONFIG_SCRATCH buffer and where
647  -- forced to overflow to sqlite3_malloc(). The values returned include overflows
648  -- because the requested allocation was too larger (that is, because the requested
649  -- allocation was larger than the "sz" parameter to SQLITE_CONFIG_SCRATCH) and
650  -- because no scratch buffer slots were available.
651  | SqliteStatusScratchOverflow
652  -- | This parameter records the largest memory allocation request handed to
653  -- sqlite3_malloc() or sqlite3_realloc() (or their internal equivalents). Only
654  -- the value returned in 'sqliteStatusHighwater' field of 'SqliteStatus' record
655  -- is of interest. The value written into the 'sqliteStatusCurrent' field is Nothing.
656  | SqliteStatusMallocSize
657  -- | This parameter records the largest memory allocation request handed to
658  -- pagecache memory allocator. Only the value returned in the 'sqliteStatusHighwater'
659  -- field of 'SqliteStatus' record is of interest. The value written into the
660  -- 'sqliteStatusCurrent' field is Nothing.
661  | SqliteStatusPagecacheSize
662  -- | This parameter records the largest memory allocation request handed to
663  -- scratch memory allocator. Only the value returned in the 'sqliteStatusHighwater'
664  -- field of 'SqliteStatus' record is of interest. The value written into the
665  -- 'sqliteStatusCurrent' field is Nothing.
666  | SqliteStatusScratchSize
667  -- | This parameter records the number of separate memory allocations currently
668  -- checked out.
669  | SqliteStatusMallocCount
670
671-- Internal function to convert status parameter to a triple of its integral
672-- constant and two bools indicating if native sqlite3_status function actually
673-- modifies values at pCurrent and pHighwater pointers.
674statusVerbInfo :: SqliteStatusVerb -> (CInt, Bool, Bool)
675statusVerbInfo v = case v of
676  SqliteStatusMemoryUsed -> (0, True, True)
677  SqliteStatusPagecacheUsed -> (1, True, True)
678  SqliteStatusPagecacheOverflow -> (2, True, True)
679  SqliteStatusScratchUsed -> (3, True, True)
680  SqliteStatusScratchOverflow -> (4, True, True)
681  SqliteStatusMallocSize -> (5, False, True)
682  SqliteStatusPagecacheSize -> (7, False, True)
683  SqliteStatusScratchSize -> (8, False, True)
684  SqliteStatusMallocCount -> (9, True, True)
685
686foreign import ccall "sqlite3_status"
687  statusC :: CInt -> Ptr CInt -> Ptr CInt -> CInt -> IO Int
688
689-- | Retrieves runtime status information about the performance of SQLite,
690-- and optionally resets various highwater marks. The first argument is a
691-- status parameter to measure, the second is reset flag. If reset flag is
692-- True then the highest recorded value is reset after being returned from
693-- this function.
694--
695-- @since 2.6.1
696status :: SqliteStatusVerb -> Bool -> IO SqliteStatus
697status verb reset' = alloca $ \pCurrent -> alloca $ \pHighwater -> do
698  let (code, hasCurrent, hasHighwater) = statusVerbInfo verb
699  e <- decodeError <$> statusC code pCurrent pHighwater (if reset' then 1 else 0)
700  case e of
701    ErrorOK -> do
702      current <- if hasCurrent then Just . fromIntegral <$> peek pCurrent else return Nothing
703      highwater <- if hasHighwater then Just . fromIntegral <$> peek pHighwater else return Nothing
704      return $ SqliteStatus current highwater
705    _ -> sqlError Nothing "sqlite3_status" e
706
707foreign import ccall "sqlite3_soft_heap_limit64"
708  softHeapLimit64C :: CLLong -> IO CLLong
709
710-- | Sets and/or queries the soft limit on the amount of heap memory that may be
711-- allocated by SQLite. If the argument is zero then the soft heap limit is disabled.
712-- If the argument is negative then no change is made to the soft heap limit. Hence,
713-- the current size of the soft heap limit can be determined by invoking
714-- this function with a negative argument.
715--
716-- @since 2.6.1
717softHeapLimit :: Int64 -> IO Int64
718softHeapLimit x = fromIntegral <$> softHeapLimit64C (CLLong x)
719