{-# LANGUAGE ScopedTypeVariables , TemplateHaskell , FlexibleContexts , CPP #-} module SqlValues where import Control.Applicative import Data.Decimal import Data.Int import Data.List (intercalate) import Data.DeriveTH import Data.Time import Data.UUID import Data.Word import Database.HDBI (ToSql(..), FromSql(..), BitField(..), FromRow(..), ToRow(..)) import Database.HDBI.Parsers import Language.Haskell.TH.HDBI 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 data D1 = D1 Int deriving (Show, Eq) data D3 = D3 Int String Double deriving (Show, Eq) data D4 = D4 UUID String UTCTime Decimal deriving (Show, Eq) deriveToRow ''D1 deriveFromRow ''D1 deriveToRow ''D3 deriveFromRow ''D3 deriveToRow ''D4 deriveFromRow ''D4 $(derive makeArbitrary ''D1) $(derive makeArbitrary ''D3) $(derive makeArbitrary ''D4) #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 ] thTests :: Test thTests = testGroup "TH tests" [ testProperty "data D1 = D1 Int" $ \(d :: D1) -> testFromToRow d , testProperty "data D3 = D3 Int String Double" $ \(d :: D3) -> testFromToRow d , testProperty "data D4 = D4 UUID String UTCTime Decimal" $ \(d :: D4) -> testFromToRow d ] testFromToRow :: (FromRow a, ToRow a, Show a, Eq a) => a -> Result testFromToRow a = a ==? (fromRow $ toRow a) 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 , thTests ]