hsql-1.8.2/0000775000175000017500000000000011735603327007744 5ustar iihsql-1.8.2/ChangeLog0000644000175000017500000000016211326713315011506 0ustar ii2010-1-24 1.8.1: exception handling updated from Control.OldException to Control.Exception; refactorings hsql-1.8.2/hsql.cabal0000644000175000017500000000227011735510633011673 0ustar iiName: hsql Version: 1.8.2 Cabal-Version: >=1.10 Build-Type: Simple License: BSD3 License-File: LICENSE Author: Krasimir Angelov Maintainer: Nick Rudnick Category: Database Synopsis: Database access from Haskell. Description: Simple library for database access from Haskell. Library { Build-Depends: base==4.*, old-time 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 Exposed: True Other-Modules: Hs-Source-Dirs: . Default-Extensions: Other-Extensions: CPP, DeriveDataTypeable, FlexibleInstances, ForeignFunctionInterface, RankNTypes, ScopedTypeVariables Buildable: True GHC-Options: Includes: Install-includes: Include-Dirs: C-Sources: Extra-Libraries: Extra-Lib-Dirs: CC-Options: LD-Options: PkgConfig-Depends: Frameworks: Default-Language: Haskell2010 } hsql-1.8.2/DB/0000755000175000017500000000000011326155164010224 5ustar iihsql-1.8.2/DB/HSQL/0000755000175000017500000000000011735603345010776 5ustar iihsql-1.8.2/DB/HSQL/Core.hs0000644000175000017500000000320711735516517012230 0ustar ii{-| Management of handles and exception handling. -} 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, no action. 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, throws `SqlClosedHandle' 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 be cast -> Maybe SqlError sqlExceptions = cast -- | Deprecated: Use `Control.Exception.catch' instead. {-# DEPRECATED catchSql "Use Control.Exception.catch instead." #-} catchSql :: IO a -> (SqlError -> IO a) -> IO a catchSql = catch -- | Deprecated: Use `Control.Exception.handle' instead. {-# DEPRECATED handleSql "Use Control.Exception.handle instead." #-} handleSql :: (SqlError -> IO a) -> IO a -> IO a handleSql = handle hsql-1.8.2/DB/HSQL/Type/0000755000175000017500000000000011735603353011716 5ustar iihsql-1.8.2/DB/HSQL/Type/NetAddress.hs0000644000175000017500000000442311735564374014322 0ustar ii{-| Network addresses, equipped with `SqlBind' instances. -} 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(..)) -- | An IP4 address with netmask in CIDR notation. data INetAddr = INetAddr { ip4Octet1:: Int , ip4Octet2:: Int , ip4Octet3:: Int , ip4Octet4:: Int , cidrMaskBits:: Int } deriving (Eq,Ord,Show,Read) 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 '/' -- | A MAC network address. data MacAddr = MacAddr { macOctet1:: Int , macOctet2:: Int , macOctet3:: Int , macOctet4:: Int , macOctet5:: Int , macOctet6:: Int } deriving (Eq,Ord,Show,Read) 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 hsql-1.8.2/DB/HSQL/Type/Diverse.hs0000644000175000017500000000221611735416451013655 0ustar ii{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-| `SqlBind' instances for `String', `Bool' and `Maybe'. -} 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" hsql-1.8.2/DB/HSQL/Type/Time.hsc0000644000175000017500000001120711735514636013321 0ustar ii{-# LANGUAGE CPP,ForeignFunctionInterface #-} {-| `SqlBind' instance for `ClockTime'. -} 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.Types(CTime(CTime),CInt) import DB.HSQL.Type (SqlType(SqlTimeTZ,SqlTime,SqlDate,SqlDateTimeTZ,SqlDateTime ,SqlTimeStamp,SqlText)) import Database.HSQL.Types(SqlBind(..)) #include -- | 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 ':' -- | 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) hsql-1.8.2/DB/HSQL/Type/Geometric.hs0000644000175000017500000000606111735564507014202 0ustar ii{-| Geometric 2D types, equipped with `SqlBind' instances. -} module DB.HSQL.Type.Geometric where import DB.HSQL.Type (SqlType(SqlPoint,SqlLSeg,SqlPath,SqlBox,SqlPolygon,SqlCircle)) import Database.HSQL.Types(SqlBind(..)) -- | A 2D point. data Point = Point { pointX:: Double, pointY:: Double } deriving (Eq,Ord,Show,Read) 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) "'" -- | A 2D straight line. data Line = Line { lineBegin:: Point, lineEnd:: Point } deriving (Eq, Show,Read) 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)] "'" -- | A 2D path, either open, or closed (looping). data Path = OpenPath { pathPoints:: [Point] } -- ^ An open path | ClosedPath { pathPoints:: [Point] } -- ^ A looping path deriving (Eq, Show,Read) 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)) ++ "')" -- | A 2D rectangle. data Box = Box { boxX1:: Double , boxY1:: Double , boxX2:: Double , boxY2:: Double } deriving (Eq, Show,Read) 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)) "'" -- | A 2D polygon (without holes). data Polygon = Polygon { polygonPoints:: [Point] } deriving (Eq, Show,Read) 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)) ++ "')" -- | A 2D circle data Circle = Circle { circleCenter:: Point , circleRadius:: Double } deriving (Eq, Show,Read) 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 ++ "'>" hsql-1.8.2/DB/HSQL/Type/Numeric.hs0000644000175000017500000000704311735564745013673 0ustar ii{-# LANGUAGE CPP,ForeignFunctionInterface #-} {-| `SqlBind' instances for `Int', `Int64', `Integer', `Double', and `Float'. -} 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 hsql-1.8.2/DB/HSQL/Type.hs0000644000175000017500000000645211735561335012264 0ustar iimodule DB.HSQL.Type where {-| Variety of common data types used in databases. -} data SqlType -- numeric: = SqlInteger -- ODBC, MySQL, PostgreSQL, MSI | SqlBigInt -- ODBC, MySQL, PostgreSQL, MSI | SqlSmallInt -- ODBC, MySQL, PostgreSQL | SqlTinyInt -- ODBC, MySQL, PostgreSQL | SqlMedInt -- , MySQL, | SqlDecimal { typeSize:: Int , typeDecimals:: Int } -- ODBC, MySQL, PostgreSQL | SqlNumeric { typeSize:: Int , typeDecimals:: Int } -- ODBC, MySQL, PostgreSQL | SqlReal -- ODBC, MySQL, PostgreSQL | SqlDouble -- ODBC, MySQL, PostgreSQL | SqlFloat -- ODBC -- monetary: | SqlMoney -- , , PostgreSQL -- character: | SqlChar { typeSize:: Int } -- ODBC, MySQL, PostgreSQL | SqlVarChar { typeSize:: Int } -- ODBC, MySQL, PostgreSQL, MSI | SqlLongVarChar { typeSize:: Int } -- ODBC | SqlText -- , , PostgreSQL, MSI | SqlWChar { typeSize:: Int } -- ODBC | SqlWVarChar { typeSize:: Int } -- ODBC | SqlWLongVarChar { typeSize:: 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 { typeSize:: Int } -- ODBC, , PostgreSQL | SqlVarBinary { typeSize:: Int } -- ODBC, , PostgreSQL | SqlLongVarBinary { typeSize:: Int } -- ODBC -- collections: | SqlSET -- , MySQL -- lobs: | SqlBLOB -- , MySQL, , MSI -- unknown: | SqlUnknown { typeCode:: Int } -- ^ HSQL returns `SqlUnknown' for all -- columns for which it cannot determine -- the right type. The `backendTypeCode' here is the -- internal type code returned from the -- backend library deriving (Eq,Ord,Show,Read) hsql-1.8.2/DB/HSQL/Error.hs0000644000175000017500000000515611735557056012441 0ustar ii{-# LANGUAGE CPP,DeriveDataTypeable #-} {-| `SqlError' type for a variety of DB specific error conditions, with appropriate `Show', `Typeable', and `Exception' instances. -} module DB.HSQL.Error(SqlError(..)) where import Control.Exception(Exception(..),SomeException(..)) import Data.Dynamic(Typeable,TyCon,mkTyCon3,cast) import DB.HSQL.Type(SqlType) -- | data SqlError = SqlError { seState :: String , seNativeError :: Int , seErrorMsg :: String } -- ^ generic error condition, with further specification | SqlNoMoreData -- ^ no more data was available | SqlInvalidHandle -- ^ requested handle is invalid | SqlStillExecuting -- ^ connection is blocked by running transaction | SqlNeedMoreData -- ^ more data is needed, e.g. additional connection -- specs | SqlBadTypeCast { seFieldName :: String , seFieldType :: SqlType } -- ^ requested field can't be converted to requested type | SqlFetchNull { seFieldName :: String } -- ^ requested field returns NULL | SqlUnknownField { seFieldName :: String } -- ^ requested field isn't known | SqlUnsupportedOperation -- ^ requested operation isn't supported | SqlClosedHandle -- ^ referenced handle is already closed #ifdef __GLASGOW_HASKELL__ deriving (Eq,Ord,Typeable) #else deriving (Eq,Ord) instance Typeable SqlError where typeOf _ = mkAppTy sqlErrorTc [] #endif -- | The `TyCon' of `SqlError'. sqlErrorTc :: TyCon sqlErrorTc = mkTyCon3 "DB.HSQL" "Error" "SqlError" -- | instance Show SqlError where showsPrec _ (SqlError{seErrorMsg=msg}) = showString msg showsPrec _ SqlNoMoreData = showString "No more data was available" showsPrec _ SqlInvalidHandle = showString "Invalid handle" showsPrec _ SqlStillExecuting = showString "Still executing" showsPrec _ SqlNeedMoreData = showString "More data is needed, e.g. additional connection specs" 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 hsql-1.8.2/LICENSE0000644000175000017500000000000011132667375010741 0ustar iihsql-1.8.2/Database/0000755000175000017500000000000011735603332011442 5ustar iihsql-1.8.2/Database/HSQL.hs0000644000175000017500000002356511735575624012574 0ustar ii{-# 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 () -- * Metadata , tables -- :: Connection -> IO [String] , ColDef, describe -- :: Connection -> String -> IO [ColDef] -- * Command Execution Functions , SQL -- | 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 , 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 -- * 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(SQL,TableId,ColDef,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 -> SQL -- ^ 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 -> SQL -- ^ 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 [TableId] -- ^ 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 -> TableId -- ^ Name of a database table -> IO [ColDef] -- ^ 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 -> [ColDef] -> 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 [] hsql-1.8.2/Database/HSQL/0000755000175000017500000000000011735603337012216 5ustar iihsql-1.8.2/Database/HSQL/Types.hs0000644000175000017500000001012411735574721013660 0ustar ii{-# LANGUAGE RankNTypes #-} -- #hide {-| Basic type class & type definitions for DB interfacing. -} module Database.HSQL.Types (SQL,TableId,Connection(..) ,ColId,Nullability,ColDef,FieldReader,FieldReading,Statement(..) ,SqlBind(..),SqlType(..),SqlError(..)) where import Control.Concurrent.MVar(MVar) import Control.Exception(throw) import Foreign(nullPtr) import Foreign.C(CString,peekCStringLen) import DB.HSQL.Type(SqlType(..)) import DB.HSQL.Error(SqlError(..)) -- | A table column ID. type ColId = String -- | Whether fields of a table col may be NULL. type Nullability = Bool -- | Description of the properties of a table column. type ColDef = (ColId, SqlType, Nullability) -- | An SQL Query. type SQL = String -- | A table ID. type TableId = String -- | 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 { -- | disconnect action connDisconnect :: IO (), -- | query execution action (without return value) connExecute :: SQL -> IO (), -- | query action with return value connQuery :: SQL -> IO Statement, -- | retrieval of the names of the tables in reach connTables :: IO [TableId], -- | retrieval of the field defs of a table connDescribe :: TableId -> IO [ColDef], -- | 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 } -- | A DB generic field extraction function, specifiable by -- field definition, receiving the content code and its length. type FieldReader t = ColDef -- ^ field type spec -> CString -- ^ field content code -> Int -- ^ field content length -> IO t -- ^ field read action -- | An extraction of a field of type to be specified by requester, -- from a row index with source `ColDef', applying an appropriate -- `FieldReader'. type FieldReading = forall t . Int -- ^ field (column) index -> ColDef -- ^ source field type spec -> FieldReader t -- ^ field reader to be applied -> IO t -- ^ field read action -- | The 'Statement' type represents a result from the execution of given -- SQL query. data Statement = Statement { -- | DB connection the statement depends on stmtConn :: Connection, -- | close action stmtClose :: IO (), -- | incrementation of the row pointer and indication -- whether this is still in range of available rows stmtFetch :: IO Bool, -- | a `FieldReading' function applicable for each row stmtGetCol :: FieldReading, -- | field descriptors for each result table column stmtFields :: [ColDef], -- | check whether the statement is closed stmtClosed :: MVar Bool } -- | Equivalent to Show and Read adapted to SQL expressions. class SqlBind a where -- | show as an SQL expression toSqlValue:: a-> SQL -- | read from an SQL expression in text representation, -- by support of its `SqlType' fromSqlValue:: SqlType-> SQL-> Maybe a -- | read from SQL expression in binary representation, -- by support of its `ColDef' and code size info. -- This allows for faster conversion for e.g. integral numeric types, -- etc. fromSqlCStringLen:: ColDef -> CString -- ^ binary content of SQL expression -> Int -- ^ size of binary content -> IO a fromSqlCStringLen (name,sqlType,_) cstr cstrLen | cstr == nullPtr = throw (SqlFetchNull name) | otherwise = do str <- peekCStringLen (cstr, cstrLen) case fromSqlValue sqlType str of Nothing -> throw (SqlBadTypeCast name sqlType) Just v -> return v hsql-1.8.2/Setup.lhs0000644000175000017500000000013211132667375011552 0ustar ii#!/usr/bin/runghc \begin{code} import Distribution.Simple main = defaultMain \end{code}