hdbi-1.3.0: Database/HDBI/SqlValue.hs
{-# 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(..)
, ToRow(..)
, FromRow(..)
, ConvertError(..)
, BitField(..)
-- * SQL value marshalling
, SqlValue(..)
-- * Auxiliary convertion functions
, one , onei , oned
, onet , onetl , oneb , onebl
, safeUnOne
, unone , unonei , unoned
, unonet , unonetl
, unoneb , unonebl
)
where
import Control.Applicative ((<$>), (<*>))
import Control.Exception
import Data.Attoparsec.Text.Lazy
import Data.Bits (Bits)
import Data.Data (Data)
import Data.Decimal
import Data.Int
import Data.Ix (Ix)
import Data.List (intercalate)
import Data.Time
import Data.Typeable
import Data.UUID (UUID, fromString, toString)
import Data.Word
import Database.HDBI.Formaters
import Database.HDBI.Parsers
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
{-# INLINEABLE fromSql #-}
class ToRow a where
toRow :: a -> [SqlValue]
class FromRow a where
safeFromRow :: [SqlValue] -> Either ConvertError a
fromRow :: [SqlValue] -> a
fromRow sqls = case safeFromRow sqls of
Left e -> throw e
Right a -> a
{-# INLINEABLE fromRow #-}
wrongSqlList :: [SqlValue] -- ^ given list of SqlValues
-> Int -- ^ expected length of list
-> Either ConvertError a
wrongSqlList x c = Left $ ConvertError
$ "Wrong count of SqlValues: " ++ (show $ length x)
++ " but expected: " ++ (show c)
-- | instance for conveniently pass empty list of parameters
instance ToRow () where
toRow _ = []
{-# INLINEABLE toRow #-}
-- | instance for convenient ignoring all the parameters
instance FromRow () where
fromRow _ = ()
{-# INLINEABLE fromRow #-}
safeFromRow _ = Right ()
{-# INLINEABLE safeFromRow #-}
-- instance (ToSql a) => ToRow [a] where
-- toRow a = map toSql a
-- {-# INLINEABLE toRow #-}
-- instance (FromSql a) => FromRow [a] where
-- safeFromRow a = mapM safeFromSql a
-- {-# INLINEABLE safeFromRow #-}
instance (ToSql a, ToSql b) => ToRow (a, b) where
toRow (a, b) = [toSql a, toSql b]
{-# INLINEABLE toRow #-}
instance (FromSql a, FromSql b) => FromRow (a, b) where
safeFromRow [a, b] = (,) <$> safeFromSql a <*> safeFromSql b
safeFromRow x = wrongSqlList x 2
{-# INLINEABLE safeFromRow #-}
instance (ToSql a, ToSql b, ToSql c) => ToRow (a, b, c) where
toRow (a, b, c) = [toSql a, toSql b, toSql c]
{-# INLINEABLE toRow #-}
instance (FromSql a, FromSql b, FromSql c) => FromRow (a, b, c) where
safeFromRow [a, b, c] = (,,) <$> safeFromSql a <*> safeFromSql b <*> safeFromSql c
safeFromRow x = wrongSqlList x 3
{-# INLINEABLE safeFromRow #-}
instance (ToSql a, ToSql b, ToSql c, ToSql d) => ToRow (a, b, c, d) where
toRow (a, b, c, d) = [toSql a, toSql b, toSql c, toSql d]
{-# INLINEABLE toRow #-}
instance (FromSql a, FromSql b, FromSql c, FromSql d) => FromRow (a, b, c, d) where
safeFromRow [a, b, c, d] = (,,,) <$> safeFromSql a <*> safeFromSql b <*> safeFromSql c <*> safeFromSql d
safeFromRow x = wrongSqlList x 4
{-# INLINEABLE safeFromRow #-}
instance (ToSql a, ToSql b, ToSql c, ToSql d, ToSql e) => ToRow (a, b, c, d, e) where
toRow (a, b, c, d, e) = [toSql a, toSql b, toSql c, toSql d, toSql e]
{-# INLINEABLE toRow #-}
instance (FromSql a, FromSql b, FromSql c, FromSql d, FromSql e) => FromRow (a, b, c, d, e) where
safeFromRow [a, b, c, d, e] = (,,,,)
<$> safeFromSql a
<*> safeFromSql b
<*> safeFromSql c
<*> safeFromSql d
<*> safeFromSql e
safeFromRow x = wrongSqlList x 5
{-# INLINEABLE safeFromRow #-}
instance (ToSql a, ToSql b, ToSql c, ToSql d, ToSql e, ToSql f) => ToRow (a, b, c, d, e, f) where
toRow (a, b, c, d, e, f) = [toSql a, toSql b, toSql c, toSql d, toSql e, toSql f]
{-# INLINEABLE toRow #-}
instance (FromSql a, FromSql b, FromSql c, FromSql d, FromSql e, FromSql f) => FromRow (a, b, c, d, e, f) where
safeFromRow [a, b, c, d, e, f] = (,,,,,)
<$> safeFromSql a
<*> safeFromSql b
<*> safeFromSql c
<*> safeFromSql d
<*> safeFromSql e
<*> safeFromSql f
safeFromRow x = wrongSqlList x 6
{-# INLINEABLE safeFromRow #-}
instance (ToSql a, ToSql b, ToSql c, ToSql d, ToSql e, ToSql f, ToSql g) => ToRow (a, b, c, d, e, f, g) where
toRow (a, b, c, d, e, f, g) = [toSql a, toSql b, toSql c, toSql d, toSql e, toSql f, toSql g]
{-# INLINEABLE toRow #-}
instance (FromSql a, FromSql b, FromSql c, FromSql d, FromSql e, FromSql f, FromSql g) => FromRow (a, b, c, d, e, f, g) where
safeFromRow [a, b, c, d, e, f, g] = (,,,,,,)
<$> safeFromSql a
<*> safeFromSql b
<*> safeFromSql c
<*> safeFromSql d
<*> safeFromSql e
<*> safeFromSql f
<*> safeFromSql g
safeFromRow x = wrongSqlList x 7
{-# INLINEABLE safeFromRow #-}
-- | 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
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql Int where
toSql i = SqlInteger $ toInteger i
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql Int32 where
toSql i = SqlInteger $ toInteger i
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql Int64 where
toSql i = SqlInteger $ toInteger i
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql Integer where
toSql = SqlInteger
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql Word32 where
toSql i = SqlInteger $ toInteger i
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql Word64 where
toSql i = SqlInteger $ toInteger i
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql Word where
toSql i = SqlInteger $ toInteger i
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql Double where
toSql = SqlDouble
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql [Char] where
toSql s = SqlText $ TL.pack s
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql TL.Text where
toSql = SqlText
{-# INLINEABLE toSql #-}
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
{-# INLINEABLE safeFromSql #-}
instance ToSql T.Text where
toSql t = SqlText $ TL.fromChunks [t]
{-# INLINEABLE toSql #-}
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
{-# INLINEABLE safeFromSql #-}
instance ToSql B.ByteString where
toSql = SqlBlob
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql BL.ByteString where
toSql b = SqlBlob $ BB.toByteString $ BB.fromLazyByteString b
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql Bool where
toSql = SqlBool
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql BitField where
toSql = SqlBitField
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql UUID where
toSql = SqlUUID
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql UTCTime where
toSql = SqlUTCTime
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql Day where
toSql = SqlLocalDate
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql TimeOfDay where
toSql = SqlLocalTimeOfDay
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance ToSql LocalTime where
toSql = SqlLocalTime
{-# INLINEABLE toSql #-}
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)
{-# INLINEABLE safeFromSql #-}
instance (ToSql a) => ToSql (Maybe a) where
toSql m = case m of
Nothing -> SqlNull
Just a -> toSql a
{-# INLINEABLE toSql #-}
instance (FromSql a) => FromSql (Maybe a) where
safeFromSql SqlNull = Right Nothing
safeFromSql x = Just <$> safeFromSql x
{-# INLINEABLE safeFromSql #-}
-- | This instance must not be considered as (Maybe row) but as row with exactly
-- one nullable value
instance (ToSql a) => ToRow (Maybe a) where
toRow a = [toSql a]
{-# INLINEABLE toRow #-}
-- | This instance must not be considered as (Maybe row) but as row with exactly
-- one nullable value
instance (FromSql a) => FromRow (Maybe a) where
safeFromRow [a] = safeFromSql a
safeFromRow x = Left $ ConvertError $ "length of row must be 1, not" ++ (show $ length x)
{-# INLINEABLE safeFromRow #-}
instance (ToSql a, ToSql b) => ToSql (Either a b) where
toSql (Left a) = toSql a
toSql (Right b) = toSql b
{-# INLINEABLE toSql #-}
-- | Tries to convert to Left type first, if it fails try convert to Right type
instance (FromSql a, FromSql b) => FromSql (Either a b) where
safeFromSql x = case safeFromSql x of
Right a -> Right $ Left a
Left _ -> case safeFromSql x of
Right b -> Right $ Right b
Left e -> Left e
{-# INLINEABLE safeFromSql #-}
instance (ToSql a, ToSql b) => ToRow (Either a b) where
toRow a = [toSql a]
{-# INLINEABLE toRow #-}
instance (FromSql a, FromSql b) => FromRow (Either a b) where
safeFromRow [a] = safeFromSql a
safeFromRow x = Left $ ConvertError $ "length of row must be 1, not" ++ (show $ length x)
{-# INLINEABLE safeFromRow #-}
instance ToSql SqlValue where
toSql = id
{-# INLINEABLE toSql #-}
instance FromSql SqlValue where
safeFromSql x = Right x
{-# INLINEABLE safeFromSql #-}
fromSql = id
{-# INLINEABLE fromSql #-}
instance ToRow SqlValue where
toRow a = [a]
{-# INLINEABLE toRow #-}
instance FromRow SqlValue where
safeFromRow [a] = Right a
safeFromRow x = Left $ ConvertError $ "length of row must be 1, not" ++ (show $ length x)
{-# INLINEABLE safeFromRow #-}
instance ToRow [SqlValue] where
toRow a = a
{-# INLINEABLE toRow #-}
instance FromRow [SqlValue] where
fromRow a = a
{-# INLINEABLE fromRow #-}
safeFromRow a = Right a
{-# INLINEABLE safeFromRow #-}
-- | creates row of one element
one :: (ToSql a) => a -> [SqlValue]
one a = [toSql a]
{-# INLINEABLE one #-}
-- | create row of one Integer element
onei :: Integer -> [SqlValue]
onei = one
{-# INLINEABLE onei #-}
-- | create row of one Double element
oned :: Double -> [SqlValue]
oned = one
{-# INLINEABLE oned #-}
onet :: T.Text -> [SqlValue]
onet = one
{-# INLINEABLE onet #-}
onetl :: TL.Text -> [SqlValue]
onetl = one
{-# INLINEABLE onetl #-}
oneb :: B.ByteString -> [SqlValue]
oneb = one
{-# INLINEABLE oneb #-}
onebl :: BL.ByteString -> [SqlValue]
onebl = one
{-# INLINEABLE onebl #-}
-- | unwrap the row of one element safely
safeUnOne :: (FromSql a) => [SqlValue] -> Either ConvertError a
safeUnOne [a] = safeFromSql a
safeUnOne x = Left $ ConvertError
$ "safeUnOne: row must contain exactly ONE element, not " ++ (show $ length x)
{-# INLINEABLE safeUnOne #-}
-- | same as `safeUnOne` but throws an exception if not converted
unone :: (FromSql a) => [SqlValue] -> a
unone x = case safeUnOne x of
Left e -> throw e
Right a -> a
{-# INLINEABLE unone #-}
-- | unwrap row of one Integer
unonei :: [SqlValue] -> Integer
unonei = unone
{-# INLINEABLE unonei #-}
unoned :: [SqlValue] -> Double
unoned = unone
{-# INLINEABLE unoned #-}
unonet :: [SqlValue] -> T.Text
unonet = unone
{-# INLINEABLE unonet #-}
unonetl :: [SqlValue] -> TL.Text
unonetl = unone
{-# INLINEABLE unonetl #-}
unoneb :: [SqlValue] -> B.ByteString
unoneb = unone
{-# INLINEABLE unoneb #-}
unonebl :: [SqlValue] -> BL.ByteString
unonebl = unone
{-# INLINEABLE unonebl #-}