diff --git a/Database/SQL.hs b/Database/SQL.hs new file mode 100644 --- /dev/null +++ b/Database/SQL.hs @@ -0,0 +1,8 @@ +module Database.SQL (module Database.SQL, module Database.SQL.Types) where + +import Database.SQL.Types + +sqlInsert :: TableName -> [(ColumnName,SQLExpr)] -> SQLInsert +sqlInsert t xs = let (as,bs) = unzip xs + in SQLInsert t as bs + diff --git a/Database/SQL/Types.hs b/Database/SQL/Types.hs new file mode 100644 --- /dev/null +++ b/Database/SQL/Types.hs @@ -0,0 +1,436 @@ +-------------------------------------------------------------------- +-- | +-- Module : Database.SQL.Types +-- Copyright : (c) Galois, Inc. 2007 +-- License : BSD3 +-- +-- Maintainer: Don Stewart +-- Stability : provisional +-- Portability: +-- +-- Basic embedding of SQL types in Haskell. +-- +-- Note: the quary part of this modules was imported (with modifications) +-- from the lowest layer of abstraction of HaskellDB. +module Database.SQL.Types + ( TableName + , ColumnName + , DatabaseName + , OpName + + , SQLOrder(..) + , SQLSelect(..) + , select_all + , SelectSource(..) + , Join(..) + , TableSource(..) + , SQLExpr(..) + , SQLUpdate(..) + , SQLDelete(..) + , SQLInsert(..) + , SQLCreate(..) + , SQLDrop(..) + + , Clause(..) + , Constraint(..) + , Table(..) + , Column(..) + , SQLTable + + , SQLType(..) + , IntType(..) + , DateTimeType(..) + , BlobType(..) + + , showType + , showClause + , toSQLString + , export_sql + , PrettySQL(..) + ) where + +import Data.List ( intersperse ) +import Text.PrettyPrint.HughesPJ + +type DatabaseName = String +type TableName = String +type ColumnName = String +type OpName = String + +data Clause + = IsNullable Bool + | DefaultValue String + | PrimaryKey Bool -- ^ Auto-increment? + | ForeignKey TableName [ColumnName] + | Clustered Bool + | Unique + +data Constraint + = TablePrimaryKey [ColumnName] + | TableUnique [ColumnName] + | TableCheck SQLExpr + +data Table a + = Table { tabName :: String + , tabColumns :: [Column a] + , tabConstraints :: [Constraint] + } + +type SQLTable = Table SQLType + +-- | We parameterize over column type, since SQL engines +-- do tend to provide their own set of supported datatypes +-- (which may or may not map onto SQL99's set of types.) +data Column a + = Column { colName :: ColumnName + , colType :: a + , colClauses :: [Clause] + } + +-- | MySQL slanted, but also SQLite friendly if you don't get +-- too fancy.. +data SQLType + = SQLBoolean + | SQLChar (Maybe Int) + | SQLVarChar Int + | SQLBlob BlobType + | SQLDateTime DateTimeType + | SQLInt IntType Bool{-unsigned?-} Bool{-zero fill-} + | SQLDecimal (Maybe Int){-total number of digits-} + (Maybe Int){-digits after dec. point (the scale)-} + | SQLFloat (Maybe Int){-total number of digits-} + (Maybe Int){-digits following dec. point-} + | SQLEnum [String] + | SQLSet [String] + +data IntType + = TINY | SMALL | MEDIUM | NORMAL | BIG + +data DateTimeType + = DATE | DATETIME | TIMESTAMP | TIME | YEAR (Maybe Int) + +data BlobType + = TinyBlob + | NormalBlob (Maybe Int) + | MediumBlob + | LongBlob + +showType :: SQLType -> String +showType t = + case t of + SQLBoolean -> "BOOLEAN" + SQLChar Nothing -> "CHAR" + SQLChar (Just x) -> "CHAR("++shows x ")" + SQLVarChar x -> "VARCHAR("++shows x ")" + SQLBlob bt -> + case bt of + TinyBlob -> "TINYBLOB" + NormalBlob Nothing -> "BLOB" + NormalBlob (Just x) -> "BLOB("++shows x ")" + MediumBlob -> "MEDIUMBLOB" + LongBlob -> "LONGBLOB" + + SQLDateTime dt -> + case dt of + DATE -> "DATE" + DATETIME -> "DATETIME" + TIMESTAMP -> "TIMESTAMP" + TIME -> "TIME" + YEAR Nothing -> "YEAR" + YEAR (Just x) -> "YEAR(" ++ shows x ")" + SQLInt it unsigned zeroFill -> + (if unsigned then (++" UNSIGNED") else id) $ + (if zeroFill then (++" ZEROFILL") else id) $ + (case it of + TINY -> "TINYINT" + SMALL -> "SMALLINT" + MEDIUM -> "MEDIUMINT" + NORMAL -> "INTEGER" + BIG -> "BIGINT") + SQLDecimal mbDig mbScale -> + "DECIMAL" ++ + case sequence [mbDig,mbScale] of + Nothing -> "" + Just xs -> '(':concat (intersperse "," (map show xs)) ++ ")" + SQLFloat mbDig mbScale -> + "FLOAT" ++ + case sequence [mbDig,mbScale] of + Nothing -> "" + Just xs -> '(':concat (intersperse "," (map show xs)) ++ ")" + SQLEnum tgs -> + "ENUM(" ++ toTags tgs ++ ")" + SQLSet tgs -> + "SET(" ++ toTags tgs ++ ")" + where + toTags xs = concat $ intersperse "," (map quote xs) + + quote nm = '\'':nm ++ "'" + +showClause :: Clause -> String +showClause c = + case c of + IsNullable flg + | flg -> "NULL" + | otherwise -> "NOT NULL" + DefaultValue x -> "DEFAULT " ++ toSQLString x + PrimaryKey auto -> "PRIMARY KEY" ++ if auto then " AUTOINCREMENT" else "" + ForeignKey tb cs -> "FOREIGN KEY " ++ tb ++ '(':concat (intersperse ", " cs) ++ ")" + Clustered flg + | flg -> "CLUSTERED" + | otherwise -> "NONCLUSTERED" + Unique -> "UNIQUE" + +toSQLString :: String -> String +toSQLString "" = "" +toSQLString ('\'':xs) = '\'':'\'':toSQLString xs +toSQLString (x:xs) = x : toSQLString xs + +-------------------------------------------------------------------------------- + + + + +data SQLOrder = SQLAsc | SQLDesc + +-- | Data type for SQL SELECT statements. +data SQLSelect = SQLSelect + { options :: [String] -- ^ DISTINCT, ALL etc. + -- | result, alias. Empty list means "select all". + , attrs :: [(SQLExpr,String)] + , tables :: SelectSource -- ^ FROM + , criteria :: [SQLExpr] -- ^ WHERE + , groupby :: [SQLExpr] -- ^ GROUP BY + , orderby :: [(SQLExpr,SQLOrder)] -- ^ ORDER BY + , extra :: [String] -- ^ TOP n, etc. + } + | SQLBin OpName SQLSelect SQLSelect -- ^ UNION, etc + +select_all :: SelectSource -> SQLSelect +select_all src = SQLSelect { options = ["DISTINCT"] + , attrs = [] + , tables = src + , criteria = [] + , groupby = [] + , orderby = [] + , extra = [] + } + +data SelectSource = From TableSource [Join] + +-- | Join with another table. +data Join = Join OpName TableSource (Maybe (OpName ,SQLExpr)) + +-- | Use empty string for no alias. +data TableSource = SrcTable TableName String + | SrcSelect SQLSelect String + +-- | Expressions in SQL statements. +data SQLExpr = ColumnSQLExpr ColumnName + | BinSQLExpr OpName SQLExpr SQLExpr + | PrefixSQLExpr OpName SQLExpr + | PostfixSQLExpr OpName SQLExpr + | FunSQLExpr OpName [SQLExpr] + | ConstSQLExpr String + | CaseSQLExpr [(SQLExpr,SQLExpr)] SQLExpr + | ListSQLExpr [SQLExpr] + +-- | Data type for SQL UPDATE statements. +data SQLUpdate = SQLUpdate TableName [(ColumnName,SQLExpr)] [SQLExpr] + +-- | Data type for SQL DELETE statements. +data SQLDelete = SQLDelete TableName [SQLExpr] + +-- | Data type for SQL INSERT statements. +data SQLInsert = SQLInsert TableName [ColumnName] [SQLExpr] + | SQLInsertQuery TableName [ColumnName] SQLSelect + +-- | Data type for SQL CREATE statements. +data SQLCreate a = SQLCreateDB DatabaseName -- ^ Create a database + | SQLCreateTable (Table a) -- ^ Create a table + +-- | Data type representing the SQL DROP statement. +data SQLDrop = SQLDropDB DatabaseName -- ^ Delete a database + | SQLDropTable TableName -- ^ Delete a table named SQLTable + + + +-------------------------------------------------------------------------------- + + + + +class PrettySQL t where + pp_sql :: t -> Doc + +export_sql :: (PrettySQL t) => t -> String +export_sql x = render (pp_sql x) + +instance PrettySQL SQLSelect where pp_sql = ppSelect +instance PrettySQL SQLUpdate where pp_sql = ppUpdate +instance PrettySQL SQLDelete where pp_sql = ppDelete +instance PrettySQL SQLInsert where pp_sql = ppInsert +instance PrettySQL a => PrettySQL (SQLCreate a) where pp_sql = ppCreate pp_sql +instance PrettySQL SQLDrop where pp_sql = ppDrop + +instance PrettySQL SQLType where pp_sql = text . showType + + +-- * SELECT + +-- | Pretty prints a 'SQLSelect' +ppSelect :: SQLSelect -> Doc +ppSelect (SQLSelect opts as src crit group order other) + = text "SELECT" + <+> hsep (map text opts) + <+> ppAttrs as + $$ ppSelectSource src + $$ ppWhere crit + $$ ppGroupBy group + $$ ppOrderBy order + $$ hsep (map text other) +ppSelect (SQLBin op q1 q2) = parens (ppSelect q1) $$ text op $$ parens (ppSelect q2) + +ppAttrs :: [(SQLExpr,ColumnName)] -> Doc +ppAttrs [] = text "*" +ppAttrs xs = commaV nameAs xs + where + -- | Print a name-value binding, or just the name if + -- name and value are the same. + nameAs :: (SQLExpr,ColumnName) -> Doc + nameAs (ColumnSQLExpr c, name) | name == c = text name + nameAs (expr, name) = ppSQLExpr expr <+> ppAlias name + + +ppSelectSource :: SelectSource -> Doc +ppSelectSource (From t js) = text "FROM" <+> ppTableSource t + <+> vcat (map ppJoin js) + +ppJoin :: Join -> Doc +ppJoin (Join op s a) = text op <+> ppTableSource s <+> ppJoinArg a + +ppJoinArg :: Maybe (String,SQLExpr) -> Doc +ppJoinArg Nothing = empty +ppJoinArg (Just (op,e)) = text op <+> ppSQLExpr e + +ppTableSource :: TableSource -> Doc +ppTableSource (SrcTable x a) = text x <+> ppAlias a +ppTableSource (SrcSelect s a) = parens (ppSelect s) <+> ppAlias a + +ppAlias :: String -> Doc +ppAlias "" = empty +ppAlias as = text "AS" <+> text as + +ppWhere :: [SQLExpr] -> Doc +ppWhere [] = empty +ppWhere es = text "WHERE" + <+> hsep (intersperse (text "AND") (map ppSQLExpr es)) + +ppGroupBy :: [SQLExpr] -> Doc +ppGroupBy [] = empty +ppGroupBy es = text "GROUP BY" <+> commaV ppSQLExpr es + +ppOrderBy :: [(SQLExpr,SQLOrder)] -> Doc +ppOrderBy [] = empty +ppOrderBy ord = text "ORDER BY" <+> commaV ppOrd ord + where + ppOrd (e,o) = ppSQLExpr e <+> ppSQLOrder o + ppSQLOrder :: SQLOrder -> Doc + ppSQLOrder SQLAsc = text "ASC" + ppSQLOrder SQLDesc = text "DESC" + + +-- * UPDATE + +-- | Pretty prints a 'SQLUpdate' +ppUpdate :: SQLUpdate -> Doc +ppUpdate (SQLUpdate name assigns crit) + = text "UPDATE" <+> text name + $$ text "SET" <+> commaV ppAssign assigns + $$ ppWhere crit + where + ppAssign (c,e) = text c <+> equals <+> ppSQLExpr e + + +-- * DELETE + +-- | Pretty prints a 'SQLDelete' +ppDelete :: SQLDelete -> Doc +ppDelete (SQLDelete name crit) = + text "DELETE FROM" <+> text name $$ ppWhere crit + + +-- * INSERT + +ppInsert :: SQLInsert -> Doc + +ppInsert (SQLInsert table names values) + = text "INSERT INTO" <+> text table + <+> parens (commaV text names) + $$ text "VALUES" <+> parens (commaV ppSQLExpr values) + +ppInsert (SQLInsertQuery table names select) + = text "INSERT INTO" <+> text table + <+> parens (commaV text names) + $$ ppSelect select + + +-- * CREATE + +-- | Pretty prints a 'SQLCreate'. +ppCreate :: (a -> Doc) -> SQLCreate a -> Doc +ppCreate _ (SQLCreateDB name) = text "CREATE DATABASE" <+> text name +ppCreate ppType (SQLCreateTable t) + = text "CREATE TABLE" <+> text (tabName t) + <+> parens (vcat $ punctuate comma + $ map (ppColumn ppType) (tabColumns t) ++ + map ppConstraint (tabConstraints t) + ) + +ppColumn :: (a -> Doc) -> Column a -> Doc +ppColumn ppType c = text (colName c) + <+> ppType (colType c) + <+> hsep (map ppClause (colClauses c)) + +ppClause :: Clause -> Doc +ppClause c = text (showClause c) + +ppConstraint :: Constraint -> Doc +ppConstraint c = case c of + TablePrimaryKey cs -> text "PRIMARY KEY" <+> parens (commaH text cs) + TableUnique cs -> text "UNIQUE" <+> parens (commaH text cs) + TableCheck e -> text "CHECK" <+> (ppSQLExpr e) + + + + +-- * DROP + +-- | Pretty prints a 'SQLDrop'. +ppDrop :: SQLDrop -> Doc +ppDrop (SQLDropDB name) = text "DROP DATABASE" <+> text name +ppDrop (SQLDropTable name) = text "DROP TABLE" <+> text name + + +-- * Expressions + +-- | Pretty prints a 'SQLExpr' +ppSQLExpr :: SQLExpr -> Doc +ppSQLExpr e = + case e of + ColumnSQLExpr c -> text c + BinSQLExpr op e1 e2 -> ppSQLExpr e1 <+> text op <+> ppSQLExpr e2 + PrefixSQLExpr op e1 -> text op <+> ppSQLExpr e1 + PostfixSQLExpr op e1-> ppSQLExpr e1 <+> text op + FunSQLExpr f es -> text f <> parens (commaH ppSQLExpr es) + ConstSQLExpr c -> text c + CaseSQLExpr cs el -> text "CASE" <+> vcat (map ppWhen cs) + <+> text "ELSE" <+> ppSQLExpr el <+> text "END" + where ppWhen (w,t) = text "WHEN" <+> ppSQLExpr w + <+> text "THEN" <+> ppSQLExpr t + ListSQLExpr es -> parens (commaH ppSQLExpr es) + +commaH :: (a -> Doc) -> [a] -> Doc +commaH f = hcat . punctuate comma . map f + +commaV :: (a -> Doc) -> [a] -> Doc +commaV f = vcat . punctuate comma . map f diff --git a/Database/SQLite.hs b/Database/SQLite.hs new file mode 100644 --- /dev/null +++ b/Database/SQLite.hs @@ -0,0 +1,371 @@ +-------------------------------------------------------------------- +-- | +-- Module : Database.SQLite +-- Copyright : (c) Galois, Inc. 2007 +-- License : BSD3 +-- +-- Maintainer: docserver-dev-team@galois.com +-- Stability : provisional +-- Portability: portable +-- +-- A Haskell binding to the sqlite3 database. +-- See: +-- +-- * +-- +-- for more information. +-- +-- The api is documented at: +-- +-- * +-- + +module Database.SQLite + ( module Database.SQLite.Base + , module Database.SQLite.Types + , module Database.SQL.Types + + -- * Opening and closing a database + , openConnection + , closeConnection + + -- * Executing SQL queries on the database + , execStatement + , execStatement_ + , execParamStatement + , execParamStatement_ + + -- * Basic insertion operations + , insertRow + , defineTable + , defineTableOpt + , getLastRowID + , Row + , Value(..) + + , addRegexpSupport + , RegexpHandler + , withPrim + , SQLiteHandle() + , newSQLiteHandle + ) where + +import Database.SQLite.Types +import Database.SQLite.Base +import Database.SQL.Types + +import Foreign.Marshal +import Foreign.C +import Foreign.C.String (newCStringLen, peekCString) +import Foreign.Storable +import qualified Foreign.Concurrent as Conc +import Foreign.Ptr +import Foreign.ForeignPtr +import Data.List +import Data.Int +import Data.Char ( isDigit ) +import Data.ByteString (ByteString, packCStringLen, useAsCStringLen) +import Data.ByteString.Unsafe (unsafePackCStringLen) +import Control.Monad ((<=<),when) +import qualified Codec.Binary.UTF8.String as UTF8 + +------------------------------------------------------------------------ + +newtype SQLiteHandle = SQLiteHandle (ForeignPtr ()) + +addSQLiteHandleFinalizer :: SQLiteHandle -> IO () -> IO () +addSQLiteHandleFinalizer (SQLiteHandle h) = Conc.addForeignPtrFinalizer h + +newSQLiteHandle :: SQLite -> IO SQLiteHandle +newSQLiteHandle h@(SQLite p) = SQLiteHandle `fmap` Conc.newForeignPtr p close + where close = sqlite3_close h >> return () + +-- | Open a new database connection, whose name is given +-- by the 'dbName' argument. A sqlite3 handle is returned. +-- +-- An exception is thrown if the database could not be opened. +-- +openConnection :: String -> IO SQLiteHandle +openConnection dbName = + alloca $ \ptr -> do + st <- withCString dbName $ \ c_dbName -> + sqlite3_open c_dbName ptr + case st of + 0 -> do db <- peek ptr + newSQLiteHandle db + _ -> fail ("openDatabase: failed to open " ++ show st) + + +-- | Close a database connection. +-- Destroys the SQLite value associated with a database, closes +-- all open files relating to the database, and releases all resources. +-- +closeConnection :: SQLiteHandle -> IO () +closeConnection (SQLiteHandle h) = finalizeForeignPtr h + +withPrim :: SQLiteHandle -> (SQLite -> IO a) -> IO a +withPrim (SQLiteHandle h) f = withForeignPtr h (f . SQLite) + +------------------------------------------------------------------------ +-- Adding data + +type Row a = [(ColumnName,a)] + +defineTableOpt :: SQLiteHandle -> Bool -> SQLTable -> IO (Maybe String) +defineTableOpt h check tab = execStatement_ h (createTable tab) + where + opt = if check then " IF NOT EXISTS " else "" + createTable t = + "CREATE TABLE " ++ opt ++ toSQLString (tabName t) ++ + tupled (map toCols (tabColumns t)) ++ ";" + + toCols col = + toSQLString (colName col) ++ " " ++ showType (colType col) ++ + ' ':unwords (map showClause (colClauses col)) + + +-- | Define a new table, populated from 'tab' in the database. +-- +defineTable :: SQLiteHandle -> SQLTable -> IO (Maybe String) +defineTable h tab = defineTableOpt h False tab + +-- | Insert a row into the table 'tab'. +insertRow :: SQLiteHandle -> TableName -> Row String -> IO (Maybe String) +insertRow h tab cs = do + let stmt = ("INSERT INTO " ++ tab ++ + tupled (toVals fst) ++ " VALUES " ++ + tupled (toVals (quote.snd)) ++ ";") + execStatement_ h stmt + where + toVals f = map (toVal f) cs + toVal f p = f p -- ($ f) + + quote "" = "''" + quote nm@(x:_) + | isDigit x = nm + | otherwise = '\'':toSQLString nm ++ "'" + + +-- | Return the rowid (as an Integer) of the most recent +-- successful INSERT into the database. +-- +getLastRowID :: SQLiteHandle -> IO Integer +getLastRowID h = withPrim h $ \ p -> do + v <- sqlite3_last_insert_rowid p + return (fromIntegral v) + +------------------------------------------------------------------------ +-- Executing queries + +data Value + = Double Double + | Int Int64 + | Text String + | Blob ByteString + | Null + deriving Show + +foreign import ccall "stdlib.h &free" + p_free :: FunPtr (Ptr a -> IO ()) + + +-- | Sets the value of a parameter in a statement. +-- Perofrms UTF8 encoding. +bindValue :: SQLiteStmt -> String -> Value -> IO Status +bindValue stmt key value = + withCString (UTF8.encodeString key) $ \ckey -> + ensure (sqlite3_bind_parameter_index stmt ckey) + (> 0) (return sQLITE_OK) $ \ix -> + case value of + Text txt -> + do (cptr,len) <- newCStringLen (UTF8.encodeString txt) + res <- sqlite3_bind_text stmt ix cptr (fromIntegral len) p_free + when (res /= sQLITE_OK) (free cptr) + return res + Null -> sqlite3_bind_null stmt ix + Int x -> sqlite3_bind_int64 stmt ix x + Double x -> sqlite3_bind_double stmt ix x + Blob x -> useAsCStringLen x $ \ (ptr,bytes) -> + sqlite3_bind_blob stmt ix (castPtr ptr) + (fromIntegral bytes) nullFunPtr + + +-- | Called when we know that an error has occured. +to_error :: SQLite -> IO (Either String a) +to_error db = Left `fmap` (peekCString =<< sqlite3_errmsg db) + + + +-- | Prepare and execute a parameterized statment, ignoring the result. +-- See also 'execParamStatement'. +execParamStatement_ :: SQLiteHandle -> String -> [(String,Value)] + -> IO (Maybe String) +execParamStatement_ db q ps = + either Just (const Nothing) `fmap` + (execParamStatement db q ps :: IO (Either String [[Row ()]])) + +-- | Prepare and execute a parameterized statment. +-- Statement parameter names start with a colon (for example, @:col_id@). +-- Note that for the moment, column names should not contain \0 +-- characters because that part of the column name will be ignored. +execParamStatement :: SQLiteResult a => SQLiteHandle -> String + -> [(String,Value)] -> IO (Either String [[Row a]]) +execParamStatement h query params = withPrim h $ \ db -> + alloca $ \stmt_ptr -> + alloca $ \pzTail -> + let encoded = UTF8.encodeString query in + withCString encoded $ \zSql -> do + poke pzTail zSql + prepare_loop db stmt_ptr pzTail + + where + prepare_loop db stmt_ptr sqltxt_ptr = loop [] where + loop xs = + peek sqltxt_ptr >>= \ sqltxt -> + ensure_ (peek sqltxt) (/= 0) (eReturn (reverse xs)) $ + + ensure_ (sqlite3_prepare db sqltxt (-1) stmt_ptr sqltxt_ptr) + (== sQLITE_OK) (to_error db) $ + + ensure (peek stmt_ptr) + (not . isNullStmt) (loop xs) $ \ stmt -> + + then_finalize db (recv_rows db stmt) stmt `ebind` \ x -> + loop (x:xs) + + recv_rows db stmt = + do mapM_ (uncurry $ bindValue stmt) params + col_num <- sqlite3_column_count stmt + let cols = [0..col_num-1] + -- Note: column names should not contain \0 characters + names <- mapM (peekCString <=< sqlite3_column_name stmt) cols + let decoded_names = map UTF8.decodeString names + get_rows db stmt cols decoded_names [] + + get_rows db stmt cols col_names rows = do + res <- sqlite3_step stmt + if res == sQLITE_ROW + then do + txts <- mapM (get_sqlite_val stmt) cols + let row = zip col_names txts + get_rows db stmt cols col_names (row:rows) + else if res == sQLITE_DONE + then eReturn (reverse rows) + else to_error db + + then_finalize db m stmt = do + e <- m + sqlite3_finalize stmt + case e of + Left _ -> to_error db + Right r -> return (Right r) + +-- | Evaluate the SQL statement specified by 'sqlStmt' +execStatement :: SQLiteResult a + => SQLiteHandle -> String -> IO (Either String [[Row a]]) +execStatement db s = execParamStatement db s [] + +-- | Returns an error, or 'Nothing' if everything was OK. +execStatement_ :: SQLiteHandle -> String -> IO (Maybe String) +execStatement_ h sqlStmt = withPrim h $ \ db -> + withCString (UTF8.encodeString sqlStmt) $ \ c_sqlStmt -> + sqlite3_exec db c_sqlStmt noCallback nullPtr nullPtr >>= \ st -> + if st == sQLITE_OK + then return Nothing + else fmap Just . peekCString =<< sqlite3_errmsg db + +tupled :: [String] -> String +tupled xs = "(" ++ concat (intersperse ", " xs) ++ ")" + +infixl 1 `ebind` +ebind :: Monad m => m (Either e a) -> (a -> m (Either e b)) -> m (Either e b) +m `ebind` f = do x <- m + case x of Left e -> return $ Left e + Right r -> f r + +eReturn :: Monad m => a -> m (Either e a) +eReturn x = return $ Right x + +ensure :: Monad m => m a -> (a -> Bool) -> m b -> (a -> m b) -> m b +ensure m p t f = m >>= \ x -> if p x then f x else t + +ensure_ :: Monad m => m a -> (a -> Bool) -> m b -> m b -> m b +ensure_ m p t f = ensure m p t (const f) + +class SQLiteResult a where + get_sqlite_val :: SQLiteStmt -> CInt -> IO a + +instance SQLiteResult String where + get_sqlite_val = get_text_val + +instance SQLiteResult () where + get_sqlite_val _ _ = return () + +instance SQLiteResult Value where + get_sqlite_val = get_val + +get_text_val :: SQLiteStmt -> CInt -> IO String +get_text_val stmt n = + do ptr <- sqlite3_column_text stmt n + bytes <- sqlite3_column_bytes stmt n + str <- peekCStringLen (ptr,fromIntegral bytes) + return (UTF8.decodeString str) + +get_val :: SQLiteStmt -> CInt -> IO Value +get_val stmt n = + do val <- sqlite3_column_value stmt n + typ <- sqlite3_value_type val + case () of + _ | typ == sQLITE_NULL -> return Null + | typ == sQLITE_INTEGER -> Int `fmap` sqlite3_value_int64 val + | typ == sQLITE_FLOAT -> Double `fmap` sqlite3_value_double val + | typ == sQLITE_TEXT -> + fmap Text . peekCStringLen =<< sqlite3_value_cstringlen val + | typ == sQLITE_BLOB -> + do SQLiteBLOB ptr <- sqlite3_value_blob val + bytes <- sqlite3_value_bytes val + str <- packCStringLen (castPtr ptr, fromIntegral bytes) + return $ Blob str + | otherwise -> error "get_val: unknown type" + +-- | This is the type of the function supported by the 'add_regexp_support' +-- function. The first argument is the regular expression to match with +-- and the second argument is the string to match. The result shall be +-- 'True' for successful match and 'False' otherwise. +type RegexpHandler = ByteString -> ByteString -> IO Bool + +-- | This function registers a 'RegexpHandler' to be called when +-- REGEXP(regexp,str) is used in an SQL query. +addRegexpSupport :: SQLiteHandle -> RegexpHandler -> IO () +addRegexpSupport h f = + withCString "REGEXP" $ \ zFunctionName -> + do xFunc <- mkStepHandler $ regexp_callback f + withPrim h $ \ db -> + sqlite3_create_function db zFunctionName 2 sQLITE_UTF8 nullPtr + xFunc noCallback noCallback + addSQLiteHandleFinalizer h (freeCallback xFunc) + +-- | Internal function to marshall the C types into Haskell types to +-- make a RegexpHandler compatible with the Sqlite3 API. +regexp_callback :: RegexpHandler -> StepHandler +regexp_callback f ctx argc argv = + if argc /= 2 then return_fail else + do arg0 <- sqlite3_value_cstringlen =<< peek argv + arg1 <- sqlite3_value_cstringlen =<< peekElemOff argv 1 + if isNullCStringLen arg0 || isNullCStringLen arg1 then return_fail else + do regexp_str <- unsafePackCStringLen arg0 + str <- unsafePackCStringLen arg1 + res <- f regexp_str str + if res then return_success else return_fail + where + return_fail = sqlite3_result_int ctx 0 + return_success = sqlite3_result_int ctx 1 + +isNullCStringLen :: CStringLen -> Bool +isNullCStringLen (p,_) = p == nullPtr + +sqlite3_value_cstringlen :: SQLiteValue -> IO CStringLen +sqlite3_value_cstringlen v = + do str <- sqlite3_value_text v + len <- sqlite3_value_bytes v + return (str, fromIntegral len) diff --git a/Database/SQLite/Base.hs b/Database/SQLite/Base.hs new file mode 100644 --- /dev/null +++ b/Database/SQLite/Base.hs @@ -0,0 +1,708 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-------------------------------------------------------------------- +-- | +-- Module : Database.SQLite.Base +-- Copyright : (c) Galois, Inc. 2007 +-- License : BSD3 +-- +-- Maintainer: Don Stewart +-- Stability : provisional +-- Portability: +-- +-- Bindings to the SQLite C interface. +-- +-- The documentation for these functions is at: +-- +-- * +-- +module Database.SQLite.Base + ( sqlite3_libversion + , sqlite3_libversion_number + , sqlite3_close + , sqlite3_exec + , sqlite3_extended_result_codes + , sqlite3_last_insert_rowid + , sqlite3_changes + , sqlite3_total_changes + , sqlite3_interrupt + , sqlite3_complete + , sqlite3_complete16 + , sqlite3_busy_handler + , sqlite3_busy_timeout + , sqlite3_get_table + , sqlite3_free_table + , sqlite3_malloc + , sqlite3_realloc + , sqlite3_free +{- + , sqlite3_memory_used + , sqlite3_memory_highwater +-} + , sqlite3_set_authorizer + , sqlite3_trace + , sqlite3_profile + , sqlite3_progress_handler + , sqlite3_open + , sqlite3_open16 +-- , sqlite3_open_v2 + , sqlite3_errcode + , sqlite3_errmsg + + , sqlite3_prepare + + , sqlite3_bind_blob + , sqlite3_bind_double + , sqlite3_bind_int + , sqlite3_bind_int64 + , sqlite3_bind_null + , sqlite3_bind_text + , sqlite3_bind_value + , sqlite3_bind_zeroblob + , sqlite3_bind_parameter_count + , sqlite3_bind_parameter_name + , sqlite3_bind_parameter_index + + , sqlite3_clear_bindings + , sqlite3_column_count + , sqlite3_column_name + , sqlite3_column_decltype + , sqlite3_step + , sqlite3_data_count + + , sqlite3_column_blob + , sqlite3_column_bytes + , sqlite3_column_bytes16 + , sqlite3_column_double + , sqlite3_column_int + , sqlite3_column_int64 + , sqlite3_column_text + , sqlite3_column_text16 + , sqlite3_column_type + , sqlite3_column_value + + , sqlite3_finalize + , sqlite3_create_function + + , sqlite3_value_blob + , sqlite3_value_bytes + , sqlite3_value_bytes16 + , sqlite3_value_double + , sqlite3_value_int + , sqlite3_value_int64 + , sqlite3_value_text + , sqlite3_value_text16 + , sqlite3_value_text16le + , sqlite3_value_text16be + , sqlite3_value_numeric_type + , sqlite3_value_type + , sqlite3_aggregate_context + , sqlite3_user_data + + , sqlite3_get_auxdata + , sqlite3_set_auxdata + + , sqlite3_static_destructor + , sqlite3_transient_destructor + + , sqlite3_result_blob + , sqlite3_result_double + , sqlite3_result_error + , sqlite3_result_error16 + , sqlite3_result_error_toobig +{- + , sqlite3_result_error_nomem +-} + , sqlite3_result_int + , sqlite3_result_int64 + , sqlite3_result_null + , sqlite3_result_text + , sqlite3_result_text16 + , sqlite3_result_text16le + , sqlite3_result_text16be + , sqlite3_result_value + , sqlite3_result_zeroblob + + , sqlite3_create_collation + , sqlite3_create_collation16 + , sqlite3_create_collation_v2 + , sqlite3_collation_needed + , sqlite3_collation_needed16 + + , sqlite3_sleep + , sqlite3_set_temp_directory + , sqlite3_get_temp_directory + , sqlite3_get_autocommit + , sqlite3_db_handle + , sqlite3_commit_hook + , sqlite3_rollback_hook + , sqlite3_update_hook + , sqlite3_enable_shared_cache +{- + , sqlite3_release_memory + , sqlite3_soft_heap_limit +-} + + , sqlite3_blob_open + , sqlite3_blob_close + , sqlite3_blob_bytes + , sqlite3_blob_read + , sqlite3_blob_write + + -- helpful callback constructors: + , ExecHandler + , FreeHandler + , UpdateHook + , FilterHandler + , StepHandler + , FinalizeContextHandler + , CompareHandler + , CollationHandler + , CollationHandler16 + , mkExecHandler + , mkFreeHandler + , mkUpdateHook + , mkFilterHandler + , mkStepHandler + , mkFinalizeContextHandler + , mkCompareHandler + , mkCollationHandler + , mkCollationHandler16 + ) where + +import Database.SQLite.Types + +import Foreign.C +import Foreign.Ptr + +-- the various callback function types and constructors for their +-- Haskell wrappers: + +type ExecHandler + = SQLiteCallbackUserData + -> CInt + -> Ptr CString + -> Ptr CString + -> IO Status + +foreign import ccall "wrapper" + mkExecHandler :: ExecHandler -> IO (SQLiteCallback ExecHandler) + +type FreeHandler = SQLiteCallbackUserData -> IO () + +foreign import ccall "wrapper" + mkFreeHandler :: FreeHandler -> IO (SQLiteCallback FreeHandler) + +type UpdateHook + = SQLiteCallbackUserData + -> CInt + -> CString + -> CString + -> SQLiteInt64 -> IO () + +foreign import ccall "wrapper" + mkUpdateHook :: UpdateHook -> IO (SQLiteCallback UpdateHook) + +type FilterHandler + = SQLiteCallbackUserData + -> IO Status + +foreign import ccall "wrapper" + mkFilterHandler :: FilterHandler -> IO (SQLiteCallback FilterHandler) + +type FinalizeContextHandler = SQLiteContext -> IO () + +foreign import ccall "wrapper" + mkFinalizeContextHandler + :: FinalizeContextHandler + -> IO (SQLiteCallback FinalizeContextHandler) + +type StepHandler + = SQLiteContext + -> CInt + -> Ptr SQLiteValue + -> IO () + +foreign import ccall "wrapper" + mkStepHandler :: StepHandler -> IO (SQLiteCallback StepHandler) + +type CompareHandler + = SQLiteCallbackUserData + -> CInt + -> Ptr () + -> CInt + -> Ptr () + -> IO CInt + +foreign import ccall "wrapper" + mkCompareHandler :: CompareHandler -> IO (SQLiteCallback CompareHandler) + +type CollationHandler + = SQLiteCallbackUserData + -> SQLite + -> TextEncodeFlag + -> CString + -> IO () + +foreign import ccall "wrapper" + mkCollationHandler :: CollationHandler -> IO (SQLiteCallback CollationHandler) + +type CollationHandler16 + = SQLiteCallbackUserData + -> SQLite + -> TextEncodeFlag + -> SQLiteUTF16 + -> IO () + +foreign import ccall "wrapper" + mkCollationHandler16 :: CollationHandler16 -> IO (SQLiteCallback CollationHandler16) + +-- Binding the main API: + +foreign import ccall "sqlite3.h sqlite3_libversion" + sqlite3_libversion :: IO CString + +foreign import ccall "sqlite3.h sqlite3_libversion_number" + sqlite3_libversion_number :: IO CString + +foreign import ccall "sqlite3.h sqlite3_close" + sqlite3_close :: SQLite -> IO Status + +foreign import ccall "sqlite3.h sqlite3_exec" + sqlite3_exec :: SQLite + -> CString + -> SQLiteCallback ExecHandler + -> SQLiteCallbackUserData + -> Ptr CString + -> IO Status + +foreign import ccall "sqlite3.h sqlite3_extended_result_codes" + sqlite3_extended_result_codes :: SQLite -> Bool -> IO Status + +foreign import ccall "sqlite3.h sqlite3_last_insert_rowid" + sqlite3_last_insert_rowid :: SQLite -> IO SQLiteInt64 + +foreign import ccall "sqlite3.h sqlite3_changes" + sqlite3_changes :: SQLite -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_total_changes" + sqlite3_total_changes :: SQLite -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_interrupt" + sqlite3_interrupt :: SQLite -> IO () + +foreign import ccall "sqlite3.h sqlite3_complete" + sqlite3_complete :: CString -> IO Bool + +foreign import ccall "sqlite3.h sqlite3_complete16" + sqlite3_complete16 :: SQLiteUTF16 -> IO Bool + +foreign import ccall "sqlite3.h sqlite3_busy_handler" + sqlite3_busy_handler :: SQLite -> FunPtr (Ptr () -> CInt -> IO CInt) -> Ptr () -> IO Status + +foreign import ccall "sqlite3.h sqlite3_busy_timeout" + sqlite3_busy_timeout :: SQLite -> CInt -> IO Status + +foreign import ccall "sqlite3.h sqlite3_get_table" + sqlite3_get_table :: SQLite + -> CString + -> Ptr (Ptr CString) + -> Ptr CInt + -> Ptr CInt + -> Ptr (Ptr CString) + -> IO Status + +foreign import ccall "sqlite3.h sqlite3_free_table" + sqlite3_free_table :: Ptr (Ptr CString) -> IO () + +foreign import ccall "sqlite3.h sqlite3_malloc" + sqlite3_malloc :: CInt -> IO (Ptr ()) + +foreign import ccall "sqlite3.h sqlite3_realloc" + sqlite3_realloc :: Ptr () -> CInt -> IO (Ptr ()) + +foreign import ccall "sqlite3.h sqlite3_free" + sqlite3_free :: Ptr () -> IO () + +{- +foreign import ccall "sqlite3.h sqlite3_memory_used" + sqlite3_memory_used :: IO SQLiteInt64 + +foreign import ccall "sqlite3.h sqlite3_memory_highwater" + sqlite3_memory_highwater :: CInt -> IO SQLiteInt64 +-} + +foreign import ccall "sqlite3.h sqlite3_set_authorizer" + sqlite3_set_authorizer :: SQLite -> FunPtr (Ptr () -> CInt -> CString -> CString -> CString -> CString -> IO Status) -> Ptr () -> IO Status + +foreign import ccall "sqlite3.h sqlite3_trace" + sqlite3_trace :: SQLite -> FunPtr (Ptr () -> CString -> IO ()) -> Ptr () -> IO (Ptr ()) + +foreign import ccall "sqlite3.h sqlite3_profile" + sqlite3_profile :: SQLite -> FunPtr (Ptr () -> CString -> SQLiteInt64 -> IO ()) -> Ptr () -> IO (Ptr ()) + +foreign import ccall "sqlite3.h sqlite3_progress_handler" + sqlite3_progress_handler :: SQLite -> CInt -> FunPtr (Ptr () -> IO CInt) -> Ptr () -> IO () + +foreign import ccall "sqlite3.h sqlite3_open" + sqlite3_open :: CString -> Ptr SQLite -> IO Status + +foreign import ccall "sqlite3.h sqlite3_open16" + sqlite3_open16 :: SQLiteUTF16 -> Ptr SQLite -> IO Status + +{- +foreign import ccall "sqlite3.h sqlite3_open_v2" + sqlite3_open_v2 :: CString -> Ptr SQLite -> OpenFlags -> CString -> IO Status +-} + +foreign import ccall "sqlite3.h sqlite3_errcode" + sqlite3_errcode :: SQLite -> IO Status + +foreign import ccall "sqlite3.h sqlite3_errmsg" + sqlite3_errmsg :: SQLite -> IO CString + +foreign import ccall "sqlite3.h sqlite3_prepare_v2" + sqlite3_prepare :: SQLite -> CString -> CInt -> Ptr SQLiteStmt -> Ptr CString -> IO Status + +foreign import ccall "sqlite3.h sqlite3_bind_blob" + sqlite3_bind_blob :: SQLiteStmt -> CInt -> Ptr () -> CInt -> FunPtr (Ptr () -> IO ()) -> IO Status + +foreign import ccall "sqlite3.h sqlite3_bind_double" + sqlite3_bind_double :: SQLiteStmt -> CInt -> Double -> IO Status + +foreign import ccall "sqlite3.h sqlite3_bind_int" + sqlite3_bind_int :: SQLiteStmt -> CInt -> CInt -> IO Status + +foreign import ccall "sqlite3.h sqlite3_bind_int64" + sqlite3_bind_int64 :: SQLiteStmt -> CInt -> SQLiteInt64 -> IO Status + +foreign import ccall "sqlite3.h sqlite3_bind_null" + sqlite3_bind_null :: SQLiteStmt -> CInt -> IO Status + +foreign import ccall "sqlite3.h sqlite3_bind_text" + sqlite3_bind_text :: SQLiteStmt -> CInt -> CString -> CInt -> FunPtr (Ptr () -> IO ()) -> IO Status + +foreign import ccall "sqlite3.h sqlite3_bind_value" + sqlite3_bind_value :: SQLiteStmt -> CInt -> SQLiteValue -> IO Status + +foreign import ccall "sqlite3.h sqlite3_bind_zeroblob" + sqlite3_bind_zeroblob :: SQLiteStmt -> CInt -> CInt -> IO Status + +foreign import ccall "sqlite3.h sqlite3_bind_parameter_count" + sqlite3_bind_parameter_count :: SQLiteStmt -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_bind_parameter_name" + sqlite3_bind_parameter_name :: SQLiteStmt -> CInt -> IO CString + +foreign import ccall "sqlite3.h sqlite3_bind_parameter_index" + sqlite3_bind_parameter_index :: SQLiteStmt -> CString -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_clear_bindings" + sqlite3_clear_bindings :: SQLiteStmt -> IO Status + +foreign import ccall "sqlite3.h sqlite3_column_count" + sqlite3_column_count :: SQLiteStmt -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_column_name" + sqlite3_column_name :: SQLiteStmt -> CInt -> IO CString + +{- Not compiled into the Windows version of the lib by default, hence leave out + for now: +foreign import ccall "sqlite3.h sqlite3_column_database_name" + sqlite3_column_database_name :: SQLiteStmt -> CInt -> IO CString + +foreign import ccall "sqlite3.h sqlite3_column_table_name" + sqlite3_column_table_name :: SQLiteStmt -> CInt -> IO CString + +foreign import ccall "sqlite3.h sqlite3_column_origin_name" + sqlite3_column_origin_name :: SQLiteStmt -> CInt -> IO CString +-} +foreign import ccall "sqlite3.h sqlite3_column_decltype" + sqlite3_column_decltype :: SQLiteStmt -> CInt -> IO CString + +foreign import ccall "sqlite3.h sqlite3_step" + sqlite3_step :: SQLiteStmt -> IO Status + +foreign import ccall "sqlite3.h sqlite3_data_count" + sqlite3_data_count :: SQLiteStmt -> IO Status + +foreign import ccall "sqlite3.h sqlite3_column_blob" + sqlite3_column_blob :: SQLiteStmt -> CInt -> IO (Ptr ()) + +foreign import ccall "sqlite3.h sqlite3_column_bytes" + sqlite3_column_bytes :: SQLiteStmt -> CInt -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_column_bytes16" + sqlite3_column_bytes16 :: SQLiteStmt -> CInt -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_column_double" + sqlite3_column_double :: SQLiteStmt -> CInt -> IO Double + +foreign import ccall "sqlite3.h sqlite3_column_int" + sqlite3_column_int :: SQLiteStmt -> CInt -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_column_int64" + sqlite3_column_int64 :: SQLiteStmt -> CInt -> IO SQLiteInt64 + +foreign import ccall "sqlite3.h sqlite3_column_text" + sqlite3_column_text :: SQLiteStmt -> CInt -> IO CString + +foreign import ccall "sqlite3.h sqlite3_column_text16" + sqlite3_column_text16 :: SQLiteStmt -> CInt -> IO SQLiteUTF16 + +foreign import ccall "sqlite3.h sqlite3_column_type" + sqlite3_column_type :: SQLiteStmt -> CInt -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_column_value" + sqlite3_column_value :: SQLiteStmt -> CInt -> IO SQLiteValue + +foreign import ccall "sqlite3.h sqlite3_finalize" + sqlite3_finalize :: SQLiteStmt -> IO Status + +foreign import ccall "sqlite3.h sqlite3_create_function" + sqlite3_create_function :: SQLite + -> CString + -> CInt + -> TextEncodeFlag + -> SQLiteCallbackUserData + -> SQLiteCallback StepHandler + -> SQLiteCallback StepHandler + -> SQLiteCallback FinalizeContextHandler + -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_value_blob" + sqlite3_value_blob :: SQLiteValue -> IO SQLiteBLOB + +foreign import ccall "sqlite3.h sqlite3_value_bytes" + sqlite3_value_bytes :: SQLiteValue -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_value_bytes16" + sqlite3_value_bytes16 :: SQLiteValue -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_value_double" + sqlite3_value_double :: SQLiteValue -> IO Double + +foreign import ccall "sqlite3.h sqlite3_value_int" + sqlite3_value_int :: SQLiteValue -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_value_int64" + sqlite3_value_int64 :: SQLiteValue -> IO SQLiteInt64 + +foreign import ccall "sqlite3.h sqlite3_value_text" + sqlite3_value_text :: SQLiteValue -> IO CString + +foreign import ccall "sqlite3.h sqlite3_value_text16" + sqlite3_value_text16 :: SQLiteValue -> IO SQLiteUTF16 + +foreign import ccall "sqlite3.h sqlite3_value_text16le" + sqlite3_value_text16le :: SQLiteValue -> IO SQLiteUTF16 + +foreign import ccall "sqlite3.h sqlite3_value_text16be" + sqlite3_value_text16be :: SQLiteValue -> IO SQLiteUTF16 + +foreign import ccall "sqlite3.h sqlite3_value_numeric_type" + sqlite3_value_numeric_type :: SQLiteValue -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_value_type" + sqlite3_value_type :: SQLiteValue -> IO FundamentalDatatype + +foreign import ccall "sqlite3.h sqlite3_aggregate_context" + sqlite3_aggregate_context :: SQLiteContext -> CInt -> IO SQLiteContextBuffer + +foreign import ccall "sqlite3.h sqlite3_user_data" + sqlite3_user_data :: SQLiteContext -> IO (Ptr ()) + +foreign import ccall "sqlite3.h sqlite3_get_auxdata" + sqlite3_get_auxdata :: SQLiteContext -> CInt -> IO (Ptr ()) + +foreign import ccall "sqlite3.h sqlite3_set_auxdata" + sqlite3_set_auxdata :: SQLiteContext -> CInt -> Ptr () -> SQLiteCallback FreeHandler -> IO () + +foreign import ccall "sqlite3.h get_SQLITE_STATIC" + sqlite3_static_destructor :: SQLiteCallback FreeHandler + +foreign import ccall "sqlite3.h get_SQLITE_TRANSIENT" + sqlite3_transient_destructor :: SQLiteCallback FreeHandler + +foreign import ccall "sqlite3.h sqlite3_result_blob" + sqlite3_result_blob :: SQLiteContext -> Ptr () -> CInt -> SQLiteCallback FreeHandler -> IO () + +foreign import ccall "sqlite3.h sqlite3_result_double" + sqlite3_result_double :: SQLiteContext -> Double -> IO () + +foreign import ccall "sqlite3.h sqlite3_result_error" + sqlite3_result_error :: SQLiteContext -> CString -> CInt -> IO () + +foreign import ccall "sqlite3.h sqlite3_result_error16" + sqlite3_result_error16 :: SQLiteContext -> SQLiteUTF16 -> CInt -> IO () + +foreign import ccall "sqlite3.h sqlite3_result_error_toobig" + sqlite3_result_error_toobig :: SQLiteContext -> IO () + +{- +foreign import ccall "sqlite3.h sqlite3_result_error_nomem" + sqlite3_result_error_nomem :: SQLiteContext -> IO () +-} + +foreign import ccall "sqlite3.h sqlite3_result_int" + sqlite3_result_int :: SQLiteContext -> CInt -> IO () + +foreign import ccall "sqlite3.h sqlite3_result_int64" + sqlite3_result_int64 :: SQLiteContext -> SQLiteInt64 -> IO () + +foreign import ccall "sqlite3.h sqlite3_result_null" + sqlite3_result_null :: SQLiteContext -> IO () + +foreign import ccall "sqlite3.h sqlite3_result_text" + sqlite3_result_text :: SQLiteContext + -> CString + -> CInt + -> SQLiteCallback FreeHandler + -> IO () + +foreign import ccall "sqlite3.h sqlite3_result_text16" + sqlite3_result_text16 :: SQLiteContext -> SQLiteUTF16 -> CInt + -> SQLiteCallback FreeHandler + -> IO () + +foreign import ccall "sqlite3.h sqlite3_result_text16le" + sqlite3_result_text16le :: SQLiteContext -> SQLiteUTF16 -> CInt + -> SQLiteCallback FreeHandler -> IO () + +foreign import ccall "sqlite3.h sqlite3_result_text16be" + sqlite3_result_text16be :: SQLiteContext -> SQLiteUTF16 -> CInt + -> SQLiteCallback FreeHandler -> IO () + +foreign import ccall "sqlite3.h sqlite3_result_value" + sqlite3_result_value :: SQLiteContext -> SQLiteValue -> IO () + +foreign import ccall "sqlite3.h sqlite3_result_zeroblob" + sqlite3_result_zeroblob :: SQLiteContext -> CInt -> IO () + +foreign import ccall "sqlite3.h sqlite3_create_collation" + sqlite3_create_collation + :: SQLite -> CString -> TextEncodeFlag + -> SQLiteCallbackUserData + -> SQLiteCallback CompareHandler + -> IO Status + +foreign import ccall "sqlite3.h sqlite3_create_collation16" + sqlite3_create_collation16 + :: SQLite -> SQLiteUTF16 -> TextEncodeFlag + -> SQLiteCallbackUserData + -> SQLiteCallback CompareHandler + -> IO Status + +foreign import ccall "sqlite3.h sqlite3_create_collation_v2" + sqlite3_create_collation_v2 :: SQLite -> CString -> TextEncodeFlag + -> SQLiteCallbackUserData + -> SQLiteCallback CompareHandler + -> SQLiteCallback FreeHandler + -> IO Status + +foreign import ccall "sqlite3.h sqlite3_collation_needed" + sqlite3_collation_needed :: SQLite -> SQLiteCallbackUserData + -> SQLiteCallback CollationHandler + -> IO Status + +foreign import ccall "sqlite3.h sqlite3_collation_needed16" + sqlite3_collation_needed16 :: SQLite -> SQLiteCallbackUserData + -> SQLiteCallback CollationHandler16 + -> IO Status + +{- +foreign import ccall "sqlite3.h sqlite3_key" + sqlite3_key :: SQLite -> Ptr () -> CInt -> IO Status + +foreign import ccall "sqlite3.h sqlite3_rekey" + sqlite3_rekey :: SQLite -> Ptr () -> CInt -> IO Status +-} +foreign import ccall "sqlite3.h sqlite3_sleep" + sqlite3_sleep :: CInt -> IO Status + +foreign import ccall "sqlite3-local.h sqlite3_set_temp_directory" + sqlite3_set_temp_directory :: CString -> IO () + +foreign import ccall "sqlite3-local.h sqlite3_get_temp_directory" + sqlite3_get_temp_directory :: IO CString + +foreign import ccall "sqlite3.h sqlite3_get_autocommit" + sqlite3_get_autocommit :: SQLite -> IO Bool + +foreign import ccall "sqlite3.h sqlite3_db_handle" + sqlite3_db_handle :: SQLiteStmt -> IO SQLite + +foreign import ccall "sqlite3.h sqlite3_commit_hook" + sqlite3_commit_hook :: SQLite + -> SQLiteCallback FilterHandler + -> SQLiteCallbackUserData + -> IO (SQLiteCallback FilterHandler) + +foreign import ccall "sqlite3.h sqlite3_rollback_hook" + sqlite3_rollback_hook :: SQLite + -> SQLiteCallback FreeHandler + -> SQLiteCallbackUserData + -> IO (SQLiteCallback FreeHandler) + +foreign import ccall "sqlite3.h sqlite3_update_hook" + sqlite3_update_hook :: SQLite + -> SQLiteCallback UpdateHook + -> SQLiteCallbackUserData + -> IO (SQLiteCallback FreeHandler) + +foreign import ccall "sqlite3.h sqlite3_enable_shared_cache" + sqlite3_enable_shared_cache :: CInt -> IO CInt + +{- +foreign import ccall "sqlite3.h sqlite3_release_memory" + sqlite3_release_memory :: CInt -> IO Status + +foreign import ccall "sqlite3.h sqlite3_soft_heap_limit" + sqlite3_soft_heap_limit :: CInt -> IO () + +foreign import ccall "sqlite3.h sqlite3_table_column_metadata" + sqlite3_table_column_metadata + :: SQLite + -> CString + -> CString + -> CString + -> Ptr CString + -> Ptr CString + -> Ptr Bool + -> Ptr Bool + -> Ptr Bool + -> IO Status + +foreign import ccall "sqlite3.h sqlite3_load_extension" + sqlite3_load_extension :: SQLite -> CString -> CString -> Ptr CString -> IO Status + +foreign import ccall "sqlite3.h sqlite3_enable_load_extension" + sqlite3_enable_load_extension :: SQLite -> CInt -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_auto_extension" + sqlite3_auto_extension :: Ptr () -> IO Status + +foreign import ccall "sqlite3.h sqlite3_reset_auto_extension" + sqlite3_reset_auto_extension :: IO () +-} +foreign import ccall "sqlite3.h sqlite3_blob_open" + sqlite3_blob_open + :: SQLite + -> CString + -> CString + -> CString + -> SQLiteInt64 + -> Bool + -> Ptr SQLiteBLOB + -> IO Status + +foreign import ccall "sqlite3.h sqlite3_blob_close" + sqlite3_blob_close :: SQLiteBLOB -> IO Status + +foreign import ccall "sqlite3.h sqlite3_blob_bytes" + sqlite3_blob_bytes :: SQLiteBLOB -> IO CInt + +foreign import ccall "sqlite3.h sqlite3_blob_read" + sqlite3_blob_read :: SQLiteBLOB -> Ptr () -> CInt -> CInt -> IO Status + +foreign import ccall "sqlite3.h sqlite3_blob_write" + sqlite3_blob_write :: SQLiteBLOB -> Ptr () -> CInt -> CInt -> IO Status diff --git a/Database/SQLite/Types.hs b/Database/SQLite/Types.hs new file mode 100644 --- /dev/null +++ b/Database/SQLite/Types.hs @@ -0,0 +1,422 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-------------------------------------------------------------------- +-- | +-- Module : Database.SQLite.Types +-- Copyright : (c) Galois, Inc. 2007 +-- License : BSD3 +-- +-- Maintainer: Don Stewart +-- Stability : provisional +-- Portability: portable +-- +-- Objects, types and constants used in the sqlite3 binding. +-- +-------------------------------------------------------------------- + +module Database.SQLite.Types where + +import Foreign.C +import Foreign.Ptr +import Foreign.Storable +import Data.Int +import Data.Word +import Data.Bits + +type SQLiteInt64 = Int64 +type SQLiteWord64 = Word64 + +------------------------------------------------------------------------ +-- 'typed' pointers to various SQLite handles\/values. + +-- | An open SQLite database object. +-- +newtype SQLite = SQLite (Ptr ()) deriving Storable + +-- | An instance of this object represent single SQL statements. This +-- object is variously known as a "prepared statement" or a "compiled +-- SQL statement" or simply as a "statement". +-- +newtype SQLiteStmt = SQLiteStmt (Ptr ()) deriving Storable + +-- | SQLite uses the sqlite3_value object to represent all values that +-- are or can be stored in a database table. SQLite uses dynamic typing +-- for the values it stores. Values stored in sqlite3_value objects can +-- be be integers, floating point values, strings, BLOBs, or NULL. +-- +newtype SQLiteValue = SQLiteValue (Ptr ()) deriving Storable + +-- | The context in which an SQL function executes is stored in an +-- sqlite3_context object. A pointer to an sqlite3_context object is +-- always first parameter to application-defined SQL functions. +-- +newtype SQLiteContext = SQLiteContext (Ptr ()) deriving Storable + +-- | A BLOB handle +newtype SQLiteBLOB = SQLiteBLOB (Ptr ()) deriving Storable + +newtype SQLiteUTF16 = SQLiteUTF16 (Ptr ()) deriving Storable +newtype SQLiteContextBuffer = SQLiteContextBuffer (Ptr ()) deriving Storable +newtype SQLiteCallback a = SQLiteCallback (FunPtr a) deriving Storable + +-- don't use it much, so leave it as a bare pointer. +type SQLiteCallbackUserData = Ptr () + +------------------------------------------------------------------------ + +-- | SQLite types +data SQLiteType + = SQLiteInt + | SQLiteFloat + | SQLiteText + | SQLiteBlob + | SQLiteNull + deriving ( Eq ) + +instance Enum SQLiteType where + fromEnum e = + case e of + SQLiteInt -> 1 + SQLiteFloat -> 2 + SQLiteText -> 3 + SQLiteBlob -> 4 + SQLiteNull -> 5 + toEnum x = + case x of + 1 -> SQLiteInt + 2 -> SQLiteFloat + 3 -> SQLiteText + 4 -> SQLiteBlob + 5 -> SQLiteNull + _ -> error ("toEnum{SQLiteType}: unknown type tag " ++ show x) + +------------------------------------------------------------------------ + +type Status = Word32 + +-- | SQLite C status codes. +-- +-- * +-- +sQLITE_OK :: Status +sQLITE_OK = 0 + +-- error codes: +sQLITE_ERROR :: Status +sQLITE_ERROR = 1 +sQLITE_INTERNAL :: Status +sQLITE_INTERNAL = 2 +sQLITE_PERM :: Status +sQLITE_PERM = 3 +sQLITE_ABORT :: Status +sQLITE_ABORT = 4 +sQLITE_BUSY :: Status +sQLITE_BUSY = 5 +sQLITE_LOCKED :: Status +sQLITE_LOCKED = 6 +sQLITE_NOMEM :: Status +sQLITE_NOMEM = 7 +sQLITE_READONLY :: Status +sQLITE_READONLY = 8 +sQLITE_INTERRUPT :: Status +sQLITE_INTERRUPT = 9 +sQLITE_IOERR :: Status +sQLITE_IOERR = 10 +sQLITE_CORRUPT :: Status +sQLITE_CORRUPT = 11 +sQLITE_NOTFOUND :: Status +sQLITE_NOTFOUND = 12 +sQLITE_FULL :: Status +sQLITE_FULL = 13 +sQLITE_CANTOPEN :: Status +sQLITE_CANTOPEN = 14 +sQLITE_PROTOCOL :: Status +sQLITE_PROTOCOL = 15 +sQLITE_EMPTY :: Status +sQLITE_EMPTY = 16 +sQLITE_SCHEMA :: Status +sQLITE_SCHEMA = 17 +sQLITE_TOOBIG :: Status +sQLITE_TOOBIG = 18 +sQLITE_CONSTRAINT :: Status +sQLITE_CONSTRAINT = 19 +sQLITE_MISMATCH :: Status +sQLITE_MISMATCH = 20 +sQLITE_MISUSE :: Status +sQLITE_MISUSE = 21 +sQLITE_NOLFS :: Status +sQLITE_NOLFS = 22 +sQLITE_AUTH :: Status +sQLITE_AUTH = 23 +sQLITE_FORMAT :: Status +sQLITE_FORMAT = 24 +sQLITE_RANGE :: Status +sQLITE_RANGE = 25 +sQLITE_NOTADB :: Status +sQLITE_NOTADB = 26 +sQLITE_ROW :: Status +sQLITE_ROW = 100 +sQLITE_DONE :: Status +sQLITE_DONE = 101 + +------------------------------------------------------------------------ +-- | SQLite extended result codes: +-- +-- * +-- +sQLITE_IOERR_READ :: Status +sQLITE_IOERR_READ = sQLITE_IOERR + (1 `shiftL` 8) +sQLITE_IOERR_SHORT_READ :: Status +sQLITE_IOERR_SHORT_READ = sQLITE_IOERR + (2 `shiftL` 8) +sQLITE_IOERR_WRITE :: Status +sQLITE_IOERR_WRITE = sQLITE_IOERR + (3 `shiftL` 8) +sQLITE_IOERR_FSYNC :: Status +sQLITE_IOERR_FSYNC = sQLITE_IOERR + (4 `shiftL` 8) +sQLITE_IOERR_DIR_FSYNC :: Status +sQLITE_IOERR_DIR_FSYNC = sQLITE_IOERR + (5 `shiftL` 8) +sQLITE_IOERR_TRUNCATE :: Status +sQLITE_IOERR_TRUNCATE = sQLITE_IOERR + (6 `shiftL` 8) +sQLITE_IOERR_FSTAT :: Status +sQLITE_IOERR_FSTAT = sQLITE_IOERR + (7 `shiftL` 8) +sQLITE_IOERR_UNLOCK :: Status +sQLITE_IOERR_UNLOCK = sQLITE_IOERR + (8 `shiftL` 8) +sQLITE_IOERR_RDLOCK :: Status +sQLITE_IOERR_RDLOCK = sQLITE_IOERR + (9 `shiftL` 8) +sQLITE_IOERR_DELETE :: Status +sQLITE_IOERR_DELETE = sQLITE_IOERR + (10 `shiftL` 8) +sQLITE_IOERR_BLOCKED :: Status +sQLITE_IOERR_BLOCKED = sQLITE_IOERR + (11 `shiftL` 8) +sQLITE_IOERR_NOMEM :: Status +sQLITE_IOERR_NOMEM = sQLITE_IOERR + (12 `shiftL` 8) + +------------------------------------------------------------------------ + +type OpenFlags = Word32 + +-- | SQLite flags for open operations. +-- +-- * +-- +sQLITE_OPEN_READONLY :: OpenFlags +sQLITE_OPEN_READONLY = 0x00000001 +sQLITE_OPEN_READWRITE :: OpenFlags +sQLITE_OPEN_READWRITE = 0x00000002 +sQLITE_OPEN_CREATE :: OpenFlags +sQLITE_OPEN_CREATE = 0x00000004 +sQLITE_OPEN_DELETEONCLOSE :: OpenFlags +sQLITE_OPEN_DELETEONCLOSE = 0x00000008 +sQLITE_OPEN_EXCLUSIVE :: OpenFlags +sQLITE_OPEN_EXCLUSIVE = 0x00000010 +sQLITE_OPEN_MAIN_DB :: OpenFlags +sQLITE_OPEN_MAIN_DB = 0x00000100 +sQLITE_OPEN_TEMP_DB :: OpenFlags +sQLITE_OPEN_TEMP_DB = 0x00000200 +sQLITE_OPEN_TRANSIENT_DB :: OpenFlags +sQLITE_OPEN_TRANSIENT_DB = 0x00000400 +sQLITE_OPEN_MAIN_JOURNAL :: OpenFlags +sQLITE_OPEN_MAIN_JOURNAL = 0x00000800 +sQLITE_OPEN_TEMP_JOURNAL :: OpenFlags +sQLITE_OPEN_TEMP_JOURNAL = 0x00001000 +sQLITE_OPEN_SUBJOURNAL :: OpenFlags +sQLITE_OPEN_SUBJOURNAL = 0x00002000 +sQLITE_OPEN_MASTER_JOURNAL :: OpenFlags +sQLITE_OPEN_MASTER_JOURNAL = 0x00004000 + +------------------------------------------------------------------------ + +type IOCap = Word32 + +-- | Device characteristics +-- +-- * +-- +sQLITE_IOCAP_ATOMIC :: IOCap +sQLITE_IOCAP_ATOMIC = 0x00000001 +sQLITE_IOCAP_ATOMIC512 :: IOCap +sQLITE_IOCAP_ATOMIC512 = 0x00000002 +sQLITE_IOCAP_ATOMIC1K :: IOCap +sQLITE_IOCAP_ATOMIC1K = 0x00000004 +sQLITE_IOCAP_ATOMIC2K :: IOCap +sQLITE_IOCAP_ATOMIC2K = 0x00000008 +sQLITE_IOCAP_ATOMIC4K :: IOCap +sQLITE_IOCAP_ATOMIC4K = 0x00000010 +sQLITE_IOCAP_ATOMIC8K :: IOCap +sQLITE_IOCAP_ATOMIC8K = 0x00000020 +sQLITE_IOCAP_ATOMIC16K :: IOCap +sQLITE_IOCAP_ATOMIC16K = 0x00000040 +sQLITE_IOCAP_ATOMIC32K :: IOCap +sQLITE_IOCAP_ATOMIC32K = 0x00000080 +sQLITE_IOCAP_ATOMIC64K :: IOCap +sQLITE_IOCAP_ATOMIC64K = 0x00000100 +sQLITE_IOCAP_SAFE_APPEND :: IOCap +sQLITE_IOCAP_SAFE_APPEND = 0x00000200 +sQLITE_IOCAP_SEQUENTIAL :: IOCap +sQLITE_IOCAP_SEQUENTIAL = 0x00000400 + +------------------------------------------------------------------------ + +type LockFlag = Word32 + +-- | File locking levels +-- +-- * +-- +sQLITE_LOCK_NONE :: LockFlag +sQLITE_LOCK_NONE = 0 +sQLITE_LOCK_SHARED :: LockFlag +sQLITE_LOCK_SHARED = 1 +sQLITE_LOCK_RESERVED :: LockFlag +sQLITE_LOCK_RESERVED = 2 +sQLITE_LOCK_PENDING :: LockFlag +sQLITE_LOCK_PENDING = 3 +sQLITE_LOCK_EXCLUSIVE :: LockFlag +sQLITE_LOCK_EXCLUSIVE = 4 + +------------------------------------------------------------------------ + +type SyncFlag = Word32 + +-- | Synchronization flags +-- +-- * +-- +sQLITE_SYNC_NORMAL :: SyncFlag +sQLITE_SYNC_NORMAL = 0x00002 +sQLITE_SYNC_FULL :: SyncFlag +sQLITE_SYNC_FULL = 0x00003 +sQLITE_SYNC_DATAONLY:: SyncFlag +sQLITE_SYNC_DATAONLY = 0x00010 + +------------------------------------------------------------------------ + +type AccessFlag = Word32 + +-- | xAccess methods +-- +-- * +-- +sQLITE_ACCESS_EXISTS :: AccessFlag +sQLITE_ACCESS_EXISTS = 0 +sQLITE_ACCESS_READWRITE :: AccessFlag +sQLITE_ACCESS_READWRITE = 1 +sQLITE_ACCESS_READ :: AccessFlag +sQLITE_ACCESS_READ = 2 + +------------------------------------------------------------------------ + +type AuthCode = Word32 + +-- | Authorizer Action Codes +-- +-- * +-- +sQLITE_COPY :: AuthCode +sQLITE_COPY = 0 -- No longer used +sQLITE_CREATE_INDEX :: AuthCode +sQLITE_CREATE_INDEX = 1 -- Index Name Table Name +sQLITE_CREATE_TABLE :: AuthCode +sQLITE_CREATE_TABLE = 2 -- Table Name NULL +sQLITE_CREATE_TEMP_INDEX :: AuthCode +sQLITE_CREATE_TEMP_INDEX = 3 -- Index Name Table Name +sQLITE_CREATE_TEMP_TABLE :: AuthCode +sQLITE_CREATE_TEMP_TABLE = 4 -- Table Name NULL +sQLITE_CREATE_TEMP_TRIGGER :: AuthCode +sQLITE_CREATE_TEMP_TRIGGER = 5 -- Trigger Name Table Name +sQLITE_CREATE_TEMP_VIEW :: AuthCode +sQLITE_CREATE_TEMP_VIEW = 6 -- View Name NULL +sQLITE_CREATE_TRIGGER :: AuthCode +sQLITE_CREATE_TRIGGER = 7 -- Trigger Name Table Name +sQLITE_CREATE_VIEW :: AuthCode +sQLITE_CREATE_VIEW = 8 -- View Name NULL +sQLITE_DELETE :: AuthCode +sQLITE_DELETE = 9 -- Table Name NULL +sQLITE_DROP_INDEX :: AuthCode +sQLITE_DROP_INDEX = 10 -- Index Name Table Name +sQLITE_DROP_TABLE :: AuthCode +sQLITE_DROP_TABLE = 11 -- Table Name NULL +sQLITE_DROP_TEMP_INDEX :: AuthCode +sQLITE_DROP_TEMP_INDEX = 12 -- Index Name Table Name +sQLITE_DROP_TEMP_TABLE :: AuthCode +sQLITE_DROP_TEMP_TABLE = 13 -- Table Name NULL +sQLITE_DROP_TEMP_TRIGGER :: AuthCode +sQLITE_DROP_TEMP_TRIGGER = 14 -- Trigger Name Table Name +sQLITE_DROP_TEMP_VIEW :: AuthCode +sQLITE_DROP_TEMP_VIEW = 15 -- View Name NULL +sQLITE_DROP_TRIGGER :: AuthCode +sQLITE_DROP_TRIGGER = 16 -- Trigger Name Table Name +sQLITE_DROP_VIEW :: AuthCode +sQLITE_DROP_VIEW = 17 -- View Name NULL +sQLITE_INSERT :: AuthCode +sQLITE_INSERT = 18 -- Table Name NULL +sQLITE_PRAGMA :: AuthCode +sQLITE_PRAGMA = 19 -- Pragma Name 1st arg or NULL +sQLITE_READ :: AuthCode +sQLITE_READ = 20 -- Table Name Column Name +sQLITE_SELECT :: AuthCode +sQLITE_SELECT = 21 -- NULL NULL +sQLITE_TRANSACTION :: AuthCode +sQLITE_TRANSACTION = 22 -- NULL NULL +sQLITE_UPDATE :: AuthCode +sQLITE_UPDATE = 23 -- Table Name Column Name +sQLITE_ATTACH :: AuthCode +sQLITE_ATTACH = 24 -- Filename NULL +sQLITE_DETACH :: AuthCode +sQLITE_DETACH = 25 -- Database Name NULL +sQLITE_ALTER_TABLE :: AuthCode +sQLITE_ALTER_TABLE = 26 -- Database Name Table Name +sQLITE_REINDEX :: AuthCode +sQLITE_REINDEX = 27 -- Index Name NULL +sQLITE_ANALYZE :: AuthCode +sQLITE_ANALYZE = 28 -- Table Name NULL +sQLITE_CREATE_VTABLE :: AuthCode +sQLITE_CREATE_VTABLE = 29 -- Table Name Module Name +sQLITE_DROP_VTABLE :: AuthCode +sQLITE_DROP_VTABLE = 30 -- Table Name Module Name +sQLITE_FUNCTION :: AuthCode +sQLITE_FUNCTION = 31 -- Function Name NULL + +------------------------------------------------------------------------ + +type TextEncodeFlag = CInt + +-- | Text encodings +-- +-- * +-- +sQLITE_UTF8 :: TextEncodeFlag +sQLITE_UTF8 = 1 +sQLITE_UTF16LE :: TextEncodeFlag +sQLITE_UTF16LE = 2 +sQLITE_UTF16BE :: TextEncodeFlag +sQLITE_UTF16BE = 3 +sQLITE_UTF16 :: TextEncodeFlag +sQLITE_UTF16 = 4 +sQLITE_ANY :: TextEncodeFlag +sQLITE_ANY = 5 +sQLITE_UTF16_ALIGNED :: TextEncodeFlag +sQLITE_UTF16_ALIGNED = 8 + +type FundamentalDatatype = CInt + +-- | Fundamental datatypes +-- +-- * +-- +sQLITE_INTEGER :: FundamentalDatatype +sQLITE_INTEGER = 1 +sQLITE_FLOAT :: FundamentalDatatype +sQLITE_FLOAT = 2 +sQLITE_BLOB :: FundamentalDatatype +sQLITE_BLOB = 4 +sQLITE_NULL :: FundamentalDatatype +sQLITE_NULL = 5 +sQLITE_TEXT :: FundamentalDatatype +sQLITE_TEXT = 3 + +isNullStmt :: SQLiteStmt -> Bool +isNullStmt (SQLiteStmt p) = p == nullPtr + +noCallback :: SQLiteCallback a +noCallback = SQLiteCallback nullFunPtr + +freeCallback :: SQLiteCallback a -> IO () +freeCallback (SQLiteCallback c) = freeHaskellFunPtr c diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) Galois Inc, 2007 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,6 @@ +sqlite3 bindings for Haskell. + +The configuration of this package isn't automatic on Windows +platforms, you'll have to manually move sqlite.buildinfo away before +renaming sqlite.buildinfo.win32 as sqlite.buildinfo, followed by +tweaking the paths in there to fit your local environment. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple + + +main :: IO () +main = defaultMainWithHooks defaultUserHooks diff --git a/cbits/sqlite3-local.c b/cbits/sqlite3-local.c new file mode 100644 --- /dev/null +++ b/cbits/sqlite3-local.c @@ -0,0 +1,27 @@ +#include "sqlite3.h" +#include "sqlite3-local.h" +#include +#include + +void +sqlite3_set_temp_directory(char* x) +{ + sqlite3_temp_directory = (char*)sqlite3_malloc(strlen(x)+1); + if (sqlite3_temp_directory) { + strcpy(sqlite3_temp_directory,x); + } +} + +char * +sqlite3_get_temp_directory(void) +{ + return sqlite3_temp_directory; +} + +sqlite3_destructor_type +get_SQLITE_STATIC() +{ return SQLITE_STATIC; } + +sqlite3_destructor_type +get_SQLITE_TRANSIENT() +{ return SQLITE_TRANSIENT; } diff --git a/configure b/configure new file mode 100644 --- /dev/null +++ b/configure @@ -0,0 +1,18 @@ +#!/bin/sh +# +# +UNAME=uname +case `${UNAME} -a` in + *MINGW* | *CYGWIN* ) + echo "Windows platform... using .buildinfo.win32" + cp sqlite.buildinfo.win32 sqlite.buildinfo + ;; + *) + # subst standard header path variables + if test -n "$CPPFLAGS" ; then + echo "Found CPPFLAGS in environment: '$CPPFLAGS'" + sed 's,@CPPFLAGS@,'"$CPPFLAGS"',g' < sqlite.buildinfo.unix > sqlite.buildinfo + fi + ;; +esac + diff --git a/include/sqlite3-local.h b/include/sqlite3-local.h new file mode 100644 --- /dev/null +++ b/include/sqlite3-local.h @@ -0,0 +1,11 @@ +#ifndef __SQLITE3_LOCAL_H +#define __SQLITE3_LOCAL_H +#include "sqlite3.h" + +extern void sqlite3_set_temp_directory(char* x); +extern char *sqlite3_get_temp_directory(); + +extern sqlite3_destructor_type get_SQLITE_STATIC(); +extern sqlite3_destructor_type get_SQLITE_TRANSIENT(); + +#endif diff --git a/sqlite.buildinfo.unix b/sqlite.buildinfo.unix new file mode 100644 --- /dev/null +++ b/sqlite.buildinfo.unix @@ -0,0 +1,3 @@ +-- Should you have a custom include path for sqlite, edit the next two lines: +Ghc-options: -optc@CPPFLAGS@ +Cc-options: @CPPFLAGS@ diff --git a/sqlite.buildinfo.win32 b/sqlite.buildinfo.win32 new file mode 100644 --- /dev/null +++ b/sqlite.buildinfo.win32 @@ -0,0 +1,3 @@ +-- Should you have a custom include path for sqlite, edit the next two lines: +Ghc-options: -optc-Ic:/src/sqlite-3.5.1 +Cc-options: -Ic:/src/sqlite-3.5.1 diff --git a/sqlite.cabal b/sqlite.cabal new file mode 100644 --- /dev/null +++ b/sqlite.cabal @@ -0,0 +1,56 @@ +Name: sqlite +Version: 0.4.1 +Synopsis: Haskell binding to sqlite3 +Description: + Haskell binding to sqlite3 . + . +License: BSD3 +License-file: LICENSE +Author: Galois Inc +Maintainer: Don Stewart +Copyright: + Copyright (c) 2007-8, Galois Inc +Category: Database +cabal-version: >= 1.2 +build-type: Configure + +-- Cheating here, including the tests/ .cabal + +-- files in the parent (so as to dist them as one.) +extra-source-files: + README configure + include/sqlite3-local.h + sqlite.buildinfo.unix sqlite.buildinfo.win32 + tests/configure tests/Main.hs tests/Setup.hs + tests/sqlite-tests.cabal + tests/test.db tests/sqlite-tests.buildinfo.unix + tests/sqlite-tests.buildinfo.win32 +extra-tmp-files: + sqlite.buildinfo + +flag builtin-sqlite3 + default: False + description: Compile sqlite3 as a part of the library. + +library + Build-depends: base, pretty, utf8-string, bytestring, time, directory + Extensions: ForeignFunctionInterface, GeneralizedNewtypeDeriving, + TypeSynonymInstances + Ghc-options: -Wall + Cc-options: -Wall + Include-dirs: include + Includes: sqlite3-local.h + C-Sources: cbits/sqlite3-local.c + + if flag(builtin-sqlite3) + Include-dirs: sqlite3.5 + Includes: sqlite3.5 + C-Sources: sqlite3.5/sqlite3.c + else + Extra-Libraries: sqlite3 + + Exposed-modules: + Database.SQLite, + Database.SQLite.Base, + Database.SQLite.Types, + Database.SQL + Database.SQL.Types diff --git a/sqlite3.5/sqlite3.c b/sqlite3.5/sqlite3.c new file mode 100644 # file too large to diff: sqlite3.5/sqlite3.c diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,42 @@ +module Main where + +import Database.SQLite + +newTable :: TableName -> Table SQLType +newTable tName = + Table { tabName = tName + , tabColumns = + [ Column { colName = "id" + , colType = SQLInt NORMAL False False + , colClauses = [PrimaryKey True] + } + , Column { colName = "name" + , colType = SQLVarChar 200 + , colClauses = [IsNullable False] + } + , Column { colName = "age" + , colType = SQLVarChar 200 + , colClauses = [IsNullable True] + } + ] + , tabConstraints = [] + } + +main :: IO () +main = do + let dbFile = "test.db" + let ign act = + catch (act >> return ()) + (\ err -> putStrLn ("Error (but ignoring) -- " ++ show err) >> return ()) + h <- openConnection dbFile + ign $ defineTable h (newTable "names") + ign $ insertRow h "Poststed" [("Postnr", "4278"),("Poststed", "Veakrossen")] + ls <- execStatement h "SELECT * FROM Poststed WHERE PostNr=4276;" + print ls + ign $ insertRow h "names" [("id", "1"),("name", "foo"), ("age", "30")] + ls <- execStatement h "SELECT * FROM names;" + print ls + ls <- execStatement h "SELECT * FROM names where id=1;" + print ls + closeConnection h + diff --git a/tests/Setup.hs b/tests/Setup.hs new file mode 100644 --- /dev/null +++ b/tests/Setup.hs @@ -0,0 +1,7 @@ +module Main where + +import Distribution.Simple + + +main :: IO () +main = defaultMainWithHooks defaultUserHooks diff --git a/tests/configure b/tests/configure new file mode 100644 --- /dev/null +++ b/tests/configure @@ -0,0 +1,15 @@ +#!/bin/sh +# +# +UNAME=uname +case `${UNAME} -a` in + *MINGW* | *CYGWIN* ) + echo "Windows platform... using .buildinfo.win32" + cp sqlite-tests.buildinfo.win32 sqlite-tests.buildinfo + ;; + *) + echo "UNIXy platform... using .buildinfo.unix" + cp sqlite-tests.buildinfo.unix sqlite-tests.buildinfo + ;; +esac + diff --git a/tests/sqlite-tests.buildinfo.unix b/tests/sqlite-tests.buildinfo.unix new file mode 100644 --- /dev/null +++ b/tests/sqlite-tests.buildinfo.unix @@ -0,0 +1,1 @@ +ghc-options: -L/usr/lib diff --git a/tests/sqlite-tests.buildinfo.win32 b/tests/sqlite-tests.buildinfo.win32 new file mode 100644 --- /dev/null +++ b/tests/sqlite-tests.buildinfo.win32 @@ -0,0 +1,1 @@ +ghc-options: -Lc:/src/sqlite-3.5.1/ diff --git a/tests/sqlite-tests.cabal b/tests/sqlite-tests.cabal new file mode 100644 --- /dev/null +++ b/tests/sqlite-tests.cabal @@ -0,0 +1,20 @@ +name: sqlite-tests +cabal-version: >= 1.2.0 +version: 0.1 + +flag new-base { + description: Build with new smaller base library + default: False +} + +executable sqlite-test { + build-depends: base, sqlite + if flag(new-base) { + build-depends: base >= 2.1 + } else { + build-depends: base == 2.0 || == 2.1.1 + } + + main-is: Main.hs + ghc-options: -Wall -fglasgow-exts -lsqlite3 +} diff --git a/tests/test.db b/tests/test.db new file mode 100644 Binary files /dev/null and b/tests/test.db differ