@@ -0,0 +1,191 @@
1+------------------------------------------------------------------------------
3+-- Module: Database.PostgreSQL.Simple.Time.Implementation
4+-- Copyright: (c) 2011 Leon P Smith
6+-- Maintainer: Leon P Smith <leon@melding-monads.com>
7+-- Stability: experimental
9+------------------------------------------------------------------------------
11+{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, PatternGuards #-}
13+module Database.PostgreSQL.Simple.Time.Implementation where
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)
27+import Data.Time hiding (getTimeZone, getZonedTime)
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
40+ deriving (Eq, Ord, Typeable)
42+instance Show a => Show (Unbounded a) where
43+ showsPrec prec x rest
45+ NegInfinity -> "-infinity" ++ rest
46+ Finite time -> showsPrec prec time rest
47+ PosInfinity -> "infinity" ++ rest
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)
55+type LocalTimestamp = Unbounded LocalTime
56+type UTCTimestamp = Unbounded UTCTime
57+type ZonedTimestamp = Unbounded ZonedTime
58+type Date = Unbounded Day
60+instance FromField UTCTimestamp where
61+ fromField = ff PG.TimestampWithTimeZone "UTCTimestamp" parseUTCTimestamp
63+instance FromField ZonedTimestamp where
64+ fromField = ff PG.TimestampWithTimeZone "ZonedTimestamp" parseZonedTimestamp
66+instance FromField LocalTimestamp where
67+ fromField = ff PG.Timestamp "LocalTimestamp" parseLocalTimestamp
69+instance FromField Date where
70+ fromField = ff PG.Date "Date" parseDate
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 "")
78+ = left (UnexpectedNull (B8.unpack (typename f)) hsType "")
81+ Left msg -> left (ConversionFailed (B8.unpack (typename f)) hsType msg)
82+ Right val -> pure val
85+left :: Exception err => err -> Ok a
86+left err = Errors [SomeException err]
89+parseUTCTimestamp :: B.ByteString -> Either String UTCTimestamp
90+parseUTCTimestamp = A.parseOnly (getUTCTimestamp <* A.endOfInput)
92+parseZonedTimestamp :: B.ByteString -> Either String ZonedTimestamp
93+parseZonedTimestamp = A.parseOnly (getZonedTimestamp <* A.endOfInput)
95+parseLocalTimestamp :: B.ByteString -> Either String LocalTimestamp
96+parseLocalTimestamp = A.parseOnly (getLocalTimestamp <* A.endOfInput)
98+parseDate :: B.ByteString -> Either String Date
99+parseDate = A.parseOnly (getDate <* A.endOfInput)
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)
107+getDay :: A.Parser Day
109+ yearStr <- A.takeWhile isDigit
110+ when (B.length yearStr < 4) (fail "year must consist of at least 4 digits")
112+ let !year = toNum yearStr
114+ month <- digits "month"
118+ case fromGregorianValid year month day of
119+ Nothing -> fail "invalid date"
120+ Just x -> return $! x
122+getDate :: A.Parser Date
123+getDate = getUnbounded getDay
125+toPicos :: Num a => B.ByteString -> a
126+toPicos str = toNum str * 10^(12 - B.length str)
128+getTimeOfDay :: A.Parser TimeOfDay
130+ hour <- digits "hours"
132+ minute <- digits "minutes"
134+ second <- digits "seconds"
135+ picos <- (A.char '.' *> (toPicos <$> A.takeWhile1 isDigit)) <|> return 0
137+ let !picos' = second * 1000000000000 + picos
139+ case makeTimeOfDayValid hour minute picos' of
140+ Nothing -> fail "invalid time of day"
141+ Just x -> return $! x
143+getLocalTime :: A.Parser LocalTime
144+getLocalTime = LocalTime <$> getDay <*> (A.char ' ' *> getTimeOfDay)
146+getLocalTimestamp :: A.Parser LocalTimestamp
147+getLocalTimestamp = getUnbounded getLocalTime
149+getTimeZone :: A.Parser TimeZone
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
156+getZonedTime :: A.Parser ZonedTime
157+getZonedTime = ZonedTime <$> getLocalTime <*> getTimeZone
159+getZonedTimestamp :: A.Parser ZonedTimestamp
160+getZonedTimestamp = getUnbounded getZonedTime
162+getUTCTime :: A.Parser UTCTime
166+ time <- getTimeOfDay
168+ let (!dayDelta,!time') = utcToLocalTimeOfDay zone time
169+ let !day' = addDays dayDelta day
170+ let !time'' = timeOfDayToTime time'
171+ return (UTCTime day' time'')
173+getUTCTimestamp :: A.Parser UTCTimestamp
174+getUTCTimestamp = getUnbounded getUTCTime
176+toNum :: Num n => B.ByteString -> n
177+toNum = B.foldl' (\a c -> 10*a + digit c) 0
180+digit :: Num n => Word8 -> n
181+digit c = fromIntegral (c .&. 0x0f)
184+digits :: Num n => String -> A.Parser n
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 #-}