persistent-sqlite 2.9.3 → 2.10.0
raw patch · 8 files changed
+442/−155 lines, 8 filesdep +HUnitdep +QuickCheckdep +exceptionsdep −old-localedep ~aesondep ~basedep ~bytestringnew-uploader
Dependencies added: HUnit, QuickCheck, exceptions, fast-logger, persistent-test, system-fileio, system-filepath
Dependencies removed: old-locale
Dependency ranges changed: aeson, base, bytestring, conduit, containers, hspec, monad-logger, persistent, resourcet, text, transformers
Files
- ChangeLog.md +4/−0
- Database/Persist/Sqlite.hs +48/−49
- Database/Sqlite.hs +17/−22
- persistent-sqlite.cabal +49/−30
- test/Spec.hs +0/−53
- test/SqliteInit.hs +104/−0
- test/main.hs +218/−0
- test/sanity.hs +2/−1
ChangeLog.md view
@@ -1,5 +1,9 @@ # Changelog for persistent-sqlite +## 2.10.0++* Updated for `persistent-2.10.0` compatibility.+ ## 2.9.3 * Add retry-on-busy support, automatically retrying when sqlite returns a busy
Database/Persist/Sqlite.hs view
@@ -1,12 +1,10 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-}-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE TypeFamilies #-} -- | A sqlite backend for persistent. -- -- Note: If you prepend @WAL=off @ to your connection string, it will disable@@ -35,20 +33,12 @@ , waitForDatabase ) where -import Database.Persist.Sql-import Database.Persist.Sql.Types.Internal (mkPersistBackend)-import qualified Database.Persist.Sql.Util as Util--import qualified Database.Sqlite as Sqlite--import Control.Applicative as A-import qualified Control.Exception as E import Control.Concurrent (threadDelay)+import qualified Control.Exception as E import Control.Monad (forM_) import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO, withUnliftIO, unliftIO, withRunInIO) import Control.Monad.Logger (NoLoggingT, runNoLoggingT, MonadLogger, logWarn, runLoggingT) import Control.Monad.Trans.Reader (ReaderT, runReaderT)-import UnliftIO.Resource (ResourceT, runResourceT) import Control.Monad.Trans.Writer (runWriterT) import Data.Acquire (Acquire, mkAcquire, with) import Data.Aeson@@ -65,14 +55,21 @@ import qualified Data.Text as T import qualified Data.Text.IO as TIO import Lens.Micro.TH (makeLenses)+import UnliftIO.Resource (ResourceT, runResourceT) +import Database.Persist.Sql+import Database.Persist.Sql.Types.Internal (mkPersistBackend)+import qualified Database.Persist.Sql.Util as Util+import qualified Database.Sqlite as Sqlite++ -- | 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'.-createSqlitePool :: (MonadLogger m, MonadUnliftIO m, IsSqlBackend backend)- => Text -> Int -> m (Pool backend)+createSqlitePool :: (MonadLogger m, MonadUnliftIO m)+ => Text -> Int -> m (Pool SqlBackend) createSqlitePool = createSqlitePoolFromInfo . conStringToInfo -- | Create a pool of SQLite connections.@@ -82,17 +79,17 @@ -- Instead, use 'withSqliteConn'. -- -- @since 2.6.2-createSqlitePoolFromInfo :: (MonadLogger m, MonadUnliftIO m, IsSqlBackend backend)- => SqliteConnectionInfo -> Int -> m (Pool backend)+createSqlitePoolFromInfo :: (MonadLogger m, MonadUnliftIO m)+ => SqliteConnectionInfo -> Int -> m (Pool SqlBackend) createSqlitePoolFromInfo connInfo = createSqlPool $ open' connInfo -- | Run the given action with a connection pool. -- -- Like 'createSqlitePool', this should not be used with @:memory:@.-withSqlitePool :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend)+withSqlitePool :: (MonadUnliftIO m, MonadLogger m) => Text -> Int -- ^ number of connections to open- -> (Pool backend -> m a) -> m a+ -> (Pool SqlBackend -> m a) -> m a withSqlitePool connInfo = withSqlPool . open' $ conStringToInfo connInfo -- | Run the given action with a connection pool.@@ -100,22 +97,22 @@ -- Like 'createSqlitePool', this should not be used with @:memory:@. -- -- @since 2.6.2-withSqlitePoolInfo :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend)- => SqliteConnectionInfo- -> Int -- ^ number of connections to open- -> (Pool backend -> m a) -> m a+withSqlitePoolInfo :: (MonadUnliftIO m, MonadLogger m)+ => SqliteConnectionInfo+ -> Int -- ^ number of connections to open+ -> (Pool SqlBackend -> m a) -> m a withSqlitePoolInfo connInfo = withSqlPool $ open' connInfo -withSqliteConn :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend)- => Text -> (backend -> m a) -> m a+withSqliteConn :: (MonadUnliftIO m, MonadLogger m)+ => Text -> (SqlBackend -> m a) -> m a withSqliteConn = withSqliteConnInfo . conStringToInfo -- | @since 2.6.2-withSqliteConnInfo :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend)- => SqliteConnectionInfo -> (backend -> m a) -> m a+withSqliteConnInfo :: (MonadUnliftIO m, MonadLogger m)+ => SqliteConnectionInfo -> (SqlBackend -> m a) -> m a withSqliteConnInfo = withSqlConn . open' -open' :: (IsSqlBackend backend) => SqliteConnectionInfo -> LogFunc -> IO backend+open' :: SqliteConnectionInfo -> LogFunc -> IO SqlBackend open' connInfo logFunc = do conn <- Sqlite.open $ _sqlConnectionStr connInfo wrapConnectionInfo connInfo conn logFunc `E.onException` Sqlite.close conn@@ -132,20 +129,20 @@ -- > {-# LANGUAGE TemplateHaskell #-} -- > {-# LANGUAGE QuasiQuotes #-} -- > {-# LANGUAGE GeneralizedNewtypeDeriving #-}--- > +-- > -- > import Control.Monad.IO.Class (liftIO) -- > import Database.Persist -- > import Database.Sqlite -- > import Database.Persist.Sqlite -- > import Database.Persist.TH--- > +-- > -- > share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| -- > Person -- > name String -- > age Int Maybe -- > deriving Show -- > |]--- > +-- > -- > main :: IO () -- > main = do -- > conn <- open "/home/sibi/test.db"@@ -162,9 +159,9 @@ -- -- > Migrating: CREATE TABLE "person"("id" INTEGER PRIMARY KEY,"name" VARCHAR NOT NULL,"age" INTEGER NULL) -- > [Entity {entityKey = PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 1}}, entityVal = Person {personName = "John doe", personAge = Just 35}},Entity {entityKey = PersonKey {unPersonKey = SqlBackendKey {unSqlBackendKey = 2}}, entityVal = Person {personName = "Hema", personAge = Just 36}}]--- +-- -- @since 1.1.5-wrapConnection :: (IsSqlBackend backend) => Sqlite.Connection -> LogFunc -> IO backend+wrapConnection :: Sqlite.Connection -> LogFunc -> IO SqlBackend wrapConnection = wrapConnectionInfo (mkSqliteConnectionInfo "") -- | Retry if a Busy is thrown, following an exponential backoff strategy.@@ -195,18 +192,20 @@ -- | Wait until some noop action on the database does not return an 'Sqlite.ErrorBusy'. See 'retryOnBusy'. -- -- @since 2.9.3-waitForDatabase :: (MonadUnliftIO m, MonadLogger m, IsSqlBackend backend, BackendCompatible SqlBackend backend) => ReaderT backend m ()+waitForDatabase+ :: (MonadUnliftIO m, MonadLogger m, BackendCompatible SqlBackend backend)+ => ReaderT backend m () waitForDatabase = retryOnBusy $ rawExecute "SELECT 42" [] -- | 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+wrapConnectionInfo+ :: SqliteConnectionInfo+ -> Sqlite.Connection+ -> LogFunc+ -> IO SqlBackend wrapConnectionInfo connInfo conn logFunc = do let -- Turn on the write-ahead log@@ -233,7 +232,7 @@ Sqlite.finalize stmt smap <- newIORef $ Map.empty- return . mkPersistBackend $ SqlBackend+ return $ SqlBackend { connPrepare = prepare' conn , connStmtMap = smap , connInsertSql = insertSql'@@ -265,9 +264,9 @@ -- that all log messages are discarded. -- -- @since 1.1.4-runSqlite :: (MonadUnliftIO m, IsSqlBackend backend)+runSqlite :: (MonadUnliftIO m) => Text -- ^ connection string- -> ReaderT backend (NoLoggingT (ResourceT m)) a -- ^ database action+ -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -- ^ database action -> m a runSqlite connstr = runResourceT . runNoLoggingT@@ -279,9 +278,9 @@ -- that all log messages are discarded. -- -- @since 2.6.2-runSqliteInfo :: (MonadUnliftIO m, IsSqlBackend backend)+runSqliteInfo :: (MonadUnliftIO m) => SqliteConnectionInfo- -> ReaderT backend (NoLoggingT (ResourceT m)) a -- ^ database action+ -> ReaderT SqlBackend (NoLoggingT (ResourceT m)) a -- ^ database action -> m a runSqliteInfo conInfo = runResourceT . runNoLoggingT@@ -626,11 +625,11 @@ 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"+ <$> o .: "database"+ <*> o .: "poolsize" else SqliteConfInfo- A.<$> o .: "connInfo"- A.<*> o .: "poolsize"+ <$> o .: "connInfo"+ <*> o .: "poolsize" instance PersistConfig SqliteConf where type PersistConfigBackend SqliteConf = SqlPersistT
Database/Sqlite.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE ForeignFunctionInterface, DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-} -- | A port of the direct-sqlite package for dealing directly with -- 'PersistValue's. module Database.Sqlite (@@ -8,8 +8,7 @@ Statement, Error(..), SqliteException(..),- StepResult(Row,- Done),+ StepResult(Row, Done), Config(ConfigLogFn), LogFunction, SqliteStatus (..),@@ -81,30 +80,25 @@ import Prelude hiding (error) import qualified Prelude as P-import qualified Prelude++import Control.Exception (Exception, throwIO) import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BSU import qualified Data.ByteString.Internal as BSI-import Foreign-import Foreign.C-import Control.Exception (Exception, throwIO)-import Control.Applicative as A ((<$>))-import Database.Persist (PersistValue (..), listToJSON, mapToJSON)+import Data.Fixed (Pico)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Monoid (mappend, mconcat) import Data.Text (Text, pack, unpack) import Data.Text.Encoding (encodeUtf8, decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)-import Data.Monoid (mappend, mconcat)-import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Data.Fixed (Pico)-import Data.Time (formatTime, UTCTime)+import Data.Time (defaultTimeLocale, formatTime, UTCTime) import Data.Typeable (Typeable)+import Foreign+import Foreign.C -#if MIN_VERSION_time(1,5,0)-import Data.Time (defaultTimeLocale)-#else-import System.Locale (defaultTimeLocale)-#endif+import Database.Persist (PersistValue (..), listToJSON, mapToJSON) + data Connection = Connection !(IORef Bool) Connection' newtype Connection' = Connection' (Ptr ()) newtype Statement = Statement (Ptr ())@@ -198,7 +192,7 @@ decodeError 26 = ErrorNotAConnection decodeError 100 = ErrorRow decodeError 101 = ErrorDone-decodeError i = Prelude.error $ "decodeError " ++ show i+decodeError i = P.error $ "decodeError " ++ show i decodeColumnType :: Int -> ColumnType decodeColumnType 1 = IntegerColumn@@ -206,7 +200,7 @@ decodeColumnType 3 = TextColumn decodeColumnType 4 = BlobColumn decodeColumnType 5 = NullColumn-decodeColumnType i = Prelude.error $ "decodeColumnType " ++ show i+decodeColumnType i = P.error $ "decodeColumnType " ++ show i foreign import ccall "sqlite3_errmsg" errmsgC :: Ptr () -> IO CString@@ -236,7 +230,7 @@ openError path' = do let flag = sqliteFlagReadWrite .|. sqliteFlagCreate .|. sqliteFlagUri BS.useAsCString (encodeUtf8 path') $ \path -> alloca $ \database -> do- err <- decodeError A.<$> openC path database flag nullPtr+ err <- decodeError <$> openC path database flag nullPtr case err of ErrorOK -> do database' <- peek database active <- newIORef True@@ -480,6 +474,7 @@ PersistList l -> bindText statement parameterIndex $ listToJSON l PersistMap m -> bindText statement parameterIndex $ mapToJSON m PersistDbSpecific s -> bindText statement parameterIndex $ decodeUtf8With lenientDecode s+ PersistArray a -> bindText statement parameterIndex $ listToJSON a -- copy of PersistList's definition PersistObjectId _ -> P.error "Refusing to serialize a PersistObjectId to a SQLite value" ) $ zip [1..] sqlData
persistent-sqlite.cabal view
@@ -1,5 +1,5 @@ name: persistent-sqlite-version: 2.9.3+version: 2.10.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -8,7 +8,7 @@ description: This package includes a thin sqlite3 wrapper based on the direct-sqlite package, as well as the entire C library, so there are no system dependencies. category: Database, Yesod stability: Stable-cabal-version: >= 1.8+cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/book/persistent bug-reports: https://github.com/yesodweb/persistent/issues@@ -37,25 +37,25 @@ default: True library- build-depends: base >= 4.8 && < 5- , bytestring >= 0.9.1- , transformers >= 0.2.1+ build-depends: base >= 4.9 && < 5 , persistent >= 2.9 && < 3- , unliftio-core- , containers >= 0.2- , text >= 0.7- , aeson >= 0.6.2- , conduit >= 1.2.8- , monad-logger >= 0.2.4+ , aeson >= 1.0+ , bytestring >= 0.10+ , conduit >= 1.2.12+ , containers >= 0.5 , microlens-th >= 0.4.1.1- , resourcet >= 1.1- , time- , old-locale+ , monad-logger >= 0.3.25 , resource-pool+ , resourcet >= 1.1.9+ , text >= 1.2+ , time+ , transformers >= 0.5+ , unliftio-core , unordered-containers exposed-modules: Database.Sqlite Database.Persist.Sqlite ghc-options: -Wall+ default-language: Haskell2010 if flag(systemlib) if flag(use-pkgconfig) pkgconfig-depends: sqlite3@@ -86,21 +86,6 @@ type: git location: git://github.com/yesodweb/persistent.git --test-suite test- type: exitcode-stdio-1.0- main-is: Spec.hs- hs-source-dirs: test- build-depends: base- , hspec- , persistent- , persistent-sqlite- , persistent-template- , temporary- , text- , time- , transformers- executable sanity if flag(build-sanity-exe) buildable: True@@ -108,4 +93,38 @@ buildable: False main-is: sanity.hs hs-source-dirs: test- build-depends: base, persistent-sqlite, monad-logger+ build-depends: base+ , persistent-sqlite+ , monad-logger+ default-language: Haskell2010++test-suite test+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ other-modules: SqliteInit+ ghc-options: -Wall++ build-depends: base >= 4.9 && < 5+ , persistent+ , persistent-sqlite+ , persistent-template+ , persistent-test+ , bytestring+ , containers+ , exceptions+ , fast-logger+ , hspec >= 2.4+ , HUnit+ , monad-logger+ , QuickCheck+ , resourcet+ , system-fileio+ , system-filepath+ , temporary+ , text+ , time+ , transformers+ , time+ , unliftio-core+ default-language: Haskell2010
− test/Spec.hs
@@ -1,53 +0,0 @@-{-# LANGUAGE EmptyDataDecls #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# 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-import Data.Time-import Database.Persist.Sqlite-import Database.Persist.TH-import qualified Database.Sqlite as Sqlite-import System.IO (hClose)-import System.IO.Temp (withSystemTempFile)-import Test.Hspec--share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|-Test- time UTCTime-|]--asIO :: IO a -> IO a-asIO = id--main :: IO ()-main = hspec $ do- it "issue #328" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do- runMigration migrateAll- _ <- 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 $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do- runMigration migrateAll- now <- liftIO getCurrentTime- tid <- insert $ Test now- Just (Test now') <- get tid- liftIO $ now' `shouldBe` now- it "issue #564" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do- hClose h- 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")
+ test/SqliteInit.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE OverloadedStrings #-}++module SqliteInit (+ (@/=), (@==), (==@)+ , asIO+ , assertNotEqual+ , assertNotEmpty+ , assertEmpty+ , isTravis+ , BackendMonad+ , runConn++ , MonadIO+ , persistSettings+ , MkPersistSettings (..)+ , db+ , sqlite_database+ , sqlite_database_file+ , BackendKey(..)+ , GenerateKey(..)++ , RunDb+ -- re-exports+ , module Database.Persist+ , module Test.Hspec+ , module Test.HUnit+ , liftIO+ , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase+ , Int32, Int64+ , Text+ , module Control.Monad.Trans.Reader+ , module Control.Monad+ , module Database.Persist.Sql+ , BS.ByteString+ , SomeException+ , TestFn(..)+ , truncateTimeOfDay+ , truncateToMicro+ , truncateUTCTime+ , arbText+ , liftA2+ , MonadFail+ ) where++import Init+ ( TestFn(..), truncateTimeOfDay, truncateUTCTime+ , truncateToMicro, arbText, liftA2, GenerateKey(..)+ , (@/=), (@==), (==@), MonadFail+ , assertNotEqual, assertNotEmpty, assertEmpty, asIO+ , isTravis, RunDb+ )++-- re-exports+import Control.Exception (SomeException)+import Control.Monad (void, replicateM, liftM, when, forM_)+import Control.Monad.Trans.Reader+import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..))+import Test.Hspec++-- testing+import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool)++import Control.Monad (unless, (>=>))+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Logger+import Control.Monad.Trans.Resource (ResourceT, runResourceT)+import qualified Data.ByteString as BS+import Data.Text (Text)+import System.Log.FastLogger (fromLogStr)++import Database.Persist+import Database.Persist.Sql+import Database.Persist.Sqlite+import Database.Persist.TH ()+++-- Data types+import Control.Monad.IO.Class+import Data.Int (Int32, Int64)+++_debugOn :: Bool+_debugOn = False++persistSettings :: MkPersistSettings+persistSettings = sqlSettings { mpsGeneric = True }+type BackendMonad = SqlBackend++sqlite_database_file :: Text+sqlite_database_file = "testdb.sqlite3"+sqlite_database :: SqliteConnectionInfo+sqlite_database = mkSqliteConnectionInfo sqlite_database_file+runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m ()+runConn f = do+ travis <- liftIO isTravis+ let debugPrint = not travis && _debugOn+ let printDebug = if debugPrint then print . fromLogStr else void . return+ flip runLoggingT (\_ _ _ s -> printDebug s) $ do+ _<-withSqlitePoolInfo sqlite_database 1 $ runSqlPool f+ return ()++db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion+db actions = do+ runResourceT $ runConn $ actions >> transactionUndo
+ test/main.hs view
@@ -0,0 +1,218 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++import SqliteInit++import qualified CompositeTest+import qualified CustomPersistFieldTest+import qualified CustomPrimaryKeyReferenceTest+import qualified DataTypeTest+import qualified EmptyEntityTest+import qualified EmbedOrderTest+import qualified EmbedTest+import qualified EquivalentTypeTest+import qualified HtmlTest+import qualified LargeNumberTest+import qualified MaxLenTest+import qualified MpsNoPrefixTest+import qualified MigrationColumnLengthTest+import qualified MigrationOnlyTest+import qualified PersistentTest+import qualified PersistUniqueTest+import qualified PrimaryTest+import qualified RawSqlTest+import qualified ReadWriteTest+import qualified Recursive+import qualified RenameTest+import qualified SumTypeTest+import qualified TransactionLevelTest+import qualified UniqueTest+import qualified UpsertTest++import Control.Exception (handle, IOException)+import Control.Monad.Catch (catch)+import Control.Monad.IO.Class (liftIO)+import qualified Data.ByteString as BS+import Data.Fixed+import Data.IntMap (IntMap)+import qualified Data.Text as T+import Data.Time+import Filesystem (removeFile)+import Filesystem.Path.CurrentOS (fromText)+import Test.QuickCheck.Arbitrary (Arbitrary, arbitrary)+import System.IO (hClose)+import System.IO.Temp (withSystemTempFile)++import Database.Persist.Sqlite+import qualified Database.Sqlite as Sqlite+import PersistentTestModels++import qualified MigrationTest++type Tuple = (,)++-- Test lower case names+share [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase|+DataTypeTable no-json+ text Text+ textMaxLen Text maxlen=100+ bytes ByteString+ bytesTextTuple (Tuple ByteString Text)+ bytesMaxLen ByteString maxlen=100+ int Int+ intList [Int]+ intMap (IntMap Int)+ double Double+ bool Bool+ day Day+ pico Pico+ time TimeOfDay+ utc UTCTime+|]++instance Arbitrary DataTypeTable where+ arbitrary = DataTypeTable+ <$> arbText -- text+ <*> (T.take 100 <$> arbText) -- textManLen+ <*> arbitrary -- bytes+ <*> liftA2 (,) arbitrary arbText -- bytesTextTuple+ <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen+ <*> arbitrary -- int+ <*> arbitrary -- intList+ <*> arbitrary -- intMap+ <*> arbitrary -- double+ <*> arbitrary -- bool+ <*> arbitrary -- day+ <*> arbitrary -- pico+ <*> (truncateTimeOfDay =<< arbitrary) -- time+ <*> (truncateUTCTime =<< arbitrary) -- utc++share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|+Test+ time UTCTime+|]++setup :: MonadIO m => Migration -> ReaderT SqlBackend m ()+setup migration = do+ printMigration migration+ runMigrationUnsafe migration++main :: IO ()+main = do+ handle (\(_ :: IOException) -> return ())+ $ removeFile $ fromText sqlite_database_file++ runConn $ do+ mapM_ setup+ [ PersistentTest.testMigrate+ , PersistentTest.noPrefixMigrate+ , EmbedTest.embedMigrate+ , EmbedOrderTest.embedOrderMigrate+ , LargeNumberTest.numberMigrate+ , UniqueTest.uniqueMigrate+ , MaxLenTest.maxlenMigrate+ , Recursive.recursiveMigrate+ , CompositeTest.compositeMigrate+ , MigrationTest.migrationMigrate+ , PersistUniqueTest.migration+ , RenameTest.migration+ , CustomPersistFieldTest.customFieldMigrate+ , PrimaryTest.migration+ , CustomPrimaryKeyReferenceTest.migration+ , MigrationColumnLengthTest.migration+ , TransactionLevelTest.migration+ ]+ PersistentTest.cleanDB++ hspec $ do+ RenameTest.specsWith db+ DataTypeTest.specsWith+ db+ (Just (runMigrationSilent dataTypeMigrate))+ [ TestFn "text" dataTypeTableText+ , TestFn "textMaxLen" dataTypeTableTextMaxLen+ , TestFn "bytes" dataTypeTableBytes+ , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple+ , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen+ , TestFn "int" dataTypeTableInt+ , TestFn "intList" dataTypeTableIntList+ , TestFn "intMap" dataTypeTableIntMap+ , TestFn "bool" dataTypeTableBool+ , TestFn "day" dataTypeTableDay+ , TestFn "time" (DataTypeTest.roundTime . dataTypeTableTime)+ , TestFn "utc" (DataTypeTest.roundUTCTime . dataTypeTableUtc)+ ]+ [ ("pico", dataTypeTablePico) ]+ dataTypeTableDouble+ HtmlTest.specsWith+ db+ (Just (runMigrationSilent HtmlTest.htmlMigrate))+ EmbedTest.specsWith db+ EmbedOrderTest.specsWith db+ LargeNumberTest.specsWith db+ UniqueTest.specsWith db+ MaxLenTest.specsWith db+ Recursive.specsWith db+ SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate))+ MigrationOnlyTest.specsWith db+ (Just+ $ runMigrationSilent MigrationOnlyTest.migrateAll1+ >> runMigrationSilent MigrationOnlyTest.migrateAll2+ )+ PersistentTest.specsWith db+ PersistentTest.filterOrSpecs db+ ReadWriteTest.specsWith db+ RawSqlTest.specsWith db+ UpsertTest.specsWith+ db+ UpsertTest.Don'tUpdateNull+ UpsertTest.UpsertPreserveOldKey++ MpsNoPrefixTest.specsWith db+ EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration))+ CompositeTest.specsWith db+ PersistUniqueTest.specsWith db+ PrimaryTest.specsWith db+ CustomPersistFieldTest.specsWith db+ CustomPrimaryKeyReferenceTest.specsWith db+ MigrationColumnLengthTest.specsWith db+ EquivalentTypeTest.specsWith db+ TransactionLevelTest.specsWith db+ MigrationTest.specsWith db++ it "issue #328" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do+ runMigration migrateAll+ _ <- 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 $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do+ runMigration migrateAll+ now <- liftIO getCurrentTime+ tid <- insert $ Test now+ Just (Test now') <- get tid+ liftIO $ now' `shouldBe` now+ it "issue #564" $ asIO $ withSystemTempFile "test564.sqlite3"$ \fp h -> do+ hClose h+ 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")++ it "afterException" $ asIO $ runSqliteInfo (mkSqliteConnectionInfo ":memory:") $ do+ runMigration testMigrate+ let catcher :: forall m. Monad m => SomeException -> m ()+ catcher _ = return ()+ _ <- insert $ Person "A" 0 Nothing+ _ <- insert_ (Person "A" 1 Nothing) `catch` catcher+ _ <- insert $ Person "B" 0 Nothing+ return ()
test/sanity.hs view
@@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}-import Database.Persist.Sqlite import Control.Monad.Logger++import Database.Persist.Sqlite $(return []) -- just force TH to run