@@ -10,24 +10,116 @@
1010-- Stability : provisional
1111-- Portability : non-portable (GHC extensions)
1212--
13−module Network.Google.Data.Time where
13+module Network.Google.Data.Time
14+ ( Time' (..)
15+ , Date' (..)
16+ , DateTime' (..)
1417
18+ , _Time
19+ , _Date
20+ , _DateTime
21+ ) where
22+
23+import Control.Lens
1524import Data.Aeson
16−import Data.Data (Data, Typeable)
17−import Data.Text (Text)
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)
30+import Data.Data (Data, Typeable)
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
1835import Data.Time
1936import GHC.Generics
20−import Servant.API (FromText, ToText)
37+import Servant.Common.Text
38+
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)
44+
45+_Time :: Iso' Time' TimeOfDay
46+_Time = iso (\(Time' t) -> t) Time'
47+
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)
53+
54+_Date :: Iso' Date' Day
55+_Date = iso (\(Date' t) -> t) Date'
56+
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)
61+
62+_DateTime :: Iso' DateTime' UTCTime
63+_DateTime = iso (\(DateTime' t) -> t) DateTime'
64+
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
68+
69+instance FromJSON Time' where
70+ parseJSON = fmap Time' . withText "time" (run timeParser)
71+
72+instance FromJSON Date' where
73+ parseJSON = fmap Date' . withText "date" (run dayParser)
74+
75+instance FromJSON DateTime' where
76+ parseJSON = fmap DateTime' . parseJSON
77+
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
82+
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
87+
88+parseText :: Parser a -> Text -> Maybe a
89+parseText p = either (const Nothing) Just . parseOnly p
90+
91+encodeText :: ToJSON a => a -> Text
92+encodeText = LText.toStrict . Build.toLazyText . encodeToTextBuilder . toJSON
2193
22−_Time = undefined
23−_Date = undefined
24−_DateTime = undefined
94+-- | Parse a time of the form @HH:MM:SS@.
95+timeParser :: Parser TimeOfDay
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"
25103
26−newtype Time' = Time' Text -- TimeOfDay
27− deriving (Eq, Ord, Show, Read, Generic, Data, Typeable, FromText, ToText, FromJSON, ToJSON)
104+-- | Parse a date of the form @YYYY-MM-DD@.
105+dayParser :: Parser Day
106+dayParser = do
107+ y <- decimal <* char '-'
108+ m <- twoDigits <* char '-'
109+ d <- twoDigits
110+ maybe (fail "invalid date") pure (fromGregorianValid y m d)
28111
29−newtype Date' = Date' Text -- LocalTime
30− deriving (Eq, Ord, Show, Read, Generic, Data, Typeable, FromText, ToText, FromJSON, ToJSON)
112+-- | Parse a two-digit integer (e.g. day of month, hour).
113+twoDigits :: Parser Int
114+twoDigits = do
115+ a <- digit
116+ b <- digit
117+ let c2d c = ord c .&. 15
118+ pure $! c2d a * 10 + c2d b
31119
32−newtype DateTime' = DateTime' Text -- UTCTime
33− deriving (Eq, Ord, Show, Read, Generic, Data, Typeable, FromText, ToText, FromJSON, ToJSON)
120+-- | Run an attoparsec parser as an aeson parser.
121+run :: Parser a -> Text -> Aeson.Parser a
122+run p t =
123+ case parseOnly (p <* endOfInput) t of
124+ Left err -> fail $ "could not parse date: " ++ err
125+ Right r -> pure r