diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,11 @@ +# 0.2.2.0 (2015-11-10) + +- `U` and `Z` to parse `UTCTime` and `ZonedTime` compatibly +- Orphans `FromJSON` for `Day` and `LocalTime` + # 0.2.1.0 (2015-10-05) GHC 7.6 Support -- No `Sym` or `SingObject` support +- No `SymTag` or `SingObject` support # 0.2.0.0 (2015-09-29) No ListLike diff --git a/aeson-extra.cabal b/aeson-extra.cabal --- a/aeson-extra.cabal +++ b/aeson-extra.cabal @@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack name: aeson-extra -version: 0.2.1.0 +version: 0.2.2.0 synopsis: Extra goodies for aeson description: The package motivation is twofold: . @@ -35,20 +35,22 @@ ghc-options: -Wall build-depends: base >=4.6 && <4.9 - , aeson >=0.8 && <0.11 + , aeson >=0.7.0.6 && <0.11 , attoparsec >=0.12 && <0.14 , bytestring >=0.10 && <0.11 , containers >=0.5 && <0.6 , exceptions >=0.8 && <0.9 , hashable >=1.2 && <1.3 , scientific >=0.3 && <0.4 - , tagged >=0.7 && <0.9 , text >=1.2 && <1.3 + , time >=1.4.2 && <1.6 , unordered-containers >=0.2 && <0.3 , vector >=0.10 && <0.12 exposed-modules: Data.Aeson.Compat Data.Aeson.Extra + other-modules: + Data.Aeson.Extra.Time default-language: Haskell2010 test-suite aeson-extra-test @@ -59,15 +61,15 @@ ghc-options: -Wall build-depends: base >=4.6 && <4.9 - , aeson >=0.8 && <0.11 + , aeson >=0.7.0.6 && <0.11 , attoparsec >=0.12 && <0.14 , bytestring >=0.10 && <0.11 , containers >=0.5 && <0.6 , exceptions >=0.8 && <0.9 , hashable >=1.2 && <1.3 , scientific >=0.3 && <0.4 - , tagged >=0.7 && <0.9 , text >=1.2 && <1.3 + , time >=1.4.2 && <1.6 , unordered-containers >=0.2 && <0.3 , vector >=0.10 && <0.12 , aeson-extra diff --git a/src/Data/Aeson/Compat.hs b/src/Data/Aeson/Compat.hs --- a/src/Data/Aeson/Compat.hs +++ b/src/Data/Aeson/Compat.hs @@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Aeson.Compat @@ -59,6 +60,11 @@ import Data.Text as T import Data.Typeable (Typeable) +#if !MIN_VERSION_aeson(0,10,0) +import Data.Time (Day, LocalTime) +import qualified Data.Aeson.Extra.Time as ExtraTime +#endif + -- | Exception thrown by 'decode' - family of functions in this module. newtype AesonException = AesonException String deriving (Show, Typeable) @@ -70,7 +76,7 @@ eitherAesonExc (Right x) = return x -- | Like original 'Data.Aeson.decode' but in arbitrary 'MonadThrow'. --- +-- -- Parse a top-level JSON value, i.e. also strings, numbers etc. decode :: (FromJSON a, MonadThrow m) => L.ByteString -> m a decode = eitherAesonExc . eitherDecode @@ -114,7 +120,7 @@ (.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a) obj .:! key = case H.lookup key obj of Nothing -> pure Nothing - Just v -> + Just v -> #if MIN_VERSION_aeson(0,10,0) modifyFailure addKeyName $ Just <$> parseJSON v -- Key key where @@ -175,4 +181,14 @@ Error msg -> Left msg {-# INLINE eitherDecodeStrictWith #-} +#endif + +#if !MIN_VERSION_aeson(0,10,0) +-- | /Since: aeson-extra-0.2.2.0/ +instance FromJSON Day where + parseJSON = withText "Day" (ExtraTime.run ExtraTime.day) + +-- | /Since: aeson-extra-0.2.2.0/ +instance FromJSON LocalTime where + parseJSON = withText "LocalTime" (ExtraTime.run ExtraTime.localTime) #endif diff --git a/src/Data/Aeson/Extra.hs b/src/Data/Aeson/Extra.hs --- a/src/Data/Aeson/Extra.hs +++ b/src/Data/Aeson/Extra.hs @@ -37,6 +37,9 @@ CollapsedList(..), getCollapsedList, parseCollapsedList, + -- * UTCTime + U(..), + Z(..), -- * Re-exports module Data.Aeson.Compat, ) where @@ -56,6 +59,7 @@ import qualified Data.Map as Map import Data.Text as T import qualified Data.Text.Lazy as TL +import Data.Time (UTCTime, ZonedTime) import qualified Data.Text.Read as T #if MIN_VERSION_base(4,7,0) @@ -63,6 +67,10 @@ import GHC.TypeLits #endif +#if !MIN_VERSION_aeson (0,10,0) +import qualified Data.Aeson.Extra.Time as ExtraTime +#endif + -- | A wrapper type to parse arbitrary maps -- -- > λ > decode "{\"1\": 1, \"2\": 2}" :: Maybe (M (H.HashMap Int Int)) @@ -135,7 +143,7 @@ -- > decode "\"foobar\"" :: Maybe (SymTag "barfoo") -- > Nothing -- --- > /Available with: base >=4.7/ +-- /Available with: base >=4.7/ data SymTag (s :: Symbol) = SymTag deriving (Eq, Ord, Show, Read, Enum, Bounded) @@ -159,7 +167,7 @@ -- > λ > encode (SingObject 42 :: SingObject "value" Int) -- > "{\"value\":42}" -- --- > /Available with: base >=4.7/ +-- /Available with: base >=4.7/ newtype SingObject (s ::Symbol) a = SingObject a deriving (Eq, Ord, Show, Read, Functor, Foldable, Traversable) @@ -248,4 +256,53 @@ addKeyName = (("failed to parse field " <> T.unpack key <> ": ") <>) #else Just v -> getCollapsedList <$> parseJSON v +#endif + +-- | A type to parse 'UTCTime' +-- +-- 'FromJSON' instance accepts for example: +-- +-- @ +-- 2015-09-07T08:16:40.807Z +-- 2015-09-07 11:16:40.807 +03:00 +-- @ +-- +-- Latter format is accepted by @aeson@ staring from version @0.10.0.0@. +-- +-- See +-- +-- /Since: aeson-extra-0.2.2.0/ +newtype U = U { getU :: UTCTime } + deriving (Eq, Ord, Show, Read) + +instance ToJSON U where + toJSON = toJSON . getU +#if MIN_VERSION_aeson (0,10,0) + toEncoding = toEncoding . getU +#endif + +instance FromJSON U where +#if MIN_VERSION_aeson (0,10,0) + parseJSON = fmap U . parseJSON +#else + parseJSON = withText "UTCTime" (fmap U . ExtraTime.run ExtraTime.utcTime) +#endif + +-- | A type to parse 'ZonedTime' +-- +-- /Since: aeson-extra-0.2.2.0/ +newtype Z = Z { getZ :: ZonedTime } + deriving (Show, Read) + +instance ToJSON Z where + toJSON = toJSON . getZ +#if MIN_VERSION_aeson (0,10,0) + toEncoding = toEncoding . getZ +#endif + +instance FromJSON Z where +#if MIN_VERSION_aeson (0,10,0) + parseJSON = fmap Z . parseJSON +#else + parseJSON = withText "ZonedTime" (fmap Z . ExtraTime.run ExtraTime.zonedTime) #endif diff --git a/src/Data/Aeson/Extra/Time.hs b/src/Data/Aeson/Extra/Time.hs new file mode 100644 --- /dev/null +++ b/src/Data/Aeson/Extra/Time.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-} + +-- | +-- Module: Data.Aeson.Extra.Time (Data.Aeson.Parser.Time) +-- Copyright: (c) 2015 Bryan O'Sullivan +-- License: Apache +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Parsers for parsing dates and times. + +module Data.Aeson.Extra.Time + ( + run + , day + , localTime + , timeOfDay + , timeZone + , utcTime + , zonedTime + ) where + +import Control.Monad (when, void) +import Data.Attoparsec.Text as A +import Data.Bits ((.&.)) +import Data.Char (isDigit, ord) +import Data.Fixed (Pico) +import Data.Int (Int64) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Time.Calendar (Day, fromGregorianValid) +import Data.Time.Clock (UTCTime(..)) +import qualified Data.Aeson.Types as Aeson +import qualified Data.Text as T +import qualified Data.Time.LocalTime as Local + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>), (<*), (*>)) +#endif + +-- from Data.Aeson.Internal.Time +import Unsafe.Coerce (unsafeCoerce) + +toPico :: Integer -> Pico +toPico = unsafeCoerce + +-- | Run an attoparsec parser as an aeson parser. +run :: Parser a -> Text -> Aeson.Parser a +run p t = case A.parseOnly (p <* endOfInput) t of + Left err -> fail $ "could not parse date: " ++ err + Right r -> return r + +-- | Parse a date of the form @YYYY-MM-DD@. +day :: Parser Day +day = do + y <- decimal <* char '-' + m <- twoDigits <* char '-' + d <- twoDigits + maybe (fail "invalid date") return (fromGregorianValid y m d) + +-- | Parse a two-digit integer (e.g. day of month, hour). +twoDigits :: Parser Int +twoDigits = do + a <- digit + b <- digit + let c2d c = ord c .&. 15 + return $! c2d a * 10 + c2d b + +-- | Parse a time of the form @HH:MM:SS[.SSS]@. +timeOfDay :: Parser Local.TimeOfDay +timeOfDay = do + h <- twoDigits <* char ':' + m <- twoDigits <* char ':' + s <- seconds + if h < 24 && m < 60 && s < 61 + then return (Local.TimeOfDay h m s) + else fail "invalid time" + +data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64 + +-- | Parse a count of seconds, with the integer part being two digits +-- long. +seconds :: Parser Pico +seconds = do + real <- twoDigits + mc <- peekChar + case mc of + Just '.' -> do + t <- anyChar *> takeWhile1 isDigit + return $! parsePicos real t + _ -> return $! fromIntegral real + where + parsePicos a0 t = toPico (fromIntegral (t' * 10^n)) + where T n t' = T.foldl' step (T 12 (fromIntegral a0)) t + step ma@(T m a) c + | m <= 0 = ma + | otherwise = T (m-1) (10 * a + fromIntegral (ord c) .&. 15) + +-- | Parse a time zone, and return 'Nothing' if the offset from UTC is +-- zero. (This makes some speedups possible.) +timeZone :: Parser (Maybe Local.TimeZone) +timeZone = do + let maybeSkip c = do ch <- peekChar'; when (ch == c) (void anyChar) + maybeSkip ' ' + ch <- satisfy $ \c -> c == 'Z' || c == '+' || c == '-' + if ch == 'Z' + then return Nothing + else do + h <- twoDigits + mm <- peekChar + m <- case mm of + Just ':' -> anyChar *> twoDigits + Just d | isDigit d -> twoDigits + _ -> return 0 + let off | ch == '-' = negate off0 + | otherwise = off0 + off0 = h * 60 + m + case undefined of + _ | off == 0 -> + return Nothing + | off < -720 || off > 840 || m > 59 -> + fail "invalid time zone offset" + | otherwise -> + let !tz = Local.minutesToTimeZone off + in return (Just tz) + +-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@. +-- The space may be replaced with a @T@. The number of seconds may be +-- followed by a fractional component. +localTime :: Parser Local.LocalTime +localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay + where daySep = satisfy (\c -> c == 'T' || c == ' ') + +-- | Behaves as 'zonedTime', but converts any time zone offset into a +-- UTC time. +utcTime :: Parser UTCTime +utcTime = do + lt@(Local.LocalTime d t) <- localTime + mtz <- timeZone + case mtz of + Nothing -> let !tt = Local.timeOfDayToTime t + in return (UTCTime d tt) + Just tz -> return $! Local.localTimeToUTC tz lt + +-- | Parse a date with time zone info. Acceptable formats: +-- +-- @YYYY-MM-DD HH:MM:SS Z@ +-- +-- The first space may instead be a @T@, and the second space is +-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a +-- time zone offset of the form @+0000@ or @-08:00@, where the first +-- two digits are hours, the @:@ is optional and the second two digits +-- (also optional) are minutes. +zonedTime :: Parser Local.ZonedTime +zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone) + +utc :: Local.TimeZone +utc = Local.TimeZone 0 False "" diff --git a/test/Tests.hs b/test/Tests.hs --- a/test/Tests.hs +++ b/test/Tests.hs @@ -11,6 +11,9 @@ import Data.Aeson.Extra import qualified Data.HashMap.Lazy as H import Data.Map (Map) +import Data.Maybe (isJust) +import Data.String (fromString) +import Data.Time (zonedTimeToUTC) import Data.Vector (Vector) import Test.QuickCheck.Instances () import Test.Tasty @@ -32,6 +35,8 @@ , singObjectTests #endif , collapsedListTests + , utctimeTests + , zonedtimeTests ] ------------------------------------------------------------------------------ @@ -145,3 +150,43 @@ ex2 = "{\"value\": 42 }" ex3 = "{\"value\": null }" t = testCase "-" + +------------------------------------------------------------------------------ +-- U & Z +------------------------------------------------------------------------------ + +utctimeTests :: TestTree +utctimeTests = testGroup "U" $ + [ testCase "base case" $ assertBool "base case" $ isJust simple + ] ++ map t timeStrings + where simple = decode "\"2015-09-07T08:16:40.807Z\"" :: Maybe U + t str = testCase str + . assertEqual str simple + . decode + . fromString + $ "\"" ++ str ++ "\"" + +zonedtimeTests :: TestTree +zonedtimeTests = testGroup "Z" $ + [ testCase "base case" $ assertBool "base case" $ isJust simple + ] ++ map t timeStrings + where simple = decode "\"2015-09-07T08:16:40.807Z\"" :: Maybe Z + t str = testCase str + . assertEqual str (fmap z simple) + . fmap z + . decode + . fromString + $ "\"" ++ str ++ "\"" + z (Z z') = zonedTimeToUTC z' + +timeStrings :: [String] +timeStrings = + [ "2015-09-07T08:16:40.807Z" + , "2015-09-07T11:16:40.807+0300" + , "2015-09-07 08:16:40.807Z" + , "2015-09-07 08:16:40.807 Z" + , "2015-09-07 08:16:40.807 +0000" + , "2015-09-07 08:16:40.807 +00:00" + , "2015-09-07 11:16:40.807 +03:00" + , "2015-09-07 05:16:40.807 -03:00" + ]