persistent-sqlite 0.1.1 → 0.2.0
raw patch · 4 files changed
+226/−139 lines, 4 filesdep +containersdep ~persistent
Dependencies added: containers
Dependency ranges changed: persistent
Files
- Database/Persist/Sqlite.hs +204/−104
- Database/Sqlite.hs +19/−26
- cbits/sqlite3.c too large to diff
- persistent-sqlite.cabal +3/−9
Database/Persist/Sqlite.hs view
@@ -1,129 +1,104 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PackageImports #-} -- | A sqlite backend for persistent. module Database.Persist.Sqlite- ( SqliteReader- , runSqlite- , runSqliteConn- , withSqlite+ ( withSqlitePool , withSqliteConn- , Connection- , Pool , module Database.Persist+ , module Database.Persist.GenericSql ) where import Database.Persist import Database.Persist.Base-import Control.Monad.Trans.Reader+import Database.Persist.GenericSql+import Database.Persist.GenericSql.Internal++import qualified Database.Sqlite as Sqlite+ import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Class (MonadTrans (..)) import Data.List (intercalate) import "MonadCatchIO-transformers" Control.Monad.CatchIO-import Database.Sqlite-import qualified Database.Persist.GenericSql as G-import Control.Applicative (Applicative)-import Data.Int (Int64)-import Database.Persist.Pool---- | A ReaderT monad transformer holding a sqlite database connection.-newtype SqliteReader m a = SqliteReader (ReaderT Connection m a)- deriving (Monad, MonadIO, MonadTrans, MonadCatchIO, Functor,- Applicative)+import Data.IORef+import qualified Data.Map as Map --- | Handles opening and closing of the database connection automatically.-withSqlite :: MonadCatchIO m- => String- -> Int -- ^ number of connections to open- -> (Pool Connection -> m a) -> m a-withSqlite s i f = createPool (open s) close i f+withSqlitePool :: MonadCatchIO m+ => String+ -> Int -- ^ number of connections to open+ -> (ConnectionPool -> m a) -> m a+withSqlitePool s = withSqlPool $ open' s --- | Handles opening and closing of the database connection automatically.--- You probably want to take advantage of connection pooling by using withSqlite instead withSqliteConn :: MonadCatchIO m => String -> (Connection -> m a) -> m a-withSqliteConn s f = bracket (liftIO $ open s) (liftIO . close) f- ---- | Run a series of database actions within a single transactions.--- On any exception, the transaction is rolled back.-runSqlite :: MonadCatchIO m => SqliteReader m a -> Pool Connection -> m a-runSqlite r pconn = withPool' pconn $ runSqliteConn r---- | Run a series of database actions within a single transactions.--- On any exception, the transaction is rolled back.--- You probably want to take advantage of connection pooling by using runSqlite instead-runSqliteConn :: MonadCatchIO m => SqliteReader m a -> Connection -> m a-runSqliteConn (SqliteReader r) conn = do- Done <- liftIO begin- res <- onException (runReaderT r conn) $ liftIO rollback- Done <- liftIO commit- return res- where- begin = bracket (prepare conn "BEGIN") finalize step- commit = bracket (prepare conn "COMMIT") finalize step- rollback = bracket (prepare conn "ROLLBACK") finalize step+withSqliteConn = withSqlConn . open' -withStmt :: MonadCatchIO m- => String- -> [PersistValue]- -> (G.RowPopper (SqliteReader m) -> SqliteReader m a)- -> SqliteReader m a-withStmt sql vals f = do- conn <- SqliteReader ask- bracket (liftIO $ prepare conn sql) (liftIO . finalize) $ \stmt -> do- liftIO $ bind stmt vals- f $ go stmt+open' :: String -> IO Connection+open' s = do+ conn <- Sqlite.open s+ smap <- newIORef $ Map.empty+ return Connection+ { prepare = prepare' conn+ , stmtMap = smap+ , insertSql = insertSql'+ , close = Sqlite.close conn+ , migrateSql = migrate'+ , begin = helper "BEGIN"+ , commit = helper "COMMIT"+ , rollback = helper "ROLLBACK"+ , escapeName = escape+ , noLimit = "LIMIT -1"+ } where- go stmt = liftIO $ do- x <- step stmt- case x of- Done -> return Nothing- Row -> do- cols <- liftIO $ columns stmt- return $ Just cols--execute :: MonadCatchIO m => String -> [PersistValue] -> SqliteReader m ()-execute sql vals = do- conn <- SqliteReader ask- bracket (liftIO $ prepare conn sql) (liftIO . finalize) $ \stmt -> do- liftIO $ bind stmt vals- Done <- liftIO $ step stmt- return ()+ helper t getter = do+ stmt <- getter t+ execute stmt [] -insert' :: MonadCatchIO m- => String -> [String] -> [PersistValue] -> SqliteReader m Int64-insert' t cols vals = do- let sql = "INSERT INTO " ++ t ++- "(" ++ intercalate "," cols ++ ") VALUES(" ++- intercalate "," (map (const "?") cols) ++ ")"- execute sql vals- withStmt "SELECT last_insert_rowid()" [] $ \pop -> do- Just [PersistInt64 i] <- pop- return i+prepare' :: Sqlite.Connection -> String -> IO Statement+prepare' conn sql = do+ stmt <- Sqlite.prepare conn sql+ return Statement+ { finalize = Sqlite.finalize stmt+ , reset = Sqlite.reset stmt+ , execute = execute' stmt+ , withStmt = withStmt' stmt+ } -tableExists :: MonadCatchIO m => String -> SqliteReader m Bool-tableExists t = withStmt sql [PersistString t] $ \pop -> do- Just [PersistInt64 i] <- pop- return $ i == 1+insertSql' :: RawName -> [RawName] -> Either String (String, String)+insertSql' t cols =+ Right (ins, sel) where- sql = "SELECT COUNT(*) FROM sqlite_master WHERE type='table' AND name=?"--genericSql :: MonadCatchIO m => G.GenericSql (SqliteReader m)-genericSql = G.GenericSql withStmt execute insert' tableExists- "INTEGER PRIMARY KEY" showSqlType+ sel = "SELECT last_insert_rowid()"+ ins = concat+ [ "INSERT INTO "+ , escape t+ , "("+ , intercalate "," $ map escape cols+ , ") VALUES("+ , intercalate "," (map (const "?") cols)+ , ")"+ ] -instance MonadCatchIO m => PersistBackend (SqliteReader m) where- initialize = G.initialize genericSql- insert = G.insert genericSql- get = G.get genericSql- replace = G.replace genericSql- select = G.select genericSql- deleteWhere = G.deleteWhere genericSql- update = G.update genericSql- updateWhere = G.updateWhere genericSql- getBy = G.getBy genericSql- delete = G.delete genericSql- deleteBy = G.deleteBy genericSql+execute' :: Sqlite.Statement -> [PersistValue] -> IO ()+execute' stmt vals = do+ Sqlite.bind stmt vals+ Sqlite.Done <- Sqlite.step stmt+ return () +withStmt' :: MonadCatchIO m+ => Sqlite.Statement+ -> [PersistValue]+ -> (RowPopper m -> m a)+ -> m a+withStmt' stmt vals f = do+ liftIO $ Sqlite.bind stmt vals+ x <- f go+ liftIO $ Sqlite.reset stmt+ return x+ where+ go = liftIO $ do+ x <- Sqlite.step stmt+ case x of+ Sqlite.Done -> return Nothing+ Sqlite.Row -> do+ cols <- liftIO $ Sqlite.columns stmt+ return $ Just cols showSqlType :: SqlType -> String showSqlType SqlString = "VARCHAR" showSqlType SqlInteger = "INTEGER"@@ -133,3 +108,128 @@ showSqlType SqlDayTime = "TIMESTAMP" showSqlType SqlBlob = "BLOB" showSqlType SqlBool = "BOOLEAN"++migrate' :: PersistEntity val+ => (String -> IO Statement)+ -> val+ -> IO (Either [String] [(Bool, String)])+migrate' getter val = do+ let (cols, uniqs) = mkColumns val+ let newSql = mkCreateTable False table (cols, uniqs)+ stmt <- getter $ "SELECT sql FROM sqlite_master WHERE " +++ "type='table' AND name=?"+ oldSql' <- withStmt stmt [PersistString $ unRawName table] go+ case oldSql' of+ Nothing -> return $ Right [(False, newSql)]+ Just oldSql ->+ if oldSql == newSql+ then return $ Right []+ else do+ sql <- getCopyTable getter val+ return $ Right sql+ where+ def = entityDef val+ table = rawTableName def+ go pop = do+ x <- pop+ case x of+ Nothing -> return Nothing+ Just [PersistString y] -> return $ Just y+ Just y -> error $ "Unexpected result from sqlite_master: " ++ show y++getCopyTable :: PersistEntity val => (String -> IO Statement) -> val+ -> IO [(Bool, Sql)]+getCopyTable getter val = do+ stmt <- getter $ "PRAGMA table_info(" ++ escape table ++ ")"+ oldCols' <- withStmt stmt [] getCols+ let oldCols = map RawName $ filter (/= "id") oldCols'+ let newCols = map cName cols+ let common = filter (`elem` oldCols) newCols+ return [ (False, tmpSql)+ , (False, copyToTemp $ RawName "id" : common)+ , (common /= oldCols, dropOld)+ , (False, newSql)+ , (False, copyToFinal $ RawName "id" : newCols)+ , (False, dropTmp)+ ]+ where+ def = entityDef val+ getCols pop = do+ x <- pop+ case x of+ Nothing -> return []+ Just (_:PersistString name:_) -> do+ names <- getCols pop+ return $ name : names+ Just y -> error $ "Invalid result from PRAGMA table_info: " ++ show y+ table = rawTableName def+ tableTmp = RawName $ unRawName table ++ "_backup"+ (cols, uniqs) = mkColumns val+ newSql = mkCreateTable False table (cols, uniqs)+ tmpSql = mkCreateTable True tableTmp (cols, uniqs)+ dropTmp = "DROP TABLE " ++ escape tableTmp+ dropOld = "DROP TABLE " ++ escape table+ copyToTemp common = concat+ [ "INSERT INTO "+ , escape tableTmp+ , "("+ , intercalate "," $ map escape common+ , ") SELECT "+ , intercalate "," $ map escape common+ , " FROM "+ , escape table+ ]+ copyToFinal newCols = concat+ [ "INSERT INTO "+ , escape table+ , " SELECT "+ , intercalate "," $ map escape newCols+ , " FROM "+ , escape tableTmp+ ]++mkCreateTable :: Bool -> RawName -> ([Column], [UniqueDef]) -> Sql+mkCreateTable isTemp table (cols, uniqs) = concat+ [ "CREATE"+ , if isTemp then " TEMP" else ""+ , " TABLE "+ , escape table+ , "(id INTEGER PRIMARY KEY"+ , concatMap sqlColumn cols+ , concatMap sqlUnique uniqs+ , ")"+ ]++sqlColumn :: Column -> String+sqlColumn (Column name isNull typ def ref) = concat+ [ ","+ , escape name+ , " "+ , showSqlType typ+ , if isNull then " NULL" else " NOT NULL"+ , case def of+ Nothing -> ""+ Just d -> " DEFAULT " ++ d+ , case ref of+ Nothing -> ""+ Just (table, _) -> " REFERENCES " ++ escape table+ ]++sqlUnique :: UniqueDef -> String+sqlUnique (cname, cols) = concat+ [ ",CONSTRAINT "+ , escape cname+ , " UNIQUE ("+ , intercalate "," $ map escape cols+ , ")"+ ]++type Sql = String++escape :: RawName -> String+escape (RawName s) =+ '"' : go s ++ "\""+ where+ go "" = ""+ go ('"':xs) = "\"\"" ++ go xs+ go (x:xs) = x : go xs
Database/Sqlite.hs view
@@ -33,12 +33,9 @@ import Foreign import Foreign.C import Database.Persist.Base (PersistValue (..))-import Control.Concurrent.MVar newtype Connection = Connection (Ptr ())--- | The MVar is only used for insuring the statement is not double-finalized.--- It won't stop you from using a statement after it's been finalized.-data Statement = Statement (Ptr ()) (MVar Bool)+newtype Statement = Statement (Ptr ()) data Error = ErrorOK | ErrorError@@ -185,8 +182,7 @@ case error of ErrorOK -> do statement' <- peek statement- mvar <- newMVar True- return $ Left $ Statement statement' mvar+ return $ Left $ Statement statement' _ -> return $ Right error)) prepare :: Connection -> String -> IO Statement prepare database text = do@@ -198,7 +194,7 @@ foreign import ccall "sqlite3_step" stepC :: Ptr () -> IO Int stepError :: Statement -> IO Error-stepError (Statement statement _) = do+stepError (Statement statement) = do error <- stepC statement return $ decodeError error step :: Statement -> IO StepResult@@ -212,7 +208,7 @@ foreign import ccall "sqlite3_reset" resetC :: Ptr () -> IO Int resetError :: Statement -> IO Error-resetError (Statement statement _) = do+resetError (Statement statement) = do error <- resetC statement return $ decodeError error reset :: Statement -> IO ()@@ -225,12 +221,9 @@ foreign import ccall "sqlite3_finalize" finalizeC :: Ptr () -> IO Int finalizeError :: Statement -> IO Error-finalizeError (Statement statement mvar) = modifyMVar mvar go- where- go False = return (False, ErrorOK)- go True = do- error <- finalizeC statement- return (False, decodeError error)+finalizeError (Statement statement) = do+ error <- finalizeC statement+ return $ decodeError error finalize :: Statement -> IO () finalize statement = do error <- finalizeError statement@@ -241,7 +234,7 @@ foreign import ccall "sqlite3_bind_blob" bindBlobC :: Ptr () -> Int -> Ptr () -> Int -> Ptr () -> IO Int bindBlobError :: Statement -> Int -> BS.ByteString -> IO Error-bindBlobError (Statement statement _) parameterIndex byteString = do+bindBlobError (Statement statement) parameterIndex byteString = do size <- return $ BS.length byteString BS.useAsCString byteString (\dataC -> do@@ -258,7 +251,7 @@ foreign import ccall "sqlite3_bind_double" bindDoubleC :: Ptr () -> Int -> Double -> IO Int bindDoubleError :: Statement -> Int -> Double -> IO Error-bindDoubleError (Statement statement _) parameterIndex datum = do+bindDoubleError (Statement statement) parameterIndex datum = do error <- bindDoubleC statement parameterIndex datum return $ decodeError error bindDouble :: Statement -> Int -> Double -> IO ()@@ -271,7 +264,7 @@ foreign import ccall "sqlite3_bind_int" bindIntC :: Ptr () -> Int -> Int -> IO Int bindIntError :: Statement -> Int -> Int -> IO Error-bindIntError (Statement statement _) parameterIndex datum = do+bindIntError (Statement statement) parameterIndex datum = do error <- bindIntC statement parameterIndex datum return $ decodeError error bindInt :: Statement -> Int -> Int -> IO ()@@ -284,7 +277,7 @@ foreign import ccall "sqlite3_bind_int64" bindInt64C :: Ptr () -> Int -> Int64 -> IO Int bindInt64Error :: Statement -> Int -> Int64 -> IO Error-bindInt64Error (Statement statement _) parameterIndex datum = do+bindInt64Error (Statement statement) parameterIndex datum = do error <- bindInt64C statement parameterIndex datum return $ decodeError error bindInt64 :: Statement -> Int -> Int64 -> IO ()@@ -297,7 +290,7 @@ foreign import ccall "sqlite3_bind_null" bindNullC :: Ptr () -> Int -> IO Int bindNullError :: Statement -> Int -> IO Error-bindNullError (Statement statement _) parameterIndex = do+bindNullError (Statement statement) parameterIndex = do error <- bindNullC statement parameterIndex return $ decodeError error bindNull :: Statement -> Int -> IO ()@@ -310,7 +303,7 @@ foreign import ccall "sqlite3_bind_text" bindTextC :: Ptr () -> Int -> CString -> Int -> Ptr () -> IO Int bindTextError :: Statement -> Int -> String -> IO Error-bindTextError (Statement statement _) parameterIndex text = do+bindTextError (Statement statement) parameterIndex text = do byteString <- return $ UTF8.fromString text size <- return $ BS.length byteString BS.useAsCString byteString@@ -345,7 +338,7 @@ foreign import ccall "sqlite3_column_type" columnTypeC :: Ptr () -> Int -> IO Int columnType :: Statement -> Int -> IO ColumnType-columnType (Statement statement _) columnIndex = do+columnType (Statement statement) columnIndex = do result <- columnTypeC statement columnIndex return $ decodeColumnType result @@ -355,7 +348,7 @@ foreign import ccall "sqlite3_column_blob" columnBlobC :: Ptr () -> Int -> IO (Ptr ()) columnBlob :: Statement -> Int -> IO BS.ByteString-columnBlob (Statement statement _) columnIndex = do+columnBlob (Statement statement) columnIndex = do size <- columnBytesC statement columnIndex BSI.create size (\resultPtr -> do dataPtr <- columnBlobC statement columnIndex@@ -366,19 +359,19 @@ foreign import ccall "sqlite3_column_int64" columnInt64C :: Ptr () -> Int -> IO Int64 columnInt64 :: Statement -> Int -> IO Int64-columnInt64 (Statement statement _) columnIndex = do+columnInt64 (Statement statement) columnIndex = do columnInt64C statement columnIndex foreign import ccall "sqlite3_column_double" columnDoubleC :: Ptr () -> Int -> IO Double columnDouble :: Statement -> Int -> IO Double-columnDouble (Statement statement _) columnIndex = do+columnDouble (Statement statement) columnIndex = do columnDoubleC statement columnIndex foreign import ccall "sqlite3_column_text" columnTextC :: Ptr () -> Int -> IO CString columnText :: Statement -> Int -> IO String-columnText (Statement statement _) columnIndex = do+columnText (Statement statement) columnIndex = do text <- columnTextC statement columnIndex byteString <- BS.packCString text return $ UTF8.toString byteString@@ -386,7 +379,7 @@ foreign import ccall "sqlite3_column_count" columnCountC :: Ptr () -> IO Int columnCount :: Statement -> IO Int-columnCount (Statement statement _) = do+columnCount (Statement statement) = do columnCountC statement column :: Statement -> Int -> IO PersistValue
cbits/sqlite3.c view
file too large to diff
persistent-sqlite.cabal view
@@ -1,5 +1,5 @@ name: persistent-sqlite-version: 0.1.1+version: 0.2.0 license: BSD3 license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>@@ -12,13 +12,6 @@ build-type: Simple homepage: http://docs.yesodweb.com/persistent/ -flag nolib- description: Skip building the library- default: False-flag buildtests- description: Build the executable to run unit tests- default: False- library build-depends: base >= 4 && < 5, template-haskell >= 2.4 && < 2.5,@@ -26,7 +19,8 @@ transformers >= 0.2.1 && < 0.3, MonadCatchIO-transformers >= 0.2.2 && < 0.3, utf8-string >= 0.3.4 && < 0.4,- persistent >= 0.1.0 && < 0.2+ persistent >= 0.2.0 && < 0.3,+ containers >= 0.2 && < 0.4 exposed-modules: Database.Sqlite Database.Persist.Sqlite ghc-options: -Wall