Merge pull request #945 from haskell/pr930

PR 930

Author: phadej

aeson.cabal

@@ -1,5 +1,5 @@
 name:               aeson
-version:            2.0.3.0
+version:            2.1.0.0
 license:            BSD3
 license-file:       LICENSE
 category:           Text, Web, JSON

attoparsec-iso8601/attoparsec-iso8601.cabal

@@ -1,5 +1,5 @@
 name:            attoparsec-iso8601
-version:         1.0.2.1
+version:         1.1.0.0
 synopsis:        Parsing of ISO 8601 dates, originally from aeson
 description:     Parsing of ISO 8601 dates, originally from aeson.
 license:         BSD3

attoparsec-iso8601/changelog.md

@@ -1,5 +1,9 @@
 For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/attoparsec-iso8601/changelog.md](https://github.com/bos/aeson/blob/master/attoparsec-iso8601/changelog.md).
 
+### 1.1.0.0
+
+- Change parsers of types with year (`Day`, `UTCTime`) to require years with at least 4 digits.
+
 ### 1.0.2.1
 
 * Code (re)organization.

attoparsec-iso8601/src/Data/Attoparsec/Time.hs

@@ -19,6 +19,7 @@ module Data.Attoparsec.Time
     , timeZone
     , utcTime
     , zonedTime
+    , year
     , month
     , quarter
     ) where
@@ -27,42 +28,53 @@ import Prelude.Compat
 
 import Control.Applicative ((<|>))
 import Control.Monad (void, when)
-import Data.Attoparsec.Text (Parser, char, decimal, digit, option, anyChar, peekChar, peekChar', takeWhile1, satisfy)
+import Data.Attoparsec.Text (Parser, char, digit, option, anyChar, peekChar, peekChar', takeWhile1, satisfy)
 import Data.Attoparsec.Time.Internal (toPico)
 import Data.Bits ((.&.))
 import Data.Char (isDigit, ord)
 import Data.Fixed (Pico)
 import Data.Int (Int64)
 import Data.Maybe (fromMaybe)
 import Data.Time.Calendar (Day, fromGregorianValid)
+import Data.Time.Calendar.Compat (Year)
 import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..), fromYearQuarter)
 import Data.Time.Calendar.Month.Compat (Month, fromYearMonthValid)
 import Data.Time.Clock (UTCTime(..))
 import qualified Data.Text as T
 import qualified Data.Time.LocalTime as Local
 
 -- | Parse a date of the form @[+,-]YYYY-MM-DD@.
+--
+-- The year must contain at least 4 digits, to avoid the Y2K problem:
+-- a two-digit year @YY@ may mean @YY@, @19YY@, or @20YY@, and we make it
+-- an error to prevent the ambiguity.
+-- Years from @0000@ to @0999@ must thus be zero-padded.
+-- The year may have more than 4 digits.
 day :: Parser Day
 day = do
   absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id
-  y <- (decimal <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD"
+  y <- (year <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD"
   m <- (twoDigits <* char '-') <|> fail "date must be of form [+,-]YYYY-MM-DD"
   d <- twoDigits <|> fail "date must be of form [+,-]YYYY-MM-DD"
   maybe (fail "invalid date") return (fromGregorianValid (absOrNeg y) m d)
 
 -- | Parse a month of the form @[+,-]YYYY-MM@.
+--
+-- See also 'day' for details about the year format.
 month :: Parser Month
 month = do
   absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id
-  y <- (decimal <* char '-') <|> fail "month must be of form [+,-]YYYY-MM"
+  y <- (year <* char '-') <|> fail "month must be of form [+,-]YYYY-MM"
   m <- twoDigits <|> fail "month must be of form [+,-]YYYY-MM"
   maybe (fail "invalid month") return (fromYearMonthValid (absOrNeg y) m)
 
 -- | Parse a quarter of the form @[+,-]YYYY-QN@.
+--
+-- See also 'day' for details about the year format.
 quarter :: Parser Quarter
 quarter = do
   absOrNeg <- negate <$ char '-' <|> id <$ char '+' <|> pure id
-  y <- (decimal <* char '-') <|> fail "month must be of form [+,-]YYYY-MM"
+  y <- (year <* char '-') <|> fail "month must be of form [+,-]YYYY-MM"
   _ <- char 'q' <|> char 'Q'
   q <- parseQ
   return $! fromYearQuarter (absOrNeg y) q
@@ -72,6 +84,19 @@ quarter = do
       <|> Q3 <$ char '3'
       <|> Q4 <$ char '4'
 
+-- | Parse a year @YYYY@, with at least 4 digits. Does not include any sign.
+--
+-- Note: 'Year' is a type synonym for 'Integer'.
+--
+-- @since 1.1.0.0
+year :: Parser Year
+year = do
+  ds <- takeWhile1 isDigit
+  if T.length ds < 4 then
+    fail "expected year with at least 4 digits"
+  else
+    pure (txtToInteger ds)
+
 -- | Parse a two-digit integer (e.g. day of month, hour).
 twoDigits :: Parser Int
 twoDigits = do
@@ -172,3 +197,53 @@ zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)
 
 utc :: Local.TimeZone
 utc = Local.TimeZone 0 False ""
+
+------------------ Copy-pasted and adapted from base ------------------------
+
+txtToInteger :: T.Text -> Integer
+txtToInteger bs
+    | l > 40    = valInteger 10 l [ fromIntegral (ord w - 48) | w <- T.unpack bs ]
+    | otherwise = txtToIntegerSimple bs
+  where
+    l = T.length bs
+
+txtToIntegerSimple :: T.Text -> Integer
+txtToIntegerSimple = T.foldl' step 0 where
+  step a b = a * 10 + fromIntegral (ord b - 48) -- 48 = '0'
+
+-- A sub-quadratic algorithm for Integer. Pairs of adjacent radix b
+-- digits are combined into a single radix b^2 digit. This process is
+-- repeated until we are left with a single digit. This algorithm
+-- performs well only on large inputs, so we use the simple algorithm
+-- for smaller inputs.
+valInteger :: Integer -> Int -> [Integer] -> Integer
+valInteger = go
+  where
+    go :: Integer -> Int -> [Integer] -> Integer
+    go _ _ []  = 0
+    go _ _ [d] = d
+    go b l ds
+        | l > 40 = b' `seq` go b' l' (combine b ds')
+        | otherwise = valSimple b ds
+      where
+        -- ensure that we have an even number of digits
+        -- before we call combine:
+        ds' = if even l then ds else 0 : ds
+        b' = b * b
+        l' = (l + 1) `quot` 2
+
+    combine b (d1 : d2 : ds) = d `seq` (d : combine b ds)
+      where
+        d = d1 * b + d2
+    combine _ []  = []
+    combine _ [_] = errorWithoutStackTrace "this should not happen"
+
+-- The following algorithm is only linear for types whose Num operations
+-- are in constant time.
+valSimple :: Integer -> [Integer] -> Integer
+valSimple base = go 0
+  where
+    go r [] = r
+    go r (d : ds) = r' `seq` go r' ds
+      where
+        r' = r * base + fromIntegral d

changelog.md

@@ -1,5 +1,9 @@
 For the latest version of this document, please see [https://github.com/haskell/aeson/blob/master/changelog.md](https://github.com/haskell/aeson/blob/master/changelog.md).
 
+### 2.1.0.0
+
+- Change time instances of types with year (`Day`, `UTCTime`) to require years with at least 4 digits.
+
 ### 2.0.3.0
 
 * `text-2.0` support

src/Data/Aeson.hs

@@ -34,6 +34,12 @@ module Data.Aeson
 
     -- ** Direct encoding
     -- $encoding
+
+    -- * Remarks on specific encodings
+    -- ** Time
+    -- $time
+
+    -- * Main encoding and decoding functions
       decode
     , decode'
     , eitherDecode
@@ -528,3 +534,36 @@ eitherDecodeFileStrict' =
 -- > > import Data.Sequence as Seq
 -- > > encode (Seq.fromList [1,2,3])
 -- > "[1,2,3]"
+
+-- $time
+--
+-- This module contains instances of 'ToJSON' and 'FromJSON' for types from
+-- the <https://hackage.haskell.org/package/time time> library.
+--
+-- Those instances encode time as JSON strings in
+-- <https://en.wikipedia.org/wiki/ISO_8601 ISO 8601> formats, with the
+-- following general form for 'Data.Time.Clock.UTCTime' and
+-- 'Data.Time.LocalTime.ZonedTime', while other time types use subsets of those
+-- fields:
+--
+-- > [+,-]YYYY-MM-DDThh:mm[:ss[.sss]]Z
+--
+-- where
+--
+-- - @[+,-]@ is an optional sign, @+@ or @-@.
+-- - @YYYY@ is the year, which must have at least 4 digits to prevent Y2K problems.
+--   Years from @0000@ to @0999@ must thus be zero-padded.
+-- - @MM@ is a two-digit month.
+-- - @DD@ is a two-digit day.
+-- - @T@ is a literal @\'T\'@ character separating the date and the time of
+--   day. It may be a space instead.
+-- - @hh@ is a two-digit hour.
+-- - @mm@ is a two-digit minute.
+-- - @ss@ is a two-digit second.
+-- - @sss@ is a decimal fraction of a second; it may have any nonzero number of digits.
+-- - @Z@ is a time zone; it may be preceded by an optional space.
+--
+-- For more information, see <https://en.wikipedia.org/wiki/ISO_8601 ISO 8601>
+-- <https://hackage.haskell.org/package/time time>,
+-- and <https://hackage.haskell.org/package/attoparsec-iso8601 attoparsec-iso8601>
+-- (where the relevant parsers are defined).

tests/SerializationFormatSpec.hs

@@ -31,8 +31,8 @@ import Data.Scientific (Scientific)
 import Data.Tagged (Tagged(..))
 import Data.Text (Text)
 import Data.These (These (..))
-import Data.Time (fromGregorian)
-import Data.Time.Calendar.Month.Compat (fromYearMonth)
+import Data.Time (Day, fromGregorian)
+import Data.Time.Calendar.Month.Compat (Month, fromYearMonth)
 import Data.Time.Calendar.Quarter.Compat (fromYearQuarter, QuarterOfYear (..))
 import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))
 import Data.Time.LocalTime.Compat (CalendarDiffTime (..))
@@ -159,12 +159,14 @@ jsonExamples =
   , example "Maybe String" "\"foo\""          (pure "foo" :: Maybe String)
   , example "Maybe [Identity Char]" "\"xy\""  (pure [pure 'x', pure 'y'] :: Maybe [Identity Char])
 
+  , example "Day; year >= 10000" "\"10000-01-01\""      (fromGregorian 10000   1  1)
   , example "Day; year >= 1000" "\"1999-10-12\""        (fromGregorian 1999    10 12)
   , example "Day; year > 0 && < 1000" "\"0500-03-04\""  (fromGregorian 500     3  4)
   , example "Day; year == 0" "\"0000-02-20\""           (fromGregorian 0       2  20)
   , example "Day; year < 0" "\"-0234-01-01\""           (fromGregorian (-234)  1  1)
   , example "Day; year < -1000" "\"-1234-01-01\""       (fromGregorian (-1234) 1  1)
 
+  , example "Month; year >= 10000" "\"10000-01\""      (fromYearMonth 10000   1)
   , example "Month; year >= 1000" "\"1999-10\""        (fromYearMonth 1999    10)
   , example "Month; year > 0 && < 1000" "\"0500-03\""  (fromYearMonth 500     3)
   , example "Month; year == 0" "\"0000-02\""           (fromYearMonth 0       2)
@@ -297,6 +299,8 @@ jsonDecodingExamples = [
   , MaybeExample "Word8 300"  "300"  (Nothing :: Maybe Word8)
   -- Negative zero year, encoding never produces such:
   , MaybeExample "Day -0000-02-03" "\"-0000-02-03\"" (Just (fromGregorian 0 2 3))
+  , MaybeExample "Day; year too short" "\"10-10-10\"" (Nothing :: Maybe Day)
+  , MaybeExample "Month; year too short" "\"10-10\"" (Nothing :: Maybe Month)
   ]
 
 data Example where