diff --git a/simplest-sqlite.cabal b/simplest-sqlite.cabal --- a/simplest-sqlite.cabal +++ b/simplest-sqlite.cabal @@ -2,7 +2,7 @@ cabal-version: >= 1.8 name: simplest-sqlite -version: 0.0.0.1 +version: 0.0.0.2 stability: Experimental author: YoshikuniJujo maintainer: YoshikuniJujo @@ -23,12 +23,12 @@ source-repository this type: git location: git://github.com/YoshikuniJujo/test_haskell - tag: simplest-sqlite-0.0.0.1 + tag: simplest-sqlite-0.0.0.2 library hs-source-dirs: src - exposed-modules: Database.SQLite3 - other-modules: Database.SQLite3.Constants + exposed-modules: Database.SmplstSQLite3 + other-modules: Database.SmplstSQLite3.Constants build-depends: base == 4.*, bytestring == 0.10.*, text == 1.1.* ghc-options: -Wall extra-libraries: sqlite3 diff --git a/src/Database/SQLite3.hs b/src/Database/SQLite3.hs deleted file mode 100644 --- a/src/Database/SQLite3.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE TupleSections #-} - -module Database.SQLite3 (SQLite3, withSQLite3, withPrepared, step, column) where - -import Control.Applicative -import Control.Monad -import Control.Exception -import qualified Data.ByteString as BS -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Foreign -import Foreign.C.Types -import Foreign.C.String - -import Database.SQLite3.Constants - -data SQLite3 = SQLite3 (Ptr SQLite3) deriving Show -data SQLite3Stmt = SQLite3Stmt (Ptr SQLite3Stmt) deriving Show - -foreign import ccall unsafe "sqlite3.h sqlite3_open" c_sqlite3_open :: - CString -> Ptr (Ptr SQLite3) -> IO CInt -foreign import ccall unsafe "sqlite3.h sqlite3_close" c_sqlite3_close :: - Ptr SQLite3 -> IO CInt -foreign import ccall unsafe "sqlite3.h sqlite3_errmsg" c_sqlite3_errmsg :: - Ptr SQLite3 -> IO CString - -withSQLite3 :: String -> (SQLite3 -> IO a) -> IO a -withSQLite3 fp = bracket (sqlite3Open fp) sqlite3Close - -sqlite3Open :: String -> IO SQLite3 -sqlite3Open fp = withCString fp $ \cfp -> alloca $ \ppDb -> do - ret <- c_sqlite3_open cfp ppDb - db <- peek ppDb - let sq = SQLite3 db - when (ret /= sQLITE_OK) $ do - em <- sqlite3Errmsg sq - sqlite3Close sq - ioError . userError $ "Cannot open database: " ++ em - return sq - -sqlite3Close :: SQLite3 -> IO () -sqlite3Close sq@(SQLite3 db) = do - ret <- c_sqlite3_close db - when (ret /= sQLITE_OK) $ do - em <- sqlite3Errmsg sq - ioError . userError $ "Cannot close database: " ++ em - -sqlite3Errmsg :: SQLite3 -> IO String -sqlite3Errmsg (SQLite3 db) = peekCString =<< c_sqlite3_errmsg db - -foreign import ccall unsafe "sqlite3.h sqlite3_prepare_v2" - c_sqlite3_prepare_v2 :: - Ptr SQLite3 -> CString -> CInt -> Ptr (Ptr SQLite3Stmt) -> - (Ptr CString) -> IO CInt -foreign import ccall unsafe "sqlite3.h sqlite3_finalize" c_sqlite3_finalize :: - Ptr SQLite3Stmt -> IO CInt - -withPrepared :: SQLite3 -> String -> (SQLite3Stmt -> IO a) -> IO (a, String) -withPrepared db sql act = - bracket (sqlite3PrepareV2 db sql) (sqlite3Finalize . fst) $ - \(sm, t) -> (, t) <$> act sm - -sqlite3PrepareV2 :: SQLite3 -> String -> IO (SQLite3Stmt, String) -sqlite3PrepareV2 db@(SQLite3 pdb) sql = - withCString sql $ \csql -> alloca $ \psm -> alloca $ \pt -> do - ret <- c_sqlite3_prepare_v2 pdb csql (- 1) psm pt - sm <- SQLite3Stmt <$> peek psm - when (ret /= sQLITE_OK) $ do - em <- sqlite3Errmsg db - sqlite3Finalize sm - ioError . userError $ "Cannot prepare: " ++ em - (sm ,) <$> (peekCString =<< peek pt) - -sqlite3Finalize :: SQLite3Stmt -> IO () -sqlite3Finalize (SQLite3Stmt psm) = do - ret <- c_sqlite3_finalize psm - when (ret /= sQLITE_OK) $ - ioError . userError $ - "Cannot finalize stmt: error code (" ++ show ret ++ ")" - -data ResultCode = SQLiteBusy | SQLiteRow | SQLiteDone deriving Show - -foreign import ccall unsafe "sqlite3.h sqlite3_step" c_sqlite3_step :: - Ptr SQLite3Stmt -> IO CInt - -step :: SQLite3Stmt -> IO ResultCode -step (SQLite3Stmt psm) = do - ret <- c_sqlite3_step psm - case ret of - _ | ret == sQLITE_BUSY -> return SQLiteBusy - | ret == sQLITE_ROW -> return SQLiteRow - | ret == sQLITE_DONE -> return SQLiteDone - _ -> ioError . userError $ - "Error while step: error code (" ++ show ret ++ ")" - -foreign import ccall unsafe "sqlite3.h sqlite3_column_int" - c_sqlite3_column_int :: Ptr SQLite3Stmt -> CInt -> IO CInt -foreign import ccall unsafe "sqlite3.h sqlite3_column_text" - c_sqlite3_column_text :: Ptr SQLite3Stmt -> CInt -> IO CString - -class SQLite3DataList a where - columnList :: SQLite3Stmt -> Int -> IO [a] - -class SQLite3Data a where - column :: SQLite3Stmt -> Int -> IO a - -instance SQLite3DataList a => SQLite3Data [a] where - column = columnList - -instance SQLite3Data Int where - column (SQLite3Stmt sm) i = - fromIntegral <$> c_sqlite3_column_int sm (fromIntegral i) - -instance SQLite3DataList Char where - columnList (SQLite3Stmt sm) i = - peekCString =<< c_sqlite3_column_text sm (fromIntegral i) - -instance SQLite3Data BS.ByteString where - column (SQLite3Stmt sm) i = - BS.packCString =<< c_sqlite3_column_text sm (fromIntegral i) - -instance SQLite3Data T.Text where - column sm i = T.decodeUtf8 <$> column sm i diff --git a/src/Database/SQLite3/Constants.hsc b/src/Database/SQLite3/Constants.hsc deleted file mode 100644 --- a/src/Database/SQLite3/Constants.hsc +++ /dev/null @@ -1,15 +0,0 @@ -#include - -module Database.SQLite3.Constants ( - sQLITE_OK, sQLITE_ERROR, sQLITE_BUSY, - sQLITE_ROW, sQLITE_DONE - ) where - -import Foreign.C.Types - -sQLITE_OK, sQLITE_ERROR, sQLITE_BUSY, sQLITE_ROW, sQLITE_DONE :: CInt -sQLITE_OK = #const SQLITE_OK -sQLITE_ERROR = #const SQLITE_ERROR -sQLITE_BUSY = #const SQLITE_BUSY -sQLITE_ROW = #const SQLITE_ROW -sQLITE_DONE = #const SQLITE_DONE diff --git a/src/Database/SmplstSQLite3.hs b/src/Database/SmplstSQLite3.hs new file mode 100644 --- /dev/null +++ b/src/Database/SmplstSQLite3.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE TupleSections #-} + +module Database.SmplstSQLite3 ( + SQLite3, withSQLite3, withPrepared, step, column) where + +import Control.Applicative +import Control.Monad +import Control.Exception +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Foreign +import Foreign.C.Types +import Foreign.C.String + +import Database.SQLite3.Constants + +data SQLite3 = SQLite3 (Ptr SQLite3) deriving Show +data SQLite3Stmt = SQLite3Stmt (Ptr SQLite3Stmt) deriving Show + +foreign import ccall unsafe "sqlite3.h sqlite3_open" c_sqlite3_open :: + CString -> Ptr (Ptr SQLite3) -> IO CInt +foreign import ccall unsafe "sqlite3.h sqlite3_close" c_sqlite3_close :: + Ptr SQLite3 -> IO CInt +foreign import ccall unsafe "sqlite3.h sqlite3_errmsg" c_sqlite3_errmsg :: + Ptr SQLite3 -> IO CString + +withSQLite3 :: String -> (SQLite3 -> IO a) -> IO a +withSQLite3 fp = bracket (sqlite3Open fp) sqlite3Close + +sqlite3Open :: String -> IO SQLite3 +sqlite3Open fp = withCString fp $ \cfp -> alloca $ \ppDb -> do + ret <- c_sqlite3_open cfp ppDb + db <- peek ppDb + let sq = SQLite3 db + when (ret /= sQLITE_OK) $ do + em <- sqlite3Errmsg sq + sqlite3Close sq + ioError . userError $ "Cannot open database: " ++ em + return sq + +sqlite3Close :: SQLite3 -> IO () +sqlite3Close sq@(SQLite3 db) = do + ret <- c_sqlite3_close db + when (ret /= sQLITE_OK) $ do + em <- sqlite3Errmsg sq + ioError . userError $ "Cannot close database: " ++ em + +sqlite3Errmsg :: SQLite3 -> IO String +sqlite3Errmsg (SQLite3 db) = peekCString =<< c_sqlite3_errmsg db + +foreign import ccall unsafe "sqlite3.h sqlite3_prepare_v2" + c_sqlite3_prepare_v2 :: + Ptr SQLite3 -> CString -> CInt -> Ptr (Ptr SQLite3Stmt) -> + (Ptr CString) -> IO CInt +foreign import ccall unsafe "sqlite3.h sqlite3_finalize" c_sqlite3_finalize :: + Ptr SQLite3Stmt -> IO CInt + +withPrepared :: SQLite3 -> String -> (SQLite3Stmt -> IO a) -> IO (a, String) +withPrepared db sql act = + bracket (sqlite3PrepareV2 db sql) (sqlite3Finalize . fst) $ + \(sm, t) -> (, t) <$> act sm + +sqlite3PrepareV2 :: SQLite3 -> String -> IO (SQLite3Stmt, String) +sqlite3PrepareV2 db@(SQLite3 pdb) sql = + withCString sql $ \csql -> alloca $ \psm -> alloca $ \pt -> do + ret <- c_sqlite3_prepare_v2 pdb csql (- 1) psm pt + sm <- SQLite3Stmt <$> peek psm + when (ret /= sQLITE_OK) $ do + em <- sqlite3Errmsg db + sqlite3Finalize sm + ioError . userError $ "Cannot prepare: " ++ em + (sm ,) <$> (peekCString =<< peek pt) + +sqlite3Finalize :: SQLite3Stmt -> IO () +sqlite3Finalize (SQLite3Stmt psm) = do + ret <- c_sqlite3_finalize psm + when (ret /= sQLITE_OK) $ + ioError . userError $ + "Cannot finalize stmt: error code (" ++ show ret ++ ")" + +data ResultCode = SQLiteBusy | SQLiteRow | SQLiteDone deriving Show + +foreign import ccall unsafe "sqlite3.h sqlite3_step" c_sqlite3_step :: + Ptr SQLite3Stmt -> IO CInt + +step :: SQLite3Stmt -> IO ResultCode +step (SQLite3Stmt psm) = do + ret <- c_sqlite3_step psm + case ret of + _ | ret == sQLITE_BUSY -> return SQLiteBusy + | ret == sQLITE_ROW -> return SQLiteRow + | ret == sQLITE_DONE -> return SQLiteDone + _ -> ioError . userError $ + "Error while step: error code (" ++ show ret ++ ")" + +foreign import ccall unsafe "sqlite3.h sqlite3_column_int" + c_sqlite3_column_int :: Ptr SQLite3Stmt -> CInt -> IO CInt +foreign import ccall unsafe "sqlite3.h sqlite3_column_text" + c_sqlite3_column_text :: Ptr SQLite3Stmt -> CInt -> IO CString + +class SQLite3DataList a where + columnList :: SQLite3Stmt -> Int -> IO [a] + +class SQLite3Data a where + column :: SQLite3Stmt -> Int -> IO a + +instance SQLite3DataList a => SQLite3Data [a] where + column = columnList + +instance SQLite3Data Int where + column (SQLite3Stmt sm) i = + fromIntegral <$> c_sqlite3_column_int sm (fromIntegral i) + +instance SQLite3DataList Char where + columnList (SQLite3Stmt sm) i = + peekCString =<< c_sqlite3_column_text sm (fromIntegral i) + +instance SQLite3Data BS.ByteString where + column (SQLite3Stmt sm) i = + BS.packCString =<< c_sqlite3_column_text sm (fromIntegral i) + +instance SQLite3Data T.Text where + column sm i = T.decodeUtf8 <$> column sm i diff --git a/src/Database/SmplstSQLite3/Constants.hsc b/src/Database/SmplstSQLite3/Constants.hsc new file mode 100644 --- /dev/null +++ b/src/Database/SmplstSQLite3/Constants.hsc @@ -0,0 +1,15 @@ +#include + +module Database.SmplstSQLite3.Constants ( + sQLITE_OK, sQLITE_ERROR, sQLITE_BUSY, + sQLITE_ROW, sQLITE_DONE + ) where + +import Foreign.C.Types + +sQLITE_OK, sQLITE_ERROR, sQLITE_BUSY, sQLITE_ROW, sQLITE_DONE :: CInt +sQLITE_OK = #const SQLITE_OK +sQLITE_ERROR = #const SQLITE_ERROR +sQLITE_BUSY = #const SQLITE_BUSY +sQLITE_ROW = #const SQLITE_ROW +sQLITE_DONE = #const SQLITE_DONE