packages feed

hsSqlite3 0.0.1 → 0.0.2

raw patch · 4 files changed

+417/−153 lines, 4 filesdep +mtldep +stateLocaldep +utf8-string

Dependencies added: mtl, stateLocal, utf8-string

Files

hsSqlite3.cabal view
@@ -1,7 +1,7 @@ Name: hsSqlite3-Version: 0.0.1+Version: 0.0.2 License: LGPL-Maintainer: Evgeny Jukov <johnny@oleron.ru>+Maintainer: Evgeny Jukov <masloed@gmail.com> Author: Evgeny Jukov Stability: Alpha Copyright: Copyright (c) 2007 Evgeny Jukov@@ -14,7 +14,7 @@ Exposed-Modules:    Database.Sqlite3,   Database.Sqlite3.Low-Build-Depends: base+Build-Depends: base, utf8-string, mtl, stateLocal GHC-Options: -O2  Executable: hs_sqlite3_test
src/Database/Sqlite3.hs view
@@ -1,9 +1,13 @@+{-# options -fglasgow-exts -farrows #-}+ module Database.Sqlite3  ( module Database.Sqlite3.Low  , Val ( IntV, Int64V, DoubleV, TextV, BlobV, NullV )  , fetch  , bind  , fetchOne+ , fetchOK+ , sql  ) where  import Data.Char@@ -11,67 +15,184 @@ import Data.Int import Database.Sqlite3.Low import qualified Data.ByteString as B-import System.IO.Unsafe import Control.Arrow +import Control.Monad.Trans+import Control.Monad.Error+import Control.Monad.State.Lazy++import Data.Monoid++import Data.StateLocal hiding (fetch)++import qualified Codec.Binary.UTF8.String as UTF8++--++class ValID a where+ valID  :: a -> Int++class ValFetch a where+ valFetch :: LocalState s StateDb => (Int,Int) -> StateT s IO a++class ValBind a where+ valBind :: LocalState s StateDb => (Int,a) -> StateT s IO ()++class ValID a => ValCast a b where+ valCast :: a -> b+ data Val  = IntV    Int  | Int64V  Int64  | DoubleV Double  | TextV   String- | BlobV   Bytes+ | BlobV   B.ByteString  | NullV  deriving Show -fetch :: DB -> String -> IO (Stmt, [[Val]])-fetch db sql = do- st <- prepare db sql- end <- step st- tab <- case end of-  True -> err "oneStep: no result"+instance ValID Val where+ valID (IntV    _) = 1+ valID (Int64V  _) = 1+ valID (DoubleV _) = 2+ valID (TextV   _) = 3+ valID (BlobV   _) = 4+ valID  NullV      = 5++instance ValFetch Val where+ valFetch (t,n) = do+  case t of+   1 -> liftM IntV    $ column_int n+   2 -> liftM DoubleV $ column_double n+   3 -> liftM TextV   $ column_text n+   4 -> liftM BlobV   $ column_blob n+   5 -> return NullV++instance ValBind Val where+ valBind (t,v) = do+  case v of+   IntV a -> bind_int (t,a)+   TextV a -> bind_text (t,a)++instance ValCast Val Int where+ valCast (IntV a) = a++instance ValCast Val Double where+ valCast (DoubleV a) = a++instance ValCast Val String where+ valCast (TextV a) = a++instance ValCast Val B.ByteString where+ valCast (BlobV a) = a++instance ValCast Val () where+ valCast NullV = ()++instance ValID Int          where valID _ = 1+instance ValID Double       where valID _ = 2+instance ValID String       where valID _ = 3+instance ValID B.ByteString where valID _ = 4+instance ValID ()           where valID _ = 5++reqType t' a (t,v) =  do+ errIf (t'/=t) "ValFetch"+ a v++instance ValFetch Int where+ valFetch = reqType 1 column_int++instance ValFetch Double where+ valFetch = reqType 2 column_double++instance ValFetch String where+ valFetch = reqType 3 column_text++instance ValFetch B.ByteString where+ valFetch = reqType 4 column_blob++instance ValFetch () where+ valFetch = reqType 5 (\_ -> return ())++instance ValBind Int where+ valBind = bind_int++instance ValBind String where+ valBind = bind_text++instance ValCast Int Val where+ valCast a = IntV a++instance ValCast Double Val where+ valCast a = DoubleV a++instance ValCast String Val where+ valCast a = TextV a++instance ValCast B.ByteString Val where+ valCast a = BlobV a++instance ValCast () Val where+ valCast a = NullV++--++fetch ::+ forall a s sql .+ ( ValFetch a+ --, GetCString sql IO+ , LocalState s StateDb+ --, Show sql+ )+ => String -> StateT s IO [[a]]+fetch sql = do+ liftIO $ putStr $ UTF8.encodeString $ sql++"\n"+ prepare sql+ stat <- step+ case stat of+  True -> finalize >> return []   False -> do-   cn <- column_count st-   ty <- mapM (column_type st) [0..cn-1]-   let ft = sequence $ map (conv st) (zip ty [0..])+   cn <- column_count+   ty <- mapM column_type [0..cn-1]+   let ft = mapM valFetch (zip ty [0..])    x <- ft-   xs <- fetchRow st ft+   xs <- fetchRow ft+   finalize    return (x:xs)- return (st,tab)  where-  conv st (1,n) = uns $ liftM IntV    $ column_int    st n-  conv st (2,n) = uns $ liftM DoubleV $ column_double st n-  conv st (3,n) = uns $ liftM TextV   $ column_text   st n-  conv st (4,n) = uns $ liftM BlobV   $ column_blob   st n-  conv st (5,_) = return NullV--  fetchRow :: Stmt -> IO [Val] -> IO [[Val]]-  fetchRow st ft = uns $ do-   end <- step st+  fetchRow ft = do+   end <- step    case end of     True -> return []     False -> do-     x <- uns ft-     xs <- fetchRow st ft+     x <- ft+     xs <- fetchRow ft      return (x:xs) -bind :: DB -> String -> [[Val]] -> IO ()-bind db sql tab = do- st <- prepare db sql- let f row = sequence $ map (conv st) $ zip3 (head tab) row [1..]- f (head tab) >> step st- mapM_ (\a -> reset st >> f a >> step st) (tail tab)- finalize st- where-  conv st (IntV  _,IntV  v,n) = bind_int  st n v-  conv st (TextV _,TextV v,n) = bind_text st n v+sql :: ({-Show sql,-} {-GetCString sql IO,-} LocalState s StateDb) => String -> StateT s IO ()+sql sql = do+ liftIO $ putStr $ UTF8.encodeString $ sql++"\n"+ prepare sql+ step+ finalize ---+bind :: ({-Show sql, GetCString sql IO,-} LocalState s StateDb) => String -> [[Val]] -> StateT s IO ()+bind sql tab = do+ liftIO $ putStr $ UTF8.encodeString $ sql++"\n"+ debug tab+ prepare sql+ mapM_ (\row -> mapM_ (\(v,n) -> valBind (n,v)) (zip row [1..]) >> step >> reset) tab+ finalize -fetchOne :: DB -> String -> Int -> IO (Stmt,[Val])-fetchOne db sql num = liftM (second head) $ fetch db sql'- where sql' = concat [sql," LIMIT 1 OFFSET ",show num]- ---+fetchOne' :: forall a s .  (ValFetch a, LocalState s StateDb) => String -> Int -> StateT s IO [[a]]+fetchOne' sql num = fetch sql'+ where sql' = concat [sql," LIMIT 1 OFFSET ", show num] -uns = unsafeInterleaveIO+fetchOne :: forall a s .  (ValFetch a, LocalState s StateDb) => String -> Int -> StateT s IO [a]+fetchOne sql num = liftM head $ fetchOne' sql num +fetchOK :: LocalState s StateDb => String -> StateT s IO Bool+fetchOK sql = do+ tab :: [[Val]] <- fetchOne' sql 0+ case length tab of+  1 -> return True+  _ -> return False
src/Database/Sqlite3/Low.hs view
@@ -1,161 +1,299 @@-{-# options -ffi #-}+{-# options -fglasgow-exts -ffi #-}  module Database.Sqlite3.Low where -import System.IO-import Data.Word import Foreign import Foreign.C++import System.IO+import System.IO.Unsafe+import System.IO.Error hiding (try)++import Control.Monad.Trans+import Control.Monad.Error+import Control.Monad.State.Lazy hiding (get,put)++import qualified Codec.Binary.UTF8.String as UTF8 import qualified Data.ByteString as B -foreign import ccall unsafe "sqlite3_open" open' +import Data.StateLocal hiding (getST)++import Data.Typeable++type Void = Word8++foreign import ccall unsafe "sqlite3_open" c_open  :: CString -> Ptr (Ptr Void) -> IO Int -foreign import ccall unsafe "sqlite3_close" close'+foreign import ccall unsafe "sqlite3_close" c_close  :: Ptr Void -> IO Int -foreign import ccall unsafe "sqlite3_errmsg" errmsg'+foreign import ccall unsafe "sqlite3_errmsg" c_errmsg  :: Ptr Void -> IO CString -foreign import ccall unsafe "sqlite3_prepare_v2" prepare'+foreign import ccall unsafe "sqlite3_prepare_v2" c_prepare  :: Ptr Void -> CString -> Int -> Ptr (Ptr Void) -> Ptr CString -> IO Int -foreign import ccall unsafe "sqlite3_finalize" finalize'+foreign import ccall unsafe "sqlite3_finalize" c_finalize  :: Ptr Void -> IO Int -foreign import ccall unsafe "sqlite3_reset" reset'+foreign import ccall unsafe "sqlite3_reset" c_reset  :: Ptr Void -> IO Int -foreign import ccall unsafe "sqlite3_bind_int" bind_int'+foreign import ccall unsafe "sqlite3_bind_int" c_bind_int  :: Ptr Void -> Int -> Int -> IO Int -foreign import ccall unsafe "sqlite3_bind_text" bind_text'+foreign import ccall unsafe "sqlite3_bind_text" c_bind_text  :: Ptr Void -> Int -> CString -> Int -> Int -> IO Int -foreign import ccall unsafe "sqlite3_step" step'+foreign import ccall unsafe "sqlite3_step" c_step  :: Ptr Void -> IO Int -foreign import ccall unsafe "sqlite3_column_blob" column_blob'+foreign import ccall unsafe "sqlite3_column_blob" c_column_blob  :: Ptr Void -> Int -> IO CString -foreign import ccall unsafe "sqlite3_column_bytes" column_bytes'+foreign import ccall unsafe "sqlite3_column_bytes" c_column_bytes  :: Ptr Void -> Int -> IO Int -foreign import ccall unsafe "sqlite3_column_count" column_count'+foreign import ccall unsafe "sqlite3_column_count" c_column_count  :: Ptr Void -> IO Int -foreign import ccall unsafe "sqlite3_column_int" column_int'+foreign import ccall unsafe "sqlite3_column_int" c_column_int  :: Ptr Void -> Int -> IO Int -foreign import ccall unsafe "sqlite3_column_double" column_double'+foreign import ccall unsafe "sqlite3_column_double" c_column_double  :: Ptr Void -> Int -> IO Double -foreign import ccall unsafe "sqlite3_column_text" column_text'+foreign import ccall unsafe "sqlite3_column_text" c_column_text  :: Ptr Void -> Int -> IO CString -foreign import ccall unsafe "sqlite3_column_type" column_type'+foreign import ccall unsafe "sqlite3_column_type" c_column_type  :: Ptr Void -> Int -> IO Int  -- -type Bytes = B.ByteString-type Void = Word8-data DB = DB (Ptr Void)-data Stmt = Stmt (Ptr Void)+data StateDb = SD+ { dbP :: Maybe (Ptr Void)+ , stP :: Maybe (Ptr Void)+ } deriving (Show, Typeable) -open :: String -> IO DB-open path = do- pptr <- malloc- rc <- withCString path $ \cstr -> open' cstr pptr- ptr <- peek pptr- dbErrRc rc ptr "open"- return (DB ptr)+instance ZeroState StateDb where+ zeroST = SD+  { dbP = Nothing+  , stP = Nothing } -close :: DB -> IO ()-close (DB db) = do- rc <- close' db- dbErrRc rc db "close"+setDB :: (Error e, MonadError e m, LocalState sg StateDb) => Ptr Void -> StateT sg m ()+setDB ptr = get >>= \st@(SD { dbP = dbP }) ->+ case dbP of+   Nothing -> put (st { dbP = Just ptr })+   Just _  -> lift $ throwError $ strMsg+    "Database is allready set" -prepare :: DB -> String -> IO Stmt-prepare (DB db) sql = do- pptr <- malloc- rc <- withCStringLen sql $ \(sql',len) ->-      prepare' db sql' len pptr nullPtr- dbErrRc rc db "prepare"- ptr <- peek pptr- return (Stmt ptr)+setST :: (Error e, MonadError e m, LocalState sg StateDb) => Ptr Void -> StateT sg m ()+setST ptr = get >>= \st@(SD { stP = stP }) ->+    case stP of+      Nothing -> put (st { stP = Just ptr })+      Just _  -> lift $ throwError $ strMsg+        "Statement is allready set" -finalize :: Stmt -> IO ()-finalize (Stmt st) = do- rc <- finalize' st- errRc rc "finalize"+isSetDB :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m Bool+isSetDB = get >>= \(SD { dbP = dbP }) ->+    case dbP of+      Nothing -> return False+      Just _ -> return True -reset :: Stmt -> IO ()-reset (Stmt st) = do- rc <- reset' st- errRc rc "reset"+getDB :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m (Ptr Void)+getDB = get >>= \(SD { dbP = dbP }) ->+    case dbP of+      Just a  -> return a+      Nothing -> lift $ throwError $ strMsg+        "Database is not set" -step :: Stmt -> IO Bool-step (Stmt st) = do- rc <- step' st- errIf (rc /= 100 && rc /= 101) ("step: "++show rc)- return (if rc == 101 then True else False)+getST :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m (Ptr Void)+getST = get >>= \(SD { stP = stP }) ->+    case stP of+      Just a  -> return a+      Nothing -> lift $ throwError $ strMsg+        "Statement is not set" -bind_int :: Stmt -> Int -> Int -> IO ()-bind_int (Stmt st) num val = do- debug ("bind_int",st,num,val)- rc <- bind_int' st num val- errRc rc "bind_int"+clearDB :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m ()+clearDB = get >>= \st@(SD { dbP = dbP }) ->+    case dbP of+      Just _  -> put (st { dbP = Nothing })+      Nothing -> lift $ throwError $ strMsg+        "Database is allready clear" -bind_text :: Stmt -> Int -> String -> IO ()-bind_text (Stmt st) num str' =- (debug ("bind_text",st,num,str') >>) $- withCStringLen str' $ \(str,len) -> do-  rc <- bind_text' st num str len (-1)-  errRc rc "bind_text"+clearST :: (Error e, MonadError e m, LocalState sg StateDb) => StateT sg m ()+clearST = get >>= \st@(SD { stP = stP }) ->+    case stP of+      Just _  -> put (st { stP = Nothing })+      Nothing -> lift $ throwError $ strMsg+        "Statement is allready clear" -column_blob :: Stmt -> Int -> IO Bytes-column_blob (Stmt st) num = do- by <- column_bytes' st num- bl <- column_blob'  st num- return $ B.packCStringLen (bl,by)+-- -column_bytes :: Stmt -> Int -> IO Int-column_bytes (Stmt st) num = column_bytes' st num+err :: String -> StateT s IO ()+err = liftIO .  throwError .  strMsg -column_count :: Stmt -> IO Int-column_count (Stmt st) = column_count' st+errRc :: LocalState s StateDb => Int -> String -> StateT s IO ()+errRc 0 _ = return ()+errRc rc msg = do+ ans <- isSetDB+ case ans of+  True -> do+    ptr <- getDB+    cstr <- liftIO $ c_errmsg ptr+    reason <- liftIO $ peekCString cstr+    err $ "Foreign: "++msg++": (rc="++show rc++") "++reason+  False ->+    err $ "Foreign: "++msg++": (rc="++show rc++")" -column_int :: Stmt -> Int -> IO Int-column_int (Stmt st) num = column_int' st num+errIf :: LocalState s StateDb => Bool -> String -> StateT s IO ()+errIf False _ = return ()+errIf True msg = do+ ans <- isSetDB+ case ans of+  True -> do+    ptr <- getDB+    cstr <- liftIO $ c_errmsg ptr+    reason <- liftIO $ peekCString cstr+    err $ "Foreign: "++msg++": "++reason+  False ->+    err $ "Foreign: "++msg -column_double :: Stmt -> Int -> IO Double-column_double (Stmt st) = column_double' st -column_text :: Stmt -> Int -> IO String-column_text (Stmt st) num = do- by <- column_bytes' st num- tx <- column_text'  st num- peekCStringLen (tx,by)+--debug a = liftIO $ hPutStr stderr $ "DEBUG: " ++ show a ++ "\n" -column_type :: Stmt -> Int -> IO Int-column_type (Stmt st) num = column_type' st num+debug :: Show a => a -> StateT s IO ()+debug a = liftIO $ hPutStr stderr ("DEBUG: " ++ show a ++ "\n") +cont :: ((a -> IO (b,s)) -> IO (b,s)) -> (a -> StateT s IO b) -> StateT s IO b+cont f g = StateT $ \st -> liftIO $ f $ \a -> (runStateT (g a)) st++fin a b = catchError a (\e -> b >> throwError e)++try a = catchError (liftM Right a) (\e -> return $ Left e)+ -- -debug :: Show a => a -> IO ()---debug = hPutStr stderr . ("DEBUG: "++) . (++"\n") . show-debug _ = return ()+open :: LocalState s StateDb => String -> StateT s IO ()+open path =+ cont alloca $ \pptr ->+ cont (withCString path) $ \cstr -> do+  debug (cstr,pptr,"open")+  rc <- liftIO $ c_open cstr pptr+  ptr <- liftIO $ peek pptr+  setDB ptr+  fin (errRc rc "open") $ do+    r <- try close+    case r of+     Left _ -> clearDB+     Right () -> return () -err msg = ioError $ userError $ "Sqlite3: "++msg+close :: LocalState s StateDb => StateT s IO ()+close = do+ ptr <- getDB+ debug (ptr,"close")+ rc <- liftIO $ c_close ptr+ errRc rc "close"+ clearDB -errIf False _ = return ()-errIf True msg = err $ "Foreign: "++msg+prepare :: LocalState s StateDb => String -> StateT s IO ()+prepare sql =+ cont alloca $ \pptr ->+ cont (withCStringLen sql) $ \(cstr,len) -> do+  ptr <- getDB+  debug (cstr,len,pptr,"prepare")+  rc <- liftIO $ c_prepare ptr cstr len pptr nullPtr+  sptr <- liftIO $ peek pptr+  setST sptr+  fin (errRc rc "prepare") $ do+   r <- try finalize+   case r of+    Left _ -> clearST+    Right () -> return () -errRc 0 _ = return ()-errRc rc msg = err $ "Foreign: "++msg++": rc="++show rc+finalize :: LocalState s StateDb => StateT s IO ()+finalize = do+ ptr <- getST+ debug (ptr,"finalize")+ rc <- liftIO $ c_finalize ptr+ errRc rc "finalize"+ clearST -dbErrRc 0 _ _ = return ()-dbErrRc rc db msg = do- reason <- errmsg' db >>= peekCString- err $ "Foreign: "++msg++": (rc="++show rc++") "++reason+reset :: LocalState s StateDb => StateT s IO ()+reset = do+ ptr <- getST+ debug (ptr,"reset")+ rc <- liftIO $ c_reset ptr+ errRc rc "reset"++step :: LocalState s StateDb => StateT s IO Bool+step = do+ ptr <- getST+ debug (ptr,"step")+ rc <- liftIO $ c_step ptr+ errIf (rc /= 100 && rc /= 101) $ "step: "++show rc+ return (rc == 101)++bind_int :: LocalState s StateDb => (Int,Int) -> StateT s IO ()+bind_int (num,val) = do+ ptr <- getST+ debug (ptr,"bind_int")+ rc <- liftIO $ c_bind_int ptr num val+ errRc rc "bind_int"++bind_text :: LocalState s StateDb => (Int,String) -> StateT s IO ()+bind_text (num,val) =+ cont (withCStringLen val) $ \(cstr,len) -> do+  ptr <- getST+  debug (ptr,"bind_text")+  rc <- liftIO $ c_bind_text ptr num cstr len (-1)+  errRc rc "bind_text"++column_bytes :: LocalState s StateDb => Int -> StateT s IO Int+column_bytes num = do+ ptr <- getST+ debug (ptr,"column_bytes")+ liftIO $ c_column_bytes ptr num++column_count :: LocalState s StateDb => StateT s IO Int+column_count = do+ ptr <- getST+ debug (ptr,"column_count")+ liftIO $ c_column_count ptr++column_int :: LocalState s StateDb => Int -> StateT s IO Int+column_int num = do+ ptr <- getST+ debug (ptr,"column_int")+ liftIO $ c_column_int ptr num++column_double :: LocalState s StateDb => Int -> StateT s IO Double+column_double num = do+ ptr <- getST+ debug (ptr,"column_double")+ liftIO $ c_column_double ptr num++column_type :: LocalState s StateDb => Int -> StateT s IO Int+column_type num = do+ ptr <- getST+ debug (ptr,"column_type")+ liftIO $ c_column_type ptr num++column_text :: LocalState s StateDb => Int -> StateT s IO String+column_text num = do+ ptr <- getST+ by <- column_bytes num+ debug (ptr,by,"column_text")+ tx <- liftIO $ c_column_text ptr num+ utf <- liftIO $ peekCStringLen (tx,by)+ return $ UTF8.decodeString utf++column_blob :: LocalState s StateDb => Int -> StateT s IO B.ByteString+column_blob num = do+ ptr <- getST+ debug (ptr,"column_blob")+ by <- column_bytes num+ bl <- liftIO $ c_column_blob ptr num+ return $ B.packCStringLen (bl,by)
src/hs_sqlite3_test.hs view
@@ -1,17 +1,22 @@+{-# options -fglasgow-exts -farrows #-}+ import Data.Char import Database.Sqlite3 (Val (IntV,TextV)) import qualified Database.Sqlite3 as S import qualified Data.ByteString as B +import Control.Monad.Trans+import Control.Monad.Error+import Control.Monad.State.Lazy+import Data.StateLocal+ main = do- db <- S.open "test"- S.bind db ins tab- (st,row) <- S.fetchOne db "SELECT * FROM test_tab" 400- putStr $ show row- S.finalize st- S.close db- where-  ins = "INSERT INTO test_tab VALUES (?,?,?)"-  tab = replicate 500 row-  row = [TextV "test A",TextV "B test",TextV "test C test"]- +  x <- (`runStateT` (zeroST :: S.StateDb)) $ do+    S.open "db"+    tab :: [[Val]] <- S.fetch "SELECT * FROM test_tab"+    S.bind "INSERT INTO test_tab VALUES (?,?,?)" $+       replicate 4+        [IntV 5,TextV "B test",TextV "test C test"]+    S.close+    return tab+  putStr $ "end"++ show x ++"\n"