selda-sqlite 0.1.4.0 → 0.1.5.0

raw patch · 2 files changed

+74/−42 lines, 2 filesdep ~seldaPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: selda

API changes (from Hackage documentation)

Files

• selda-sqlite.cabal +2/−2
• src/Database/Selda/SQLite.hs +72/−40

@@ -1,5 +1,5 @@ name:                selda-sqlite-version:             0.1.4.0+version:             0.1.5.0 synopsis:            SQLite backend for the Selda database EDSL. description:         SQLite backend for the Selda database EDSL. homepage:            https://github.com/valderman/selda@@ -24,7 +24,7 @@   build-depends:       base          >=4.8     && <5     , exceptions    >=0.8     && <0.9-    , selda         >=0.1.7.0 && <0.2+    , selda         >=0.1.8.0 && <0.2     , text          >=1.0     && <1.3   if !flag(haste)     build-depends:

@@ -1,16 +1,31 @@ {-# LANGUAGE GADTs, CPP, OverloadedStrings #-} -- | SQLite3 backend for Selda.-module Database.Selda.SQLite (withSQLite) where+module Database.Selda.SQLite (withSQLite, sqliteOpen, seldaClose) where import Database.Selda import Database.Selda.Backend+import Data.Dynamic import Data.Text (pack) import Control.Monad.Catch-import Control.Concurrent #ifndef __HASTE__ import Database.SQLite3 import System.Directory (makeAbsolute) #endif +-- | Open a new connection to an SQLite database.+--   The connection is reusable across calls to `runSeldaT`, and must be+--   explicitly closed using 'seldaClose' when no longer needed.+sqliteOpen :: (MonadIO m, MonadCatch m) => FilePath -> m SeldaConnection+sqliteOpen file = do+  edb <- try $ liftIO $ open (pack file)+  case edb of+    Left e@(SQLError{}) -> do+      throwM (DbError (show e))+    Right db -> do+      absFile <- liftIO $ pack <$> makeAbsolute file+      let backend = sqliteBackend db+      liftIO $ runStmt backend "PRAGMA foreign_keys = ON;" []+      newConnection backend absFile+ -- | Perform the given computation over an SQLite database. --   The database is guaranteed to be closed when the computation terminates. withSQLite :: (MonadIO m, MonadMask m) => FilePath -> SeldaT m a -> m a@@ -18,54 +33,70 @@ withSQLite _ _ = return $ error "withSQLite called in JS context" #else withSQLite file m = do-  lock <- liftIO $ newMVar ()-  edb <- try $ liftIO $ open (pack file)-  case edb of-    Left e@(SQLError{}) -> do-      throwM (DbError (show e))-    Right db -> do-      absFile <- liftIO $ makeAbsolute file-      let backend = sqliteBackend lock absFile db-      liftIO $ runStmt backend "PRAGMA foreign_keys = ON;" []-      runSeldaT m backend `finally` liftIO (close db)+  conn <- sqliteOpen file+  runSeldaT m conn `finally` seldaClose conn -sqliteBackend :: MVar () -> FilePath -> Database -> SeldaBackend-sqliteBackend lock dbfile db = SeldaBackend-  { runStmt        = \q ps -> snd <$> sqliteQueryRunner lock db q ps-  , runStmtWithPK  = \q ps -> fst <$> sqliteQueryRunner lock db q ps-  , customColType  = \_ _ -> Nothing-  , defaultKeyword = "NULL"-  , dbIdentifier   = pack dbfile+sqliteBackend :: Database -> SeldaBackend+sqliteBackend db = SeldaBackend+  { runStmt         = \q ps -> snd <$> sqliteQueryRunner db q ps+  , runStmtWithPK   = \q ps -> fst <$> sqliteQueryRunner db q ps+  , prepareStmt     = \_ _ -> sqlitePrepare db+  , runPrepared     = sqliteRunPrepared db+  , ppConfig        = defPPConfig+  , backendId       = SQLite+  , closeConnection = \conn -> do+      stmts <- allStmts conn+      flip mapM_ stmts $ \(_, stm) -> do+        finalize $ fromDyn stm (error "BUG: non-statement SQLite statement")+      close db   } -sqliteQueryRunner :: MVar () -> Database -> QueryRunner (Int, (Int, [[SqlValue]]))-sqliteQueryRunner lock db qry params = do+sqlitePrepare :: Database -> Text -> IO Dynamic+sqlitePrepare db qry = do+  eres <- try $ prepare db qry+  case eres of+    Left e@(SQLError{}) -> throwM (SqlError (show e))+    Right r             -> return $ toDyn r++sqliteRunPrepared :: Database -> Dynamic -> [Param] -> IO (Int, [[SqlValue]])+sqliteRunPrepared db hdl params = do+  eres <- try $ do+    let Just stm = fromDynamic hdl+    sqliteRunStmt db stm params `finally` do+      clearBindings stm+      reset stm+  case eres of+    Left e@(SQLError{}) -> throwM (SqlError (show e))+    Right res           -> return (snd res)++sqliteQueryRunner :: Database -> QueryRunner (Int, (Int, [[SqlValue]]))+sqliteQueryRunner db qry params = do     eres <- try $ do       stm <- prepare db qry-      takeMVar lock-      go stm `finally` do-        putMVar lock ()+      sqliteRunStmt db stm params `finally` do         finalize stm     case eres of       Left e@(SQLError{}) -> throwM (SqlError (show e))       Right res           -> return res-  where-    go stm = do-      bind stm [toSqlData p | Param p <- params]-      rows <- getRows stm []-      rid <- lastInsertRowId db-      cs <- changes db-      return (fromIntegral rid, (cs, [map fromSqlData r | r <- rows])) -    getRows s acc = do-      res <- step s-      case res of-        Row -> do-          cs <- columns s-          getRows s (cs : acc)-        _ -> do-          return $ reverse acc+sqliteRunStmt :: Database -> Statement -> [Param] -> IO (Int, (Int, [[SqlValue]]))+sqliteRunStmt db stm params = do+  bind stm [toSqlData p | Param p <- params]+  rows <- getRows stm []+  rid <- lastInsertRowId db+  cs <- changes db+  return (fromIntegral rid, (cs, [map fromSqlData r | r <- rows])) +getRows :: Statement -> [[SQLData]] -> IO [[SQLData]]+getRows s acc = do+  res <- step s+  case res of+    Row -> do+      cs <- columns s+      getRows s (cs : acc)+    _ -> do+      return $ reverse acc+ toSqlData :: Lit a -> SQLData toSqlData (LInt i)      = SQLInteger $ fromIntegral i toSqlData (LDouble d)   = SQLFloat d@@ -74,6 +105,7 @@ toSqlData (LDate s)     = SQLText s toSqlData (LTime s)     = SQLText s toSqlData (LBool b)     = SQLInteger $ if b then 1 else 0+toSqlData (LBlob b)     = SQLBlob b toSqlData (LNull)       = SQLNull toSqlData (LJust x)     = toSqlData x toSqlData (LCustom l)   = toSqlData l@@ -82,6 +114,6 @@ fromSqlData (SQLInteger i) = SqlInt $ fromIntegral i fromSqlData (SQLFloat f)   = SqlFloat f fromSqlData (SQLText s)    = SqlString s-fromSqlData (SQLBlob _)    = error "BUG: SQLite returned BLOB"+fromSqlData (SQLBlob b)    = SqlBlob b fromSqlData SQLNull        = SqlNull #endif