diff --git a/Database/Persist/Sqlite.hs b/Database/Persist/Sqlite.hs --- a/Database/Persist/Sqlite.hs +++ b/Database/Persist/Sqlite.hs @@ -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 diff --git a/Database/Sqlite.hs b/Database/Sqlite.hs --- a/Database/Sqlite.hs +++ b/Database/Sqlite.hs @@ -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 diff --git a/persistent-sqlite.cabal b/persistent-sqlite.cabal --- a/persistent-sqlite.cabal +++ b/persistent-sqlite.cabal @@ -1,5 +1,5 @@ name: persistent-sqlite -version: 1.1.5 +version: 1.2.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -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