diff --git a/Database/HDBI.hs b/Database/HDBI.hs new file mode 100644 --- /dev/null +++ b/Database/HDBI.hs @@ -0,0 +1,258 @@ +{- | + Module : Database.HDBI + Copyright : Copyright (C) 2005-2011 John Goerzen + License : BSD3 + + Maintainer : Aleksey Uymanov + Stability : experimental + Portability: portable + -} + +module Database.HDBI + ( + +-- | Welcome to HDBI, the Haskell Database Independed interface. Written by +-- John Goerzen, jgoerzen\@complete.org, rewritten by Aleksey Uymanov +-- + +-- * Introduction + +-- |HDBI provides an abstraction layer between Haskell programs and SQL +-- relational databases. This lets you write database code once, in Haskell, +-- and have it work with any number of backend SQL databases (MySQL, Oracle, +-- PostgreSQL, ODBC-compliant databases, etc.) + +-- * Design notes + +-- | There is two typeclasses 'Connection' and 'Statement'. Each database driver +-- must provide it's own types (e.g. PostgreConnection and PostgreStatement in +-- HDBI-postgresql driver) and instances for them. Driver can provide additional +-- low-level functions not covered by these typeclasses. +-- +-- There is also database-independent wrappers 'StmtWrapper' and 'ConnWrapper' +-- which are instances of 'Statement' and 'Connection' respectively. These +-- wrappers can hold database-specific type and call it's instance methods to +-- interact with database. You can still use low-level functions provided for +-- wrapped type by casting the wrapper back to the specific type by functions +-- 'castStatement' and 'castConnection'. Here is how it's look like: +-- +-- @ +--genericStmtLen :: StmtWrapper -> IO Int +--genericStmtLen stmt = do +-- executeRaw stmt +-- case castStatement stmt of +-- Nothing -> wrapperLen stmt +-- Just pgstmt -> pgLen pgstmt +-- +--wrapperLen :: StmtWrapper -> IO Int +--wrapperLen stmt = length \<$\> fetchAllRows stmt +-- +--pgLen :: PostgreStatement -> IO Int +--pgLen = undefined -- assume implementation is provided by driver, the fast +-- -- PostgreSQL-specific way by ''ntuples'' low-level function. This +-- -- feature is not included to 'Statement' typeclass because some +-- -- databases have no such posibility. +-- @ +-- +-- You can see, that 'StmtWrapper' is still can be converted safely to +-- PostgreStatement, and if you pass PostgreStatement wrapped in StmtWrapper +-- function ''genericStmtLen'' will automatically use fast PostgreSQL +-- implementation. If it could not cast statement to specific type it will use +-- slow implementation based on 'Statement' methods. +-- +-- There is also 'SqlValue' representing value from database's columns. This +-- type has a set of constructors each of them holds value of some type. There +-- is 'SqlUTCTime' for saving and fetching 'UTCTime' value from the database, +-- and 'SqlText' to save and get the text from database fields. You can execute +-- queries like this: +-- +-- @ +-- {-# LANGUAGE +-- OverloadedStrings +-- #-} +-- +--module Main where +-- +--import Database.HDBI +--import Database.HDBI.PostgreSQL +--import Control.Applicative +--import Data.Time +--import qualified Data.ByteString as B +--import qualified Data.Text.Lazy as TL +-- +--insertTuples :: (Connection conn) => [(Int, TL.Text, UTCTime, B.ByteString)] -> conn -> IO () +--insertTuples x conn = runMany conn +-- \"insert into tupletbl (ifield, tfield, dtfield, bsfield) values (?,?,?,?)\" +-- $ map (\(a, b, c, d) -> [ toSql a , toSql b , toSql c , toSql d]) x +-- @ +-- +-- Note, that you can still safely use ''?'' parameter placeholders inside the +-- query even with PostgreSQL, which use ''$1'' like placeholders. +-- +-- There is also 'Query' type which is type-safe newtype wrapper around simple +-- lazy Text. You can write it literal, using ''-XOverloadedStrings'' extension. +-- +-- We do not use String except inside 'SqlError', not 'Query' nor 'SqlText' does +-- not use String inside. + +-- * Some kind of roadmap + +-- |* Finish other hdbi drivers, like mysql and sqlite +-- +-- * Unify the testing and benchmarking with one package. +-- +-- * Create package hdbi-introspect with common interface to introspect and +-- change the schema. Also it will be necessary to create packages +-- hdbi-introspect-postgresql, hdbi-introspect-mysql and so on for each database +-- using specific methods to introspect and change the schema. This is the base +-- package for doing migrations like in Ruby on Rails. +-- +-- * Create hdbi-resourcet and hdbi-conduit to provide convenient and reliable +-- way for finalizing statements and streaming processing the query results. +-- +-- * Port other high-level database interfaces, like ''persistent'' and +-- ''haskelldb''. This will posibly lead to need to patch ''persistent'' and/or +-- ''haskelldb'' to support Decimal for example, or not. This is too earnly to +-- plan this in detail. + +-- * Project scope + +-- |* Provide common interface to execute queries and send/fetch data to/from +-- the database. +-- +-- * Provide the type (''SqlValue'') to represent data which can be sent or fetched +-- from the database. +-- +-- * Provide convenient way to convert Haskell-side data to database-side data +-- and vice versa. This is done with 'FromSql' and 'ToSql' instances. +-- +-- * Give the most wide set of supported types, such as Decimal (arbitrary +-- precision values), Integer, Date and Time +-- +-- * Safe interface with protection from re-release of resources. There must +-- not be errors, the more segafults, if you try to finish the statement when +-- the connection is already closed. +-- +-- * Thread-safety. +-- +-- * Concurrency. If database's low level client library provides concurrent +-- acces to one connection and/or statement then driver must support it. As +-- well as protect connection/statement from concurrent access if database does +-- not support it. +-- +-- * To be clean, minimalistic, well-tested and correct base for other +-- higher-level packages. + +-- * Out of scope + +-- | * Database introspection: HDBI must not know how to introspect the +-- database. This problem must be solved with separate package +-- e.g. hdbi-introspect providing the common interface to introspect the +-- schema and drivers hdbi-introspect-postgresql, hdbi-introspect-mysql and +-- so on to provide database-specific implementation of this +-- interface. Current HDBI architecture allows to acces to low-levl +-- connection and statement functions. The mandatory Typeable instance for +-- any Connection and Statement instance allows to downcast any polymorphic +-- type to specific type and do whatever you need. +-- +-- * Implicit transactions: if you want to work in transaction you must use +-- withTransaction function which correctly rollback the transaction on +-- exceptions. +-- +-- * Lazy IO and resource management: to be short Conduit and ResourceT +-- +-- * Any other things not related to query execution. + +-- * Difference between HDBC and HDBI + +-- |This is the rewritten HDBC with new features and better design. Here is the +-- difference between HDBC and HDBI: +-- +-- * typeclass IConnection renamed to 'Connection' to be more Haskell-specific +-- +-- * removed methods getTables and describeTable because they are not +-- compatible with project's goals. +-- +-- * 'Statement' is not data but typeclass for now +-- +-- * 'Connection' and 'Statement' instances must be 'Typeable' instances as +-- well. 'Typeable' let you to write database-independent code with +-- 'ConnWrapper' and 'StmtWrapper' wrappers. +-- +-- * 'ConnWrapper' and 'StmtWrapper' wrappers which can be downcasted to +-- specific 'Connection' or 'Statement' instance or used +-- directly. 'ConnWrapper' and 'StmtWrapper' are 'Connection' and 'Statement' +-- instances too +-- +-- * 'SqlValue' constructors set is reduced. +-- +-- * Removed any lazy IO operations. +-- +-- * Fast parsers for date, time, timestamp and numbers. Written using 'attoparsec'. + +-- ** Differences in SqlValue + +-- |New 'SqlValue' has just the munimum set of posible types which can be stored +-- on database side or fetched from the database. +-- +-- * SqlString is replaced with SqlText which stores lazy text instead of +-- String. String is ineffective in memory and speed. +-- +-- * SqlByteString is renamed to SqlBlob to be more verbal. +-- +-- * SqlWord32, SqlWord64, SqlInt32, SqlInt64 are removed and replaced with one +-- SqlInteger. +-- +-- * SqlChar is removed because this is the same as Text with one character, +-- and there is no special ''one char'' type. +-- +-- * SqlRational is replaced with SqlDecimal because there is no one database +-- which has native Rational support. You can not to save any Rational value +-- to database and get back just the same. Decimal is more proper type to +-- represent database-level arbitrary precision value. +-- +-- * SqlZonedLocalTimeOfDay is removed because there is no native support of +-- this type on database-level except the PostgreSQL. But the documentation +-- says, that this type is deprecated, difficult to use and must not be used +-- in new applications. +-- +-- * SqlZonedTime, SqlPOSIXTime and SqlEpochTime are removed. They has +-- absolutely the same type on database side as SqlUTCTime. You can convert +-- PosixTime to UTCTime and vice versa explicitly, so there is no need in +-- this consturctors. No one database has native type storing ZoneInfo +-- directly, every database convert zoned datetime to utc format and apply +-- local server's timezone to convert utc back to zoned datetime when you +-- select this value. So SqlZonedTime is just the same as SqlUTCTime on +-- database side. +-- +-- * SqlZonedTime and SqlDiffTime removed because no wide support of this types on +-- database level. In fact just PostgreSql. But maybe I am wrong. +-- +-- * 'SqlUUID' is added because there is many databases supporting UUID +-- natively. + +-- * Drivers + +-- |Drivers must be implemented using clean and safe bindings. You must not use +-- C-hacks to interact with database client library, this is the binding's goal. +-- +-- * HDBI-postgresql: use postgresql-libpq and postgresql-simple +-- bindings. PostgreSQL use ''$n'' (where ''n'' is parameter index) +-- placeholder for query parameters, but you can safely use ''?'' placeholder +-- like in other databases. HDBI-postgresql replaces ''?'' with sequential +-- ''$n'' placeholders before passing the query to database. You can also use +-- ''$n'' directly but will break portablility. + +-- * Thread-safety + +-- | All HDBI drivers must use thread safe MVars to store data, which can be +-- shared between threads. + +-- * Reimported modules + module Database.HDBI.SqlValue + , module Database.HDBI.Types + ) where + + +import Database.HDBI.SqlValue +import Database.HDBI.Types diff --git a/Database/HDBI/DriverUtils.hs b/Database/HDBI/DriverUtils.hs new file mode 100644 --- /dev/null +++ b/Database/HDBI/DriverUtils.hs @@ -0,0 +1,80 @@ +{- | + Module : Database.HDBI.DriverUtils + Copyright : Copyright (C) 2006 John Goerzen + License : BSD3 + + Maintainer : Aleksey Uymanov + Stability : experimental + Portability: portable + +Written by John Goerzen, jgoerzen\@complete.org +-} + +module Database.HDBI.DriverUtils ( +-- | Utilities for database backend drivers. +-- +-- Please note: this module is intended for authors of database driver libraries +-- only. Authors of applications using HDBI should use 'Database.HDBI' +-- exclusively. + + ChildList + , closeAllChildren + , addChild + , newChildList + ) + +where +import Control.Concurrent.MVar +import System.Mem.Weak +import Control.Monad +import Database.HDBI.Types (Statement(..)) + +-- | List of weak pointers to childs with concurrent access +type ChildList stmt = MVar [Weak stmt] + + +-- | new empty child list +newChildList :: IO (ChildList stmt) +newChildList = newMVar [] + +{- | Close all children. Intended to be called by the 'disconnect' function +in 'Connection'. + +There may be a potential race condition wherein a call to newSth at the same +time as a call to this function may result in the new child not being closed. +-} +closeAllChildren :: (Statement stmt) => (ChildList stmt) -> IO () +closeAllChildren mcl = modifyMVar_ mcl $ \ls -> do + mapM_ closefunc ls + return ls + where closefunc child = + do c <- deRefWeak child + case c of + Nothing -> return () + Just x -> finish x + +{- | Adds a new child to the existing list. Also takes care of registering +a finalizer for it, to remove it from the list when possible. -} +addChild :: (Statement stmt) => (ChildList stmt) -> stmt -> IO () +addChild mcl stmt = + do weakptr <- mkWeakPtr stmt (Just (childFinalizer mcl)) + modifyMVar_ mcl (\l -> return (weakptr : l)) + +{- | The general finalizer for a child. + +It is simply a filter that removes any finalized weak pointers from the parent. + +If the MVar is locked at the start, does nothing to avoid deadlock. Future +runs would probably catch it anyway. -} +childFinalizer :: ChildList a -> IO () +childFinalizer mcl = do + c <- isEmptyMVar mcl + case c of + True -> return () + False -> modifyMVar_ mcl (filterM filterfunc) + + where filterfunc c = do + dc <- deRefWeak c + case dc of + Nothing -> return False + Just _ -> return True diff --git a/Database/HDBI/Formaters.hs b/Database/HDBI/Formaters.hs new file mode 100644 --- /dev/null +++ b/Database/HDBI/Formaters.hs @@ -0,0 +1,45 @@ +{- | + Module : Database.HDBI.Formaters + Copyright : Copyright (C) 2006 John Goerzen + License : BSD3 + + Maintainer : Aleksey Uymanov + Stability : experimental + Portability: portable +-} + + +module Database.HDBI.Formaters + ( + formatBitField + , formatIsoUTCTime + , formatIsoDay + , formatIsoTimeOfDay + , formatIsoLocalTime + ) where + +import Data.Word +import Data.Bits +import Data.Time +import System.Locale (defaultTimeLocale) + + +formatBitField :: Word64 -> String +formatBitField w = "b'" ++ (map (tochar . testBit w) [bs,bs-1..0]) ++ "'" + where + bs = (bitSize w) - 1 + tochar True = '1' + tochar False = '0' + + +formatIsoUTCTime :: UTCTime -> String +formatIsoUTCTime = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q%z" + +formatIsoDay :: Day -> String +formatIsoDay = formatTime defaultTimeLocale "%Y-%m-%d" + +formatIsoTimeOfDay :: TimeOfDay -> String +formatIsoTimeOfDay = formatTime defaultTimeLocale "%H:%M:%S%Q" + +formatIsoLocalTime :: LocalTime -> String +formatIsoLocalTime = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S%Q" diff --git a/Database/HDBI/Parsers.hs b/Database/HDBI/Parsers.hs new file mode 100644 --- /dev/null +++ b/Database/HDBI/Parsers.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE + OverloadedStrings + #-} + +{- | + Module : Database.HDBI.Parsers + Copyright : Copyright (C) 2006 John Goerzen + License : BSD3 + + Maintainer : Aleksey Uymanov + Stability : experimental + Portability: portable +-} + + +module Database.HDBI.Parsers + ( +-- | This module is for driver developers. Here is fast parsers, trying to parse +-- time and date in the most wide input formats. + +-- * Parsers + parseBitField + , parseIsoZonedTime + , parseIsoDay + , parseIsoTimeOfDay + , parseIsoLocalTime + ) where + +import Control.Applicative ((<$>), (<|>)) +import qualified Data.Attoparsec.Text.Lazy as P +import Data.Bits +import Data.Char (isDigit) +import Data.Time +import Data.Word +import Data.Monoid (getFirst, First(..), mconcat) +import qualified Data.Text as T + +spaces :: P.Parser () +spaces = P.takeWhile (\x -> x == ' ' || x == '\t') >> return () + + +-- | Parse bit field literal in format ''b'00101011'''. Takes just last 64 bits +-- of input, other bits are ignored +parseBitField :: P.Parser Word64 +parseBitField = do + _ <- P.string "b'" + d <- P.takeWhile $ \x -> x == '0' || x == '1' + _ <- P.string "'" + return $ toword d + where + toword t = foldl setBit 0 + $ map snd + $ filter fst + $ zip (take wlen + $ reverse + $ map tobool + $ T.unpack t) [0..] + wlen = bitSize (undefined :: Word64) + tobool '1' = True + tobool '0' = False + tobool _ = error "tobool got wrong value, error in the parser, please report a bug" + +parseIsoZonedTime :: P.Parser ZonedTime +parseIsoZonedTime = zoned P. "ZonedTime parser" + where + zoned = do + time <- parseIsoLocalTime + spaces + zn <- P.option Nothing $ Just <$> zone + case zn of + Nothing -> return $ ZonedTime time utc + Just (addt, z) -> return $ if addt /= 0 + then utcToZonedTime z + $ addUTCTime addt + $ zonedTimeToUTC + $ ZonedTime time z + else ZonedTime time z + zone = do + sign <- P.option '+' (P.char '-' <|> P.char '+') + (a, z) <- hhmmss <|> hhmm <|> hhhh + return $ if sign == '+' + then (fromIntegral a, minutesToTimeZone z) + else (fromIntegral $ negate a, minutesToTimeZone $ negate z) + + fromh h = (0, 60 * h) + fromhm h m = (0, m + (60 * h)) + fromhms h m s = (s, m + (60 * h)) + + hhmmss = do + hh <- P.decimal + _ <- P.char ':' + mm <- P.decimal + _ <- P.char ':' + ss <- P.decimal + return $ fromhms hh mm ss + + hhmm = do + hh <- P.decimal + _ <- P.char ':' + mm <- P.decimal + return $ fromhm hh mm + + hhhh = do + h <- P.takeWhile1 isDigit + case T.length h of + 4 -> return $ fromhm (readd $ T.take 2 h) (readd $ T.drop 2 h) -- 0400 format + 6 -> return $ fromhms (readd $ T.take 2 h) (readd $ T.take 2 $ T.drop 2 h) (readd $ T.drop 4 h) + _ -> return $ fromh $ readd h + + readd t = T.foldl' fld 0 t + where + fld ac c = (fromEnum c - fromEnum '0') + (ac * 10) + +parseIsoDay :: P.Parser Day +parseIsoDay = dayparse P. "Day parser" + where + dayparse = do + yr <- P.decimal + delim + mn <- P.decimal + delim + dy <- P.decimal + let err = getFirst $ mconcat + [ First $ if mn > 12 || mn < 1 + then Just $ "month is " ++ show mn ++ " must be in bounds from 1 to 12" + else Nothing + , First $ if dy > 31 || dy < 1 + then Just $ "day is " ++ show dy ++ " must be in bounds from 1 to 31" + else Nothing + ] + case err of + Just e -> fail e + Nothing -> case fromGregorianValid yr mn dy of + Just ret -> return ret + Nothing -> fail $ "could not convert year: " ++ show yr + ++ " month: " ++ show mn + ++ " day: " ++ show dy + ++ " to date" + + delim = do + spaces + _ <- P.option Nothing $ Just <$> do + _ <- P.char '-' + spaces + return () + + + +parseIsoTimeOfDay :: P.Parser TimeOfDay +parseIsoTimeOfDay = timeparse P. "TimeOfDay parser" + where + timeparse = do + hh <- P.decimal P. "hours" + colon + mm <- P.decimal P. "minutes" + colon + ss <- P.rational P. "seconds" + let err = getFirst $ mconcat + [ First $ if hh > 23 || hh < 0 + then Just $ "Hour is " ++ show hh ++ " must be in bounds from 0 to 23" + else Nothing + , First $ if mm > 59 || hh < 0 + then Just $ "Minute is " ++ show mm ++ " must be in bounds from 0 to 59" + else Nothing + , First $ if ss > 60 || ss < 0 + then Just $ "Seconds is " ++ show ss ++ " must be in bounds from 0 to 59" + else Nothing + ] + case err of + Nothing -> return $ TimeOfDay hh mm ss + Just e -> fail e + + colon = do + spaces + _ <- P.char ':' + spaces + return () + +parseIsoLocalTime :: P.Parser LocalTime +parseIsoLocalTime = parsetime P. "LocalTime parser" + where + parsetime = do + day <- parseIsoDay + spaces + _ <- P.option Nothing $ Just <$> do + _ <- P.char 'T' + spaces + time <- parseIsoTimeOfDay + return $ LocalTime day time diff --git a/Database/HDBI/SqlValue.hs b/Database/HDBI/SqlValue.hs new file mode 100644 --- /dev/null +++ b/Database/HDBI/SqlValue.hs @@ -0,0 +1,703 @@ +{-# LANGUAGE + CPP + , DeriveDataTypeable + , FlexibleContexts + , FlexibleInstances + , GeneralizedNewtypeDeriving + , MultiParamTypeClasses + , OverloadedStrings + , ScopedTypeVariables + #-} + +#if ! (MIN_VERSION_time(1,1,3)) +{-# LANGUAGE + StandaloneDeriving #-} +#endif + +{- | + Module : Database.HDBI.SqlValue + Copyright : Copyright (C) 2006 John Goerzen + License : BSD3 + + Maintainer : Aleksey Uymanov + Stability : experimental + Portability: portable +-} + + +module Database.HDBI.SqlValue + ( + ToSql(..) + , FromSql(..) + , ConvertError(..) + , BitField(..) + -- * SQL value marshalling + , SqlValue(..) + ) + +where + +import Database.HDBI.Formaters +import Database.HDBI.Parsers + +import Control.Applicative ((<$>)) +import Control.Exception +import Data.Attoparsec.Text.Lazy +import Data.Data (Data) +import Data.Ix (Ix) +import Data.Bits (Bits) +import Data.Decimal +import Data.Int +import Data.List (intercalate) +import Data.Time +import Data.Typeable +import Data.UUID (UUID, fromString, toString) +import Data.Word +import qualified Blaze.ByteString.Builder as BB +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL + +-- | Convertion error description. Used in 'FromSql' typeclass. +data ConvertError = + ConvertError { ceReason :: String -- ^ Detailed description of convertion error + } + -- | Type names must unique. Expecting names are generated by ('show' . 'typeOf') + -- function + | IncompatibleTypes { ceFromType :: String -- ^ name of type trying to convert + -- from. + , ceToType :: String -- ^ name of target type. + } + deriving (Show, Typeable, Eq) + +instance Exception ConvertError + + +-- | Auxiliary type to represent bit field outside of SqlValue +newtype BitField = BitField { unBitField :: Word64 } + deriving (Bounded, Enum, Eq, Integral, Data, Num, Ord, Real, Ix, Typeable, Bits) + +instance Show BitField where + show = formatBitField . unBitField + +-- | All types must convert to SqlValue safely and unambiguously. That's why +-- there is no ''safeToSql'' method +class ToSql a where + toSql :: a -> SqlValue + +class FromSql a where + safeFromSql :: SqlValue -> Either ConvertError a + + -- | Unsafe method, throws 'ConvertError' if convertion failed. Has default + -- implementation. + fromSql :: SqlValue -> a + fromSql s = case safeFromSql s of + Left e -> throw e + Right a -> a + + +-- | Show parser detail error +showFail :: [String] -- ^ List of contexts of parser + -> String -- ^ Error message + -> String +showFail cont msg = "Parser failed in context " + ++ (show $ intercalate ", " cont) + ++ " with message " + ++ (show msg) + + +incompatibleTypes :: (Typeable a, Typeable b) => a -> b -> Either ConvertError c +incompatibleTypes a b = Left $ IncompatibleTypes (show $ typeOf a) (show $ typeOf b) + +-- | create converting from Null error message +nullConvertError :: (Typeable a) => a -> Either ConvertError b +nullConvertError a = Left $ ConvertError ("could not convert SqlNull to " ++ (show $ typeOf a)) + +convertToBounded :: forall b. (Integral b, Typeable b, Bounded b) => Integer -> Either ConvertError b +convertToBounded a = if a > bmax + then errorval + else if a < bmin + then errorval + else Right $ fromIntegral a + where + bmin = toInteger (minBound :: b) + bmax = toInteger (maxBound :: b) + errorval = Left $ ConvertError ("The value " ++ show a ++ " is out of bounds of " ++ (show $ typeOf (undefined :: b))) + +tryParse :: TL.Text -> Parser a -> Either ConvertError a +tryParse t parser = case parse parser t of + Fail _ cont desc -> Left $ ConvertError $ showFail cont desc + Done _ res -> Right res + + +{- | 'SqlValue' is the main type for expressing Haskell values to SQL databases. + +/WHAT IS SQLVALUE/ + +SqlValue is an intermediate type to store/recevie data to/from the +database. Every database driver will do it's best to properly convert any +SqlValue to the database record's field, and properly convert the record's field +to SqlValue back. + +The 'SqlValue' has predefined 'FromSql' and 'ToSql' instances for many Haskell's +types. Any Haskell's type can be converted to the 'SqlValue' with 'toSql' +function. There is no safeToSql function because 'toSql' never fails. Also, any +'SqlValue' type can be converted to almost any Haskell's type as well. Not any +'SqlValue' can be converted back to Haskell's type, so there is 'safeFromSql' +function to do that safely. There is also unsafe 'toSql' function of caurse. + +You can sure, that @fromSql . toSql == id@ + +/SQLVALUE CONSTRUCTORS/ + +'SqlValue' constructors is the MINIMAL set of constructors, required to +represent the most wide range of native database types. + +For example, there is FLOAT native database type and DOUBLE, but any DOUBLE can +carry any FLOAT value, so there is no need to create 'SqlValue' constructor to +represent FLOAT type, we can do it with Double. But there is DECIMAL database +type, representing arbitrary precision value which can be carried just by +'Decimal' Haskell's type, so we need a constructor for it. + +There is no SqlRational any more, because there is no one database which have +native Rational type. This is the key idea: if database can not store this type +natively we will not create 'SqlValue' clause for it. + +Each 'SqlValue' constructor is documented or self-explaining to understand what +it is needed for. + +/'ToSql' and 'FromSql' INSTANCES/ + +The key idea is to do the most obvious conversion between types only if it is +not ambiguous. For example, the most obvious conversion of 'Double' to 'Int32' +is just truncate the 'Double', the most obvious conversion of String to +'UTCTime' is to try read the 'String' as date and time. But there is no obvious +way to convert 'Int32' to 'UTCTime', so if you will try to convert ('SqlInteger' +44) to date you will fail. User must handle this cases properly converting +values with right way. It is not very good idea to silently perform strange and +ambiguous convertions between absolutely different data types. + +/ERROR CONDITIONS/ + +There may be sometimes an error during conversion. For instance, if you have an +'SqlText' and attempting to convert it to an 'Integer', but it doesn't parse as +an 'Integer', you will get an error. This will be indicated as an exception +using 'fromSql', or a Left result using 'safeFromSql'. + + +/STORING SQLVALUE TO DATABASE/ + +Any 'SqlValue' can be converted to 'Text' and then readed from 'Text' back. This +is guaranteed by tests, so the database driver's author can use it to store and +read data through 'Text' for types which is not supported by the database +natively. + +/TEXT AND BYTESTRINGS/ + +We are using lazy Text everywhere because it is faster than 'String' and has +builders. Strict text can be converted to one-chanked lazy text with O(1) +complexity, but lazy to strict converts with O(n) complexity, so it is logical +to use lazy Text. + +We are not using ByteString as text encoded in UTF-8, ByteStrings are just +sequences of bytes. We are using strict ByteStrings because HDBI drivers uses +them to pass the ByteString to the C library as 'CString', so it must be strict. + +We are not using 'String' as data of query or as query itself because it is not +effective in memory and cpu. + +/DATE AND TIME/ + +We are not using time with timezone, because there is no one database working +with it natively except PostgreSQL, but the documentations of PostgreSQL says + +/To address these difficulties, we recommend using date/time types that contain +both date and time when using time zones. We do not recommend using the type +time with time zone (though it is supported by PostgreSQL for legacy +applications and for compliance with the SQL standard). PostgreSQL assumes your +local time zone for any type containing only date or time./ + +This is not recomended to use time with timezone. + +We are using 'UTCTime' instead of 'TimeWithTimezone' because no one database +actually save timezone information. All databases just convert datetime to +'UTCTime' when save data and convert UTCTime back to LOCAL SERVER TIMEZONE when +returning the data. So it is logical to work with timezones on the haskell side. + +Time intervals are not widely supported, actually just in PostgreSQL and +Oracle. So, if you need them you can serialize throgh 'SqlText' by hands, or +write your own 'ToSql' and 'FromSql' instances to do that more convenient. + +/EQUALITY OF SQLVALUE/ + +Two SqlValues are considered to be equal if one of these hold. The +first comparison that can be made is controlling; if none of these +comparisons can be made, then they are not equal: + + * Both are NULL + + * Both represent the same type and the encapsulated values are considered equal + by applying (==) to them + + * The values of each, when converted to a 'String', are equal. + +-} +data SqlValue = + -- | Arbitrary precision DECIMAL value + SqlDecimal Decimal + -- | Any Integer, including Int32, Int64 and Words. + | SqlInteger Integer + | SqlDouble Double + | SqlText TL.Text + -- | Blob field in the database. This field can not be implicitly converted + -- to any other type because it is just an array of bytes, not an UTF-8 + -- encoded string. + | SqlBlob B.ByteString + | SqlBool Bool + -- | Represent bit field with 64 bits + | SqlBitField BitField + -- | UUID value http://en.wikipedia.org/wiki/UUID + | SqlUUID UUID + + | SqlUTCTime UTCTime -- ^ UTC YYYY-MM-DD HH:MM:SS + | SqlLocalDate Day -- ^ Local YYYY-MM-DD (no timezone) + | SqlLocalTimeOfDay TimeOfDay -- ^ Local HH:MM:SS (no timezone) + | SqlLocalTime LocalTime -- ^ Local YYYY-MM-DD HH:MM:SS (no timezone) + | SqlNull -- ^ NULL in SQL or Nothing in Haskell + deriving (Show, Typeable, Ord) + +instance Eq SqlValue where + + (SqlDecimal a) == (SqlDecimal b) = a == b + (SqlInteger a) == (SqlInteger b) = a == b + (SqlDouble a) == (SqlDouble b) = a == b + (SqlText a) == (SqlText b) = a == b + (SqlBlob a) == (SqlBlob b) = a == b + (SqlBool a) == (SqlBool b) = a == b + (SqlBitField a) == (SqlBitField b) = a == b + (SqlUUID a) == (SqlUUID b) = a == b + (SqlUTCTime a) == (SqlUTCTime b) = a == b + (SqlLocalDate a) == (SqlLocalDate b) = a == b + (SqlLocalTimeOfDay a) == (SqlLocalTimeOfDay b) = a == b + (SqlLocalTime a) == (SqlLocalTime b) = a == b + SqlNull == SqlNull = True + SqlNull == _ = False + _ == SqlNull = False + a == b = case convres of -- FIXME: uncomment + Left _ -> False + Right r -> r + where + convres = do + (x :: String) <- safeFromSql a + y <- safeFromSql b + return $ x == y + + +instance ToSql Decimal where + toSql = SqlDecimal + +instance FromSql Decimal where + safeFromSql (SqlDecimal d) = Right d + safeFromSql (SqlInteger i) = Right $ fromIntegral i + safeFromSql (SqlDouble d) = Right $ realToFrac d + safeFromSql (SqlText t) = tryParse t $ signed rational + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: Decimal) + safeFromSql (SqlBool b) = Right $ if b then 1 else 0 + safeFromSql (SqlBitField bf) = Right $ fromIntegral bf + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: Decimal) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: Decimal) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: Decimal) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: Decimal) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: Decimal) + safeFromSql SqlNull = nullConvertError (undefined :: Decimal) + + +instance ToSql Int where + toSql i = SqlInteger $ toInteger i + +instance FromSql Int where + safeFromSql (SqlDecimal d) = convertToBounded $ truncate d + safeFromSql (SqlInteger i) = convertToBounded i + safeFromSql (SqlDouble d) = convertToBounded $ truncate d + safeFromSql (SqlText t) = tryParse t $ signed decimal + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: Int) + safeFromSql (SqlBool b) = Right $ if b then 1 else 0 + safeFromSql (SqlBitField bf) = convertToBounded $ toInteger bf + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: Int) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: Int) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: Int) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: Int) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: Int) + safeFromSql SqlNull = nullConvertError (undefined :: Int) + + +instance ToSql Int32 where + toSql i = SqlInteger $ toInteger i + +instance FromSql Int32 where + safeFromSql (SqlDecimal d) = convertToBounded $ truncate d + safeFromSql (SqlInteger i) = convertToBounded i + safeFromSql (SqlDouble d) = convertToBounded $ truncate d + safeFromSql (SqlText t) = tryParse t $ signed decimal + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: Int32) + safeFromSql (SqlBool b) = Right $ if b then 1 else 0 + safeFromSql (SqlBitField bf) = convertToBounded $ toInteger bf + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: Int32) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: Int32) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: Int32) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: Int32) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: Int32) + safeFromSql SqlNull = nullConvertError (undefined :: Int32) + + +instance ToSql Int64 where + toSql i = SqlInteger $ toInteger i + +instance FromSql Int64 where + safeFromSql (SqlDecimal d) = convertToBounded $ truncate d + safeFromSql (SqlInteger i) = convertToBounded i + safeFromSql (SqlDouble d) = convertToBounded $ truncate d + safeFromSql (SqlText t) = tryParse t $ signed decimal + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: Int64) + safeFromSql (SqlBool b) = Right $ if b then 1 else 0 + safeFromSql (SqlBitField bf) = convertToBounded $ toInteger bf + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: Int64) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: Int64) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: Int64) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: Int64) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: Int64) + safeFromSql SqlNull = nullConvertError (undefined :: Int64) + + +instance ToSql Integer where + toSql = SqlInteger + +instance FromSql Integer where + safeFromSql (SqlDecimal d) = Right $ truncate d + safeFromSql (SqlInteger i) = Right i + safeFromSql (SqlDouble d) = Right $ truncate d + safeFromSql (SqlText t) = tryParse t $ signed decimal + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: Integer) + safeFromSql (SqlBool b) = Right $ if b then 1 else 0 + safeFromSql (SqlBitField bf) = Right $ toInteger bf + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: Integer) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: Integer) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: Integer) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: Integer) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: Integer) + safeFromSql SqlNull = nullConvertError (undefined :: Integer) + + +instance ToSql Word32 where + toSql i = SqlInteger $ toInteger i + +instance FromSql Word32 where + safeFromSql (SqlDecimal d) = convertToBounded $ truncate d + safeFromSql (SqlInteger i) = convertToBounded i + safeFromSql (SqlDouble d) = convertToBounded $ truncate d + safeFromSql (SqlText t) = tryParse t (decimal "Word32 parser") + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: Word32) + safeFromSql (SqlBool b) = Right $ if b then 1 else 0 + safeFromSql (SqlBitField bf) = convertToBounded $ toInteger bf + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: Word32) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: Word32) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: Word32) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: Word32) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: Word32) + safeFromSql SqlNull = nullConvertError (undefined :: Word32) + + +instance ToSql Word64 where + toSql i = SqlInteger $ toInteger i + +instance FromSql Word64 where + safeFromSql (SqlDecimal d) = convertToBounded $ truncate d + safeFromSql (SqlInteger i) = convertToBounded i + safeFromSql (SqlDouble d) = convertToBounded $ truncate d + safeFromSql (SqlText t) = tryParse t (decimal "Word64 parser") + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: Word64) + safeFromSql (SqlBool b) = Right $ if b then 1 else 0 + safeFromSql (SqlBitField bf) = Right $ unBitField bf + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: Word64) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: Word64) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: Word64) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: Word64) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: Word64) + safeFromSql SqlNull = nullConvertError (undefined :: Word64) + + +instance ToSql Word where + toSql i = SqlInteger $ toInteger i + +instance FromSql Word where + safeFromSql (SqlDecimal d) = convertToBounded $ truncate d + safeFromSql (SqlInteger i) = convertToBounded i + safeFromSql (SqlDouble d) = convertToBounded $ truncate d + safeFromSql (SqlText t) = tryParse t (decimal "Word parser") + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: Word) + safeFromSql (SqlBool b) = Right $ if b then 1 else 0 + safeFromSql (SqlBitField bf) = convertToBounded $ toInteger bf + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: Word) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: Word) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: Word) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: Word) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: Word) + safeFromSql SqlNull = nullConvertError (undefined :: Word) + + +instance ToSql Double where + toSql = SqlDouble + +instance FromSql Double where + safeFromSql (SqlDecimal d) = Right $ realToFrac d + safeFromSql (SqlInteger i) = Right $ fromIntegral i + safeFromSql (SqlDouble d) = Right d + safeFromSql (SqlText t) = tryParse t $ signed double + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: Double) + safeFromSql (SqlBool b) = Right $ if b then 1 else 0 + safeFromSql (SqlBitField bf) = Right $ fromIntegral bf + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: Double) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: Double) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: Double) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: Double) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: Double) + safeFromSql SqlNull = nullConvertError (undefined :: Double) + + +instance ToSql [Char] where + toSql s = SqlText $ TL.pack s + +instance FromSql [Char] where + safeFromSql (SqlDecimal d) = Right $ show d + safeFromSql (SqlInteger i) = Right $ show i + safeFromSql (SqlDouble d) = Right $ show d + safeFromSql (SqlText t) = Right $ TL.unpack t + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: String) + safeFromSql (SqlBool b) = Right $ if b then "t" else "f" + safeFromSql (SqlBitField bf) = Right $ formatBitField $ unBitField bf + safeFromSql (SqlUUID u) = Right $ toString u + safeFromSql (SqlUTCTime ut) = Right $ formatIsoUTCTime ut + safeFromSql (SqlLocalDate ld) = Right $ formatIsoDay ld + safeFromSql (SqlLocalTimeOfDay tod) = Right $ formatIsoTimeOfDay tod + safeFromSql (SqlLocalTime lt) = Right $ formatIsoLocalTime lt + safeFromSql SqlNull = nullConvertError (undefined :: String) + + +instance ToSql TL.Text where + toSql = SqlText + +instance FromSql TL.Text where + safeFromSql (SqlText t) = Right t + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: TL.Text) + safeFromSql SqlNull = nullConvertError (undefined :: TL.Text) + safeFromSql x = TL.pack <$> safeFromSql x + + +instance ToSql T.Text where + toSql t = SqlText $ TL.fromChunks [t] + +instance FromSql T.Text where + safeFromSql (SqlText t) = Right $ TL.toStrict t + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: T.Text) + safeFromSql SqlNull = nullConvertError (undefined :: T.Text) + safeFromSql x = T.pack <$> safeFromSql x + + +instance ToSql B.ByteString where + toSql = SqlBlob + +instance FromSql B.ByteString where + safeFromSql (SqlDecimal d) = incompatibleTypes d (undefined :: B.ByteString) + safeFromSql (SqlInteger i) = incompatibleTypes i (undefined :: B.ByteString) + safeFromSql (SqlDouble d) = incompatibleTypes d (undefined :: B.ByteString) + safeFromSql (SqlText t) = incompatibleTypes t (undefined :: B.ByteString) + safeFromSql (SqlBlob b) = Right b + safeFromSql (SqlBool b) = incompatibleTypes b (undefined :: B.ByteString) + safeFromSql (SqlBitField bf) = incompatibleTypes bf (undefined :: B.ByteString) + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: B.ByteString) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: B.ByteString) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: B.ByteString) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: B.ByteString) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: B.ByteString) + safeFromSql SqlNull = nullConvertError (undefined :: B.ByteString) + + +instance ToSql BL.ByteString where + toSql b = SqlBlob $ BB.toByteString $ BB.fromLazyByteString b + +instance FromSql BL.ByteString where + safeFromSql (SqlDecimal d) = incompatibleTypes d (undefined :: BL.ByteString) + safeFromSql (SqlInteger i) = incompatibleTypes i (undefined :: BL.ByteString) + safeFromSql (SqlDouble d) = incompatibleTypes d (undefined :: BL.ByteString) + safeFromSql (SqlText t) = incompatibleTypes t (undefined :: BL.ByteString) + safeFromSql (SqlBlob b) = Right $ BL.fromChunks [b] + safeFromSql (SqlBool b) = incompatibleTypes b (undefined :: BL.ByteString) + safeFromSql (SqlBitField bf) = incompatibleTypes bf (undefined :: BL.ByteString) + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: BL.ByteString) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: BL.ByteString) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: BL.ByteString) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: BL.ByteString) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: BL.ByteString) + safeFromSql SqlNull = nullConvertError (undefined :: BL.ByteString) + + +instance ToSql Bool where + toSql = SqlBool + +instance FromSql Bool where + safeFromSql (SqlDecimal d) = Right $ d /= 0 + safeFromSql (SqlInteger i) = Right $ i /= 0 + safeFromSql (SqlDouble d) = Right $ d /= 0 + safeFromSql (SqlText t) = case TL.toLower t of + "t" -> Right True + "true" -> Right True + "1" -> Right True + "f" -> Right False + "false" -> Right False + "0" -> Right False + _ -> Left $ ConvertError + $ "Could not convert string \"" ++ (show t) ++ "\" to Bool" + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: Bool) + safeFromSql (SqlBool b) = Right b + safeFromSql (SqlBitField bf) = Right $ bf /= 0 + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: Bool) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: Bool) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: Bool) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: Bool) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: Bool) + safeFromSql SqlNull = nullConvertError (undefined :: Bool) + + +instance ToSql BitField where + toSql = SqlBitField + +instance FromSql BitField where + safeFromSql (SqlDecimal d) = incompatibleTypes d (undefined :: BitField) + safeFromSql (SqlInteger i) = BitField <$> convertToBounded i + safeFromSql (SqlDouble d) = incompatibleTypes d (undefined :: BitField) + safeFromSql (SqlText t) = BitField <$> tryParse t parseBitField + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: BitField) + safeFromSql (SqlBool b) = Right $ BitField $ if b then 1 else 0 + safeFromSql (SqlBitField bf) = Right bf + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: BitField) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: BitField) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: BitField) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: BitField) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: BitField) + safeFromSql SqlNull = nullConvertError (undefined :: BitField) + + +instance ToSql UUID where + toSql = SqlUUID + +instance FromSql UUID where + safeFromSql (SqlDecimal d) = incompatibleTypes d (undefined :: UUID) + safeFromSql (SqlInteger i) = incompatibleTypes i (undefined :: UUID) + safeFromSql (SqlDouble d) = incompatibleTypes d (undefined :: UUID) + safeFromSql (SqlText t) = case fromString $ TL.unpack t of + Nothing -> Left $ ConvertError $ "Could not convert \"" ++ (show t) ++ "\" to UUID" + Just u -> Right u + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: UUID) + safeFromSql (SqlBool b) = incompatibleTypes b (undefined :: UUID) + safeFromSql (SqlBitField bf) = incompatibleTypes bf (undefined :: UUID) + safeFromSql (SqlUUID u) = Right u + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: UUID) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: UUID) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: UUID) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: UUID) + safeFromSql SqlNull = nullConvertError (undefined :: UUID) + + +instance ToSql UTCTime where + toSql = SqlUTCTime + +instance FromSql UTCTime where + safeFromSql (SqlDecimal d) = incompatibleTypes d (undefined :: UTCTime) + safeFromSql (SqlInteger i) = incompatibleTypes i (undefined :: UTCTime) + safeFromSql (SqlDouble d) = incompatibleTypes d (undefined :: UTCTime) + safeFromSql (SqlText t) = zonedTimeToUTC <$> tryParse t parseIsoZonedTime + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: UTCTime) + safeFromSql (SqlBool b) = incompatibleTypes b (undefined :: UTCTime) + safeFromSql (SqlBitField bf) = incompatibleTypes bf (undefined :: UTCTime) + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: UTCTime) + safeFromSql (SqlUTCTime ut) = Right ut + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: UTCTime) + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: UTCTime) + safeFromSql (SqlLocalTime lt) = incompatibleTypes lt (undefined :: UTCTime) + safeFromSql SqlNull = nullConvertError (undefined :: UTCTime) + + +instance ToSql Day where + toSql = SqlLocalDate + +instance FromSql Day where + safeFromSql (SqlDecimal d) = incompatibleTypes d (undefined :: Day) + safeFromSql (SqlInteger i) = incompatibleTypes i (undefined :: Day) + safeFromSql (SqlDouble d) = incompatibleTypes d (undefined :: Day) + safeFromSql (SqlText t) = tryParse t parseIsoDay + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: Day) + safeFromSql (SqlBool b) = incompatibleTypes b (undefined :: Day) + safeFromSql (SqlBitField bf) = incompatibleTypes bf (undefined :: Day) + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: Day) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: Day) + safeFromSql (SqlLocalDate ld) = Right $ ld + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: Day) + safeFromSql (SqlLocalTime lt) = Right $ localDay lt + safeFromSql SqlNull = nullConvertError (undefined :: Day) + + +instance ToSql TimeOfDay where + toSql = SqlLocalTimeOfDay + +instance FromSql TimeOfDay where + safeFromSql (SqlDecimal d) = incompatibleTypes d (undefined :: TimeOfDay) + safeFromSql (SqlInteger i) = incompatibleTypes i (undefined :: TimeOfDay) + safeFromSql (SqlDouble d) = incompatibleTypes d (undefined :: TimeOfDay) + safeFromSql (SqlText t) = tryParse t parseIsoTimeOfDay + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: TimeOfDay) + safeFromSql (SqlBool b) = incompatibleTypes b (undefined :: TimeOfDay) + safeFromSql (SqlBitField bf) = incompatibleTypes bf (undefined :: TimeOfDay) + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: TimeOfDay) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: TimeOfDay) + safeFromSql (SqlLocalDate ld) = incompatibleTypes ld (undefined :: TimeOfDay) + safeFromSql (SqlLocalTimeOfDay tod) = Right $ tod + safeFromSql (SqlLocalTime lt) = Right $ localTimeOfDay lt + safeFromSql SqlNull = nullConvertError (undefined :: TimeOfDay) + + +instance ToSql LocalTime where + toSql = SqlLocalTime + +instance FromSql LocalTime where + safeFromSql (SqlDecimal d) = incompatibleTypes d (undefined :: LocalTime) + safeFromSql (SqlInteger i) = incompatibleTypes i (undefined :: LocalTime) + safeFromSql (SqlDouble d) = incompatibleTypes d (undefined :: LocalTime) + safeFromSql (SqlText t) = tryParse t parseIsoLocalTime + safeFromSql (SqlBlob b) = incompatibleTypes b (undefined :: LocalTime) + safeFromSql (SqlBool b) = incompatibleTypes b (undefined :: LocalTime) + safeFromSql (SqlBitField bf) = incompatibleTypes bf (undefined :: LocalTime) + safeFromSql (SqlUUID u) = incompatibleTypes u (undefined :: LocalTime) + safeFromSql (SqlUTCTime ut) = incompatibleTypes ut (undefined :: LocalTime) + safeFromSql (SqlLocalDate ld) = Right $ LocalTime ld midnight + safeFromSql (SqlLocalTimeOfDay tod) = incompatibleTypes tod (undefined :: LocalTime) + safeFromSql (SqlLocalTime lt) = Right $ lt + safeFromSql SqlNull = nullConvertError (undefined :: LocalTime) + + +instance (ToSql a) => ToSql (Maybe a) where + toSql m = case m of + Nothing -> SqlNull + Just a -> toSql a + +instance (FromSql a) => FromSql (Maybe a) where + safeFromSql SqlNull = Right Nothing + safeFromSql x = Just <$> safeFromSql x + + +instance ToSql SqlValue where + toSql = id + +instance FromSql SqlValue where + safeFromSql x = Right x + fromSql = id diff --git a/Database/HDBI/Types.hs b/Database/HDBI/Types.hs new file mode 100644 --- /dev/null +++ b/Database/HDBI/Types.hs @@ -0,0 +1,329 @@ +{-# LANGUAGE + TypeFamilies + , DeriveDataTypeable + , ExistentialQuantification + , FlexibleContexts + , ScopedTypeVariables + , GeneralizedNewtypeDeriving + #-} + +{- | + Module : Database.HDBI.Types + Copyright : Copyright (C) 2005-2011 John Goerzen + License : BSD3 + + Maintainer : Aleksey Uymanov + Stability : experimental + Portability: portable + +Types for HDBI. + +Written by John Goerzen, jgoerzen\@complete.org +-} + +module Database.HDBI.Types + ( + -- * Typeclasses + Connection(..) + , Statement(..) + -- * Data types + , Query(..) + , ConnStatus(..) + , ConnWrapper(..) + , StatementStatus(..) + , StmtWrapper(..) + , SqlError(..) + -- * functions + , castConnection + , castStatement + , withTransaction + , withStatement + ) where + +import Prelude hiding (catch) +import qualified Data.Text.Lazy as TL +import Database.HDBI.SqlValue (SqlValue) + +import Control.Applicative ((<$>)) +import Control.Exception (Exception(..), SomeException, try, catch, throwIO, bracket) +import Control.DeepSeq (NFData(..)) +import Data.Typeable +import Data.String (IsString(..)) +import Data.Data (Data(..)) +import Data.Monoid (Monoid(..), Endo(..)) + +-- | Error throwing by driver when database operation fails +data SqlError = + -- | Internal database error + SqlError { seErrorCode :: String -- ^ Low level database-specific error code + , seErrorMsg :: String -- ^ Error description from the database client library + } + -- | Driver-specific operational error + | SqlDriverError { seErrorMsg :: String -- ^ Error description + } + deriving (Eq, Show, Typeable) + +instance Exception SqlError + +-- | safe newtype wrapper for queries. Just lazy Text inside. +newtype Query = Query { unQuery :: TL.Text -- ^ Unwrap query to lazy Text + } + deriving (Eq, Data, Ord, Read, Show, IsString, Typeable, Monoid, NFData) + +-- | Connection status +data ConnStatus = ConnOK -- ^ Successfully connected + | ConnDisconnected -- ^ Successfully disconnected, all + -- statements must be closed at this state + | ConnBad -- ^ Connection is in some bad state + deriving (Typeable, Show, Read, Eq) + +-- | Typeclass to abstract the working with connection. +class (Typeable conn, (Statement (ConnStatement conn))) => Connection conn where + + -- | Specific statement for specific connection + type ConnStatement conn :: * + + -- | Disconnection from the database. Every opened statement must be finished + -- after this method executed. + disconnect :: conn -> IO () + + -- | Explicitly start the transaction. Without starting the transaction you + -- can not commit or rollback it. HDBI does not check if transaction started + -- or not, this is the application's resposibility. + -- + -- This is not recomended to use 'start' by hands, use 'withTransaction' + -- instead + begin :: conn -> IO () + + -- | Explicitly commit started transaction. You must 'start' the transaction + -- before 'commit' + -- + -- This is not recomended to use 'commit' by hands, use 'withTransaction' + -- instead + commit :: conn -> IO () + + -- | Rollback the transaction's state. You must 'start' the transaction before + -- 'rollback' + -- + -- This is not recomended to use 'rollback' by hands, use 'withTransaction' + -- instead + rollback :: conn -> IO () + + -- | Check if current connection is in transaction state. Return True if + -- transaction is started. Each driver implements it with it's own way: some + -- RDBMS has API to check transaction state (like PostgreSQL), some has no + -- (like Sqlite3). + inTransaction :: conn -> IO Bool + + -- | Return the current status of connection + connStatus :: conn -> IO ConnStatus + + -- | Prepare the statement. Some databases has no feature of preparing + -- statements (PostgreSQL can just prepare named statements), so each driver + -- behaves it's own way. + prepare :: conn -> Query -> IO (ConnStatement conn) + + -- | Run query and safely finalize statement after that. Has default + -- implementation through 'execute'. + run :: conn -> Query -> [SqlValue] -> IO () + run conn query values = withStatement conn query $ + \s -> execute s values + + -- | Run raw query without parameters and safely finalize statement. Has + -- default implementation through 'executeRaw'. + runRaw :: conn -> Query -> IO () + runRaw conn query = withStatement conn query executeRaw + + -- | Execute query with set of parameters. Has default implementation through + -- 'executeMany'. + runMany :: conn -> Query -> [[SqlValue]] -> IO () + runMany conn query values = withStatement conn query $ + \s -> executeMany s values + + -- | Clone the database connection. Return new connection with the same + -- settings + clone :: conn -> IO conn + + -- | The name of the HDBI driver module for this connection. Ideally would be + -- the same as the database name portion of the Cabal package name. For + -- instance, \"sqlite3\" or \"postgresql\". This is the layer that is bound most + -- tightly to HDBI + hdbiDriverName :: conn -> String + + -- | Whether or not the current database supports transactions. If False, then + -- 'commit' and 'rollback' should be expected to raise errors. + dbTransactionSupport :: conn -> Bool + + +-- | Wrapps the specific connection. You can write database-independent code +-- mixing it with database-dependent using 'castConnection' function to cast +-- Wrapper to specific connection type, if you need. +data ConnWrapper = forall conn. Connection conn => ConnWrapper conn + deriving (Typeable) + +instance Connection ConnWrapper where + type ConnStatement ConnWrapper = StmtWrapper + + disconnect (ConnWrapper conn) = disconnect conn + begin (ConnWrapper conn) = begin conn + commit (ConnWrapper conn) = commit conn + rollback (ConnWrapper conn) = rollback conn + inTransaction (ConnWrapper conn) = inTransaction conn + connStatus (ConnWrapper conn) = connStatus conn + prepare (ConnWrapper conn) str = StmtWrapper <$> prepare conn str + run (ConnWrapper conn) = run conn + runRaw (ConnWrapper conn) = runRaw conn + runMany (ConnWrapper conn) = runMany conn + clone (ConnWrapper conn) = ConnWrapper <$> clone conn + hdbiDriverName (ConnWrapper conn) = hdbiDriverName conn + dbTransactionSupport (ConnWrapper conn) = dbTransactionSupport conn + +-- | Cast wrapped connection to the specific connection type using 'cast' of +-- 'Typeable'. You can write database-specific code safely casting wrapped +-- connection to specific type dynamically. +castConnection :: (Connection conn) => ConnWrapper -> Maybe conn +castConnection (ConnWrapper conn) = cast conn + + + +-- | Statement's status returning by function 'statementStatus'. +data StatementStatus = StatementNew -- ^ Newly created statement + | StatementExecuted -- ^ Expression executed, now you can fetch the rows 'Statement' + | StatementFetched -- ^ Fetching is done, no more rows can be queried + | StatementFinished -- ^ Finished, no more actions with this statement + deriving (Typeable, Show, Read, Eq) + +-- | Statement prepared on database side or just in memory +class (Typeable stmt) => Statement stmt where + + -- | Execute single query with parameters. In query each parameter must be + -- replaced with ''?'' placeholder. This rule is true for every database, even + -- for PostgreSQL which uses placeholders like ''$1''. Application must ensure + -- that the count of placeholders is equal to count of parameter, it is likely + -- cause an error if it is not. + execute :: stmt -> [SqlValue] -> IO () + + -- | Execute single query without parameters. Has default implementation + -- through 'execute'. + executeRaw :: stmt -> IO () + executeRaw stmt = execute stmt [] + + -- | Execute one query many times with a list of paramters. Has default + -- implementation through 'execute'. + executeMany :: stmt -> [[SqlValue]] -> IO () + executeMany stmt vals = mapM_ (execute stmt) vals + + -- | Return the current statement's status. + statementStatus :: stmt -> IO StatementStatus + + -- | Return the count of rows affected by INSERT, UPDATE or DELETE + -- query. After executing SELECT query it will return 0 every time. + -- It is also undefined result after executing 'executeMany' + affectedRows :: stmt -> IO Integer + + -- | Finish statement and remove database-specific pointer. No any actions may + -- be proceeded after closing the statement, excpet 'statementStatus' which + -- will return 'StatementFinished' and 'reset'. + finish :: stmt -> IO () + + -- | Reset statement to it's initial state, just like after 'prepare'. + reset :: stmt -> IO () + + -- | Fetch next row from the executed statement. Return Nothing when there is + -- no more results acceptable. Each call return next row from the result. + -- + -- UPDATE INSERT and DELETE queries will likely return Nothing. + -- + -- NOTE: You still need to explicitly finish the statement after receiving + -- Nothing, unlike with old HDBC interface. + fetchRow :: stmt -> IO (Maybe [SqlValue]) + + -- | Optional method to strictly fetch all rows from statement. Has default + -- implementation through 'fetchRow'. + fetchAllRows :: stmt -> IO [[SqlValue]] + fetchAllRows stmt = do + e <- f mempty + return $ (appEndo e) [] + where + f acc = do + res <- fetchRow stmt + case res of + Just r -> f (acc `mappend` (Endo (r:))) + Nothing -> return acc + + -- | Return list of column names of the result. + getColumnNames :: stmt -> IO [TL.Text] + + -- | Return the number of columns representing the result. Has default + -- implementation through 'getColumnNames' + getColumnsCount :: stmt -> IO Int + getColumnsCount stmt = fmap length $ getColumnNames stmt + + -- | Return the original query the statement was prepared from. + originalQuery :: stmt -> Query + +-- | Wrapper around some specific 'Statement' instance to write +-- database-independent code +data StmtWrapper = forall stmt. Statement stmt => StmtWrapper stmt + deriving (Typeable) + +instance Statement StmtWrapper where + execute (StmtWrapper stmt) = execute stmt + executeRaw (StmtWrapper stmt) = executeRaw stmt + executeMany (StmtWrapper stmt) = executeMany stmt + statementStatus (StmtWrapper stmt) = statementStatus stmt + affectedRows (StmtWrapper stmt) = affectedRows stmt + finish (StmtWrapper stmt) = finish stmt + reset (StmtWrapper stmt) = reset stmt + fetchRow (StmtWrapper stmt) = fetchRow stmt + fetchAllRows (StmtWrapper stmt) = fetchAllRows stmt + getColumnNames (StmtWrapper stmt) = getColumnNames stmt + getColumnsCount (StmtWrapper stmt) = getColumnsCount stmt + originalQuery (StmtWrapper stmt) = originalQuery stmt + +-- | Cast wrapped statement to specific type. You can write database-specific +-- code safely casting wrapped statement to specific type dynamically. +castStatement :: (Statement stmt) => StmtWrapper -> Maybe stmt +castStatement (StmtWrapper stmt) = cast stmt + +{- | Execute some code. If any uncaught exception occurs, run +'rollback' and re-raise it. Otherwise, run 'commit' and return. + +This function, therefore, encapsulates the logical property that a transaction +is all about: all or nothing. + +The 'Connection' object passed in is passed directly to the specified function +as a convenience. + +This function traps /all/ uncaught exceptions, not just 'SqlError'. Therefore, +you will get a rollback for any exception that you don't handle. That's +probably what you want anyway. + +If there was an error while running 'rollback', this error will not be +reported since the original exception will be propogated back. (You'd probably +like to know about the root cause for all of this anyway.) Feedback +on this behavior is solicited. +-} +withTransaction :: Connection conn => conn -> IO a -> IO a +withTransaction conn func = do + begin conn + r <- try func + case r of + Right x -> do + commit conn + return x + Left (e :: SomeException) -> do + catch (rollback conn) (\(_ :: SomeException) -> return ()) + throwIO e + +{-| Create statement and execute monadic action using +it. Safely finalize Statement after action is done. +-} +withStatement :: (Connection conn, Statement stmt, stmt ~ (ConnStatement conn)) + => conn -- ^ Connection + -> Query -- ^ Query string + -> (stmt -> IO a) -- ^ Action at the statement + -> IO a +withStatement conn query = bracket + (prepare conn query) + finish diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2011, John Goerzen +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, this + list of conditions and the following disclaimer in the documentation and/or + other materials provided with the distribution. + +* Neither the name of John Goerzen nor the names of its + contributors may be used to endorse or promote products derived from this + software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,16 @@ +HDBI +==== + +Welcome to HDBI, Haskell Database Independent interface. + +HDBI is the fork of HDBC. This is just improved HDBC with new features. + +Installation +------------ + +Tested on GHC-7.4 but must work on older and newer versions, HUGS is not +supported for now. + +The steps to install are: + + cabal install hdbi diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hdbi.cabal b/hdbi.cabal new file mode 100644 --- /dev/null +++ b/hdbi.cabal @@ -0,0 +1,99 @@ +Name: hdbi +Version: 1.0.0 +License: BSD3 +Maintainer: Aleksey Uymanov +Author: John Goerzen +homepage: https://github.com/s9gf4ult/hdbi +Copyright: Copyright (c) 2005-2013 John Goerzen +license-file: LICENSE +extra-source-files: LICENSE, README.md +Category: Database +synopsis: Haskell Database Independent interface +Description: HDBI provides an abstraction layer between Haskell programs and SQL + relational databases. This lets you write database code once, in + Haskell, and have it work with any number of backend SQL databases + (MySQL, Oracle, PostgreSQL, ODBC-compliant databases, etc.) + +Stability: experimental +Build-Type: Simple + +Cabal-Version: >=1.8 + +source-repository head + type: git + location: https://github.com/s9gf4ult/hdbi.git + + +library + + Build-Depends: base>=3 && <5 + , Decimal >= 0.2.1 + , attoparsec + , blaze-builder + , bytestring + , deepseq + , old-locale + , text + , time >=1.1.2.4 && <=1.5 + , uuid >= 1.0.0 + + -- Hack for cabal-install weirdness. cabal-install forces base 3, + -- though it works fine for Setup.lhs manually. Fix. + if impl(ghc >= 6.9) + build-depends: base >= 4 + + GHC-Options: -Wall -fno-warn-orphans + ghc-prof-options: -fprof-auto + + Exposed-Modules: Database.HDBI + , Database.HDBI.DriverUtils + , Database.HDBI.SqlValue + , Database.HDBI.Types + , Database.HDBI.Formaters + , Database.HDBI.Parsers + +Test-Suite sqlvalues + Type: exitcode-stdio-1.0 + Main-Is: testsrc/sqlvalues.hs + other-modules: Database.HDBI + GHC-Options: -Wall -main-is SqlValues -fno-warn-orphans + ghc-prof-options: -fprof-auto + Build-Depends: base >= 4 + , Decimal >= 0.2.1 + , HUnit + , QuickCheck + , attoparsec + , blaze-builder + , bytestring + , deepseq + , old-locale + , quickcheck-assertions + , quickcheck-instances + , test-framework + , test-framework-hunit + , test-framework-quickcheck2 + , text + , time >=1.1.2.4 && <=1.5 + , uuid >= 1.0.0 + +Test-Suite dummydriver + Type: exitcode-stdio-1.0 + Main-Is: testsrc/dummydriver.hs + other-modules: Database.HDBI + , Database.HDBI.DriverUtils + GHC-Options: -Wall -main-is DummyDriver -fno-warn-orphans + ghc-prof-options: -fprof-auto + Build-Depends: base + , Decimal >= 0.2.1 + , HUnit + , attoparsec + , blaze-builder + , bytestring + , deepseq + , hspec-expectations + , old-locale + , test-framework + , test-framework-hunit + , text + , time >=1.1.2.4 && <=1.5 + , uuid >= 1.0.0 diff --git a/testsrc/dummydriver.hs b/testsrc/dummydriver.hs new file mode 100644 --- /dev/null +++ b/testsrc/dummydriver.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE + DeriveDataTypeable +, TypeFamilies +, OverloadedStrings +, ScopedTypeVariables + #-} + +module DummyDriver where + +import System.Mem +import System.Mem.Weak + +import Test.HUnit (Assertion) +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Hspec.Expectations + +import Control.Applicative +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad +import Data.Typeable +import Data.Maybe + +import Database.HDBI +import Database.HDBI.DriverUtils + +data TStatus = TIdle | TInTransaction + deriving (Eq, Show, Read, Typeable) + +data DummyConnection = + DummyConnection { dcState :: MVar ConnStatus + , dcTrans :: MVar TStatus + , dcData :: MVar [[SqlValue]] + , dcChilds :: ChildList DummyStatement + , dcTransSupport :: Bool + } + deriving (Typeable, Eq) + +data DummyStatement = + DummyStatement { dsConnection :: DummyConnection + , dsQuery :: Query + , dsSelecting :: MVar (Maybe Int) + , dsStatus :: MVar StatementStatus + } + deriving (Typeable, Eq) + + +newConnection :: Bool -> IO DummyConnection +newConnection transSupport = DummyConnection + <$> newMVar ConnOK + <*> newMVar TIdle + <*> newMVar [] + <*> newChildList + <*> return transSupport + +withOKConnection :: DummyConnection -> IO a -> IO a +withOKConnection conn action = do + st <- connStatus conn + case st of + ConnOK -> action + _ -> throwIO $ SqlError "1" $ "Connection has wrong status " ++ show st + +withTransactionSupport :: DummyConnection -> IO a -> IO a +withTransactionSupport conn action = case (dcTransSupport conn) of + True -> action + False -> throwIO $ SqlError "10" "Transaction is not supported by this connection" + + +instance Connection DummyConnection where + type ConnStatement DummyConnection = DummyStatement + disconnect conn = modifyMVar_ (dcState conn) $ \_ -> do + closeAllChildren $ dcChilds conn + return ConnDisconnected + + begin conn = withOKConnection conn + $ withTransactionSupport conn + $ modifyMVar_ (dcTrans conn) + $ \s -> case s of + TIdle -> return TInTransaction + TInTransaction -> throwIO $ SqlError "2" $ "Connection is already in transaction " + commit conn = withOKConnection conn + $ withTransactionSupport conn + $ modifyMVar_ (dcTrans conn) + $ \s -> case s of + TInTransaction -> return TIdle + TIdle -> throwIO $ SqlError "3" $ "Connection is not in transaction to commit" + rollback conn = withOKConnection conn + $ withTransactionSupport conn + $ modifyMVar_ (dcTrans conn) + $ \s -> case s of + TInTransaction -> return TIdle + TIdle -> throwIO $ SqlError "4" $ "Connection is not in transaction to rollback" + inTransaction conn = withTransactionSupport conn $ do + t <- readMVar $ dcTrans conn + return $ t == TInTransaction + connStatus = readMVar . dcState + prepare conn query = do + st <- DummyStatement + <$> return conn + <*> return query + <*> newMVar Nothing + <*> newMVar StatementNew + addChild (dcChilds conn) st + return st + clone conn = DummyConnection + <$> (newMVar ConnOK) + <*> (newMVar TIdle) + <*> newMVar [] + <*> newChildList + <*> (return $ dcTransSupport conn) + hdbiDriverName = const "DummyDriver" + dbTransactionSupport = dcTransSupport + + +instance Statement DummyStatement where + execute stmt params = modifyMVar_ (dsStatus stmt) $ \st -> do + case st of + StatementNew -> do + case originalQuery stmt of + "throw" -> throwIO $ SqlError "5" "Throwed query exception" + "insert" -> modifyMVar (dcData $ dsConnection stmt) $ \d -> return (d ++ [params], StatementExecuted) + "select" -> modifyMVar (dsSelecting stmt) $ const $ return (Just 0, StatementExecuted) + _ -> return StatementExecuted + _ -> throwIO $ SqlError "6" $ "Statement has wrong status to execute query " ++ show st + + statementStatus = readMVar . dsStatus + + affectedRows = const $ return 0 + finish stmt = modifyMVar_ (dsStatus stmt) $ const $ return StatementFinished + reset stmt = modifyMVar_ (dsStatus stmt) $ const $ return StatementNew + fetchRow stmt = modifyMVar (dsSelecting stmt) $ \slct -> case slct of + Nothing -> return (Nothing, Nothing) + Just sl -> do + dt <- readMVar $ dcData $ dsConnection stmt + if (length dt) > sl + then return (Just $ sl+1, Just $ dt !! sl) + else return (Nothing, Nothing) + + + getColumnNames = const $ return [] + originalQuery = dsQuery + + +test1 :: Assertion +test1 = do + c <- ConnWrapper <$> newConnection True + (withTransaction c $ do + intr <- inTransaction c + intr `shouldBe` True + stmt <- prepare c "throw" -- cause an exception throwing + executeRaw stmt + ) `shouldThrow` (\(_ :: SqlError) -> True) + intr <- inTransaction c + intr `shouldBe` False -- after rollback + +test2 :: Assertion +test2 = do + c <- ConnWrapper <$> newConnection True + intr1 <- inTransaction c + intr1 `shouldBe` False + withTransaction c $ do + stmt <- prepare c "dummy query" + executeRaw stmt + intr <- inTransaction c + intr `shouldBe` True + intr <- inTransaction c + intr `shouldBe` False -- after commit + +test3 :: Assertion +test3 = do + c <- ConnWrapper <$> newConnection False + sub c + performGC -- after this all refs must be empty + p <- case castConnection c of + Just cc -> readMVar $ dcChilds cc + prts <- filterM (deRefWeak >=> (return . isJust)) p + (length prts) `shouldBe` 0 + + where + sub cn = case castConnection cn of + Just c -> do + st1 <- prepare c "query 1" + st2 <- prepare c "query 2" + executeRaw st2 + prts <- readMVar $ dcChilds c + (length prts) `shouldBe` 2 + +test4 :: Assertion +test4 = do + c <- ConnWrapper <$> newConnection False + stmt <- prepare c "query 1" + disconnect c + ss <- statementStatus stmt + ss `shouldBe` StatementFinished + +test5 :: Assertion +test5 = do + c <- ConnWrapper <$> newConnection True + c2 <- clone c + st1 <- prepare c "query" + stt <- statementStatus st1 + stt `shouldBe` StatementNew + st2 <- prepare c2 "query" + stt2 <- statementStatus st2 + stt2 `shouldBe` StatementNew + disconnect c + stt <- statementStatus st1 + stt `shouldBe` StatementFinished + stt2 <- statementStatus st2 + stt2 `shouldBe` StatementNew + disconnect c2 + stt2 <- statementStatus st2 + stt2 `shouldBe` StatementFinished + +testFetchAllRows :: Assertion +testFetchAllRows = do + c <- ConnWrapper <$> newConnection True + let indt = [ [SqlInteger 10, SqlText "hello"] + , [SqlDouble 45.4, SqlNull] + , [SqlText "sdf", SqlText "efef"] + ] + s <- prepare c "insert" + execute s $ indt !! 0 + finish s + s2 <- prepare c "insert" + execute s2 $ indt !! 1 + finish s2 + s3 <- prepare c "insert" + execute s3 $ indt !! 2 + finish s3 + ss <- prepare c "select" + executeRaw ss + outdt <- fetchAllRows ss + outdt `shouldBe` indt + + + +main :: IO () +main = defaultMain [ testCase "Transaction exception handling" test1 + , testCase "Transaction commiting" test2 + , testCase "Child statements" test3 + , testCase "Childs closed when disconnect" test4 + , testCase "Each connection has it's own childs" test5 + , testCase "Fetch all rows preserve order" testFetchAllRows + ] diff --git a/testsrc/sqlvalues.hs b/testsrc/sqlvalues.hs new file mode 100644 --- /dev/null +++ b/testsrc/sqlvalues.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE + ScopedTypeVariables +, FlexibleContexts +, CPP + #-} + +module SqlValues where + +import Control.Applicative +import Database.HDBI (ToSql(..), FromSql(..), BitField(..)) +import Database.HDBI.Parsers +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit hiding (Test) +import Test.QuickCheck (Arbitrary(..)) +import Test.QuickCheck.Assertions +import Test.QuickCheck.Instances () +import Test.QuickCheck.Property + +import qualified Data.Attoparsec.Text.Lazy as P +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Decimal +import Data.Int +import Data.List (intercalate) +import Data.Time +import Data.UUID +import Data.Word + + +#if MIN_VERSION_Decimal(0,3,1) +-- Decimal-0.2.4 has no Arbitrary instance in library any more +instance (Arbitrary i, Integral i) => Arbitrary (DecimalRaw i) where + arbitrary = Decimal <$> arbitrary <*> arbitrary +#endif + +instance Arbitrary UUID where + arbitrary = fromWords + <$> arbitrary + <*> arbitrary + <*> arbitrary + <*> arbitrary + +instance Arbitrary BitField where + arbitrary = BitField <$> arbitrary + +instance Eq ZonedTime where + (ZonedTime a b) == (ZonedTime aa bb) = a == aa && b == bb + +commonChecks :: (Eq a, Show a, ToSql a, FromSql a) => a -> Property +commonChecks x = (partialChecks x) .&&. + (x ==? (fromSql $ toSql (fromSql $ toSql x :: TL.Text))) -- convert to Text and back + +partialChecks :: (Eq a, Show a, ToSql a, FromSql a) => a -> Result +partialChecks x = x ==? (fromSql $ toSql x) + +doubleChecks :: Double -> Property +doubleChecks x = (partialChecks x) .&&. + (x ~==? (fromSql $ toSql (fromSql $ toSql x :: TL.Text))) -- convert to Text and back + + +sqlValueTestGroup :: Test +sqlValueTestGroup = testGroup "can convert to SqlValue and back" + [ testProperty "with string" $ \(s::String) -> commonChecks s + , testProperty "with text" $ \(t::T.Text) -> commonChecks t + , testProperty "with lazy text" $ \(t::TL.Text) -> commonChecks t + , testProperty "with bytestring" $ \(b::B.ByteString) -> partialChecks b -- not any bytestring can be converted to Text + , testProperty "with lazy bytestring" $ \(b::BL.ByteString) -> partialChecks b -- same as above + , testProperty "with int" $ \(i :: Int) -> commonChecks i + , testProperty "with int32" $ \(i :: Int32) -> commonChecks i + , testProperty "with int64" $ \(i :: Int64) -> commonChecks i + , testProperty "with word" $ \(w :: Word) -> commonChecks w + , testProperty "with word32" $ \(w :: Word32) -> commonChecks w + , testProperty "with word64" $ \(w :: Word64) -> commonChecks w + , testProperty "with Integer" $ \(i :: Integer) -> commonChecks i + , testProperty "with Bool" $ \(b :: Bool) -> commonChecks b + , testProperty "with BitField" $ \(bf :: BitField) -> commonChecks bf + , testProperty "with Double" doubleChecks + , testProperty "with Decimal" $ \(d :: Decimal) -> commonChecks d + , testProperty "with Day" $ \(d :: Day) -> commonChecks d + , testProperty "with UUID" $ \(u :: UUID) -> commonChecks u + , testProperty "with TimeOfDay" $ \(tod :: TimeOfDay) -> commonChecks tod + , testProperty "with LocalTime" $ \(lt :: LocalTime) -> commonChecks lt + , testProperty "with UTCTime" $ \(ut :: UTCTime) -> commonChecks ut + , testProperty "with Maybe Int" $ \(mi :: Maybe Int) -> mi == (fromSql $ toSql mi) -- can not represent Null as ByteString + ] + +parserFail :: [String] -> String -> String +parserFail cont msg = "parser failed in context: " + ++ (intercalate ", " cont) + ++ " with message: " + ++ msg + +parsedTo :: (Eq a, Show a) => P.Parser a -> TL.Text -> a -> Assertion +parsedTo pr t res = case P.parse pr t of + P.Fail _ cnt msg -> assertFailure $ parserFail cnt msg + P.Done _ r -> r @?= res + +parseCase :: (Eq a, Show a) => String -> P.Parser a -> a -> Test +parseCase s p val = testCase s $ parsedTo p (TL.pack s) val + +parserTests :: Test +parserTests = testGroup "can parse this dates and times" + [ parseCase "1920-10-10" parseIsoDay $ fromGregorian 1920 10 10 + , parseCase "12:00:23" parseIsoTimeOfDay $ TimeOfDay 12 00 23 + , parseCase "2010 -3-25 22:11:00" parseIsoLocalTime + $ LocalTime (fromGregorian 2010 3 25) + $ TimeOfDay 22 11 0 + , parseCase "2013-07-01T00:00:00" parseIsoZonedTime + $ ZonedTime + (LocalTime (fromGregorian 2013 7 1) + $ TimeOfDay 0 0 0) + utc + , parseCase "2014-4-18 12:12:12+0400" parseIsoZonedTime + $ ZonedTime + (LocalTime (fromGregorian 2014 4 18) + $ TimeOfDay 12 12 12) + $ minutesToTimeZone $ 4 * 60 + , parseCase "2014-4-18 12:12:12+04" parseIsoZonedTime + $ ZonedTime + (LocalTime (fromGregorian 2014 4 18) + $ TimeOfDay 12 12 12) + $ minutesToTimeZone $ 4 * 60 + , parseCase "2014-4-18 12:12:12+04:00" parseIsoZonedTime + $ ZonedTime + (LocalTime (fromGregorian 2014 4 18) + $ TimeOfDay 12 12 12) + $ minutesToTimeZone $ 4 * 60 + , parseCase "2014-4-18 12:12:12+04:00:30" parseIsoZonedTime -- postgre's strange format + $ ZonedTime + (LocalTime (fromGregorian 2014 4 18) + $ TimeOfDay 12 12 42) + $ minutesToTimeZone $ 4 * 60 + , parseCase "2014-4-18 12:12:12.234-4" parseIsoZonedTime + $ ZonedTime + (LocalTime (fromGregorian 2014 4 18) + $ TimeOfDay 12 12 12.234) + $ minutesToTimeZone $ (-4) * 60 + , parseCase "2014-4-18 12:12:12.44-04:30:12" parseIsoZonedTime -- postgre's strange format + $ ZonedTime + (LocalTime (fromGregorian 2014 4 18) + $ TimeOfDay 12 12 0.44) + $ minutesToTimeZone $ (-4) * 60 - 30 + , parseCase "2014-4-18 12:12:12.44-043012" parseIsoZonedTime -- postgre's strange format + $ ZonedTime + (LocalTime (fromGregorian 2014 4 18) + $ TimeOfDay 12 12 0.44) + $ minutesToTimeZone $ (-4) * 60 - 30 + ] + +main :: IO () +main = defaultMain [ sqlValueTestGroup + , parserTests + ]