interval implemented for default postgres.

IHP/ModelSupport.hs

@@ -6,7 +6,7 @@ module IHP.ModelSupport
 , module IHP.Postgres.Polygon
 , module IHP.Postgres.Inet
 , module IHP.Postgres.TSVector
-, module IHP.Postgres.Interval
+, module IHP.Postgres.TimeParser
 ) where
 
 import IHP.HaskellSupport
@@ -44,7 +44,7 @@ import IHP.Postgres.Interval
 import IHP.Postgres.Polygon
 import IHP.Postgres.Inet ()
 import IHP.Postgres.TSVector
-import IHP.Postgres.Interval
+import IHP.Postgres.TimeParser
 import IHP.Log.Types
 import qualified IHP.Log as Log
 import Data.Dynamic
@@ -685,6 +685,9 @@ instance Default UTCTime where
 instance Default (PG.Binary ByteString) where
     def = PG.Binary ""
 
+instance Default PGInterval where
+    def = PGInterval "00:00:00"
+
 class Record model where
     newRecord :: model
 

IHP/Postgres/Interval.hs

@@ -1,77 +1,36 @@
+{-# LANGUAGE TemplateHaskell #-}
 {-|
 Module: IHP.Postgres.Interval
 Description: Adds support for the Postgres Interval type
 Copyright: (c) digitally induced GmbH, 2020
 -}
 module IHP.Postgres.Interval where
 
-import GHC.Float
-import ClassyPrelude hiding (try, map, (.))
+import BasicPrelude
 
-import Data.Time.Clock
-import Data.Fixed
 import Database.PostgreSQL.Simple.ToField
 import Database.PostgreSQL.Simple.FromField
-import Database.PostgreSQL.Simple.Time.Internal (getTimeOfDay)
 import qualified Database.PostgreSQL.Simple.TypeInfo.Static as TI
-import           Database.PostgreSQL.Simple.TypeInfo.Macro as TI
-import           Data.ByteString.Builder (byteString, char8)
+import Database.PostgreSQL.Simple.TypeInfo.Macro as TI
+import Data.Attoparsec.ByteString.Char8 as Attoparsec
+import Data.String.Conversions (cs)
 
-import Text.Megaparsec
-import Data.Void
-import Text.Megaparsec.Char
-import qualified Text.Megaparsec.Char.Lexer as Lexer
+import IHP.Postgres.TimeParser (PGInterval(..))
 
-import IHP.Postgres.TimeParser (pClockTime)
+instance FromField PGInterval where
+    fromField f v =
+        if typeOid f /= $(inlineTypoid TI.interval)
+        then returnError Incompatible f ""
+        else case v of
+               Nothing -> returnError UnexpectedNull f ""
+               Just bs -> case parseOnly pPGInterval bs of
+                     Left  err -> returnError ConversionFailed f err
+                     Right val -> pure val
 
-spaceConsumer :: Parser ()
-spaceConsumer = Lexer.space
-    space1
-    (Lexer.skipLineComment "//")
-    (Lexer.skipBlockComment "/*" "*/")
+pPGInterval = do
+    bs <- takeByteString
+    pure (PGInterval bs)
 
-lexeme :: Parser a -> Parser a
-lexeme = Lexer.lexeme spaceConsumer
 
-symbol :: Text -> Parser Text
-symbol = Lexer.symbol spaceConsumer
-
-symbol' :: Text -> Parser Text
-symbol' = Lexer.symbol' spaceConsumer
-
-
-
--- | See https://stackoverflow.com/questions/32398878/converting-postgres-interval-to-haskell-nominaltimediff-with-postgresql-simple
--- To support NominalDiffTime we parse Y year[s] M mon[s] D day[s] [-]HHH:MM:SS.[SSSs]
--- The default is the postgres format.
--- Corresponds to the postgresql interval 6 months see the documentation (https://www.postgresql.org/docs/current/datatype-datetime.html).
-
-type Parser = Parsec Void Text
-
-instance FromField NominalDiffTime where
-    fromField f mdat =
-        if typeOid f /= typoid pClockTime
-            then returnError Incompatible f ""
-            else case mdat of
-                Nothing  -> returnError UnexpectedNull f ""
-                Just dat -> case parseOnly (pNominalDiffTime <* endOfInput) dat of
-                    Left msg  -> returnError ConversionFailed f msg
-                    Right t   -> return t
-
-pNominalDiffTime :: Parser NominalDiffTime
-pNominalDiffTime = do
-    (years, mons, days) <- pCalTime
-    (h, m, s) <- pClockTime
-
-    let calTime =  fromRational . toRational $ (\[y,m,d] -> (365*nominalDay*y 30*nominalDay*m + nominalDay*d)) $ map (fromMaybe 0) [years, mons, days]
-    let clockTime = fromRational . toRational $ s + 60*(fromIntegral m) + 60*60*(fromIntegral h)
-
-    pure (calTime + clockTime)
-
--- | Parse a limited postgres interval of the form [-]HHH:MM:SS.[SSSS] (no larger units than hours).
-pCalTime :: Parser (Maybe Int, Maybe Int, Maybe Int)
-pCalTime = do
-    years <- try $ Lexer.decimal <* (choice $ map symbol' ["years", "year"])
-    mons  <-  try $ Lexer.decimal <* (choice $ map symbol' ["mons", "mon"])
-    days <-  try $ Lexer.decimal <* (choice $ map symbol' ["days", "day"])
-    pure (years, mons, days)
+instance ToField PGInterval where
+    toField (PGInterval interval) = toField (interval)

IHP/Postgres/TimeParser.hs

@@ -1,34 +1,67 @@
+{-# LANGUAGE BangPatterns, CPP, GADTs, OverloadedStrings, RankNTypes, RecordWildCards #-}
 module IHP.Postgres.TimeParser where
 
--- |
--- Module:      Database.PostgreSQL.Simple.Time.Internal.Parser
--- Copyright:   (c) 2012-2015 Leon P Smith
---              (c) 2015 Bryan O'Sullivan
--- License:     BSD3
--- Maintainer:  Leon P Smith <[email protected]>
--- Stability:   experimental
---
--- Parsers for parsing dates and times.
-
-
-import Control.Applicative ((<$>), (<*>), (<*), (*>))
-import Data.Attoparsec.ByteString.Char8 as A
+import BasicPrelude hiding (takeWhile)
+import Data.Attoparsec.ByteString.Char8
+import Data.Attoparsec.Combinator
 import Data.Bits ((.&.))
 import Data.ByteString (ByteString)
 import Data.Char (ord)
+import Control.Applicative ((<|>))
+
 import Data.Fixed (Pico, Fixed(MkFixed))
 import Data.Int (Int64)
 import Data.Maybe (fromMaybe)
 import Data.Time.Calendar.Compat (Day, fromGregorianValid, addDays)
-import Data.Time.Clock.Compat (UTCTime(..))
+import Data.Time.Clock.Compat (UTCTime(..), NominalDiffTime)
 import Data.Time.Format.ISO8601.Compat (iso8601ParseM)
 import Data.Time.LocalTime.Compat (CalendarDiffTime)
+import Data.String.Conversions (cs)
 import qualified Data.ByteString.Char8 as B8
 import qualified Data.Time.LocalTime.Compat as Local
 
--- Take from Postgresql Internal to facilitate a definition of a NominalDiffTime FromField
-toPico :: Integer -> Pico
-toPico = MkFixed
+--Simple newtype wrapper around a postgres interval bytestring.
+newtype PGInterval = PGInterval ByteString deriving (Eq, Show)
+
+-- The mapping of the "interval" bytestring into application
+-- logic depends on the Interval Output Style of the postgres database
+-- and the semantics of the interval quantity in the application code (if they differ from the postgres
+-- interpretation for some reason).
+-- This module provides the PGInterval wrapper type and a parser for the default
+-- `postgres` output style into a a PGTimeInterval data struct of years, months, days, and NominalDiffTime.
+--  These can be combined with the standard Calendar/Time library to perform Calendar Arithmetic
+--  Days and Years are big Integers and can be added to the Gregorian year and Julian Day respectively
+--  Months are small Int (up to 1-11) denoting a month of the year, and the pgClock is a Nominal DiffTime
+--  representing the time as measured by a clock without leap seconds.
+
+data PGTimeInterval = PGTimeInterval { pgYears :: Integer
+                                     , pgMonths :: Int
+                                     , pgDays :: Integer
+                                     , pgClock :: NominalDiffTime} deriving (Eq, Show)
+
+-- To support the default postgres output style PGInterval -> PGTimeInterval
+-- in Application Code we provide the parser combinators for the `postgres` output style.
+-- for parsing (optional combination of): Y year[s] M mon[s] D day[s] [-]HH:MM:SS.[SSSs].
+-- This corresponds to the default interval `postgres` format.
+-- (https://www.postgresql.org/docs/current/datatype-datetime.html).
+-- alternative parsers would need to be provided for the `sql_standard`, `postgres_verbose`, and `iso_8601`
+-- styles/
+
+unpackInterval (PGInterval bs) = case parseOnly pPGInterval bs of
+    Left err -> error ("Couldn't parse PGInterval. " <> cs err)
+    Right val -> val
+
+
+pPGInterval :: Parser PGTimeInterval
+pPGInterval = do
+    year <- option 0 ((signed decimal <* space <* ( "years" <|>  "year")))
+    skipSpace
+    mons <-  option 0 ((signed decimal <* space <* (string "mons" <|>  string "mon")))
+    skipSpace
+    days <- option 0 ((signed decimal <* space <* (string "days" <|>  "day")))
+    skipSpace
+    timeOfDay <- option 0 nominalDiffTime
+    pure (PGTimeInterval year mons days timeOfDay)
 
 
 -- | Parse a two-digit integer (e.g. day of month, hour).
@@ -37,12 +70,27 @@ twoDigits = do
   a <- digit
   b <- digit
   let c2d c = ord c .&. 15
-  return $! c2d a * 10 + c2d b
+  pure $! c2d a * 10 + c2d b
+
 
+-- Take from Postgresql Internal to facilitate a definition of a NominalDiffTime FromField
+-- | See https://stackoverflow.com/questions/32398878/converting-postgres-interval-to-haskell-nominaltimediff-with-postgresql-simple
+-- |
+-- Module:      Database.PostgreSQL.Simple.Time.Internal.Parser
+-- Copyright:   (c) 2012-2015 Leon P Smith
+--              (c) 2015 Bryan O'Sullivan
+-- License:     BSD3
+-- Maintainer:  Leon P Smith <[email protected]>
+-- Stability:   experimental
+--
+-- Parsers for parsing dates and times.
 
+toPico :: Integer -> Pico
+toPico = MkFixed
 -- | Parse a time of the form @HH:MM[:SS[.SSS]]@.
-timeOfDay :: Parser Local.TimeOfDay
-timeOfDay = do
+
+pClockInterval :: Parser Local.TimeOfDay
+pClockInterval = do
   h <- twoDigits <* char ':'
   m <- twoDigits
   mc <- peekChar
@@ -62,21 +110,25 @@ seconds = do
   case mc of
     Just '.' -> do
       t <- anyChar *> takeWhile1 isDigit
-      return $! parsePicos (fromIntegral real) t
-    _ -> return $! fromIntegral real
+      pure $! parsePicos (fromIntegral real) t
+    _ -> pure $! fromIntegral real
  where
   parsePicos :: Int64 -> B8.ByteString -> Pico
   parsePicos a0 t = toPico (fromIntegral (t' * 10^n))
     where n  = max 0 (12 - B8.length t)
           t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0
                          (B8.take 12 t)
 
+nominalDiffTime :: Parser NominalDiffTime
+nominalDiffTime = do
+    (h, m, s) <- pClockTime
+    pure . fromRational . toRational $ s + 60*(fromIntegral m) + 60*60*(fromIntegral h)
+
+
 -- | Parse a limited postgres interval of the form [-]HHH:MM:SS.[SSSS] (no larger units than hours).
 pClockTime :: Parser (Int, Int, Pico)
 pClockTime = do
     h <- try $ signed decimal <* char ':'
     m <- try $ twoDigits <* char ':'
     s <- try seconds
-    if m < 60 && s <= 60
-        then return (h, m, s)
-        else fail "invalid interval"
+    pure (h,m,s)

IHP/SchemaCompiler.hs

@@ -68,7 +68,7 @@ atomicType = \case
     PDate -> "Data.Time.Calendar.Day"
     PBinary -> "(Binary ByteString)"
     PTime -> "TimeOfDay"
-    (PInterval _) -> "NominalDiffTime"
+    (PInterval _) -> "PGInterval"
     PCustomType theType -> tableNameToModelName theType
     PTimestamp -> "LocalTime"
     (PNumeric _ _) -> "Scientific"

Test/Main.hs

@@ -45,6 +45,7 @@ import qualified Test.ServerSideComponent.HtmlParserSpec
 import qualified Test.ServerSideComponent.HtmlDiffSpec
 import qualified Test.Postgres.Point
 import qualified Test.Postgres.Polygon
+import qualified Test.Postgres.Interval
 import qualified Test.Postgres.TSVector
 import qualified Test.FileStorage.MimeTypesSpec
 import qualified Test.DataSync.DynamicQueryCompiler
@@ -84,6 +85,7 @@ main = hspec do
     Test.ServerSideComponent.HtmlDiffSpec.tests
     Test.Postgres.Point.tests
     Test.Postgres.Polygon.tests
+    Test.Postgres.Interval.tests
     Test.Postgres.TSVector.tests
     Test.FileStorage.MimeTypesSpec.tests
     Test.DataSync.DynamicQueryCompiler.tests

Test/Postgres/Interval.hs

@@ -0,0 +1,23 @@
+{-|
+Module: Test.Postgres.Interval
+Copyright: (c) digitally induced GmbH, 2023
+-}
+module Test.Postgres.Interval where
+
+import Test.Hspec
+import Test.Postgres.Support
+import IHP.Prelude
+import IHP.Postgres.Interval
+import IHP.Postgres.TimeParser
+import Database.PostgreSQL.Simple.ToField
+import qualified Data.Attoparsec.ByteString.Char8 as Attoparsec
+
+tests = do
+    describe "Interval" do
+        describe "Parser" do
+            it "Should Parse" do
+                unpackInterval (PGInterval "25 years 6 mons 4 days 114:00:00.123") `shouldBe`  (PGTimeInterval 25 6 4 410400.123)
+            it "Should Parse" do
+               unpackInterval (PGInterval "25 years 01:00:00") `shouldBe`  (PGTimeInterval 25 0 0 3600)
+            it "Should Parse" do
+                unpackInterval (PGInterval "11 years 10 mons 683 days") `shouldBe` (PGTimeInterval 11 10 683 0)