@@ -0,0 +1,195 @@
1+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
2+
3+-- |
4+-- Module: Database.PostgreSQL.Simple.Time.Parser
5+-- Copyright: (c) 2012-2015 Leon P Smith
6+-- (c) 2015 Bryan O'Sullivan
7+-- License: BSD3
8+-- Maintainer: Leon P Smith <leon@melding-monads.com>
9+-- Stability: experimental
10+-- Portability: portable
11+--
12+-- Parsers for parsing dates and times.
13+
14+module Database.PostgreSQL.Simple.Time.Parser
15+ (
16+ day
17+ , localTime
18+ , timeOfDay
19+ , timeZone
20+ , UTCOffsetHMS(..)
21+ , timeZoneHMS
22+ , localToUTCTimeOfDayHMS
23+ , utcTime
24+ , zonedTime
25+ ) where
26+
27+import Control.Applicative ((<$>), (<*>), (<*), (*>))
28+import Database.PostgreSQL.Simple.Compat (toPico)
29+import Data.Attoparsec.ByteString.Char8 as A
30+import Data.Bits ((.&.))
31+import Data.Char (ord)
32+import Data.Fixed (Pico)
33+import Data.Int (Int64)
34+import Data.Maybe (fromMaybe)
35+import Data.Time.Calendar (Day, fromGregorianValid, addDays)
36+import Data.Time.Clock (UTCTime(..))
37+import qualified Data.ByteString.Char8 as B8
38+import qualified Data.Time.LocalTime as Local
39+
40+-- | Parse a date of the form @YYYY-MM-DD@.
41+day :: Parser Day
42+day = do
43+ y <- decimal <* char '-'
44+ m <- twoDigits <* char '-'
45+ d <- twoDigits
46+ maybe (fail "invalid date") return (fromGregorianValid y m d)
47+
48+-- | Parse a two-digit integer (e.g. day of month, hour).
49+twoDigits :: Parser Int
50+twoDigits = do
51+ a <- digit
52+ b <- digit
53+ let c2d c = ord c .&. 15
54+ return $! c2d a * 10 + c2d b
55+
56+-- | Parse a time of the form @HH:MM:SS[.SSS]@.
57+timeOfDay :: Parser Local.TimeOfDay
58+timeOfDay = do
59+ h <- twoDigits <* char ':'
60+ m <- twoDigits <* char ':'
61+ s <- seconds
62+ if h < 24 && m < 60 && s <= 60
63+ then return (Local.TimeOfDay h m s)
64+ else fail "invalid time"
65+
66+data T = T {-# UNPACK #-} !Int {-# UNPACK #-} !Int64
67+
68+-- | Parse a count of seconds, with the integer part being two digits
69+-- long.
70+seconds :: Parser Pico
71+seconds = do
72+ real <- twoDigits
73+ mc <- peekChar
74+ case mc of
75+ Just '.' -> do
76+ t <- anyChar *> takeWhile1 isDigit
77+ return $! parsePicos real t
78+ _ -> return $! fromIntegral real
79+ where
80+ parsePicos a0 t = toPico (fromIntegral (t' * 10^n))
81+ where T n t' = B8.foldl' step (T 12 (fromIntegral a0)) t
82+ step ma@(T m a) c
83+ | m <= 0 = ma
84+ | otherwise = T (m-1) (10 * a + fromIntegral (ord c) .&. 15)
85+
86+-- | Parse a time zone, and return 'Nothing' if the offset from UTC is
87+-- zero. (This makes some speedups possible.)
88+timeZone :: Parser (Maybe Local.TimeZone)
89+timeZone = do
90+ ch <- satisfy $ \c -> c == 'Z' || c == '+' || c == '-'
91+ if ch == 'Z'
92+ then return Nothing
93+ else do
94+ h <- twoDigits
95+ mm <- peekChar
96+ m <- case mm of
97+ Just ':' -> anyChar *> twoDigits
98+ _ -> return 0
99+ let off | ch == '-' = negate off0
100+ | otherwise = off0
101+ off0 = h * 60 + m
102+ case undefined of
103+ _ | off == 0 ->
104+ return Nothing
105+ | h > 23 || m > 59 ->
106+ fail "invalid time zone offset"
107+ | otherwise ->
108+ let !tz = Local.minutesToTimeZone off
109+ in return (Just tz)
110+
111+data UTCOffsetHMS = UTCOffsetHMS {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int
112+
113+-- | Parse a time zone, and return 'Nothing' if the offset from UTC is
114+-- zero. (This makes some speedups possible.)
115+timeZoneHMS :: Parser (Maybe UTCOffsetHMS)
116+timeZoneHMS = do
117+ ch <- satisfy $ \c -> c == 'Z' || c == '+' || c == '-'
118+ if ch == 'Z'
119+ then return Nothing
120+ else do
121+ h <- twoDigits
122+ m <- maybeTwoDigits
123+ s <- maybeTwoDigits
124+ case undefined of
125+ _ | h == 0 && m == 0 && s == 0 ->
126+ return Nothing
127+ | h > 23 || m >= 60 || s >= 60 ->
128+ fail "invalid time zone offset"
129+ | otherwise ->
130+ if ch == '+'
131+ then let !tz = UTCOffsetHMS h m s
132+ in return (Just tz)
133+ else let !tz = UTCOffsetHMS (-h) (-m) (-s)
134+ in return (Just tz)
135+ where
136+ maybeTwoDigits = do
137+ ch <- peekChar
138+ case ch of
139+ Just ':' -> anyChar *> twoDigits
140+ _ -> return 0
141+
142+localToUTCTimeOfDayHMS :: UTCOffsetHMS -> Local.TimeOfDay -> (Integer, Local.TimeOfDay)
143+localToUTCTimeOfDayHMS (UTCOffsetHMS dh dm ds) (Local.TimeOfDay h m s) =
144+ (\ !a !b -> (a,b)) dday (Local.TimeOfDay h'' m'' s'')
145+ where
146+ s' = s - fromIntegral ds
147+ (!s'', m')
148+ | s' < 0 = (s' + 60, m - dm - 1)
149+ | s' >= 60 = (s' - 60, m - dm + 1)
150+ | otherwise = (s' , m - dm )
151+ (!m'', h')
152+ | m' < 0 = (m' + 60, h - dh - 1)
153+ | m' >= 60 = (m' - 60, h - dh + 1)
154+ | otherwise = (m' , h - dh )
155+ (!h'', dday)
156+ | h' < 0 = (h' + 24, -1)
157+ | h' >= 24 = (h' - 24, 1)
158+ | otherwise = (h' , 0)
159+
160+
161+-- | Parse a date and time, of the form @YYYY-MM-DD HH:MM:SS@.
162+-- The space may be replaced with a @T@. The number of seconds may be
163+-- followed by a fractional component.
164+localTime :: Parser Local.LocalTime
165+localTime = Local.LocalTime <$> day <* daySep <*> timeOfDay
166+ where daySep = satisfy (\c -> c == 'T' || c == ' ')
167+
168+-- | Behaves as 'zonedTime', but converts any time zone offset into a
169+-- UTC time.
170+utcTime :: Parser UTCTime
171+utcTime = do
172+ (Local.LocalTime d t) <- localTime
173+ mtz <- timeZoneHMS
174+ case mtz of
175+ Nothing -> let !tt = Local.timeOfDayToTime t
176+ in return (UTCTime d tt)
177+ Just tz -> let !(dd,t') = localToUTCTimeOfDayHMS tz t
178+ !d' = addDays dd d
179+ !tt = Local.timeOfDayToTime t'
180+ in return (UTCTime d' tt)
181+
182+-- | Parse a date with time zone info. Acceptable formats:
183+--
184+-- @YYYY-MM-DD HH:MM:SS Z@
185+--
186+-- The first space may instead be a @T@, and the second space is
187+-- optional. The @Z@ represents UTC. The @Z@ may be replaced with a
188+-- time zone offset of the form @+0000@ or @-08:00@, where the first
189+-- two digits are hours, the @:@ is optional and the second two digits
190+-- (also optional) are minutes.
191+zonedTime :: Parser Local.ZonedTime
192+zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone)
193+
194+utc :: Local.TimeZone
195+utc = Local.TimeZone 0 False ""