diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Changelog +#### 2.4.0.4 + +* Zero-prefix years when parsing dates. + #### 2.4.0.3 * Compatibility with GHC 8.8/time 1.9 diff --git a/Database/HDBC/Locale.hs b/Database/HDBC/Locale.hs --- a/Database/HDBC/Locale.hs +++ b/Database/HDBC/Locale.hs @@ -2,7 +2,8 @@ module Database.HDBC.Locale ( defaultTimeLocale, - iso8601DateFormat + iso8601DateFormat, + oldIso8601DateFormat ) where @@ -18,6 +19,16 @@ -- (compatible) version of it. iso8601DateFormat :: Maybe String -> String iso8601DateFormat mTimeFmt = + "%0Y-%m-%d" ++ case mTimeFmt of + Nothing -> "" + Just fmt -> ' ' : fmt + +-- | HDBC would in versions up to and including 2.4.0.3 use this time format +-- string to serialize timestamps. To keep being able to deserialize timestamps +-- serialized on database engines that keep the representation intact (e.g. +-- SQLite) we keep this format string around, such that we can fall back to it. +oldIso8601DateFormat :: Maybe String -> String +oldIso8601DateFormat mTimeFmt = "%Y-%m-%d" ++ case mTimeFmt of Nothing -> "" Just fmt -> ' ' : fmt diff --git a/Database/HDBC/SqlValue.hs b/Database/HDBC/SqlValue.hs --- a/Database/HDBC/SqlValue.hs +++ b/Database/HDBC/SqlValue.hs @@ -9,6 +9,7 @@ ) where +import Control.Applicative ((<|>)) import Data.Dynamic import qualified Data.ByteString.UTF8 as BUTF8 import qualified Data.ByteString as B @@ -28,7 +29,7 @@ #endif ) import Data.Time.Clock.POSIX -import Database.HDBC.Locale (defaultTimeLocale, iso8601DateFormat) +import Database.HDBC.Locale (defaultTimeLocale, iso8601DateFormat, oldIso8601DateFormat) import Data.Ratio import Data.Convertible import Data.Fixed @@ -609,7 +610,7 @@ instance Convertible Day SqlValue where safeConvert = return . SqlLocalDate instance Convertible SqlValue Day where - safeConvert (SqlString x) = parseTime' (iso8601DateFormat Nothing) x + safeConvert (SqlString x) = parseTimeISO8601 Nothing x safeConvert (SqlByteString x) = safeConvert (SqlString (BUTF8.toString x)) safeConvert (SqlInt32 x) = return $ ModifiedJulianDay {toModifiedJulianDay = fromIntegral x} @@ -704,7 +705,7 @@ instance Convertible LocalTime SqlValue where safeConvert = return . SqlLocalTime instance Convertible SqlValue LocalTime where - safeConvert (SqlString x) = parseTime' (iso8601DateFormat (Just "%T%Q")) x + safeConvert (SqlString x) = parseTimeISO8601 (Just "%T%Q") x safeConvert (SqlByteString x) = safeConvert (SqlString (BUTF8.toString x)) safeConvert y@(SqlInt32 _) = quickError y safeConvert y@(SqlInt64 _) = quickError y @@ -730,7 +731,7 @@ instance Convertible ZonedTime SqlValue where safeConvert = return . SqlZonedTime instance Convertible SqlValue ZonedTime where - safeConvert (SqlString x) = parseTime' (iso8601DateFormat (Just "%T%Q %z")) x + safeConvert (SqlString x) = parseTimeISO8601 (Just "%T%Q %z") x safeConvert (SqlByteString x) = safeConvert (SqlString (BUTF8.toString x)) safeConvert (SqlInt32 x) = safeConvert (SqlInteger (fromIntegral x)) safeConvert (SqlInt64 x) = safeConvert (SqlInteger (fromIntegral x)) @@ -756,7 +757,7 @@ instance Convertible UTCTime SqlValue where safeConvert = return . SqlUTCTime instance Convertible SqlValue UTCTime where - safeConvert (SqlString x) = parseTime' (iso8601DateFormat (Just "%T%Q")) x + safeConvert (SqlString x) = parseTimeISO8601 (Just "%T%Q") x safeConvert (SqlByteString x) = safeConvert (SqlString (BUTF8.toString x)) safeConvert y@(SqlInt32 _) = safeConvert y >>= return . posixSecondsToUTCTime safeConvert y@(SqlInt64 _) = safeConvert y >>= return . posixSecondsToUTCTime @@ -956,4 +957,17 @@ Nothing -> convError ("Cannot parse using default format string " ++ show fmtstr) (SqlString inpstr) Just x -> Right x +#endif + +parseTimeISO8601 :: (Typeable t, Convertible SqlValue t, ParseTime t) => Maybe String -> String -> ConvertResult t +parseTimeISO8601 fmtstr inpstr = + case tryParse iso8601DateFormat <|> tryParse oldIso8601DateFormat of + Nothing -> convError "Cannot parse ISO8601 timestamp" (SqlString inpstr) + Just x -> Right x + where + tryParse fmtFunction = +#if MIN_TIME_15 + parseTimeM True defaultTimeLocale (fmtFunction fmtstr) inpstr +#else + parseTime defaultTimeLocale (fmtFunction fmtstr) inpstr #endif diff --git a/HDBC.cabal b/HDBC.cabal --- a/HDBC.cabal +++ b/HDBC.cabal @@ -1,5 +1,5 @@ Name: HDBC -Version: 2.4.0.3 +Version: 2.4.0.4 License: BSD3 Maintainer: Nicolas Wu Author: John Goerzen, Nicolas Wu @@ -16,7 +16,7 @@ Stability: Stable Build-Type: Simple -Cabal-Version: >=1.8 +Cabal-Version: >=1.10 source-repository head type: git @@ -35,10 +35,10 @@ if flag(splitBase) Build-Depends: base>=3 && <5, old-time, bytestring, containers if flag(minTime15) - Build-Depends: time >= 1.5 && < 1.10 + Build-Depends: time >= 1.5 && < 1.14 CPP-Options: -DMIN_TIME_15 else - Build-Depends: time < 1.5, old-locale + Build-Depends: time >= 1.2 && < 1.5, old-locale else Build-Depends: base<3 Build-Depends: mtl, convertible >= 1.1.0.0, text, utf8-string @@ -54,21 +54,23 @@ Database.HDBC.ColTypes, Database.HDBC.Statement, Database.HDBC.SqlValue, Database.HDBC.Locale Other-Modules: Database.HDBC.Utils - Extensions: ExistentialQuantification, CPP, MultiParamTypeClasses, + Default-Extensions: ExistentialQuantification, CPP, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, TypeOperators, RankNTypes, FlexibleInstances, DeriveDataTypeable + Default-Language: Haskell2010 Executable runtests if flag(buildtests) Buildable: True - Build-Depends: HUnit, QuickCheck (>= 2.0), testpack (>= 2.0) + Build-Depends: HUnit, QuickCheck >= 2.0 if flag(splitBase) Build-Depends: base>=3 && <5, old-time, bytestring, containers if flag(minTime15) - Build-Depends: time >= 1.5 && < 1.9 + Build-Depends: time >= 1.5 && < 1.14 + CPP-Options: -DMIN_TIME_15 else - Build-Depends: time < 1.5, old-locale + Build-Depends: time >= 1.2 && < 1.5, old-locale else Build-Depends: base<3 Build-Depends: mtl, convertible >= 1.1.0.0, utf8-string, text @@ -81,9 +83,9 @@ Buildable: False Main-Is: runtests.hs Other-Modules: TestSqlValue - TestInfrastructure Hs-Source-Dirs: ., testsrc GHC-Options: -O2 - Extensions: ExistentialQuantification, CPP, MultiParamTypeClasses, + Default-Extensions: ExistentialQuantification, CPP, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, TypeOperators, RankNTypes, FlexibleInstances + Default-Language: Haskell2010 diff --git a/testsrc/TestInfrastructure.hs b/testsrc/TestInfrastructure.hs deleted file mode 100644 --- a/testsrc/TestInfrastructure.hs +++ /dev/null @@ -1,17 +0,0 @@ -{- -Copyright (C) 2009 John Goerzen - -All rights reserved. - -For license and copyright information, see the file COPYRIGHT --} -module TestInfrastructure where -import qualified Test.QuickCheck as QC -import qualified Test.HUnit as HU -import Test.HUnit.Tools - -q :: QC.Testable a => String -> a -> HU.Test -q = qc2hu 250 - -qverbose :: QC.Testable a => String -> a -> HU.Test -qverbose = qc2hu 250 diff --git a/testsrc/TestSqlValue.hs b/testsrc/TestSqlValue.hs --- a/testsrc/TestSqlValue.hs +++ b/testsrc/TestSqlValue.hs @@ -7,27 +7,25 @@ -} module TestSqlValue where -import TestInfrastructure import Test.QuickCheck hiding (Result) import Test.QuickCheck.Property (Result) -import Test.QuickCheck.Tools import qualified Test.HUnit as HU import Database.HDBC -import Data.Time.Format +import Data.Time.Format (parseTime) import Data.Time.LocalTime -import Database.HDBC.Locale (defaultTimeLocale, iso8601DateFormat) +import Database.HDBC.Locale (defaultTimeLocale, iso8601DateFormat, oldIso8601DateFormat) import Data.Maybe instance Eq ZonedTime where a == b = zonedTimeToUTC a == zonedTimeToUTC b && zonedTimeZone a == zonedTimeZone b -toSql_Int :: Int -> Result -toSql_Int x = toSql x @?= SqlInt64 (fromIntegral x) +toSql_Int :: Int -> Property +toSql_Int x = toSql x === SqlInt64 (fromIntegral x) -fromSql_Int :: Int -> Result +fromSql_Int :: Int -> Property fromSql_Int x = - Right x @=? safeFromSql (SqlInt64 (fromIntegral x)) + Right x === safeFromSql (SqlInt64 (fromIntegral x)) testZonedTimeStr = "1989-08-01 15:33:01 -0500" testZonedTime :: ZonedTime @@ -39,14 +37,25 @@ testZonedTimeFrac = fromJust $ parseTime defaultTimeLocale (iso8601DateFormat (Just "%T%Q %z")) testZonedTimeFracStr +testZonedTimeTwoDigitYearStr = "89-08-01 15:33:01 -0500" +testZonedTimeTwoDigitYear :: ZonedTime +testZonedTimeTwoDigitYear = fromJust $ parseTime defaultTimeLocale (oldIso8601DateFormat (Just "%T %z")) + testZonedTimeTwoDigitYearStr + ztparsenf = (HU.@=?) testZonedTime (fromSql (SqlString testZonedTimeStr)) ztparsef = (HU.@=?) testZonedTimeFrac (fromSql (SqlString testZonedTimeFracStr)) +ztparseTwoDigitYear = + (HU.@=?) testZonedTimeTwoDigitYear (fromSql (SqlString testZonedTimeTwoDigitYearStr)) hut msg = HU.TestLabel msg . HU.TestCase -allt = [q "toSql Int" toSql_Int, - q "safeFromSql Int" fromSql_Int, - hut "non-frac parse" ztparsenf, - hut "frac parse" ztparsef] +allHUnitTests = [hut "non-frac parse" ztparsenf, + hut "frac parse" ztparsef, + hut "old serialization of two digit year without leading zeros" ztparseTwoDigitYear + ] + +allQuickCheckTests = [toSql_Int, + fromSql_Int + ] diff --git a/testsrc/runtests.hs b/testsrc/runtests.hs --- a/testsrc/runtests.hs +++ b/testsrc/runtests.hs @@ -1,14 +1,9 @@ module Main where import qualified Test.HUnit as HU -import Test.HUnit.Tools +import Test.QuickCheck (quickCheck) import qualified TestSqlValue -test1 = HU.TestCase ((HU.@=?) "x" "x") - -alltests = [HU.TestLabel "test1" test1, - tl "TestSqlValue" TestSqlValue.allt - ] - -main = do runVerboseTests (HU.TestList alltests) +main = do HU.runTestTT (HU.TestList $ TestSqlValue.allHUnitTests) + traverse quickCheck TestSqlValue.allQuickCheckTests return ()