never executed always true always false
    1 {-|
    2 Module: Flaw.Data.Sqlite
    3 Description: Simple SQLite Haskell interface.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE PatternSynonyms #-}
    8 {-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures #-}
    9 
   10 module Flaw.Data.Sqlite
   11   ( SqliteDb()
   12   , SqliteStmt()
   13   , SqliteQuery()
   14   , sqliteDb
   15   , sqliteExec
   16   , sqliteStmt
   17   , sqliteQuery
   18   , sqliteStep
   19   , sqliteFinalStep
   20   , sqliteTransaction
   21   , SqliteData(..)
   22   , sqliteLastInsertRowId
   23   ) where
   24 
   25 import Control.Exception
   26 import Control.Monad
   27 import qualified Data.ByteString as B
   28 import qualified Data.ByteString.Unsafe as B
   29 import Data.Int
   30 import Data.IORef
   31 import qualified Data.Text as T
   32 import qualified Data.Text.Encoding as T
   33 import Foreign.C.String
   34 import Foreign.C.Types
   35 import Foreign.Marshal.Alloc
   36 import Foreign.Ptr
   37 import Foreign.Storable
   38 
   39 import Flaw.Book
   40 
   41 data SqliteDb = SqliteDb
   42   { sqliteDbPtr :: !(Ptr C_sqlite3)
   43   , sqliteDbSavePointStmtPtr :: !(Ptr C_sqlite3_stmt)
   44   , sqliteDbReleaseStmtPtr :: !(Ptr C_sqlite3_stmt)
   45   , sqliteDbRollbackToStmtPtr :: !(Ptr C_sqlite3_stmt)
   46   }
   47 
   48 data SqliteStmt = SqliteStmt
   49   { sqliteStmtPtr :: !(Ptr C_sqlite3_stmt)
   50   , sqliteStmtDbPtr :: !(Ptr C_sqlite3)
   51   }
   52 
   53 newtype SqliteQuery = SqliteQuery SqliteStmt
   54 
   55 -- | Open SQLite database.
   56 sqliteDb :: T.Text -> IO (SqliteDb, IO ())
   57 sqliteDb fileName = withSpecialBook $ \bk -> do
   58   -- open db
   59   dbPtr <- book bk $ B.useAsCString (T.encodeUtf8 fileName) $ \fileNamePtr -> alloca $ \dbPtrPtr -> do
   60     r <- sqlite3_open fileNamePtr dbPtrPtr
   61     dbPtr <- peek dbPtrPtr
   62     when (r /= SQLITE_OK) $ do
   63       when (dbPtr /= nullPtr) $ void $ sqlite3_close dbPtr
   64       throwIO $ SqliteOpenError fileName
   65     return (dbPtr, void $ sqlite3_close dbPtr)
   66 
   67   -- create transaction statements
   68 
   69   let
   70     createStmt str = do
   71       stmtPtr <- alloca $ \stmtPtrPtr -> do
   72         sqliteCheckError dbPtr (== SQLITE_OK) $ withCString str $ \strPtr -> sqlite3_prepare_v2 dbPtr strPtr (-1) stmtPtrPtr nullPtr
   73         peek stmtPtrPtr
   74       book bk $ return (stmtPtr, void $ sqlite3_finalize stmtPtr)
   75 
   76   savePointStmtPtr <- createStmt "SAVEPOINT T"
   77   releaseStmtPtr <- createStmt "RELEASE T"
   78   rollbackToStmtPtr <- createStmt "ROLLBACK TO T"
   79 
   80   return SqliteDb
   81     { sqliteDbPtr = dbPtr
   82     , sqliteDbSavePointStmtPtr = savePointStmtPtr
   83     , sqliteDbReleaseStmtPtr = releaseStmtPtr
   84     , sqliteDbRollbackToStmtPtr = rollbackToStmtPtr
   85     }
   86 
   87 -- | Execute one-time query.
   88 sqliteExec :: SqliteDb -> T.Text -> IO ()
   89 sqliteExec SqliteDb
   90   { sqliteDbPtr = dbPtr
   91   } text =
   92   sqliteCheckError dbPtr (== SQLITE_OK) $ B.useAsCString (T.encodeUtf8 text) $ \textPtr -> sqlite3_exec dbPtr textPtr nullFunPtr nullPtr nullPtr
   93 
   94 -- | Create SQLite statement.
   95 sqliteStmt :: SqliteDb -> T.Text -> IO (SqliteStmt, IO ())
   96 sqliteStmt SqliteDb
   97   { sqliteDbPtr = dbPtr
   98   } text = do
   99   stmtPtr <- alloca $ \stmtPtrPtr -> do
  100     sqliteCheckError dbPtr (== SQLITE_OK) $ B.unsafeUseAsCStringLen (T.encodeUtf8 text) $ \(textPtr, textLen) -> sqlite3_prepare_v2 dbPtr textPtr (fromIntegral textLen) stmtPtrPtr nullPtr
  101     peek stmtPtrPtr
  102   return (SqliteStmt
  103     { sqliteStmtPtr = stmtPtr
  104     , sqliteStmtDbPtr = dbPtr
  105     }, void $ sqlite3_finalize stmtPtr)
  106 
  107 -- | Get query object from statement.
  108 -- Just to reset statement afterwards.
  109 sqliteQuery :: SqliteStmt -> (SqliteQuery -> IO a) -> IO a
  110 sqliteQuery stmt@SqliteStmt
  111   { sqliteStmtPtr = stmtPtr
  112   } action = finally (action (SqliteQuery stmt)) $ do
  113   void $ sqlite3_reset stmtPtr
  114   void $ sqlite3_clear_bindings stmtPtr
  115 
  116 -- | Perform query step.
  117 -- Returns True if step succeeded and there's row of data.
  118 -- Returns False if step succeeded, but there's no data anymore.
  119 -- Throws an exception otherwise.
  120 sqliteStep :: SqliteQuery -> IO Bool
  121 sqliteStep (SqliteQuery SqliteStmt
  122   { sqliteStmtPtr = stmtPtr
  123   , sqliteStmtDbPtr = dbPtr
  124   }) = do
  125   r <- sqlite3_step stmtPtr
  126   case r of
  127     SQLITE_ROW -> return True
  128     SQLITE_DONE -> return False
  129     _ -> throwSqliteError dbPtr
  130 
  131 -- | Perform query step, and check that it returned SQLITE_DONE.
  132 sqliteFinalStep :: SqliteQuery -> IO ()
  133 sqliteFinalStep query = do
  134   r <- sqliteStep query
  135   when r $ throwIO SqliteStepNotFinal
  136 
  137 -- | Perform SQLite transaction.
  138 sqliteTransaction :: SqliteDb -> (IO () -> IO a) -> IO a
  139 sqliteTransaction SqliteDb
  140   { sqliteDbPtr = dbPtr
  141   , sqliteDbSavePointStmtPtr = savePointStmtPtr
  142   , sqliteDbReleaseStmtPtr = releaseStmtPtr
  143   , sqliteDbRollbackToStmtPtr = rollbackToStmtPtr
  144   } io = do
  145   -- save point
  146   void $ sqlite3_reset savePointStmtPtr
  147   sqliteCheckError dbPtr (== SQLITE_DONE) $ sqlite3_step savePointStmtPtr
  148   -- commit function
  149   finishedRef <- newIORef False
  150   let
  151     commit = do
  152       -- check that transaction is not finished
  153       finished <- readIORef finishedRef
  154       when finished $ throwIO SqliteTransactionAlreadyFinished
  155       -- commit
  156       void $ sqlite3_reset releaseStmtPtr
  157       sqliteCheckError dbPtr (== SQLITE_DONE) $ sqlite3_step releaseStmtPtr
  158       -- remember
  159       writeIORef finishedRef True
  160   finally (io commit) $ do
  161     -- rollback if not finished
  162     finished <- readIORef finishedRef
  163     unless finished $ do
  164       void $ sqlite3_reset rollbackToStmtPtr
  165       void $ sqlite3_step rollbackToStmtPtr
  166       void $ sqlite3_reset releaseStmtPtr
  167       void $ sqlite3_step releaseStmtPtr
  168 
  169 -- | Class of data which could be used in statements.
  170 class SqliteData a where
  171   -- | Bind data into statement.
  172   sqliteBind :: SqliteQuery -> CInt -> a -> IO ()
  173   -- | Get data from query.
  174   sqliteColumn :: SqliteQuery -> CInt -> IO a
  175 
  176 instance SqliteData CInt where
  177   sqliteBind (SqliteQuery SqliteStmt
  178     { sqliteStmtPtr = stmtPtr
  179     , sqliteStmtDbPtr = dbPtr
  180     }) column value = sqliteCheckError dbPtr (== SQLITE_OK) $ sqlite3_bind_int stmtPtr column value
  181   sqliteColumn (SqliteQuery SqliteStmt
  182     { sqliteStmtPtr = stmtPtr
  183     }) = sqlite3_column_int stmtPtr
  184 
  185 instance SqliteData Int64 where
  186   sqliteBind (SqliteQuery SqliteStmt
  187     { sqliteStmtPtr = stmtPtr
  188     , sqliteStmtDbPtr = dbPtr
  189     }) column value = sqliteCheckError dbPtr (== SQLITE_OK) $ sqlite3_bind_int64 stmtPtr column value
  190   sqliteColumn (SqliteQuery SqliteStmt
  191     { sqliteStmtPtr = stmtPtr
  192     }) = sqlite3_column_int64 stmtPtr
  193 
  194 instance SqliteData B.ByteString where
  195   sqliteBind (SqliteQuery SqliteStmt
  196     { sqliteStmtPtr = stmtPtr
  197     , sqliteStmtDbPtr = dbPtr
  198     }) column bytes = sqliteCheckError dbPtr (== SQLITE_OK) $ B.unsafeUseAsCStringLen bytes $ \(ptr, len) ->
  199     -- note: we are forcing non-null pointer in case of zero-length bytestring, in order to bind a blob and not a NULL value
  200     sqlite3_bind_blob stmtPtr column (if len > 0 then castPtr ptr else intPtrToPtr 1) (fromIntegral len) $ castPtrToFunPtr $ intPtrToPtr SQLITE_TRANSIENT
  201   sqliteColumn (SqliteQuery SqliteStmt
  202     { sqliteStmtPtr = stmtPtr
  203     }) column = do
  204     ptr <- sqlite3_column_blob stmtPtr column
  205     len <- sqlite3_column_bytes stmtPtr column
  206     B.packCStringLen (castPtr ptr, fromIntegral len)
  207 
  208 instance SqliteData T.Text where
  209   sqliteBind (SqliteQuery SqliteStmt
  210     { sqliteStmtPtr = stmtPtr
  211     , sqliteStmtDbPtr = dbPtr
  212     }) column text = sqliteCheckError dbPtr (== SQLITE_OK) $ B.unsafeUseAsCStringLen (T.encodeUtf8 text) $ \(ptr, len) ->
  213     -- note: we are forcing non-null pointer in case of zero-length string, in order to bind a string and not a NULL value
  214     sqlite3_bind_text stmtPtr column (if len > 0 then ptr else intPtrToPtr 1) (fromIntegral len) $ castPtrToFunPtr $ intPtrToPtr SQLITE_TRANSIENT
  215   sqliteColumn (SqliteQuery SqliteStmt
  216     { sqliteStmtPtr = stmtPtr
  217     }) column = do
  218     ptr <- sqlite3_column_text stmtPtr column
  219     len <- sqlite3_column_bytes stmtPtr column
  220     T.decodeUtf8 <$> B.packCStringLen (ptr, fromIntegral len)
  221 
  222 sqliteLastInsertRowId :: SqliteDb -> IO Int64
  223 sqliteLastInsertRowId SqliteDb
  224   { sqliteDbPtr = dbPtr
  225   } = sqlite3_last_insert_rowid dbPtr
  226 
  227 throwSqliteError :: Ptr C_sqlite3 -> IO a
  228 throwSqliteError dbPtr = do
  229   errCode <- sqlite3_errcode dbPtr
  230   errMsgPtr <- sqlite3_errmsg dbPtr
  231   errMsgBytes <- B.packCString errMsgPtr
  232   throwIO $ SqliteError (fromIntegral errCode) (T.decodeUtf8 errMsgBytes)
  233 
  234 sqliteCheckError :: Ptr C_sqlite3 -> (CInt -> Bool) -> IO CInt -> IO ()
  235 sqliteCheckError dbPtr cond io = do
  236   r <- io
  237   unless (cond r) $ throwSqliteError dbPtr
  238 
  239 data SqliteError
  240   = SqliteError {-# UNPACK #-} !Int !T.Text
  241   | SqliteOpenError !T.Text
  242   | SqliteStepNotFinal
  243   | SqliteTransactionAlreadyFinished
  244   deriving Show
  245 
  246 instance Exception SqliteError
  247 
  248 -- FFI: types
  249 
  250 data C_sqlite3
  251 data C_sqlite3_stmt
  252 
  253 -- FFI: functions
  254 
  255 foreign import ccall safe sqlite3_open :: Ptr CChar -> Ptr (Ptr C_sqlite3) -> IO CInt
  256 foreign import ccall safe sqlite3_close :: Ptr C_sqlite3 -> IO CInt
  257 foreign import ccall safe sqlite3_prepare_v2 :: Ptr C_sqlite3 -> Ptr CChar -> CInt -> Ptr (Ptr C_sqlite3_stmt) -> Ptr (Ptr CChar) -> IO CInt
  258 foreign import ccall unsafe sqlite3_reset :: Ptr C_sqlite3_stmt -> IO CInt
  259 foreign import ccall safe sqlite3_step :: Ptr C_sqlite3_stmt -> IO CInt
  260 foreign import ccall unsafe sqlite3_clear_bindings :: Ptr C_sqlite3_stmt -> IO CInt
  261 foreign import ccall unsafe sqlite3_finalize :: Ptr C_sqlite3_stmt -> IO CInt
  262 foreign import ccall safe sqlite3_exec :: Ptr C_sqlite3 -> Ptr CChar -> FunPtr (Ptr () -> CInt -> Ptr (Ptr CChar) -> Ptr (Ptr CChar) -> IO CInt) -> Ptr () -> Ptr (Ptr CChar) -> IO CInt
  263 
  264 foreign import ccall unsafe sqlite3_bind_int :: Ptr C_sqlite3_stmt -> CInt -> CInt -> IO CInt
  265 foreign import ccall unsafe sqlite3_bind_int64 :: Ptr C_sqlite3_stmt -> CInt -> Int64 -> IO CInt
  266 foreign import ccall safe sqlite3_bind_blob :: Ptr C_sqlite3_stmt -> CInt -> Ptr () -> CInt -> FunPtr (Ptr () -> IO ()) -> IO CInt
  267 foreign import ccall unsafe sqlite3_bind_text :: Ptr C_sqlite3_stmt -> CInt -> Ptr CChar -> CInt -> FunPtr (Ptr () -> IO ()) -> IO CInt
  268 --foreign import ccall unsafe sqlite3_bind_null :: Ptr C_sqlite3_stmt -> CInt -> IO CInt
  269 
  270 foreign import ccall unsafe sqlite3_column_int :: Ptr C_sqlite3_stmt -> CInt -> IO CInt
  271 foreign import ccall unsafe sqlite3_column_int64 :: Ptr C_sqlite3_stmt -> CInt -> IO Int64
  272 foreign import ccall unsafe sqlite3_column_blob :: Ptr C_sqlite3_stmt -> CInt -> IO (Ptr ())
  273 foreign import ccall unsafe sqlite3_column_bytes :: Ptr C_sqlite3_stmt -> CInt -> IO CInt
  274 foreign import ccall unsafe sqlite3_column_text :: Ptr C_sqlite3_stmt -> CInt -> IO (Ptr CChar)
  275 
  276 foreign import ccall unsafe sqlite3_last_insert_rowid :: Ptr C_sqlite3 -> IO Int64
  277 
  278 foreign import ccall unsafe sqlite3_errcode :: Ptr C_sqlite3 -> IO CInt
  279 foreign import ccall unsafe sqlite3_errmsg :: Ptr C_sqlite3 -> IO (Ptr CChar)
  280 
  281 -- FFI: values
  282 
  283 pattern SQLITE_OK = 0
  284 pattern SQLITE_ROW = 100
  285 pattern SQLITE_DONE = 101
  286 
  287 pattern SQLITE_TRANSIENT = -1