@@ -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 Data.Aeson.Types.Class
@@ -65,6 +68,8 @@ import Data.Aeson.Types.Internal
6568import Data.Scientific (Scientific)
6669import qualified Data.Scientific as Scientific (coefficient, base10Exponent, fromFloatDigits, toRealFloat)
6770import Data.Attoparsec.Number (Number(..))
71+import qualified Data.Attoparsec.Text as A
72+import Data.Char (isDigit, ord)
6873import Data.Fixed
6974import Data.Foldable (Foldable, toList)
7075import Data.Functor.Identity (Identity(..))
@@ -74,8 +79,10 @@ import Data.Maybe (fromMaybe)
7479import Data.Monoid (Dual(..), First(..), Last(..))
7580import Data.Ratio (Ratio, (%), numerator, denominator)
7681import Data.Text (Text, pack, unpack)
77−import Data.Time (UTCTime, ZonedTime(..), TimeZone(..))
82+import Data.Time (UTCTime(..), ZonedTime(..), TimeZone(..), Day, utc)
83+import Data.Time.Calendar (fromGregorianValid, addDays)
7884import Data.Time.Format (FormatTime, formatTime, parseTime)
85+import Data.Time.LocalTime (TimeOfDay, makeTimeOfDayValid, minutesToTimeZone, timeOfDayToTime, localToUTCTimeOfDay)
7986import Data.Traversable as Tr (sequence, traverse)
8087import Data.Vector (Vector)
8188import Data.Word (Word, Word8, Word16, Word32, Word64)
@@ -767,11 +774,87 @@ utcTime :: UTCTime -> String
767774utcTime t = formatTime defaultTimeLocale format t
768775 where format = "%FT%T." ++ formatSubseconds t ++ "Z"
769776
777+getDay :: A.Parser Day
778+getDay = do
779+ yearStr <- A.takeWhile isDigit
780+ when (T.length yearStr < 4) (fail "year must consist of at least 4 digits")
781+
782+ let !year = toNum yearStr
783+ _ <- A.char '-'
784+ month <- digits "month"
785+ _ <- A.char '-'
786+ day <- digits "day"
787+
788+ case fromGregorianValid year month day of
789+ Nothing -> fail "invalid date"
790+ Just x -> return $! x
791+
792+toNum :: Num n => T.Text -> n
793+toNum = T.foldl' (\a c -> 10*a + digit c) 0
794+{-# INLINE toNum #-}
795+
796+digit :: Num n => Char -> n
797+digit c = fromIntegral (ord c .&. 0x0f)
798+{-# INLINE digit #-}
799+
800+digits :: Num n => String -> A.Parser n
801+digits msg = do
802+ x <- A.anyChar
803+ y <- A.anyChar
804+ if isDigit x && isDigit y
805+ then return $! (10 * digit x + digit y)
806+ else fail (msg ++ " is not 2 digits")
807+{-# INLINE digits #-}
808+
809+decimal :: Fractional a => T.Text -> a
810+decimal str = toNum str / 10^(T.length str)
811+{-# INLINE decimal #-}
812+
813+getTimeOfDay :: A.Parser TimeOfDay
814+getTimeOfDay = do
815+ hour <- digits "hours"
816+ _ <- A.char ':'
817+ minute <- digits "minutes"
818+ -- Allow omission of seconds. If seconds is omitted, don't try to
819+ -- parse the sub-second part.
820+ (sec,subsec)
821+ <- ((,) <$> (A.char ':' *> digits "seconds") <*> fract) <|> pure (0,0)
822+
823+ let !picos' = sec + subsec
824+
825+ case makeTimeOfDayValid hour minute picos' of
826+ Nothing -> fail "invalid time of day"
827+ Just x -> return $! x
828+
829+ where
830+ fract =
831+ (A.char '.' *> (decimal <$> A.takeWhile1 isDigit)) <|> pure 0
832+
833+getTimeZone :: A.Parser TimeZone
834+getTimeZone = do
835+ sign <- A.satisfy (\c -> c == '+' || c == '-')
836+ hours <- digits "timezone"
837+ mins <- (A.char ':' *> digits "timezone minutes") <|> pure 0
838+ let !absset = 60 * hours + mins
839+ !offset = if sign == '+' then absset else -absset
840+ return $! minutesToTimeZone offset
841+
842+getUTCTime :: A.Parser UTCTime
843+getUTCTime = do
844+ day <- getDay
845+ _ <- A.char ' ' <|> A.char 'T'
846+ time <- getTimeOfDay
847+ zone <- getTimeZone <|> (A.char 'Z' *> pure utc)
848+ let (!dayDelta,!time') = localToUTCTimeOfDay zone time
849+ let !day' = addDays dayDelta day
850+ let !time'' = timeOfDayToTime time'
851+ return (UTCTime day' time'')
852+
770853instance FromJSON UTCTime where
771854 parseJSON = withText "UTCTime" $ \t ->
772− case parseTime defaultTimeLocale "%FT%T%QZ" (unpack t) of
773− Just d -> pure d
774− _ -> fail "could not parse ISO-8601 date"
855+ case A.parseOnly (getUTCTime <* A.endOfInput) t of
856+ Right d -> pure d
857+ Left msg -> fail ("could not parse ISO-8601 date: " ++ msg)
775858
776859parseJSONElemAtIndex :: FromJSON a => Int -> Vector Value -> Parser a
777860parseJSONElemAtIndex idx ary = parseJSON (V.unsafeIndex ary idx) <?> Index idx