@@ -10,24 +10,116 @@
10-- Stability : provisional
10-- Stability : provisional
11-- Portability : non-portable (GHC extensions)
11-- Portability : non-portable (GHC extensions)
13−module Network.Google.Data.Time where
13+module Network.Google.Data.Time
15import Data.Aeson
24import Data.Aeson
25+import Data.Aeson.Encode
26+import qualified Data.Aeson.Types as Aeson
27+import Data.Attoparsec.Text
28+import Data.Bits ((.&.))
29+import Data.Char (ord)
16−import Data.Data (Data, Typeable)
30+import Data.Data (Data, Typeable)
17−import Data.Text (Text)
31+import Data.Text (Text)
32+import qualified Data.Text as Text
33+import qualified Data.Text.Lazy as LText
34+import qualified Data.Text.Lazy.Builder as Build
18import Data.Time
35import Data.Time
19import GHC.Generics
36import GHC.Generics
20−import Servant.API (FromText, ToText)
37+import Servant.Common.Text
39+-- | This SHOULD be a time in the format of hh:mm:ss. It is
40+-- recommended that you use the "date-time" format instead of "time"
41+-- unless you need to transfer only the time part.
42+newtype Time' = Time' TimeOfDay
43+ deriving (Eq, Ord, Show, Read, Generic, Data, Typeable)
45+_Time :: Iso' Time' TimeOfDay
46+_Time = iso (\(Time' t) -> t) Time'
48+-- | This SHOULD be a date in the format of YYYY-MM-DD. It is
49+-- recommended that you use the "date-time" format instead of "date"
50+-- unless you need to transfer only the date part.
51+newtype Date' = Date' Day
52+ deriving (Eq, Ord, Show, Read, Generic, Data, Typeable)
54+_Date :: Iso' Date' Day
55+_Date = iso (\(Date' t) -> t) Date'
57+-- | This SHOULD be a date in ISO 8601 format of YYYY-MM-
58+-- DDThh:mm:ssZ in UTC time. This is the recommended form of date/timestamp.
59+newtype DateTime' = DateTime' UTCTime
60+ deriving (Eq, Ord, Show, Read, Generic, Data, Typeable)
62+_DateTime :: Iso' DateTime' UTCTime
63+_DateTime = iso (\(DateTime' t) -> t) DateTime'
65+instance FromText Time' where fromText = fmap Time' . parseText timeParser
66+instance FromText Date' where fromText = fmap Date' . parseText dayParser
67+instance FromText DateTime' where fromText = Aeson.parseMaybe parseJSON . String
69+instance FromJSON Time' where
70+ parseJSON = fmap Time' . withText "time" (run timeParser)
72+instance FromJSON Date' where
73+ parseJSON = fmap Date' . withText "date" (run dayParser)
75+instance FromJSON DateTime' where
76+ parseJSON = fmap DateTime' . parseJSON
78+-- FIXME: Revisit once aeson-0.10 is more widely available.
79+instance ToText Time' where toText = Text.pack . show . view _Time
80+instance ToText Date' where toText = Text.pack . show . view _Date
81+instance ToText DateTime' where toText = encodeText
83+-- FIXME: Revisit once aeson-0.10 is more widely available.
84+instance ToJSON Time' where toJSON = String . toText
85+instance ToJSON Date' where toJSON = String . toText
86+instance ToJSON DateTime' where toJSON = toJSON . view _DateTime
88+parseText :: Parser a -> Text -> Maybe a
89+parseText p = either (const Nothing) Just . parseOnly p
91+encodeText :: ToJSON a => a -> Text
92+encodeText = LText.toStrict . Build.toLazyText . encodeToTextBuilder . toJSON
22−_Time = undefined
94+-- | Parse a time of the form @HH:MM:SS@.
23−_Date = undefined
95+timeParser :: Parser TimeOfDay
24−_DateTime = undefined
96+timeParser = do
97+ h <- twoDigits <* char ':'
98+ m <- twoDigits <* char ':'
99+ s <- twoDigits <&> fromIntegral
100+ if h < 24 && m < 60 && s < 61
101+ then pure (TimeOfDay h m s)
102+ else fail "invalid time"
26−newtype Time' = Time' Text -- TimeOfDay
104+-- | Parse a date of the form @YYYY-MM-DD@.
27− deriving (Eq, Ord, Show, Read, Generic, Data, Typeable, FromText, ToText, FromJSON, ToJSON)
105+dayParser :: Parser Day
107+ y <- decimal <* char '-'
108+ m <- twoDigits <* char '-'
110+ maybe (fail "invalid date") pure (fromGregorianValid y m d)
29−newtype Date' = Date' Text -- LocalTime
112+-- | Parse a two-digit integer (e.g. day of month, hour).
30− deriving (Eq, Ord, Show, Read, Generic, Data, Typeable, FromText, ToText, FromJSON, ToJSON)
113+twoDigits :: Parser Int
117+ let c2d c = ord c .&. 15
118+ pure $! c2d a * 10 + c2d b
32−newtype DateTime' = DateTime' Text -- UTCTime
120+-- | Run an attoparsec parser as an aeson parser.
33− deriving (Eq, Ord, Show, Read, Generic, Data, Typeable, FromText, ToText, FromJSON, ToJSON)
121+run :: Parser a -> Text -> Aeson.Parser a
123+ case parseOnly (p <* endOfInput) t of
124+ Left err -> fail $ "could not parse date: " ++ err