hdbi (empty) → 1.0.0
raw patch · 12 files changed
+2151/−0 lines, 12 filesdep +Decimaldep +HUnitdep +QuickChecksetup-changed
Dependencies added: Decimal, HUnit, QuickCheck, attoparsec, base, blaze-builder, bytestring, deepseq, hspec-expectations, old-locale, quickcheck-assertions, quickcheck-instances, test-framework, test-framework-hunit, test-framework-quickcheck2, text, time, uuid
Files
- Database/HDBI.hs +258/−0
- Database/HDBI/DriverUtils.hs +80/−0
- Database/HDBI/Formaters.hs +45/−0
- Database/HDBI/Parsers.hs +189/−0
- Database/HDBI/SqlValue.hs +703/−0
- Database/HDBI/Types.hs +329/−0
- LICENSE +27/−0
- README.md +16/−0
- Setup.hs +2/−0
- hdbi.cabal +99/−0
- testsrc/dummydriver.hs +246/−0
- testsrc/sqlvalues.hs +157/−0
+ Database/HDBI.hs view
@@ -0,0 +1,258 @@+{- |+ Module : Database.HDBI+ Copyright : Copyright (C) 2005-2011 John Goerzen+ License : BSD3++ Maintainer : Aleksey Uymanov <s9gf4ult@gmail.com>+ 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+-- <s9gf4ult@gmail.com>++-- * 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
+ Database/HDBI/DriverUtils.hs view
@@ -0,0 +1,80 @@+{- |+ Module : Database.HDBI.DriverUtils+ Copyright : Copyright (C) 2006 John Goerzen+ License : BSD3++ Maintainer : Aleksey Uymanov <s9gf4ult@gmail.com>+ 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
+ Database/HDBI/Formaters.hs view
@@ -0,0 +1,45 @@+{- |+ Module : Database.HDBI.Formaters+ Copyright : Copyright (C) 2006 John Goerzen+ License : BSD3++ Maintainer : Aleksey Uymanov <s9gf4ult@gmail.com>+ 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"
+ Database/HDBI/Parsers.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE+ OverloadedStrings+ #-}++{- |+ Module : Database.HDBI.Parsers+ Copyright : Copyright (C) 2006 John Goerzen+ License : BSD3++ Maintainer : Aleksey Uymanov <s9gf4ult@gmail.com>+ 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
+ Database/HDBI/SqlValue.hs view
@@ -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 <s9gf4ult@gmail.com>+ 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
+ Database/HDBI/Types.hs view
@@ -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 <s9gf4ult@gmail.com>+ 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
+ LICENSE view
@@ -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.
+ README.md view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hdbi.cabal view
@@ -0,0 +1,99 @@+Name: hdbi+Version: 1.0.0+License: BSD3+Maintainer: Aleksey Uymanov <s9gf4ult@gmail.com>+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
+ testsrc/dummydriver.hs view
@@ -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+ ]
+ testsrc/sqlvalues.hs view
@@ -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+ ]