persistent-sqlite 2.6.0.1 → 2.6.2
raw patch · 5 files changed
+288/−50 lines, 5 filesdep +microlens-thdep +unordered-containersdep ~persistent
Dependencies added: microlens-th, unordered-containers
Dependency ranges changed: persistent
Files
- ChangeLog.md +9/−0
- Database/Persist/Sqlite.hs +143/−38
- Database/Sqlite.hs +120/−6
- persistent-sqlite.cabal +4/−2
- test/Spec.hs +12/−4
ChangeLog.md view
@@ -1,3 +1,12 @@+## 2.6.2++* Turned on foreign key constraints [#646](https://github.com/yesodweb/persistent/issues/646)+* Added new `SqliteConnectionInfo`-based API++## 2.6.1++* Added functions to monitor (status) and control (softHeapLimit) process-wide SQLite memory usage.+ ## 2.6.0.1 * Ensure connection is closed if wrapConnectionWal fails
Database/Persist/Sqlite.hs view
@@ -4,20 +4,30 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE PatternGuards #-} -- | A sqlite backend for persistent. -- -- Note: If you prepend @WAL=off @ to your connection string, it will disable--- the write-ahead log. For more information, see--- <https://github.com/yesodweb/persistent/issues/363>.+-- the write-ahead log. This functionality is now deprecated in favour of using SqliteConnectionInfo. module Database.Persist.Sqlite ( withSqlitePool+ , withSqlitePoolInfo , withSqliteConn+ , withSqliteConnInfo , createSqlitePool+ , createSqlitePoolFromInfo , module Database.Persist.Sql , SqliteConf (..)+ , SqliteConnectionInfo+ , mkSqliteConnectionInfo+ , sqlConnectionStr+ , walEnabled+ , fkEnabled , runSqlite+ , runSqliteInfo , wrapConnection+ , wrapConnectionInfo , mockMigration ) where @@ -26,29 +36,31 @@ import qualified Database.Sqlite as Sqlite +import Control.Applicative as A+import qualified Control.Exception as E+import Control.Monad (when) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Logger (NoLoggingT, runNoLoggingT, MonadLogger)-import Data.IORef-import qualified Data.Map as Map import Control.Monad.Trans.Control (control)+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Trans.Reader (ReaderT, runReaderT)+import Control.Monad.Trans.Resource (ResourceT, runResourceT)+import Control.Monad.Trans.Writer (runWriterT) import Data.Acquire (Acquire, mkAcquire, with)-import qualified Control.Exception as E-import Data.Text (Text) import Data.Aeson import Data.Aeson.Types (modifyFailure)-import qualified Data.Text as T-import qualified Data.Text.IO as TIO import Data.Conduit import qualified Data.Conduit.List as CL-import Control.Applicative+import qualified Data.HashMap.Lazy as HashMap import Data.Int (Int64)+import Data.IORef+import qualified Data.Map as Map import Data.Monoid ((<>)) import Data.Pool (Pool)-import Control.Monad.Trans.Control (MonadBaseControl)-import Control.Monad.Trans.Resource (ResourceT, runResourceT)-import Control.Monad (when)-import Control.Monad.Trans.Reader (ReaderT, runReaderT)-import Control.Monad.Trans.Writer (runWriterT)+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Lens.Micro.TH (makeLenses) -- | Create a pool of SQLite connections. --@@ -57,8 +69,19 @@ -- Instead, use 'withSqliteConn'. createSqlitePool :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, IsSqlBackend backend) => Text -> Int -> m (Pool backend)-createSqlitePool s = createSqlPool $ open' s+createSqlitePool = createSqlitePoolFromInfo . conStringToInfo +-- | Create a pool of SQLite connections.+--+-- Note that this should not be used with the @:memory:@ connection string, as+-- the pool will regularly remove connections, destroying your database.+-- Instead, use 'withSqliteConn'.+--+-- @since 2.6.2+createSqlitePoolFromInfo :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, IsSqlBackend backend)+ => SqliteConnectionInfo -> Int -> m (Pool backend)+createSqlitePoolFromInfo connInfo = createSqlPool $ open' connInfo+ -- | Run the given action with a connection pool. -- -- Like 'createSqlitePool', this should not be used with @:memory:@.@@ -66,37 +89,50 @@ => Text -> Int -- ^ number of connections to open -> (Pool backend -> m a) -> m a-withSqlitePool s = withSqlPool $ open' s+withSqlitePool connInfo = withSqlPool . open' $ conStringToInfo connInfo +-- | Run the given action with a connection pool.+--+-- Like 'createSqlitePool', this should not be used with @:memory:@.+--+-- @since 2.6.2+withSqlitePoolInfo :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, IsSqlBackend backend)+ => SqliteConnectionInfo+ -> Int -- ^ number of connections to open+ -> (Pool backend -> m a) -> m a+withSqlitePoolInfo connInfo = withSqlPool $ open' connInfo+ withSqliteConn :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, IsSqlBackend backend) => Text -> (backend -> m a) -> m a-withSqliteConn = withSqlConn . open'+withSqliteConn = withSqliteConnInfo . conStringToInfo -open' :: (IsSqlBackend backend) => Text -> LogFunc -> IO backend-open' connStr logFunc = do- let (connStr', enableWal) = case () of- ()- | Just cs <- T.stripPrefix "WAL=on " connStr -> (cs, True)- | Just cs <- T.stripPrefix "WAL=off " connStr -> (cs, False)- | otherwise -> (connStr, True)+-- | @since 2.6.2+withSqliteConnInfo :: (MonadBaseControl IO m, MonadIO m, MonadLogger m, IsSqlBackend backend)+ => SqliteConnectionInfo -> (backend -> m a) -> m a+withSqliteConnInfo = withSqlConn . open' - conn <- Sqlite.open connStr'- wrapConnectionWal enableWal conn logFunc `E.onException` Sqlite.close conn+open' :: (IsSqlBackend backend) => SqliteConnectionInfo -> LogFunc -> IO backend+open' connInfo logFunc = do+ conn <- Sqlite.open $ _sqlConnectionStr connInfo+ wrapConnectionInfo connInfo conn logFunc `E.onException` Sqlite.close conn -- | Wrap up a raw 'Sqlite.Connection' as a Persistent SQL 'Connection'. -- -- Since 1.1.5 wrapConnection :: (IsSqlBackend backend) => Sqlite.Connection -> LogFunc -> IO backend-wrapConnection = wrapConnectionWal True+wrapConnection = wrapConnectionInfo (mkSqliteConnectionInfo "") --- | Allow control of WAL settings when wrapping-wrapConnectionWal :: (IsSqlBackend backend)- => Bool -- ^ enable WAL?+-- | Wrap up a raw 'Sqlite.Connection' as a Persistent SQL+-- 'Connection', allowing full control over WAL and FK constraints.+--+-- @since 2.6.2+wrapConnectionInfo :: (IsSqlBackend backend)+ => SqliteConnectionInfo -> Sqlite.Connection -> LogFunc -> IO backend-wrapConnectionWal enableWal conn logFunc = do- when enableWal $ do+wrapConnectionInfo connInfo conn logFunc = do+ when (_walEnabled connInfo) $ do -- Turn on the write-ahead log -- https://github.com/yesodweb/persistent/issues/363 turnOnWal <- Sqlite.prepare conn "PRAGMA journal_mode=WAL;"@@ -104,6 +140,14 @@ Sqlite.reset conn turnOnWal Sqlite.finalize turnOnWal + when (_fkEnabled connInfo) $ do+ -- Turn on foreign key constraints+ -- https://github.com/yesodweb/persistent/issues/646+ turnOnFK <- Sqlite.prepare conn "PRAGMA foreign_keys = on;"+ _ <- Sqlite.step turnOnFK+ Sqlite.reset conn turnOnFK+ Sqlite.finalize turnOnFK+ smap <- newIORef $ Map.empty return . mkPersistBackend $ SqlBackend { connPrepare = prepare' conn@@ -121,6 +165,7 @@ , connRDBMS = "sqlite" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" , connLogFunc = logFunc+ , connMaxParams = Just 999 } where helper t getter = do@@ -143,6 +188,20 @@ . withSqliteConn connstr . runSqlConn +-- | A convenience helper which creates a new database connection and runs the+-- given block, handling @MonadResource@ and @MonadLogger@ requirements. Note+-- that all log messages are discarded.+--+-- @since 2.6.2+runSqliteInfo :: (MonadBaseControl IO m, MonadIO m, IsSqlBackend backend)+ => SqliteConnectionInfo+ -> ReaderT backend (NoLoggingT (ResourceT m)) a -- ^ database action+ -> m a+runSqliteInfo conInfo = runResourceT+ . runNoLoggingT+ . withSqliteConnInfo conInfo+ . runSqlConn+ prepare' :: Sqlite.Connection -> Text -> IO Statement prepare' conn sql = do stmt <- Sqlite.prepare conn sql@@ -285,6 +344,8 @@ , connRDBMS = "sqlite" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT -1" , connLogFunc = undefined+ , connUpsertSql = undefined+ , connMaxParams = Just 999 } result = runReaderT . runWriterT . runWriterT $ mig resp <- result sqlbackend@@ -426,21 +487,31 @@ go '"' = "\"\"" go c = T.singleton c --- | Information required to connect to a sqlite database+-- | Information required to setup a connection pool. data SqliteConf = SqliteConf { sqlDatabase :: Text , sqlPoolSize :: Int+ }+ | SqliteConfInfo+ { sqlConnInfo :: SqliteConnectionInfo+ , sqlPoolSize :: Int } deriving Show instance FromJSON SqliteConf where- parseJSON v = modifyFailure ("Persistent: error loading Sqlite conf: " ++) $- flip (withObject "SqliteConf") v $ \o -> SqliteConf- <$> o .: "database"- <*> o .: "poolsize"+ parseJSON v = modifyFailure ("Persistent: error loading Sqlite conf: " ++) $ flip (withObject "SqliteConf") v parser where+ parser o = if HashMap.member "database" o+ then SqliteConf+ A.<$> o .: "database"+ A.<*> o .: "poolsize"+ else SqliteConfInfo+ A.<$> o .: "connInfo"+ A.<*> o .: "poolsize"+ instance PersistConfig SqliteConf where type PersistConfigBackend SqliteConf = SqlPersistT type PersistConfigPool SqliteConf = ConnectionPool- createPoolConfig (SqliteConf cs size) = runNoLoggingT $ createSqlitePool cs size -- FIXME+ createPoolConfig (SqliteConf cs size) = runNoLoggingT $ createSqlitePoolFromInfo (conStringToInfo cs) size -- FIXME+ createPoolConfig (SqliteConfInfo info size) = runNoLoggingT $ createSqlitePoolFromInfo info size -- FIXME runPool _ = runSqlPool loadConfig = parseJSON @@ -452,3 +523,37 @@ E.finally (runInIO a) (runInIO sequel) {-# INLINABLE finally #-}+-- | Creates a SqliteConnectionInfo from a connection string, with the+-- default settings.+--+-- @since 2.6.2+mkSqliteConnectionInfo :: Text -> SqliteConnectionInfo+mkSqliteConnectionInfo fp = SqliteConnectionInfo fp True True++-- | Parses connection options from a connection string. Used only to provide deprecated API.+conStringToInfo :: Text -> SqliteConnectionInfo+conStringToInfo connStr = SqliteConnectionInfo connStr' enableWal True where+ (connStr', enableWal) = case () of+ ()+ | Just cs <- T.stripPrefix "WAL=on " connStr -> (cs, True)+ | Just cs <- T.stripPrefix "WAL=off " connStr -> (cs, False)+ | otherwise -> (connStr, True)++-- | Information required to connect to a sqlite database. We export+-- lenses instead of fields to avoid being limited to the current+-- implementation.+--+-- @since 2.6.2+data SqliteConnectionInfo = SqliteConnectionInfo+ { _sqlConnectionStr :: Text -- ^ connection string for the database. Use @:memory:@ for an in-memory database.+ , _walEnabled :: Bool -- ^ if the write-ahead log is enabled - see https://github.com/yesodweb/persistent/issues/363.+ , _fkEnabled :: Bool -- ^ if foreign-key constraints are enabled.+ } deriving Show+makeLenses ''SqliteConnectionInfo++instance FromJSON SqliteConnectionInfo where+ parseJSON v = modifyFailure ("Persistent: error loading SqliteConnectionInfo: " ++) $+ flip (withObject "SqliteConnectionInfo") v $ \o -> SqliteConnectionInfo+ <$> o .: "connectionString"+ <*> o .: "walEnabled"+ <*> o .: "fkEnabled"
Database/Sqlite.hs view
@@ -12,6 +12,8 @@ Done), Config(ConfigLogFn), LogFunction,+ SqliteStatus (..),+ SqliteStatusVerb (..), open, close, prepare,@@ -30,7 +32,9 @@ changes, mkLogFunction, freeLogFunction,- config+ config,+ status,+ softHeapLimit ) where @@ -43,9 +47,8 @@ import Foreign import Foreign.C import Control.Exception (Exception, throwIO)-import Control.Applicative ((<$>))+import Control.Applicative as A ((<$>)) import Database.Persist (PersistValue (..), listToJSON, mapToJSON)-import Data.Bits ((.|.)) import Data.Text (Text, pack, unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)@@ -75,7 +78,7 @@ } deriving (Typeable) instance Show SqliteException where- show (SqliteException error functionName details) = unpack $ mconcat+ show (SqliteException error functionName details) = unpack $ Data.Monoid.mconcat ["SQLite3 returned " , pack $ show error , " while attempting to perform "@@ -177,7 +180,7 @@ details <- case maybeConnection of Just database -> do details <- errmsg database- return $ ": " `mappend` details+ return $ ": " `Data.Monoid.mappend` details Nothing -> return "." throwIO SqliteException { seError = error@@ -191,7 +194,7 @@ openError path' = do let flag = sqliteFlagReadWrite .|. sqliteFlagCreate .|. sqliteFlagUri BS.useAsCString (encodeUtf8 path') $ \path -> alloca $ \database -> do- err <- decodeError <$> openC path database flag nullPtr+ err <- decodeError A.<$> openC path database flag nullPtr case err of ErrorOK -> do database' <- peek database active <- newIORef True@@ -532,4 +535,115 @@ ErrorOK -> return () _ -> sqlError Nothing "sqlite3_config" e +-- | Return type of the 'status' function+--+-- Since 2.6.1+data SqliteStatus = SqliteStatus+ { sqliteStatusCurrent :: Maybe Int+ -- ^ The current value of the parameter. Some parameters do not record current value.+ , sqliteStatusHighwater :: Maybe Int+ -- ^ The highest recorded value. Some parameters do not record the highest value.+ } deriving (Eq, Show) +-- | Run-time status parameter that can be returned by 'status' function.+--+-- Since 2.6.1+data SqliteStatusVerb+ -- | This parameter is the current amount of memory checked out using sqlite3_malloc(),+ -- either directly or indirectly. The figure includes calls made to sqlite3_malloc()+ -- by the application and internal memory usage by the SQLite library. Scratch memory+ -- controlled by SQLITE_CONFIG_SCRATCH and auxiliary page-cache memory controlled by+ -- SQLITE_CONFIG_PAGECACHE is not included in this parameter. The amount returned is+ -- the sum of the allocation sizes as reported by the xSize method in sqlite3_mem_methods.+ = SqliteStatusMemoryUsed+ -- | This parameter returns the number of pages used out of the pagecache memory+ -- allocator that was configured using SQLITE_CONFIG_PAGECACHE. The value returned+ -- is in pages, not in bytes.+ | SqliteStatusPagecacheUsed+ -- | This parameter returns the number of bytes of page cache allocation which+ -- could not be satisfied by the SQLITE_CONFIG_PAGECACHE buffer and where forced+ -- to overflow to sqlite3_malloc(). The returned value includes allocations that+ -- overflowed because they where too large (they were larger than the "sz"+ -- parameter to SQLITE_CONFIG_PAGECACHE) and allocations that overflowed because+ -- no space was left in the page cache.+ | SqliteStatusPagecacheOverflow+ -- | This parameter returns the number of allocations used out of the scratch+ -- memory allocator configured using SQLITE_CONFIG_SCRATCH. The value returned+ -- is in allocations, not in bytes. Since a single thread may only have one+ -- scratch allocation outstanding at time, this parameter also reports the+ -- number of threads using scratch memory at the same time.+ | SqliteStatusScratchUsed+ -- | This parameter returns the number of bytes of scratch memory allocation+ -- which could not be satisfied by the SQLITE_CONFIG_SCRATCH buffer and where+ -- forced to overflow to sqlite3_malloc(). The values returned include overflows+ -- because the requested allocation was too larger (that is, because the requested+ -- allocation was larger than the "sz" parameter to SQLITE_CONFIG_SCRATCH) and+ -- because no scratch buffer slots were available.+ | SqliteStatusScratchOverflow+ -- | This parameter records the largest memory allocation request handed to+ -- sqlite3_malloc() or sqlite3_realloc() (or their internal equivalents). Only+ -- the value returned in 'sqliteStatusHighwater' field of 'SqliteStatus' record+ -- is of interest. The value written into the 'sqliteStatusCurrent' field is Nothing.+ | SqliteStatusMallocSize+ -- | This parameter records the largest memory allocation request handed to+ -- pagecache memory allocator. Only the value returned in the 'sqliteStatusHighwater'+ -- field of 'SqliteStatus' record is of interest. The value written into the+ -- 'sqliteStatusCurrent' field is Nothing.+ | SqliteStatusPagecacheSize+ -- | This parameter records the largest memory allocation request handed to+ -- scratch memory allocator. Only the value returned in the 'sqliteStatusHighwater'+ -- field of 'SqliteStatus' record is of interest. The value written into the+ -- 'sqliteStatusCurrent' field is Nothing.+ | SqliteStatusScratchSize+ -- | This parameter records the number of separate memory allocations currently+ -- checked out.+ | SqliteStatusMallocCount++-- Internal function to convert status parameter to a triple of its integral+-- constant and two bools indicating if native sqlite3_status function actually+-- modifies values at pCurrent and pHighwater pointers.+statusVerbInfo :: SqliteStatusVerb -> (CInt, Bool, Bool)+statusVerbInfo v = case v of+ SqliteStatusMemoryUsed -> (0, True, True)+ SqliteStatusPagecacheUsed -> (1, True, True)+ SqliteStatusPagecacheOverflow -> (2, True, True)+ SqliteStatusScratchUsed -> (3, True, True)+ SqliteStatusScratchOverflow -> (4, True, True)+ SqliteStatusMallocSize -> (5, False, True)+ SqliteStatusPagecacheSize -> (7, False, True)+ SqliteStatusScratchSize -> (8, False, True)+ SqliteStatusMallocCount -> (9, True, True)++foreign import ccall "sqlite3_status"+ statusC :: CInt -> Ptr CInt -> Ptr CInt -> CInt -> IO Int++-- | Retrieves runtime status information about the performance of SQLite,+-- and optionally resets various highwater marks. The first argument is a+-- status parameter to measure, the second is reset flag. If reset flag is+-- True then the highest recorded value is reset after being returned from+-- this function.+--+-- Since 2.6.1+status :: SqliteStatusVerb -> Bool -> IO SqliteStatus+status verb reset' = alloca $ \pCurrent -> alloca $ \pHighwater -> do+ let (code, hasCurrent, hasHighwater) = statusVerbInfo verb+ e <- decodeError <$> statusC code pCurrent pHighwater (if reset' then 1 else 0)+ case e of+ ErrorOK -> do+ current <- if hasCurrent then Just . fromIntegral <$> peek pCurrent else return Nothing+ highwater <- if hasHighwater then Just . fromIntegral <$> peek pHighwater else return Nothing+ return $ SqliteStatus current highwater+ _ -> sqlError Nothing "sqlite3_status" e++foreign import ccall "sqlite3_soft_heap_limit64"+ softHeapLimit64C :: CLLong -> IO CLLong++-- | Sets and/or queries the soft limit on the amount of heap memory that may be+-- allocated by SQLite. If the argument is zero then the soft heap limit is disabled.+-- If the argument is negative then no change is made to the soft heap limit. Hence,+-- the current size of the soft heap limit can be determined by invoking+-- this function with a negative argument.+--+-- Since 2.6.1+softHeapLimit :: Int64 -> IO Int64+softHeapLimit x = fromIntegral <$> softHeapLimit64C (CLLong x)
persistent-sqlite.cabal view
@@ -1,5 +1,5 @@ name: persistent-sqlite-version: 2.6.0.1+version: 2.6.2 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -25,17 +25,19 @@ build-depends: base >= 4.6 && < 5 , bytestring >= 0.9.1 , transformers >= 0.2.1- , persistent >= 2.6 && < 3+ , persistent >= 2.6.1 && < 3 , monad-control >= 0.2 , containers >= 0.2 , text >= 0.7 , aeson >= 0.6.2 , conduit >= 0.5.3 , monad-logger >= 0.2.4+ , microlens-th >= 0.4.1.1 , resourcet >= 1.1 , time , old-locale , resource-pool+ , unordered-containers exposed-modules: Database.Sqlite Database.Persist.Sqlite ghc-options: -Wall
test/Spec.hs view
@@ -6,6 +6,11 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}+module Main+ ( main+ -- avoid warnings+ , TestId+ ) where import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T@@ -13,9 +18,9 @@ import Database.Persist.Sqlite import Database.Persist.TH import qualified Database.Sqlite as Sqlite-import Test.Hspec import System.IO (hClose) import System.IO.Temp (withSystemTempFile)+import Test.Hspec share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| Test@@ -27,12 +32,12 @@ main :: IO () main = hspec $ do- it "issue #328" $ asIO $ runSqlite ":memory:" $ do+ it "issue #328" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do runMigration migrateAll- insert . Test $ read "2014-11-30 05:15:25.123"+ _ <- insert . Test $ read "2014-11-30 05:15:25.123" [Single x] <- rawSql "select strftime('%s%f',time) from test" [] liftIO $ x `shouldBe` Just ("141732452525.123" :: String)- it "issue #339" $ asIO $ runSqlite ":memory:" $ do+ it "issue #339" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do runMigration migrateAll now <- liftIO getCurrentTime tid <- insert $ Test now@@ -43,3 +48,6 @@ conn <- Sqlite.open (T.pack fp) Sqlite.close conn return ()+ it "issue #527" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do+ runMigration migrateAll+ insertMany_ $ replicate 1000 (Test $ read "2014-11-30 05:15:25.123")