persistent-sqlite 1.1.5 → 1.2.0
raw patch · 3 files changed
+56/−60 lines, 3 filesdep ~persistent
Dependency ranges changed: persistent
Files
- Database/Persist/Sqlite.hs +51/−57
- Database/Sqlite.hs +3/−1
- persistent-sqlite.cabal +2/−2
Database/Persist/Sqlite.hs view
@@ -8,18 +8,13 @@ ( withSqlitePool , withSqliteConn , createSqlitePool- , module Database.Persist- , module Database.Persist.GenericSql+ , module Database.Persist.Sql , SqliteConf (..) , runSqlite , wrapConnection ) where -import Database.Persist hiding (Entity (..))-import Database.Persist.Store-import Database.Persist.EntityDef-import Database.Persist.GenericSql hiding (Key)-import Database.Persist.GenericSql.Internal+import Database.Persist.Sql import qualified Database.Sqlite as Sqlite @@ -63,22 +58,23 @@ wrapConnection conn = do smap <- newIORef $ Map.empty return Connection- { prepare = prepare' conn- , stmtMap = smap- , insertSql = insertSql'- , close = Sqlite.close conn- , migrateSql = migrate'- , begin = helper "BEGIN"- , commitC = helper "COMMIT"- , rollbackC = ignoreExceptions . helper "ROLLBACK"- , escapeName = escape- , noLimit = "LIMIT -1"+ { connPrepare = prepare' conn+ , connStmtMap = smap+ , connInsertSql = insertSql'+ , connClose = Sqlite.close conn+ , connMigrateSql = migrate'+ , connBegin = helper "BEGIN"+ , connCommit = helper "COMMIT"+ , connRollback = ignoreExceptions . helper "ROLLBACK"+ , connEscapeName = escape+ , connNoLimit = "LIMIT -1"+ , connRDBMS = "sqlite" } where helper t getter = do stmt <- getter t- _ <- execute stmt []- reset stmt+ _ <- stmtExecute stmt []+ stmtReset stmt ignoreExceptions = E.handle (\(_ :: E.SomeException) -> return ()) -- | A convenience helper which creates a new database connection and runs the@@ -88,7 +84,7 @@ -- Since 1.1.4 runSqlite :: (MonadBaseControl IO m, MonadIO m) => Text -- ^ connection string- -> SqlPersist (NoLoggingT (ResourceT m)) a -- ^ database action+ -> SqlPersistT (NoLoggingT (ResourceT m)) a -- ^ database action -> m a runSqlite connstr = runResourceT . runNoLoggingT@@ -99,10 +95,10 @@ prepare' conn sql = do stmt <- Sqlite.prepare conn sql return Statement- { finalize = Sqlite.finalize stmt- , reset = Sqlite.reset conn stmt- , execute = execute' conn stmt- , withStmt = withStmt' conn stmt+ { stmtFinalize = Sqlite.finalize stmt+ , stmtReset = Sqlite.reset conn stmt+ , stmtExecute = execute' conn stmt+ , stmtQuery = withStmt' conn stmt } insertSql' :: DBName -> [DBName] -> DBName -> InsertSqlResult@@ -145,40 +141,41 @@ cols <- liftIO $ Sqlite.columns stmt yield cols pull-showSqlType :: SqlType -> String++showSqlType :: SqlType -> Text showSqlType SqlString = "VARCHAR" showSqlType SqlInt32 = "INTEGER" showSqlType SqlInt64 = "INTEGER" showSqlType SqlReal = "REAL"+showSqlType (SqlNumeric precision scale) = pack $ "NUMERIC(" ++ show precision ++ "," ++ show scale ++ ")" showSqlType SqlDay = "DATE" showSqlType SqlTime = "TIME" showSqlType SqlDayTimeZoned = "TIMESTAMP" showSqlType SqlDayTime = "TIMESTAMP" showSqlType SqlBlob = "BLOB" showSqlType SqlBool = "BOOLEAN"-showSqlType (SqlOther t) = T.unpack t+showSqlType (SqlOther t) = t -migrate' :: PersistEntity val- => [EntityDef]+migrate' :: [EntityDef a] -> (Text -> IO Statement)- -> val+ -> EntityDef SqlType -> IO (Either [Text] [(Bool, Text)]) migrate' allDefs getter val = do let (cols, uniqs) = mkColumns allDefs val let newSql = mkCreateTable False def (cols, uniqs) stmt <- getter "SELECT sql FROM sqlite_master WHERE type='table' AND name=?" oldSql' <- runResourceT- $ withStmt stmt [PersistText $ unDBName table] $$ go+ $ stmtQuery stmt [PersistText $ unDBName table] $$ go case oldSql' of Nothing -> return $ Right [(False, newSql)]- Just oldSql ->+ Just oldSql -> do if oldSql == newSql then return $ Right [] else do sql <- getCopyTable allDefs getter val return $ Right sql where- def = entityDef val+ def = val table = entityDB def go = do x <- CL.head@@ -187,18 +184,17 @@ Just [PersistText y] -> return $ Just y Just y -> error $ "Unexpected result from sqlite_master: " ++ show y -getCopyTable :: PersistEntity val- => [EntityDef]+getCopyTable :: [EntityDef a] -> (Text -> IO Statement)- -> val- -> IO [(Bool, Sql)]+ -> EntityDef SqlType+ -> IO [(Bool, Text)] getCopyTable allDefs getter val = do stmt <- getter $ pack $ "PRAGMA table_info(" ++ escape' table ++ ")"- oldCols' <- runResourceT $ withStmt stmt [] $$ getCols+ oldCols' <- runResourceT $ stmtQuery stmt [] $$ getCols let oldCols = map DBName $ filter (/= "id") oldCols' -- need to update for table id attribute ? let newCols = map cName cols let common = filter (`elem` oldCols) newCols- let id_ = entityID $ entityDef val+ let id_ = entityID val return [ (False, tmpSql) , (False, copyToTemp $ id_ : common) , (common /= oldCols, pack dropOld)@@ -207,7 +203,7 @@ , (False, pack dropTmp) ] where- def = entityDef val+ def = val getCols = do x <- CL.head case x of@@ -245,46 +241,44 @@ escape' :: DBName -> String escape' = T.unpack . escape -mkCreateTable :: Bool -> EntityDef -> ([Column], [UniqueDef]) -> Sql-mkCreateTable isTemp entity (cols, uniqs) = pack $ concat+mkCreateTable :: Bool -> EntityDef a -> ([Column], [UniqueDef]) -> Text+mkCreateTable isTemp entity (cols, uniqs) = T.concat [ "CREATE" , if isTemp then " TEMP" else "" , " TABLE "- , T.unpack $ escape $ entityDB entity+ , escape $ entityDB entity , "("- , T.unpack $ escape $ entityID entity+ , escape $ entityID entity , " INTEGER PRIMARY KEY"- , concatMap sqlColumn cols- , concatMap sqlUnique uniqs+ , T.concat $ map sqlColumn cols+ , T.concat $ map sqlUnique uniqs , ")" ] -sqlColumn :: Column -> String-sqlColumn (Column name isNull typ def _maxLen ref) = concat+sqlColumn :: Column -> Text+sqlColumn (Column name isNull typ def _maxLen ref) = T.concat [ ","- , T.unpack $ escape name+ , escape name , " " , showSqlType typ , if isNull then " NULL" else " NOT NULL" , case def of Nothing -> ""- Just d -> " DEFAULT " ++ T.unpack d+ Just d -> " DEFAULT " `T.append` d , case ref of Nothing -> ""- Just (table, _) -> " REFERENCES " ++ T.unpack (escape table)+ Just (table, _) -> " REFERENCES " `T.append` escape table ] -sqlUnique :: UniqueDef -> String-sqlUnique (UniqueDef _ cname cols _) = concat+sqlUnique :: UniqueDef -> Text+sqlUnique (UniqueDef _ cname cols _) = T.concat [ ",CONSTRAINT "- , T.unpack $ escape cname+ , escape cname , " UNIQUE ("- , intercalate "," $ map (T.unpack . escape . snd) cols+ , T.intercalate "," $ map (escape . snd) cols , ")" ] -type Sql = Text- escape :: DBName -> Text escape (DBName s) = T.concat [q, T.concatMap go s, q]@@ -300,7 +294,7 @@ } instance PersistConfig SqliteConf where- type PersistConfigBackend SqliteConf = SqlPersist+ type PersistConfigBackend SqliteConf = SqlPersistT type PersistConfigPool SqliteConf = ConnectionPool createPoolConfig (SqliteConf cs size) = createSqlitePool cs size runPool _ = runSqlPool
Database/Sqlite.hs view
@@ -34,12 +34,13 @@ import qualified Data.ByteString.Internal as BSI import Foreign import Foreign.C-import Database.Persist.Store (PersistValue (..), listToJSON, mapToJSON, ZT (ZT))+import Database.Persist (PersistValue (..), listToJSON, mapToJSON, ZT (ZT)) 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) data Connection = Connection !(IORef Bool) Connection' newtype Connection' = Connection' (Ptr ())@@ -342,6 +343,7 @@ case datum of PersistInt64 int64 -> bindInt64 statement parameterIndex int64 PersistDouble double -> bindDouble statement parameterIndex double+ PersistRational rational -> bindText statement parameterIndex $ pack $ show (fromRational rational :: Pico) PersistBool b -> bindInt64 statement parameterIndex $ if b then 1 else 0 PersistText text -> bindText statement parameterIndex text
persistent-sqlite.cabal view
@@ -1,5 +1,5 @@ name: persistent-sqlite-version: 1.1.5+version: 1.2.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -20,7 +20,7 @@ build-depends: base >= 4 && < 5 , bytestring >= 0.9.1 , transformers >= 0.2.1- , persistent >= 1.1.5 && < 1.2+ , persistent >= 1.2 && < 1.3 , monad-control >= 0.2 , containers >= 0.2 , text >= 0.7