@@ -1,6 +1,7 @@
1−{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,
2− GeneralizedNewtypeDeriving, IncoherentInstances, OverlappingInstances,
3− OverloadedStrings, UndecidableInstances, ViewPatterns #-}
1+{-# LANGUAGE CPP, BangPatterns, DeriveDataTypeable, FlexibleContexts,
2+ FlexibleInstances, GeneralizedNewtypeDeriving, IncoherentInstances,
3+ OverlappingInstances, OverloadedStrings, UndecidableInstances,
4+ ViewPatterns #-}
45{-# LANGUAGE DefaultSignatures #-}
56{-# OPTIONS_GHC -fno-warn-orphans #-}
67
@@ -55,9 +56,11 @@ module Data.Aeson.Types.Instances
5556 ) where
5657
5758import Control.Applicative ((<$>), (<*>), (<|>), pure, empty)
59+import Control.Monad (when)
5860import qualified Data.Aeson.Encode.Builder as E
5961import qualified Data.ByteString.Builder as B
6062import Data.Aeson.Functions
63+import Data.Bits ((.&.))
6164import Data.Monoid ((<>), mempty)
6265import Data.Aeson.Encode.Functions (brackets, builder, foldable, list)
6366import qualified Data.Aeson.Parser.Time as Time
@@ -66,6 +69,8 @@ import Data.Aeson.Types.Internal
6669import Data.Scientific (Scientific)
6770import qualified Data.Scientific as Scientific (coefficient, base10Exponent, fromFloatDigits, toRealFloat)
6871import Data.Attoparsec.Number (Number(..))
72+import qualified Data.Attoparsec.Text as A
73+import Data.Char (isDigit, ord)
6974import Data.Fixed
7075import Data.Foldable (Foldable, toList)
7176import Data.Functor.Identity (Identity(..))
@@ -75,8 +80,10 @@ import Data.Maybe (fromMaybe)
7580import Data.Monoid (Dual(..), First(..), Last(..))
7681import Data.Ratio (Ratio, (%), numerator, denominator)
7782import Data.Text (Text, pack, unpack)
78−import Data.Time (UTCTime, ZonedTime(..), TimeZone(..))
83+import Data.Time (UTCTime(..), ZonedTime(..), TimeZone(..), Day, utc)
84+import Data.Time.Calendar (fromGregorianValid, addDays)
7985import Data.Time.Format (FormatTime, formatTime, parseTime)
86+import Data.Time.LocalTime (TimeOfDay, makeTimeOfDayValid, minutesToTimeZone, timeOfDayToTime, localToUTCTimeOfDay)
8087import Data.Traversable as Tr (sequence, traverse)
8188import Data.Vector (Vector)
8289import Data.Word (Word, Word8, Word16, Word32, Word64)
@@ -740,11 +747,87 @@ utcTime :: UTCTime -> String
740747utcTime t = formatTime defaultTimeLocale format t
741748 where format = "%FT%T." ++ formatSubseconds t ++ "Z"
742749
750+getDay :: A.Parser Day
751+getDay = do
752+ yearStr <- A.takeWhile isDigit
753+ when (T.length yearStr < 4) (fail "year must consist of at least 4 digits")
754+
755+ let !year = toNum yearStr
756+ _ <- A.char '-'
757+ month <- digits "month"
758+ _ <- A.char '-'
759+ day <- digits "day"
760+
761+ case fromGregorianValid year month day of
762+ Nothing -> fail "invalid date"
763+ Just x -> return $! x
764+
765+toNum :: Num n => T.Text -> n
766+toNum = T.foldl' (\a c -> 10*a + digit c) 0
767+{-# INLINE toNum #-}
768+
769+digit :: Num n => Char -> n
770+digit c = fromIntegral (ord c .&. 0x0f)
771+{-# INLINE digit #-}
772+
773+digits :: Num n => String -> A.Parser n
774+digits msg = do
775+ x <- A.anyChar
776+ y <- A.anyChar
777+ if isDigit x && isDigit y
778+ then return $! (10 * digit x + digit y)
779+ else fail (msg ++ " is not 2 digits")
780+{-# INLINE digits #-}
781+
782+decimal :: Fractional a => T.Text -> a
783+decimal str = toNum str / 10^(T.length str)
784+{-# INLINE decimal #-}
785+
786+getTimeOfDay :: A.Parser TimeOfDay
787+getTimeOfDay = do
788+ hour <- digits "hours"
789+ _ <- A.char ':'
790+ minute <- digits "minutes"
791+ -- Allow omission of seconds. If seconds is omitted, don't try to
792+ -- parse the sub-second part.
793+ (sec,subsec)
794+ <- ((,) <$> (A.char ':' *> digits "seconds") <*> fract) <|> pure (0,0)
795+
796+ let !picos' = sec + subsec
797+
798+ case makeTimeOfDayValid hour minute picos' of
799+ Nothing -> fail "invalid time of day"
800+ Just x -> return $! x
801+
802+ where
803+ fract =
804+ (A.char '.' *> (decimal <$> A.takeWhile1 isDigit)) <|> pure 0
805+
806+getTimeZone :: A.Parser TimeZone
807+getTimeZone = do
808+ sign <- A.satisfy (\c -> c == '+' || c == '-')
809+ hours <- digits "timezone"
810+ mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0
811+ let !absset = 60 * hours + mins
812+ !offset = if sign == '+' then absset else -absset
813+ return $! minutesToTimeZone offset
814+
815+getUTCTime :: A.Parser UTCTime
816+getUTCTime = do
817+ day <- getDay
818+ _ <- A.char ' ' <|> A.char 'T'
819+ time <- getTimeOfDay
820+ zone <- getTimeZone <|> (A.char 'Z' *> pure utc)
821+ let (!dayDelta,!time') = localToUTCTimeOfDay zone time
822+ let !day' = addDays dayDelta day
823+ let !time'' = timeOfDayToTime time'
824+ return (UTCTime day' time'')
825+
743826instance FromJSON UTCTime where
744827 parseJSON = withText "UTCTime" $ \t ->
745− case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
746− Just d -> pure d
747− _ -> fail "could not parse ISO-8601 date"
828+ case A.parseOnly (getUTCTime <* A.endOfInput) t of
829+ Right d -> pure d
830+ Left msg -> fail ("could not parse ISO-8601 date: " ++ msg)
748831
749832parseJSONElemAtIndex :: FromJSON a => Int -> Vector Value -> Parser a
750833parseJSONElemAtIndex idx ary = parseJSON (V.unsafeIndex ary idx) <?> Index idx