@@ -0,0 +1,191 @@
1+------------------------------------------------------------------------------
2+-- |
3+-- Module: Database.PostgreSQL.Simple.Time.Implementation
4+-- Copyright: (c) 2011 Leon P Smith
5+-- License: BSD3
6+-- Maintainer: Leon P Smith <leon@melding-monads.com>
7+-- Stability: experimental
8+--
9+------------------------------------------------------------------------------
10+
11+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, PatternGuards #-}
12+
13+module Database.PostgreSQL.Simple.Time.Implementation where
14+
15+import Prelude hiding (take)
16+--import Blaze.ByteString.Builder(fromByteString)
17+--import Blaze.ByteString.Builder.Char8(fromString, fromChar)
18+import Control.Arrow((***))
19+import Control.Applicative
20+import Control.Exception
21+import Control.Monad(when)
22+import Data.Bits((.&.))
23+import qualified Data.ByteString as B
24+import qualified Data.ByteString.Char8 as B8
25+import Data.ByteString.Internal (c2w)
26+import Data.Char
27+import Data.Time hiding (getTimeZone, getZonedTime)
28+import Data.Typeable
29+import Data.Word(Word8)
30+import qualified Data.Attoparsec.Char8 as A
31+import qualified Database.PostgreSQL.Simple.BuiltinTypes as PG
32+import Database.PostgreSQL.Simple.FromField
33+--import Database.PostgreSQL.Simple.ToField
34+import Database.PostgreSQL.Simple.Ok
35+
36+data Unbounded a
37+ = NegInfinity
38+ | Finite !a
39+ | PosInfinity
40+ deriving (Eq, Ord, Typeable)
41+
42+instance Show a => Show (Unbounded a) where
43+ showsPrec prec x rest
44+ = case x of
45+ NegInfinity -> "-infinity" ++ rest
46+ Finite time -> showsPrec prec time rest
47+ PosInfinity -> "infinity" ++ rest
48+
49+instance Read a => Read (Unbounded a) where
50+ readsPrec prec = readParen False $ \str -> case str of
51+ ('-':'i':'n':'f':'i':'n':'i':'t':'y':xs) -> [(NegInfinity,xs)]
52+ ( 'i':'n':'f':'i':'n':'i':'t':'y':xs) -> [(PosInfinity,xs)]
53+ xs -> map (Finite *** id) (readsPrec prec xs)
54+
55+type LocalTimestamp = Unbounded LocalTime
56+type UTCTimestamp = Unbounded UTCTime
57+type ZonedTimestamp = Unbounded ZonedTime
58+type Date = Unbounded Day
59+
60+instance FromField UTCTimestamp where
61+ fromField = ff PG.TimestampWithTimeZone "UTCTimestamp" parseUTCTimestamp
62+
63+instance FromField ZonedTimestamp where
64+ fromField = ff PG.TimestampWithTimeZone "ZonedTimestamp" parseZonedTimestamp
65+
66+instance FromField LocalTimestamp where
67+ fromField = ff PG.Timestamp "LocalTimestamp" parseLocalTimestamp
68+
69+instance FromField Date where
70+ fromField = ff PG.Date "Date" parseDate
71+
72+ff :: PG.BuiltinType -> String -> (B.ByteString -> Either String a)
73+ -> Field -> Maybe B.ByteString -> Ok a
74+ff pgType hsType parse f mstr
75+ | typeOid f /= PG.builtin2oid pgType
76+ = left (Incompatible (B8.unpack (typename f)) hsType "")
77+ | Nothing <- mstr
78+ = left (UnexpectedNull (B8.unpack (typename f)) hsType "")
79+ | Just str <- mstr
80+ = case parse str of
81+ Left msg -> left (ConversionFailed (B8.unpack (typename f)) hsType msg)
82+ Right val -> pure val
83+{-# INLINE ff #-}
84+
85+left :: Exception err => err -> Ok a
86+left err = Errors [SomeException err]
87+{-# INLINE left #-}
88+
89+parseUTCTimestamp :: B.ByteString -> Either String UTCTimestamp
90+parseUTCTimestamp = A.parseOnly (getUTCTimestamp <* A.endOfInput)
91+
92+parseZonedTimestamp :: B.ByteString -> Either String ZonedTimestamp
93+parseZonedTimestamp = A.parseOnly (getZonedTimestamp <* A.endOfInput)
94+
95+parseLocalTimestamp :: B.ByteString -> Either String LocalTimestamp
96+parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)
97+
98+parseDate :: B.ByteString -> Either String Date
99+parseDate = A.parseOnly (getDate <* A.endOfInput)
100+
101+getUnbounded :: A.Parser a -> A.Parser (Unbounded a)
102+getUnbounded getFinite
103+ = (pure NegInfinity <* A.string "-infinity")
104+ <|> (pure PosInfinity <* A.string "infinity")
105+ <|> (Finite <$> getFinite)
106+
107+getDay :: A.Parser Day
108+getDay = do
109+ yearStr <- A.takeWhile isDigit
110+ when (B.length yearStr < 4) (fail "year must consist of at least 4 digits")
111+
112+ let !year = toNum yearStr
113+ _ <- A.char '-'
114+ month <- digits "month"
115+ _ <- A.char '-'
116+ day <- digits "day"
117+
118+ case fromGregorianValid year month day of
119+ Nothing -> fail "invalid date"
120+ Just x -> return $! x
121+
122+getDate :: A.Parser Date
123+getDate = getUnbounded getDay
124+
125+toPicos :: Num a => B.ByteString -> a
126+toPicos str = toNum str * 10^(12 - B.length str)
127+
128+getTimeOfDay :: A.Parser TimeOfDay
129+getTimeOfDay = do
130+ hour <- digits "hours"
131+ _ <- A.char ':'
132+ minute <- digits "minutes"
133+ _ <- A.char ':'
134+ second <- digits "seconds"
135+ picos <- (A.char '.' *> (toPicos <$> A.takeWhile1 isDigit)) <|> return 0
136+
137+ let !picos' = second * 1000000000000 + picos
138+
139+ case makeTimeOfDayValid hour minute picos' of
140+ Nothing -> fail "invalid time of day"
141+ Just x -> return $! x
142+
143+getLocalTime :: A.Parser LocalTime
144+getLocalTime = LocalTime <$> getDay <*> (A.char ' ' *> getTimeOfDay)
145+
146+getLocalTimestamp :: A.Parser LocalTimestamp
147+getLocalTimestamp = getUnbounded getLocalTime
148+
149+getTimeZone :: A.Parser TimeZone
150+getTimeZone = do
151+ sign <- A.satisfy (\c -> c == '+' || c == '-')
152+ offset <- digits "timezone"
153+ let !minutes = 60 * if sign == '+' then offset else -offset
154+ return $! minutesToTimeZone minutes
155+
156+getZonedTime :: A.Parser ZonedTime
157+getZonedTime = ZonedTime <$> getLocalTime <*> getTimeZone
158+
159+getZonedTimestamp :: A.Parser ZonedTimestamp
160+getZonedTimestamp = getUnbounded getZonedTime
161+
162+getUTCTime :: A.Parser UTCTime
163+getUTCTime = do
164+ day <- getDay
165+ _ <- A.char ' '
166+ time <- getTimeOfDay
167+ zone <- getTimeZone
168+ let (!dayDelta,!time') = utcToLocalTimeOfDay zone time
169+ let !day' = addDays dayDelta day
170+ let !time'' = timeOfDayToTime time'
171+ return (UTCTime day' time'')
172+
173+getUTCTimestamp :: A.Parser UTCTimestamp
174+getUTCTimestamp = getUnbounded getUTCTime
175+
176+toNum :: Num n => B.ByteString -> n
177+toNum = B.foldl' (\a c -> 10*a + digit c) 0
178+{-# INLINE toNum #-}
179+
180+digit :: Num n => Word8 -> n
181+digit c = fromIntegral (c .&. 0x0f)
182+{-# INLINE digit #-}
183+
184+digits :: Num n => String -> A.Parser n
185+digits msg = do
186+ x <- A.anyChar
187+ y <- A.anyChar
188+ if isDigit x && isDigit y
189+ then return $! (10 * digit (c2w x) + digit (c2w y))
190+ else fail (msg ++ " is not 2 digits")
191+{-# INLINE digits #-}