diff --git a/postgresql-simple.cabal b/postgresql-simple.cabal index 326f1702..99109d6e 100644 --- a/postgresql-simple.cabal +++ b/postgresql-simple.cabal @@ -54,6 +54,7 @@ Library Database.PostgreSQL.Simple.Time.Implementation Database.PostgreSQL.Simple.Time.Internal.Parser Database.PostgreSQL.Simple.Time.Internal.Printer + Database.PostgreSQL.Simple.Time.Interval Database.PostgreSQL.Simple.TypeInfo.Types Build-depends: diff --git a/src/Database/PostgreSQL/Simple/FromField.hs b/src/Database/PostgreSQL/Simple/FromField.hs index 2868ce33..ba1c0145 100644 --- a/src/Database/PostgreSQL/Simple/FromField.hs +++ b/src/Database/PostgreSQL/Simple/FromField.hs @@ -475,6 +475,10 @@ instance FromField LocalTimestamp where instance FromField Date where fromField = ff $(inlineTypoid TI.date) "Date" parseDate +-- | interval +instance FromField Interval where + fromField = ff $(inlineTypoid TI.interval) "Interval" parseInterval + ff :: PQ.Oid -> String -> (B8.ByteString -> Either String a) -> Field -> Maybe B8.ByteString -> Conversion a ff compatOid hsType parse f mstr = diff --git a/src/Database/PostgreSQL/Simple/Time.hs b/src/Database/PostgreSQL/Simple/Time.hs index 81df11b4..411cce45 100644 --- a/src/Database/PostgreSQL/Simple/Time.hs +++ b/src/Database/PostgreSQL/Simple/Time.hs @@ -218,6 +218,8 @@ module Database.PostgreSQL.Simple.Time , UTCTimestamp , ZonedTimestamp , LocalTimestamp + , Interval(..) + , zeroInterval , parseDay , parseUTCTime , parseZonedTime @@ -227,6 +229,7 @@ module Database.PostgreSQL.Simple.Time , parseUTCTimestamp , parseZonedTimestamp , parseLocalTimestamp + , parseInterval , dayToBuilder , utcTimeToBuilder , zonedTimeToBuilder @@ -239,6 +242,8 @@ module Database.PostgreSQL.Simple.Time , localTimestampToBuilder , unboundedToBuilder , nominalDiffTimeToBuilder + , intervalBuilder ) where import Database.PostgreSQL.Simple.Time.Implementation +import Database.PostgreSQL.Simple.Time.Interval diff --git a/src/Database/PostgreSQL/Simple/Time/Implementation.hs b/src/Database/PostgreSQL/Simple/Time/Implementation.hs index 59fed837..f2bede78 100644 --- a/src/Database/PostgreSQL/Simple/Time/Implementation.hs +++ b/src/Database/PostgreSQL/Simple/Time/Implementation.hs @@ -23,6 +23,7 @@ import Data.Typeable import Data.Maybe (fromMaybe) import qualified Data.Attoparsec.ByteString.Char8 as A import Database.PostgreSQL.Simple.Compat ((<>)) +import Database.PostgreSQL.Simple.Time.Interval (Interval) import qualified Database.PostgreSQL.Simple.Time.Internal.Parser as TP import qualified Database.PostgreSQL.Simple.Time.Internal.Printer as TPP @@ -50,6 +51,9 @@ type UTCTimestamp = Unbounded UTCTime type ZonedTimestamp = Unbounded ZonedTime type Date = Unbounded Day +parseInterval :: B.ByteString -> Either String Interval +parseInterval = A.parseOnly TP.interval + parseUTCTime :: B.ByteString -> Either String UTCTime parseUTCTime = A.parseOnly (getUTCTime <* A.endOfInput) @@ -164,3 +168,6 @@ dateToBuilder = unboundedToBuilder dayToBuilder nominalDiffTimeToBuilder :: NominalDiffTime -> Builder nominalDiffTimeToBuilder = TPP.nominalDiffTime + +intervalBuilder :: Interval -> Builder +intervalBuilder = TPP.interval diff --git a/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs b/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs index 47f292b3..d5521d5f 100644 --- a/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs +++ b/src/Database/PostgreSQL/Simple/Time/Internal/Parser.hs @@ -21,10 +21,13 @@ module Database.PostgreSQL.Simple.Time.Internal.Parser , localToUTCTimeOfDayHMS , utcTime , zonedTime + , interval ) where +import Prelude as P import Control.Applicative ((<$>), (<*>), (<*), (*>)) import Database.PostgreSQL.Simple.Compat (toPico) +import Database.PostgreSQL.Simple.Time.Interval (Interval(..)) import Data.Attoparsec.ByteString.Char8 as A import Data.Bits ((.&.)) import Data.Char (ord) @@ -193,3 +196,44 @@ zonedTime = Local.ZonedTime <$> localTime <*> (fromMaybe utc <$> timeZone) utc :: Local.TimeZone utc = Local.TimeZone 0 False "" + + +-- | Parse an interval of the form @[A year[s][ ][B mon[s][ ]][C day[s][ ]][[-]XXX:YY:ZZ[.[Z[Z[Z[Z]]]]]]@. +-- (PosgreSQL default interval output format.) +interval :: Parser Interval +interval = do + parsedYears <- option 0 $ signed decimal <* string " year" <* optionalS <* optionalSpace + parsedMonths <- option 0 $ signed decimal <* string " mon" <* optionalS <* optionalSpace + parsedDays <- option 0 $ signed decimal <* string " day" <* optionalS <* optionalSpace + parsedMicroseconds <- option 0 $ do + possibleNegativeSign <- peekChar' + normalizeSign <- case possibleNegativeSign of '-' -> anyChar *> return negate + _ -> return id + parsedHours <- decimal <* char ':' + parsedMinutes <- twoDigits <* char ':' + microsecondsOfSeconds <- (*microsecondScale) <$> twoDigits + maybePartialSeconds <- option Nothing $ Just <$> do + partialSecondStr <- char '.' *> many1 digit + let partialSeconds = read $ P.take 6 $ partialSecondStr ++ repeat '0' + return partialSeconds + + let minutesMicros = microsecondScale * 60 * fromIntegral parsedMinutes + let hoursMicros = microsecondScale * 3600 * parsedHours + let parsedMicroseconds = case maybePartialSeconds of Nothing -> + microsecondsOfSeconds + + minutesMicros + + hoursMicros + Just parsedPartialSecond -> + microsecondsOfSeconds + parsedPartialSecond + + minutesMicros + + hoursMicros + + return $ normalizeSign parsedMicroseconds + + let allMonths = 12 * parsedYears + parsedMonths + return Interval { intervalMonths = allMonths, + intervalDays = parsedDays, + intervalMicroseconds = fromIntegral parsedMicroseconds} + where optionalS = option 's' (char 's') + optionalSpace = option ' ' space + microsecondScale = 1000000 diff --git a/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs b/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs index dc15e0c3..a12f4643 100644 --- a/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs +++ b/src/Database/PostgreSQL/Simple/Time/Internal/Printer.hs @@ -17,13 +17,14 @@ module Database.PostgreSQL.Simple.Time.Internal.Printer , localTime , zonedTime , nominalDiffTime + , interval ) where import Control.Arrow ((>>>)) import Data.ByteString.Builder (Builder, integerDec) import Data.ByteString.Builder.Prim ( liftFixedToBounded, (>$<), (>*<) - , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec) + , BoundedPrim, primBounded, condB, emptyB, FixedPrim, char8, int32Dec, int64Dec, primFixed) import Data.Char ( chr ) import Data.Int ( Int32, Int64 ) import Data.Time @@ -31,6 +32,7 @@ import Data.Time , Day, toGregorian, TimeOfDay(..), timeToTimeOfDay , TimeZone, timeZoneMinutes ) import Database.PostgreSQL.Simple.Compat ((<>), fromPico) +import Database.PostgreSQL.Simple.Time.Interval (Interval(..)) import Unsafe.Coerce (unsafeCoerce) liftB :: FixedPrim a -> BoundedPrim a @@ -121,3 +123,37 @@ nominalDiffTime :: NominalDiffTime -> Builder nominalDiffTime xy = integerDec x <> primBounded frac (abs (fromIntegral y)) where (x,y) = fromPico (unsafeCoerce xy) `quotRem` 1000000000000 + + +interval :: Interval -> Builder +interval x = boundedPrefix <> integerDec afterSeconds <> fixedSuffix + where + (hours, afterHours) = intervalMicroseconds x `quotRem` 3600000000 + (minutes, afterMinutes) = afterHours `quotRem` 60000000 + (seconds, afterSeconds) = afterMinutes `quotRem` 1000000 + + boundedPrefix = primBounded + (int32Dec >*< + liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< + int32Dec >*< + liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< + int64Dec >*< + liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< + int64Dec >*< + liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< + int64Dec >*< + liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8 >*< liftB char8) + (intervalMonths x, + (' ', ('m', ('o', ('n', ('s', (' ', + (intervalDays x, + (' ', ('d', ('a', ('y', ('s', (' ', + (fromIntegral hours, + (' ', ('h', ('o', ('u', ('r', ('s', (' ', + (fromIntegral minutes, + (' ', ('m', ('i', ('n', ('s', (' ', + (fromIntegral seconds, + (' ', ('s', ('e', ('c', ('s', ' '))))))))))))))))))))))))))))))))))) + + fixedSuffix = primFixed (char8 >*< char8 >*< char8 >*< char8 >*< char8 >*< char8 >*< char8 >*< char8 >*< + char8 >*< char8 >*< char8 >*< char8 >*< char8) + (' ', ('m', ('i', ('c', ('r', ('o', ('s', ('e', ('c', ('o', ('n', ('d', 's')))))))))))) \ No newline at end of file diff --git a/src/Database/PostgreSQL/Simple/Time/Interval.hs b/src/Database/PostgreSQL/Simple/Time/Interval.hs new file mode 100644 index 00000000..9e3c493a --- /dev/null +++ b/src/Database/PostgreSQL/Simple/Time/Interval.hs @@ -0,0 +1,11 @@ +module Database.PostgreSQL.Simple.Time.Interval where + +import Data.Int + +data Interval = Interval { intervalMonths :: Int32 + , intervalDays :: Int32 + , intervalMicroseconds :: Integer } + deriving (Show, Read, Eq) + +zeroInterval :: Interval +zeroInterval = Interval 0 0 0 \ No newline at end of file diff --git a/src/Database/PostgreSQL/Simple/ToField.hs b/src/Database/PostgreSQL/Simple/ToField.hs index cf1ace18..884e30a5 100644 --- a/src/Database/PostgreSQL/Simple/ToField.hs +++ b/src/Database/PostgreSQL/Simple/ToField.hs @@ -271,6 +271,10 @@ instance ToField NominalDiffTime where toField = Plain . inQuotes . nominalDiffTimeToBuilder {-# INLINE toField #-} +instance ToField Interval where + toField = Plain . inQuotes . intervalBuilder + {-# INLINE toField #-} + instance (ToField a) => ToField (PGArray a) where toField pgArray = case fromPGArray pgArray of diff --git a/test/Main.hs b/test/Main.hs index d71a9d0a..c86fe81f 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -47,6 +47,7 @@ tests env = testGroup "tests" , testCase "Notify" . testNotify , testCase "Serializable" . testSerializable , testCase "Time" . testTime + , testCase "Interval" . testInterval , testCase "Array" . testArray , testCase "Array of nullables" . testNullableArray , testCase "HStore" . testHStore diff --git a/test/Time.hs b/test/Time.hs index cb6137b9..55426953 100644 --- a/test/Time.hs +++ b/test/Time.hs @@ -32,13 +32,14 @@ generated with granularity of seconds down to microseconds in powers of ten. -} -module Time (testTime) where +module Time (testTime, testInterval) where import Common import Control.Monad(forM_, replicateM_) import Data.Time import Data.ByteString(ByteString) import Database.PostgreSQL.Simple.SqlQQ +import Database.PostgreSQL.Simple.Time numTests :: Int numTests = 200 @@ -117,3 +118,38 @@ checkRoundTrips TestEnv{..} limit = do res <- query conn [sql| SELECT y=? FROM testtime WHERE x=? |] yx assertBool "ZonedTime did not round-trip from SQL to Haskell and back" $ res == [Only True] + +testInterval :: TestEnv -> Assertion +testInterval env@TestEnv{..} = do + initializeIntervalTable env + checkIntervalRoundTrips env + +initializeIntervalTable :: TestEnv -> IO () +initializeIntervalTable TestEnv{..} = withTransaction conn $ do + execute_ conn [sql| CREATE TEMPORARY TABLE test_interval + ( x serial, y interval, PRIMARY KEY(x) )|] + let test :: ByteString -> IO () = \x -> do + execute conn [sql| + INSERT INTO test_interval (y) VALUES (?::interval) + |] (Only x) + return () + test "10 mon" + test "1 mons" + test "10 day" + test "1 days" + test "10 year" + test "1 years" + test "00:00:00.000001" + test "100000:00:00" + test "-04:00:00" + test "10 years 10 mons 10 days 1000:10:10.101101" + test "-15 years -15 mons -10 days -1515:15:15.151515" + test "20 years -8 months 11111 days -00:00:01.1" + +checkIntervalRoundTrips :: TestEnv -> IO () +checkIntervalRoundTrips TestEnv{..} = do + yxs :: [(Interval, Int)] <- query_ conn [sql| SELECT y, x FROM test_interval|] + forM_ yxs $ \yx -> do + res <- query conn [sql| SELECT y=? FROM test_interval WHERE x=? |] yx + assertBool ("Interval did not round-trip from SQL to Haskell and back " ++ show yx ++ " ") $ + res == [Only True]