diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,3 @@ +2010-1-24 + 1.8.1: exception handling updated from Control.OldException to Control.Exception; + refactorings diff --git a/DB/HSQL/Core.hs b/DB/HSQL/Core.hs new file mode 100644 --- /dev/null +++ b/DB/HSQL/Core.hs @@ -0,0 +1,45 @@ +module DB.HSQL.Core where + +import Prelude hiding(catch) +import Control.Monad(when,unless) +import Control.Exception(Exception,throw,catch,handle) +import Control.Concurrent.MVar(MVar,withMVar,modifyMVar_) +import Data.Dynamic(cast) + +import DB.HSQL.Error(SqlError(SqlClosedHandle)) + +-- | if closed, nothing to do: +closeHandle :: MVar Bool -- ^ closing state ref + -> IO () -- ^ DB action to do if not closed + -> IO () +closeHandle ref action = + modifyMVar_ ref (\closed -> unless closed action + >> return True) + +-- | if closed, exception: +checkHandle :: MVar Bool -- ^ closing state ref + -> IO a -- ^ DB action to do if not closed + -> IO a +checkHandle ref action = + withMVar ref (\closed -> when closed (throw SqlClosedHandle) + >> action) + + +------------------------------------------------------------------------------ +-- routines for exception handling +------------------------------------------------------------------------------ +-- | Casts, if possible, an Exception to an SqlError: +sqlExceptions :: Exception x + => x -- ^ the exception thinc to cast to SQLError + -> Maybe SqlError +sqlExceptions = cast + +-- | DEPRECATED: catchSql: Use Control.Exception.catch instead. +{-# DEPRECATED catchSql "Use Control.Exception.catch instead." #-} +catchSql :: IO a -> (SqlError -> IO a) -> IO a +catchSql = catch + +-- | DEPRECATED: handleSql: Use Control.Exception.handle instead. +{-# DEPRECATED handleSql "Use Control.Exception.handle instead." #-} +handleSql :: (SqlError -> IO a) -> IO a -> IO a +handleSql = handle diff --git a/DB/HSQL/Error.hs b/DB/HSQL/Error.hs new file mode 100644 --- /dev/null +++ b/DB/HSQL/Error.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP,DeriveDataTypeable #-} +{-| Differentiation of DB specific error conditions. +-} +module DB.HSQL.Error(SqlError(..),sqlErrorTc) where + +import Control.Exception(Exception(..),SomeException(..)) +import Data.Dynamic(Typeable,TyCon,mkTyCon,cast) + +import DB.HSQL.Type(SqlType) + +-- | +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 +#else + +instance Typeable SqlError where + typeOf _ = mkAppTy sqlErrorTc [] +#endif + +sqlErrorTc :: TyCon +sqlErrorTc = mkTyCon "Database.HSQL.SqlError" + +-- | +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" + +-- | +instance Exception SqlError where + toException = SomeException + fromException (SomeException exception) = + cast exception + diff --git a/DB/HSQL/Type.hs b/DB/HSQL/Type.hs new file mode 100644 --- /dev/null +++ b/DB/HSQL/Type.hs @@ -0,0 +1,80 @@ +module DB.HSQL.Type where +{-| Differentiation of data types used in DBs. +-} + +data SqlType + -- numeric: + = SqlInteger -- ODBC, MySQL, PostgreSQL, MSI + | SqlBigInt -- ODBC, MySQL, PostgreSQL, MSI + | SqlSmallInt -- ODBC, MySQL, PostgreSQL + | SqlTinyInt -- ODBC, MySQL, PostgreSQL + | SqlMedInt -- , MySQL, + | SqlDecimal Int Int -- ODBC, MySQL, PostgreSQL + | SqlNumeric Int Int -- ODBC, MySQL, PostgreSQL + | SqlReal -- ODBC, MySQL, PostgreSQL + | SqlDouble -- ODBC, MySQL, PostgreSQL + | SqlFloat -- ODBC + + -- monetary: + | SqlMoney -- , , PostgreSQL + + -- character: + | 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 + + -- date / time: + | 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 + + -- booleans: + | SqlBit -- ODBC, , PostgreSQL + + -- enums: + | SqlENUM -- , MySQL + + -- geometric types: + | SqlPoint -- , , PostgreSQL + | SqlLSeg -- , , PostgreSQL + | SqlPath -- , , PostgreSQL + | SqlBox -- , , PostgreSQL + | SqlPolygon -- , , PostgreSQL + | SqlLine -- , , PostgreSQL + | SqlCircle -- , , PostgreSQL + + -- network addresses: + | SqlINetAddr -- , , PostgreSQL + | SqlCIDRAddr -- , , PostgreSQL + | SqlMacAddr -- , , PostgreSQL + + -- bit strings: + | SqlBinary Int -- ODBC, , PostgreSQL + | SqlVarBinary Int -- ODBC, , PostgreSQL + | SqlLongVarBinary Int -- ODBC + + -- collections: + | SqlSET -- , MySQL + + -- lobs: + | SqlBLOB -- , MySQL, , MSI + + -- unknown: + | 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) diff --git a/DB/HSQL/Type/Diverse.hs b/DB/HSQL/Type/Diverse.hs new file mode 100644 --- /dev/null +++ b/DB/HSQL/Type/Diverse.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE TypeSynonymInstances #-} +module DB.HSQL.Type.Diverse where + +import Foreign(nullPtr) + +import DB.HSQL.Type(SqlType(SqlBit)) +import Database.HSQL.Types(SqlBind(..)) + +-- | +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 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" diff --git a/DB/HSQL/Type/Geometric.hs b/DB/HSQL/Type/Geometric.hs new file mode 100644 --- /dev/null +++ b/DB/HSQL/Type/Geometric.hs @@ -0,0 +1,102 @@ +module DB.HSQL.Type.Geometric where + +import DB.HSQL.Type + (SqlType(SqlPoint,SqlLSeg,SqlPath,SqlBox,SqlPolygon,SqlCircle)) +import Database.HSQL.Types(SqlBind(..)) + +-- | +data Point + = Point Double Double + 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) "'" + + +-- | +data Line + = Line Point Point + deriving (Eq, Show) + +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)] "'" + + +-- | +data Path + = OpenPath [Point] + | ClosedPath [Point] + deriving (Eq, Show) + +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)) ++ "')" + + +-- | +data Box + = Box Double Double Double Double + deriving (Eq, Show) + +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)) "'" + + +-- | +data Polygon + = Polygon [Point] + deriving (Eq, Show) + +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)) ++ "')" + + +-- | +data Circle + = Circle Point Double + deriving (Eq, Show) + +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 ++ "'>" + diff --git a/DB/HSQL/Type/NetAddress.hs b/DB/HSQL/Type/NetAddress.hs new file mode 100644 --- /dev/null +++ b/DB/HSQL/Type/NetAddress.hs @@ -0,0 +1,64 @@ +module DB.HSQL.Type.NetAddress where + +import Data.Char(intToDigit) +import Numeric(readHex,showIntAtBase,readDec) + +import DB.HSQL.Type(SqlType(SqlINetAddr,SqlCIDRAddr,SqlMacAddr)) +import Database.HSQL.Types(SqlBind(..)) + +-- | +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 diff --git a/DB/HSQL/Type/Numeric.hs b/DB/HSQL/Type/Numeric.hs new file mode 100644 --- /dev/null +++ b/DB/HSQL/Type/Numeric.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP,ForeignFunctionInterface #-} +module DB.HSQL.Type.Numeric where + +import Control.Exception(throw) +import Data.Int(Int64) +import Foreign(Ptr,nullPtr) +import Foreign.C(CString) + +import DB.HSQL.Type + (SqlType(SqlReal,SqlFloat,SqlDouble,SqlNumeric,SqlDecimal + ,SqlBigInt,SqlTinyInt,SqlInteger,SqlMedInt,SqlSmallInt + ,SqlText)) +import DB.HSQL.Error(SqlError(SqlFetchNull,SqlBadTypeCast)) +import Database.HSQL.Types(SqlBind(..)) + +-- | +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 Int where + fromSqlCStringLen (name,sqlType,_) cstr cstrLen + | cstr == nullPtr = throw (SqlFetchNull name) + | sqlType==SqlInteger || + sqlType==SqlMedInt || + sqlType==SqlTinyInt || + sqlType==SqlSmallInt|| + sqlType==SqlBigInt = c_atoi cstr + | otherwise = throw (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 = throw (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 = throw (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 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 diff --git a/DB/HSQL/Type/Time.hsc b/DB/HSQL/Type/Time.hsc new file mode 100644 --- /dev/null +++ b/DB/HSQL/Type/Time.hsc @@ -0,0 +1,143 @@ +{-# LANGUAGE CPP,ForeignFunctionInterface #-} +module DB.HSQL.Type.Time where + +import Control.Monad(mplus) +import System.IO.Unsafe(unsafePerformIO) +import System.Time(ClockTime(..),CalendarTime(..) + ,getClockTime,toCalendarTime,toUTCTime) +import Text.ParserCombinators.ReadP(ReadP,char,skipSpaces,readP_to_S) +import Text.Read.Lex(readDecP) +import Foreign(Ptr,allocaBytes,pokeByteOff) +import Foreign.C(CTime,CInt) + +import DB.HSQL.Type + (SqlType(SqlTimeTZ,SqlTime,SqlDate,SqlDateTimeTZ,SqlDateTime + ,SqlTimeStamp,SqlText)) +import Database.HSQL.Types(SqlBind(..)) + +#include + +-- | +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 + let t'= +#if __GLASGOW_HASKELL__ >= 603 + fromEnum t +#else + t +#endif + return (TOD (fromIntegral t' + fromIntegral (tz-currTZ)) 0) + +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 ':' diff --git a/Database/HSQL.hs b/Database/HSQL.hs new file mode 100644 --- /dev/null +++ b/Database/HSQL.hs @@ -0,0 +1,235 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-| Module : Database.HSQL + 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, SqlBind(..) + , 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 + + -- * Utilities + , forEachRow -- :: (Statement -> s -> IO s) -- ^ an action + , forEachRow' -- :: (Statement -> IO ()) -> Statement -> IO () + , collectRows -- :: (Statement -> IO a) -> Statement -> IO [a] + + -- * SQL Exceptions handling + , SqlError(..) + , catchSql + , handleSql + , sqlExceptions -- :: Exception -> Maybe SqlError + + -- * Metadata + , tables -- :: Connection -> IO [String] + , describe -- :: Connection -> String -> IO [FieldDef] + + -- * Extra types + , Point(..), Line(..), Path(..), Box(..), Circle(..), Polygon(..) + , INetAddr(..), MacAddr(..) + , SqlType(..) + ) where + +import Prelude hiding(catch) +import Control.Monad(when) +import Control.Exception(SomeException,finally,throwIO,throw,catch) + +import DB.HSQL.Type +import DB.HSQL.Type.Numeric +import DB.HSQL.Type.Time +import DB.HSQL.Type.Geometric +import DB.HSQL.Type.NetAddress +import DB.HSQL.Type.Diverse() +import DB.HSQL.Error +import DB.HSQL.Core +import Database.HSQL.Types(FieldDef,Connection(..),Statement(..) + ,SqlBind(fromSqlCStringLen)) + +------------------------------------------------------------------------------ +-- 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. +-- A transaction is to catch ANY exception, so 'SomeException' is adequate. +inTransaction :: Connection -- ^ Database 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::SomeException) -> 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 = throw (SqlUnknownField name) +findFieldInfo name (fieldDef@(name',sqlType,nullable):fields) colNumber + | name == name' = (sqlType,nullable,colNumber) + | otherwise = findFieldInfo name fields $! (colNumber+1) + + +------------------------------------------------------------------------------ +-- binding +------------------------------------------------------------------------------ +-- | Retrieves the value of field with the specified name. +getFieldValue :: SqlBind a => Statement -- ^ result table data + -> 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 [] + + diff --git a/Database/HSQL.hsc b/Database/HSQL.hsc deleted file mode 100644 --- a/Database/HSQL.hsc +++ /dev/null @@ -1,607 +0,0 @@ ------------------------------------------------------------------------------------------ -{-| 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(..) - , 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 - ------------------------------------------------------------------------------------------ --- 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 [] diff --git a/Database/HSQL/Types.hs b/Database/HSQL/Types.hs --- a/Database/HSQL/Types.hs +++ b/Database/HSQL/Types.hs @@ -1,153 +1,91 @@ +{-# LANGUAGE RankNTypes #-} -- #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 +{-| Basic type class & type definitions for DB interfacing. +-} +module Database.HSQL.Types + (FieldDef,SqlType(..),SqlError(..),sqlErrorTc + ,Connection(..),Statement(..),SqlBind(..)) where -sqlErrorTc :: TyCon -sqlErrorTc = mkTyCon "Database.HSQL.SqlError" +import Control.Concurrent.MVar(MVar) +import Control.Exception(throw) +import Foreign(nullPtr) +import Foreign.C(CString,peekCStringLen) -#ifndef __GLASGOW_HASKELL__ -instance Typeable SqlError where - typeOf _ = mkAppTy sqlErrorTc [] -#endif +import DB.HSQL.Type +import DB.HSQL.Error -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" +-- | +type FieldDef = (String, SqlType, Bool) --- | 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. +-- | 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 - } + = Connection { + -- | disconnect action + connDisconnect :: IO (), + -- | query execution action (without return value) + connExecute :: String -> IO (), + -- | query action with return value + connQuery :: String -> IO Statement, + -- | retrieval of the names of the tables in reach + connTables :: IO [String], + -- | retrieval of the field defs of a table + connDescribe :: String -> IO [FieldDef], + -- | begin of a transaction + connBeginTransaction :: IO (), + -- | commit of a pending transaction + connCommitTransaction :: IO (), + -- | rollback of a pending transaction + connRollbackTransaction :: IO (), + -- | closing state of the connection + connClosed :: MVar Bool } --- | The 'Statement' type represents a result from the execution of given SQL query. + +-- | 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 - } + = Statement { + -- | field descriptors + stmtConn :: Connection, + -- | closing action + stmtClose :: IO (), + -- | incrementation of the row pointer and indication + -- whether this is still in range of available rows + stmtFetch :: IO Bool, + -- | extraction of a field from the current result row, with + -- + -- * a column index + -- + -- * a column field definition + -- + -- * a generic field extraction function, specifiable by + -- a field definition, a C string and its length + stmtGetCol :: forall a . Int -- column index + -> FieldDef -- column field definition + -> (FieldDef->CString->Int->IO a) + -- generic field extraction function, + -- specifiable by field definition, + -- receiving the C string and its length + -> IO a, + -- | field descriptors + stmtFields :: [FieldDef], + -- | closing state of the statement + stmtClosed :: MVar Bool } +-- | class SqlBind a where - -- This allows for faster conversion for eq. integral numeric types, etc. - -- Default version uses fromSqlValue. + toSqlValue :: a -> String + fromSqlValue :: SqlType -> String -> Maybe a + -- | 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 + | cstr == nullPtr = throw (SqlFetchNull name) + | otherwise = do str <- peekCStringLen (cstr, cstrLen) case fromSqlValue sqlType str of - Nothing -> throwDyn (SqlBadTypeCast name sqlType) + Nothing -> throw (SqlBadTypeCast name sqlType) Just v -> return v - - fromSqlValue :: SqlType -> String -> Maybe a - toSqlValue :: a -> String diff --git a/hsql.cabal b/hsql.cabal --- a/hsql.cabal +++ b/hsql.cabal @@ -1,16 +1,25 @@ name: hsql -version: 1.7.1 +version: 1.8.1 license: BSD3 author: Krasimir Angelov -maintainer: Chris Done +maintainer: Nick Rudnick category: Database synopsis: Simple library for database access from Haskell. description: Simple library for database access from Haskell. exposed-modules: + DB.HSQL.Core, + DB.HSQL.Error, + DB.HSQL.Type, + DB.HSQL.Type.Diverse, + DB.HSQL.Type.Geometric, + DB.HSQL.Type.Numeric, + DB.HSQL.Type.Time, + DB.HSQL.Type.NetAddress, Database.HSQL, Database.HSQL.Types -build-depends: base==3.*,old-time -extensions: ForeignFunctionInterface, TypeSynonymInstances, CPP, RankNTypes, DeriveDataTypeable +build-depends: base==4.*, old-time +extensions: CPP, ForeignFunctionInterface, DeriveDataTypeable, RankNTypes, + ScopedTypeVariables build-type: Simple license-file: LICENSE cabal-version: >= 1.6