hsql (empty) → 1.7
raw patch · 4 files changed
+778/−0 lines, 4 filesdep +basebuild-type:Customsetup-changed
Dependencies added: base
Files
- Database/HSQL.hsc +607/−0
- Database/HSQL/Types.hs +153/−0
- Setup.lhs +7/−0
- hsql.cabal +11/−0
+ Database/HSQL.hsc view
@@ -0,0 +1,607 @@+-----------------------------------------------------------------------------------------+{-| Module : Database.HSQL.ODBC+ Copyright : (c) Krasimir Angelov 2003+ License : BSD-style++ Maintainer : ka2_mail@yahoo.com+ Stability : provisional+ Portability : portable++ The module provides an abstract database interface+-}+-----------------------------------------------------------------------------------------++module Database.HSQL+ (+ -- * Connect\/Disconnect+ Connection+ , disconnect -- :: Connection -> IO ()+ + -- * Command Execution Functions+ -- | Once a connection to a database has been successfully established, + -- the functions described here are used to perform SQL queries and commands.+ , execute -- :: Connection -> String -> IO ()+ , Statement+ , query -- :: Connection -> String -> IO Statement+ , closeStatement -- :: Statement -> IO ()+ , fetch -- :: Statement -> IO Bool+ + -- * Retrieving Statement values and types+ , FieldDef, SqlType(..), SqlBind, toSqlValue+ , getFieldValue -- :: SqlBind a => Statement -> String -> IO a+ , getFieldValueMB+ , getFieldValue' -- :: SqlBind a => Statement -> String -> a -> IO a+ , getFieldValueType -- :: Statement -> String -> (SqlType, Bool)+ , getFieldsTypes -- :: Statement -> [(String, SqlType, Bool)]+ + -- * Transactions+ , inTransaction -- :: Connection -> (Connection -> IO a) -> IO a++ + -- * SQL Exceptions handling+ , SqlError(..)+ , catchSql -- :: IO a -> (SqlError -> IO a) -> IO a+ , handleSql -- :: (SqlError -> IO a) -> IO a -> IO a+ , sqlExceptions -- :: Exception -> Maybe SqlError+ + -- * Utilities+ , forEachRow -- :: (Statement -> s -> IO s) -- ^ an action+ , forEachRow' -- :: (Statement -> IO ()) -> Statement -> IO ()+ , collectRows -- :: (Statement -> IO a) -> Statement -> IO [a]+ + -- * Metadata+ , tables -- :: Connection -> IO [String]+ , describe -- :: Connection -> String -> IO [FieldDef]++ -- * Extra types+ , Point(..), Line(..), Path(..), Box(..), Circle(..), Polygon(..)+ ) where++import Prelude hiding (catch)+import Foreign+import Foreign.C+import Data.Int+import Data.Char+import Data.Dynamic+import System.Time+import System.IO.Unsafe(unsafePerformIO)+import Control.Monad(when,unless,mplus)+import Control.Exception (throwDyn, catchDyn, dynExceptions, Exception(..), finally, catch, throwIO)+import Control.Concurrent.MVar+import Text.ParserCombinators.ReadP+import Text.Read+import Text.Read.Lex+import Numeric+import Database.HSQL.Types++#include <time.h>++-----------------------------------------------------------------------------------------+-- routines for exception handling+-----------------------------------------------------------------------------------------++catchSql :: IO a -> (SqlError -> IO a) -> IO a+catchSql = catchDyn++handleSql :: (SqlError -> IO a) -> IO a -> IO a+handleSql h f = catchDyn f h++sqlExceptions :: Exception -> Maybe SqlError+sqlExceptions e = dynExceptions e >>= fromDynamic++checkHandle :: MVar Bool -> IO a -> IO a+checkHandle ref action =+ withMVar ref (\closed -> when closed (throwDyn SqlClosedHandle) >> action)++closeHandle :: MVar Bool -> IO () -> IO ()+closeHandle ref action =+ modifyMVar_ ref (\closed -> unless closed action >> return True)++-----------------------------------------------------------------------------------------+-- Operations on the connection+-----------------------------------------------------------------------------------------++-- | Closes the connection. Performing 'disconnect' on a connection that has already been +-- closed has no effect. All other operations on a closed connection will fail.+disconnect :: Connection -> IO ()+disconnect conn = closeHandle (connClosed conn) (connDisconnect conn)+ +-- | Submits a command to the database.+execute :: Connection -- ^ the database connection+ -> String -- ^ the text of SQL command+ -> IO ()+execute conn query = checkHandle (connClosed conn) (connExecute conn query)++-- | Executes a query and returns a result set+query :: Connection -- ^ the database connection+ -> String -- ^ the text of SQL query+ -> IO Statement -- ^ the associated statement. Must be closed with + -- the 'closeStatement' function+query conn query = checkHandle (connClosed conn) (connQuery conn query)+ ++-- | List all tables in the database.+tables :: Connection -- ^ Database connection+ -> IO [String] -- ^ The names of all tables in the database.+tables conn = checkHandle (connClosed conn) (connTables conn)++-- | List all columns in a table along with their types and @nullable@ flags+describe :: Connection -- ^ Database connection+ -> String -- ^ Name of a database table+ -> IO [FieldDef] -- ^ The list of fields in the table+describe conn table = checkHandle (connClosed conn) (connDescribe conn table)++-----------------------------------------------------------------------------------------+-- transactions+-----------------------------------------------------------------------------------------++-- | The 'inTransaction' function executes the specified action in transaction mode.+-- If the action completes successfully then the transaction will be commited.+-- If the action completes with an exception then the transaction will be rolled back+-- and the exception will be throw again.+inTransaction :: Connection+ -> (Connection -> IO a) -- ^ an action+ -> IO a -- ^ the returned value is the result returned from action+inTransaction conn action = do+ checkHandle (connClosed conn) (connBeginTransaction conn)+ r <- catch (action conn) (\err -> do+ checkHandle (connClosed conn) (connRollbackTransaction conn)+ throwIO err)+ checkHandle (connClosed conn) (connCommitTransaction conn)+ return r++-----------------------------------------------------------------------------------------+-- Operations on the statements+-----------------------------------------------------------------------------------------++-- | 'fetch' fetches the next rowset of data from the result set.+-- The values from columns can be retrieved with 'getFieldValue' function.+fetch :: Statement -> IO Bool+fetch stmt = checkHandle (stmtClosed stmt) (stmtFetch stmt)++-- | 'closeStatement' stops processing associated with a specific statement, closes any open cursors+-- associated with the statement, discards pending results, and frees all resources associated with+-- the statement. Performing 'closeStatement' on a statement that has already been +-- closed has no effect. All other operations on a closed statement will fail.+closeStatement :: Statement -> IO ()+closeStatement stmt = closeHandle (stmtClosed stmt) (stmtClose stmt)++-- | Returns the type and the @nullable@ flag for field with specified name+getFieldValueType :: Statement -> String -> (SqlType, Bool)+getFieldValueType stmt name = (sqlType, nullable)+ where+ (sqlType,nullable,colNumber) = findFieldInfo name (stmtFields stmt) 0++-- | Returns the list of fields with their types and @nullable@ flags+getFieldsTypes :: Statement -> [(String, SqlType, Bool)]+getFieldsTypes stmt = stmtFields stmt++findFieldInfo :: String -> [FieldDef] -> Int -> (SqlType,Bool,Int)+findFieldInfo name [] colNumber = throwDyn (SqlUnknownField name)+findFieldInfo name (fieldDef@(name',sqlType,nullable):fields) colNumber+ | name == name' = (sqlType,nullable,colNumber)+ | otherwise = findFieldInfo name fields $! (colNumber+1)++-----------------------------------------------------------------------------------------+-- binding+-----------------------------------------------------------------------------------------++foreign import ccall "stdlib.h atoi" c_atoi :: CString -> IO Int+#ifdef mingw32_TARGET_OS+foreign import ccall "stdlib.h _atoi64" c_atoi64 :: CString -> IO Int64+#else+foreign import ccall "stdlib.h strtoll" c_strtoll :: CString -> Ptr CString -> Int -> IO Int64+#endif++instance SqlBind a => SqlBind (Maybe a) where+ fromSqlCStringLen fieldDef cstr cstrLen+ | cstr == nullPtr = return Nothing+ | otherwise = do v <- fromSqlCStringLen fieldDef cstr cstrLen+ return (Just v)+ + fromSqlValue tp s = Just (fromSqlValue tp s)++ toSqlValue (Just v) = toSqlValue v+ toSqlValue Nothing = "null"++instance SqlBind Int where+ fromSqlCStringLen (name,sqlType,_) cstr cstrLen+ | cstr == nullPtr = throwDyn (SqlFetchNull name)+ | sqlType==SqlInteger || + sqlType==SqlMedInt ||+ sqlType==SqlTinyInt ||+ sqlType==SqlSmallInt||+ sqlType==SqlBigInt = c_atoi cstr+ | otherwise = throwDyn (SqlBadTypeCast name sqlType)++ fromSqlValue SqlInteger s = Just (read s)+ fromSqlValue SqlMedInt s = Just (read s)+ fromSqlValue SqlTinyInt s = Just (read s)+ fromSqlValue SqlSmallInt s = Just (read s)+ fromSqlValue SqlBigInt s = Just (read s)+ fromSqlValue SqlDouble s = Just (truncate (read s :: Double))+ fromSqlValue SqlText s = Just (read s)+ fromSqlValue _ _ = Nothing++ toSqlValue s = show s++instance SqlBind Int64 where+ fromSqlCStringLen (name,sqlType,_) cstr cstrLen+ | cstr == nullPtr = throwDyn (SqlFetchNull name)+ | sqlType==SqlInteger ||+ sqlType==SqlMedInt ||+ sqlType==SqlTinyInt ||+ sqlType==SqlSmallInt||+ sqlType==SqlBigInt =+#ifdef mingw32_TARGET_OS+ c_atoi64 cstr+#else+ c_strtoll cstr nullPtr 10+#endif+ | otherwise = throwDyn (SqlBadTypeCast name sqlType)++ fromSqlValue SqlInteger s = Just (read s)+ fromSqlValue SqlMedInt s = Just (read s)+ fromSqlValue SqlTinyInt s = Just (read s)+ fromSqlValue SqlSmallInt s = Just (read s)+ fromSqlValue SqlBigInt s = Just (read s)+ fromSqlValue SqlDouble s = Just (truncate (read s :: Double))+ fromSqlValue SqlText s = Just (read s)+ fromSqlValue _ s = Nothing++ toSqlValue val = show val++instance SqlBind Integer where+ fromSqlValue SqlInteger s = Just (read s)+ fromSqlValue SqlMedInt s = Just (read s)+ fromSqlValue SqlTinyInt s = Just (read s)+ fromSqlValue SqlSmallInt s = Just (read s)+ fromSqlValue SqlBigInt s = Just (read s)+ fromSqlValue SqlDouble s = Just (truncate (read s :: Double))+ fromSqlValue SqlText s = Just (read s)+ fromSqlValue _ _ = Nothing++ toSqlValue s = show s+instance SqlBind String where+ fromSqlValue _ = Just++ toSqlValue s = '\'' : foldr mapChar "'" s+ where+ mapChar '\\' s = '\\':'\\':s+ mapChar '\'' s = '\\':'\'':s+ mapChar '\n' s = '\\':'n' :s+ mapChar '\r' s = '\\':'r' :s+ mapChar '\t' s = '\\':'t' :s+ mapChar '\NUL' s = '\\':'0' :s+ mapChar c s = c :s++instance SqlBind Bool where+ fromSqlValue SqlBit s = Just (s == "t")+ fromSqlValue _ _ = Nothing++ toSqlValue True = "'t'"+ toSqlValue False = "'f'"++instance SqlBind Double where+ fromSqlValue (SqlDecimal _ _) s = Just (read s)+ fromSqlValue (SqlNumeric _ _) s = Just (read s)+ fromSqlValue SqlDouble s = Just (read s)+ fromSqlValue SqlReal s = Just (read s)+ fromSqlValue SqlFloat s = Just (read s)+ fromSqlValue SqlText s = Just (read s)+ fromSqlValue _ _ = Nothing++ toSqlValue d = show d++instance SqlBind Float where+ fromSqlValue (SqlDecimal _ _) s = Just (read s)+ fromSqlValue (SqlNumeric _ _) s = Just (read s)+ fromSqlValue SqlDouble s = Just (read s)+ fromSqlValue SqlReal s = Just (read s)+ fromSqlValue SqlFloat s = Just (read s)+ fromSqlValue SqlText s = Just (read s)+ fromSqlValue _ _ = Nothing++ toSqlValue d = show d++mkClockTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> ClockTime+mkClockTime year mon mday hour min sec tz =+ unsafePerformIO $ do+ allocaBytes (#const sizeof(struct tm)) $ \ p_tm -> do+ (#poke struct tm,tm_sec ) p_tm (fromIntegral sec :: CInt)+ (#poke struct tm,tm_min ) p_tm (fromIntegral min :: CInt)+ (#poke struct tm,tm_hour ) p_tm (fromIntegral hour :: CInt)+ (#poke struct tm,tm_mday ) p_tm (fromIntegral mday :: CInt)+ (#poke struct tm,tm_mon ) p_tm (fromIntegral (mon-1) :: CInt)+ (#poke struct tm,tm_year ) p_tm (fromIntegral (year-1900) :: CInt)+ (#poke struct tm,tm_isdst) p_tm (-1 :: CInt)+ t <- mktime p_tm+#if __GLASGOW_HASKELL__ >= 603+ return (TOD (fromIntegral (fromEnum t) + fromIntegral (tz-currTZ)) 0)+#else+ return (TOD (fromIntegral t + fromIntegral (tz-currTZ)) 0)+#endif+foreign import ccall unsafe mktime :: Ptr () -> IO CTime++{-# NOINLINE currTZ #-}+currTZ :: Int+currTZ = ctTZ (unsafePerformIO (getClockTime >>= toCalendarTime)) -- Hack++parseTZ :: ReadP Int+parseTZ = (char '+' >> readDecP) `mplus` (char '-' >> fmap negate readDecP)++f_read :: ReadP a -> String -> Maybe a+f_read f s = case readP_to_S f s of {[(x,_)] -> Just x}++readHMS :: ReadP (Int, Int, Int)+readHMS = do+ hour <- readDecP+ char ':'+ minutes <- readDecP+ char ':'+ seconds <- readDecP+ return (hour, minutes, seconds)++readYMD :: ReadP (Int, Int, Int)+readYMD = do+ year <- readDecP+ char '-'+ month <- readDecP+ char '-'+ day <- readDecP+ return (year, month, day)++readDateTime :: ReadP (Int, Int, Int, Int, Int, Int)+readDateTime = do+ (year, month, day) <- readYMD+ skipSpaces+ (hour, minutes, seconds) <- readHMS+ return (year, month, day, hour, minutes, seconds)++instance SqlBind ClockTime where+ fromSqlValue SqlTimeTZ s = f_read getTimeTZ s+ where+ getTimeTZ :: ReadP ClockTime+ getTimeTZ = do+ (hour, minutes, seconds) <- readHMS+ (char '.' >> readDecP) `mplus` (return 0)+ tz <- parseTZ+ return (mkClockTime 1970 1 1 hour minutes seconds (tz*3600))++ fromSqlValue SqlTime s = f_read getTime s+ where+ getTime :: ReadP ClockTime+ getTime = do+ (hour, minutes, seconds) <- readHMS+ return (mkClockTime 1970 1 1 hour minutes seconds currTZ)++ fromSqlValue SqlDate s = f_read getDate s+ where+ getDate :: ReadP ClockTime+ getDate = do+ (year, month, day) <- readYMD+ return (mkClockTime year month day 0 0 0 currTZ)++ fromSqlValue SqlDateTimeTZ s = f_read getDateTimeTZ s+ where+ getDateTimeTZ :: ReadP ClockTime+ getDateTimeTZ = do+ (year, month, day, hour, minutes, seconds) <- readDateTime+ char '.' >> readDecP -- ) `mplus` (return 0)+ tz <- parseTZ+ return (mkClockTime year month day hour minutes seconds (tz*3600))++ -- The only driver which seems to report the type as SqlTimeStamp seems+ -- to be the MySQL driver. MySQL (at least 4.1) uses the same format for datetime and + -- timestamp columns.+ -- Allow SqlText to support SQLite, which reports everything as SqlText+ fromSqlValue t s | t == SqlDateTime || t == SqlTimeStamp || t == SqlText = f_read getDateTime s+ where+ getDateTime :: ReadP ClockTime+ getDateTime = do+ (year, month, day, hour, minutes, seconds) <- readDateTime+ return (mkClockTime year month day hour minutes seconds currTZ)++ fromSqlValue _ _ = Nothing++ toSqlValue ct = '\'' : (shows (ctYear t) .+ score .+ shows (ctMonth t) .+ score .+ shows (ctDay t) .+ space .+ shows (ctHour t) .+ colon .+ shows (ctMin t) .+ colon .+ shows (ctSec t)) "'"+ where+ t = toUTCTime ct+ score = showChar '-'+ space = showChar ' '+ colon = showChar ':'++data Point = Point Double Double deriving (Eq, Show)+data Line = Line Point Point deriving (Eq, Show)+data Path = OpenPath [Point] | ClosedPath [Point] deriving (Eq, Show)+data Box = Box Double Double Double Double deriving (Eq, Show)+data Circle = Circle Point Double deriving (Eq, Show)+data Polygon = Polygon [Point] deriving (Eq, Show)++instance SqlBind Point where+ fromSqlValue SqlPoint s = case read s of+ (x,y) -> Just (Point x y)+ fromSqlValue _ _ = Nothing++ toSqlValue (Point x y) = '\'' : shows (x,y) "'"++instance SqlBind Line where+ fromSqlValue SqlLSeg s = case read s of+ [(x1,y1),(x2,y2)] -> Just (Line (Point x1 y1) (Point x2 y2))+ fromSqlValue _ _ = Nothing++ toSqlValue (Line (Point x1 y1) (Point x2 y2)) = '\'' : shows [(x1,y1),(x2,y2)] "'"++instance SqlBind Path where+ fromSqlValue SqlPath ('(':s) = case read ("["++init s++"]") of -- closed path+ ps -> Just (ClosedPath (map (\(x,y) -> Point x y) ps))+ fromSqlValue SqlPath s = case read s of -- closed path -- open path+ ps -> Just (OpenPath (map (\(x,y) -> Point x y) ps))+ fromSqlValue SqlLSeg s = case read s of+ [(x1,y1),(x2,y2)] -> Just (OpenPath [(Point x1 y1), (Point x2 y2)])+ fromSqlValue SqlPoint s = case read s of+ (x,y) -> Just (ClosedPath [Point x y])+ fromSqlValue _ _ = Nothing++ toSqlValue (OpenPath ps) = '\'' : shows ps "'"+ toSqlValue (ClosedPath ps) = "'(" ++ init (tail (show ps)) ++ "')"++instance SqlBind Box where+ fromSqlValue SqlBox s = case read ("("++s++")") of+ ((x1,y1),(x2,y2)) -> Just (Box x1 y1 x2 y2)+ fromSqlValue _ _ = Nothing++ toSqlValue (Box x1 y1 x2 y2) = '\'' : shows ((x1,y1),(x2,y2)) "'"++instance SqlBind Polygon where+ fromSqlValue SqlPolygon s = case read ("["++init (tail s)++"]") of+ ps -> Just (Polygon (map (\(x,y) -> Point x y) ps))+ fromSqlValue _ _ = Nothing++ toSqlValue (Polygon ps) = "'(" ++ init (tail (show ps)) ++ "')"++instance SqlBind Circle where+ fromSqlValue SqlCircle s = case read ("("++init (tail s)++")") of+ ((x,y),r) -> Just (Circle (Point x y) r)+ fromSqlValue _ _ = Nothing++ toSqlValue (Circle (Point x y) r) = "'<" ++ show (x,y) ++ "," ++ show r ++ "'>"++data INetAddr = INetAddr Int Int Int Int Int deriving (Eq,Show)++instance SqlBind INetAddr where+ fromSqlValue t s+ | t == SqlINetAddr || t == SqlCIDRAddr =+ case readNum s of+ (x1,s) -> case readNum s of+ (x2,s) -> case readNum s of+ (x3,s) -> case readNum s of+ (x4,s) -> case readNum s of+ (mask,_) -> Just (INetAddr x1 x2 x3 x4 mask)+ | otherwise = Nothing+ where+ readNum s = case readDec s of+ [(x,'.':s)] -> (x,s)+ [(x,'/':s)] -> (x,s)+ [(x,"")] -> (x,"")+ _ -> (0,"")++ toSqlValue (INetAddr x1 x2 x3 x4 mask) = '\'' :+ (shows x1 .+ dot .+ shows x2.+ dot .+ shows x3 .+ dot .+ shows x4 .+ slash .+ shows mask) "'"+ where+ dot = showChar '.'+ slash = showChar '/'++data MacAddr = MacAddr Int Int Int Int Int Int deriving (Eq,Show)++instance SqlBind MacAddr where+ fromSqlValue SqlMacAddr s =+ case readHex s of+ [(x1,':':s)] -> case readHex s of+ [(x2,':':s)] -> case readHex s of+ [(x3,':':s)] -> case readHex s of+ [(x4,':':s)] -> case readHex s of+ [(x5,':':s)] -> case readHex s of+ [(x6,_)] -> Just (MacAddr x1 x2 x3 x4 x5 x6)+ fromSqlValue _ _ = Nothing++ toSqlValue (MacAddr x1 x2 x3 x4 x5 x6) = '\'' :+ (showHex x1 .+ colon .+ showHex x2 .+ colon .+ showHex x3 .+ colon .+ showHex x4 .+ colon .+ showHex x5 .+ colon .+ showHex x6) "'"+ where+ colon = showChar ':'+ showHex = showIntAtBase 16 intToDigit++-- | Retrieves the value of field with the specified name.+getFieldValue :: SqlBind a => Statement+ -> String -- ^ Field name+ -> IO a -- ^ Field value+getFieldValue stmt name = do+ stmtGetCol stmt colNumber (name,sqlType,nullable) fromSqlCStringLen+ where+ (sqlType,nullable,colNumber) = findFieldInfo name (stmtFields stmt) 0++{-# DEPRECATED getFieldValueMB "Use getFieldValue instead." #-}+getFieldValueMB :: SqlBind a => Statement -> String -> IO (Maybe a)+getFieldValueMB = getFieldValue++-- | Retrieves the value of field with the specified name.+-- If the field value is @null@ then the function will return the default value.+getFieldValue' :: SqlBind a => Statement+ -> String -- ^ Field name+ -> a -- ^ Default field value+ -> IO a -- ^ Field value+getFieldValue' stmt name def = do+ mb_v <- getFieldValue stmt name+ return (case mb_v of { Nothing -> def; Just a -> a })+++-----------------------------------------------------------------------------------------+-- helpers+-----------------------------------------------------------------------------------------++-- | The 'forEachRow' function iterates through the result set in 'Statement' and+-- executes the given action for each row in the set. The function closes the 'Statement'+-- after the last row processing or if the given action raises an exception.+forEachRow :: (Statement -> s -> IO s) -- ^ an action+ -> Statement -- ^ the statement+ -> s -- ^ initial state+ -> IO s -- ^ final state+forEachRow f stmt s = loop s `finally` closeStatement stmt+ where+ loop s = do+ success <- fetch stmt+ if success then f stmt s >>= loop else return s++-- | The 'forEachRow\'' function is analogous to 'forEachRow' but doesn't provide state.+-- The function closes the 'Statement' after the last row processing or if the given+-- action raises an exception.+forEachRow' :: (Statement -> IO ()) -> Statement -> IO ()+forEachRow' f stmt = loop `finally` closeStatement stmt+ where+ loop = do+ success <- fetch stmt+ when success (f stmt >> loop)++-- | The 'collectRows' function iterates through the result set in 'Statement' and+-- executes the given action for each row in the set. The values returned from action+-- are collected and returned as list. The function closes the 'Statement' after the+-- last row processing or if the given action raises an exception.+collectRows :: (Statement -> IO a) -> Statement -> IO [a]+collectRows f stmt = loop `finally` closeStatement stmt+ where+ loop = do+ success <- fetch stmt+ if success+ then do+ x <- f stmt+ xs <- loop+ return (x:xs)+ else return []
+ Database/HSQL/Types.hs view
@@ -0,0 +1,153 @@+-- #hide+module Database.HSQL.Types where++import Control.Concurrent.MVar+import Control.Exception+import Data.Dynamic+import Foreign+import Foreign.C++type FieldDef = (String, SqlType, Bool)++data SqlType+ = SqlChar Int -- ODBC, MySQL, PostgreSQL+ | SqlVarChar Int -- ODBC, MySQL, PostgreSQL, MSI+ | SqlLongVarChar Int -- ODBC+ | SqlText -- , , PostgreSQL, MSI+ | SqlWChar Int -- ODBC+ | SqlWVarChar Int -- ODBC+ | SqlWLongVarChar Int -- ODBC+ | SqlDecimal Int Int -- ODBC+ | SqlNumeric Int Int -- ODBC, MySQL, PostgreSQL+ | SqlSmallInt -- ODBC, MySQL, PostgreSQL+ | SqlMedInt -- , MySQL, + | SqlInteger -- ODBC, MySQL, PostgreSQL, MSI+ | SqlReal -- ODBC, MySQL, PostgreSQL+ | SqlFloat -- ODBC+ | SqlDouble -- ODBC, MySQL, PostgreSQL+ | SqlBit -- ODBC, , PostgreSQL+ | SqlTinyInt -- ODBC, MySQL, PostgreSQL+ | SqlBigInt -- ODBC, MySQL, PostgreSQL, MSI+ | SqlBinary Int -- ODBC, , PostgreSQL+ | SqlVarBinary Int -- ODBC, , PostgreSQL+ | SqlLongVarBinary Int -- ODBC+ | SqlDate -- ODBC, MySQL, PostgreSQL+ | SqlTime -- ODBC, MySQL, PostgreSQL+ | SqlTimeTZ -- , , PostgreSQL+ | SqlAbsTime -- , , PostgreSQL+ | SqlRelTime -- , , PostgreSQL+ | SqlTimeInterval -- , , PostgreSQL+ | SqlAbsTimeInterval -- , , PostgreSQL+ | SqlTimeStamp -- ODBC, MySQL+ | SqlDateTime -- , MySQL+ | SqlDateTimeTZ -- , MySQL, PostgreSQL+ | SqlYear -- , MySQL+ | SqlSET -- , MySQL+ | SqlENUM -- , MySQL+ | SqlBLOB -- , MySQL, , MSI+ | SqlMoney -- , , PostgreSQL+ | SqlINetAddr -- , , PostgreSQL+ | SqlCIDRAddr -- , , PostgreSQL+ | SqlMacAddr -- , , PostgreSQL+ | SqlPoint -- , , PostgreSQL+ | SqlLSeg -- , , PostgreSQL+ | SqlPath -- , , PostgreSQL+ | SqlBox -- , , PostgreSQL+ | SqlPolygon -- , , PostgreSQL+ | SqlLine -- , , PostgreSQL+ | SqlCircle -- , , PostgreSQL+ | SqlUnknown Int -- ^ HSQL returns @SqlUnknown tp@ for all+ -- columns for which it cannot determine+ -- the right type. The @tp@ here is the+ -- internal type code returned from the+ -- backend library+ deriving (Eq, Show)++data SqlError+ = SqlError+ { seState :: String+ , seNativeError :: Int+ , seErrorMsg :: String+ }+ | SqlNoData+ | SqlInvalidHandle+ | SqlStillExecuting+ | SqlNeedData+ | SqlBadTypeCast+ { seFieldName :: String+ , seFieldType :: SqlType+ }+ | SqlFetchNull+ { seFieldName :: String+ }+ | SqlUnknownField+ { seFieldName :: String+ }+ | SqlUnsupportedOperation+ | SqlClosedHandle+#ifdef __GLASGOW_HASKELL__+ deriving Typeable+#endif++sqlErrorTc :: TyCon+sqlErrorTc = mkTyCon "Database.HSQL.SqlError"++#ifndef __GLASGOW_HASKELL__+instance Typeable SqlError where+ typeOf _ = mkAppTy sqlErrorTc []+#endif++instance Show SqlError where+ showsPrec _ (SqlError{seErrorMsg=msg}) = showString msg+ showsPrec _ SqlNoData = showString "No data"+ showsPrec _ SqlInvalidHandle = showString "Invalid handle"+ showsPrec _ SqlStillExecuting = showString "Stlll executing"+ showsPrec _ SqlNeedData = showString "Need data"+ showsPrec _ (SqlBadTypeCast name tp) = showString ("The type of " ++ name ++ " field can't be converted to " ++ show tp ++ " type")+ showsPrec _ (SqlFetchNull name) = showString ("The value of " ++ name ++ " field is null")+ showsPrec _ (SqlUnknownField name) = showString ("Unknown field name: " ++ name)+ showsPrec _ SqlUnsupportedOperation = showString "Unsupported operation"+ showsPrec _ SqlClosedHandle = showString "The referenced handle is already closed"++-- | A 'Connection' type represents a connection to a database, through which you can operate on the it.+-- In order to create the connection you need to use the @connect@ function from the module for+-- your prefered backend.+data Connection+ = Connection+ { connDisconnect :: IO ()+ , connExecute :: String -> IO ()+ , connQuery :: String -> IO Statement+ , connTables :: IO [String]+ , connDescribe :: String -> IO [FieldDef]+ , connBeginTransaction :: IO ()+ , connCommitTransaction :: IO ()+ , connRollbackTransaction :: IO ()+ , connClosed :: MVar Bool+ }++-- | The 'Statement' type represents a result from the execution of given SQL query.+data Statement+ = Statement+ { stmtConn :: Connection+ , stmtClose :: IO ()+ , stmtFetch :: IO Bool+ , stmtGetCol :: forall a . Int -> FieldDef -> (FieldDef -> CString -> Int -> IO a) -> IO a+ , stmtFields :: [FieldDef]+ , stmtClosed :: MVar Bool+ }+++class SqlBind a where+ -- This allows for faster conversion for eq. integral numeric types, etc.+ -- Default version uses fromSqlValue.+ fromSqlCStringLen :: FieldDef -> CString -> Int -> IO a+ fromSqlCStringLen (name,sqlType,_) cstr cstrLen+ | cstr == nullPtr = throwDyn (SqlFetchNull name)+ | otherwise = do + str <- peekCStringLen (cstr, cstrLen)+ case fromSqlValue sqlType str of+ Nothing -> throwDyn (SqlBadTypeCast name sqlType)+ Just v -> return v++ fromSqlValue :: SqlType -> String -> Maybe a+ toSqlValue :: a -> String
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/runghc++\begin{code}+import Distribution.Simple++main = defaultMain+\end{code}
+ hsql.cabal view
@@ -0,0 +1,11 @@+name: hsql+version: 1.7+license: BSD3+author: Krasimir Angelov <ka2_mail@yahoo.com>+category: Database+description: Simple library for database access from Haskell.+exposed-modules:+ Database.HSQL,+ Database.HSQL.Types+build-depends: base+extensions: ForeignFunctionInterface, TypeSynonymInstances, CPP