Locked into UTCTime/UTCTime is slow

persistent-postgresql/Database/Persist/Postgresql.hs

@@ -576,8 +576,8 @@ builtinGetters = I.fromList
     , (k PS.varchar,     convertPV PersistText)
     , (k PS.date,        convertPV PersistDay)
     , (k PS.time,        convertPV PersistTimeOfDay)
-    , (k PS.timestamp,   convertPV (PersistUTCTime. localTimeToUTC utc))
-    , (k PS.timestamptz, convertPV PersistUTCTime)
+    , (k PS.timestamp,   convertPV (PersistByteString . unUnknown))
+    , (k PS.timestamptz, convertPV (PersistByteString . unUnknown))
     , (k PS.interval,    convertPV (PersistDbSpecific . pgIntervalToBs))
     , (k PS.bit,         convertPV PersistInt64)
     , (k PS.varbit,      convertPV PersistInt64)

persistent-postgresql/benchmark/ChronosPersistent.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+
+module ChronosPersistent where
+
+import qualified Data.Text as T
+import Data.String.Conversions (cs)
+import qualified Data.Attoparsec.ByteString as APBS
+import Database.Persist (PersistField(..), PersistValue(..))
+import Database.Persist.Sql (PersistFieldSql(..), SqlType(..))
+import Chronos (OffsetDatetime(..), parserUtf8_YmdHMSz, encode_YmdHMSz, OffsetFormat(..), DatetimeFormat(..), SubsecondPrecision(..), Datetime(..), Date(..), Year(..), Month(..), DayOfMonth(..), TimeOfDay(..), Offset(..), builder_Ymd)
+import qualified Data.Binary.Builder as B
+import Data.Aeson (ToJSON(..), FromJSON(..), Value(..))
+import qualified Data.Text.Lazy.Builder as DTLB
+import qualified Data.Aeson.Encoding as Encoding
+
+instance PersistField OffsetDatetime where
+  toPersistValue date = PersistText $ encode_YmdHMSz OffsetFormatColonAuto SubsecondPrecisionAuto datetimeFormat date
+  fromPersistValue (PersistByteString bs) = case APBS.parseOnly (parserUtf8_YmdHMSz OffsetFormatColonAuto datetimeFormat) bs of
+    Left err -> Left $ "When parsing a Chronos OffsetDatetime, got error: " <> T.pack err
+    Right offsetDateTime -> Right offsetDateTime
+  fromPersistValue bad = Left $ "When deserializing a Chronos OffsetDatetime, expected PersistByteString but got " <> (T.pack $ show bad)
+
+instance PersistFieldSql OffsetDatetime where
+  sqlType _ = SqlOther "timestamptz"
+
+
+datetimeFormat :: DatetimeFormat
+datetimeFormat = DatetimeFormat
+  { datetimeFormatDateSeparator = Just '-'
+  , datetimeFormatSeparator = Just ' '
+  , datetimeFormatTimeSeparator = Just ':'
+  }
+
+placeholderOffsetDatetime :: OffsetDatetime
+placeholderOffsetDatetime = 
+  let zeroDate = Date (Year 0) (Month 0) (DayOfMonth 1)
+      zeroTime = TimeOfDay 0 0 0
+      zeroDatetime = Datetime zeroDate zeroTime
+      utcOffset = Offset 0
+  in OffsetDatetime zeroDatetime utcOffset
+
+-- instance ToJSON Date where
+--   toJSON date = String $ cs $ DTLB.toLazyText $ builder_Ymd (Just '-') date
+--   toEncoding date = Encoding.lazyText $ DTLB.toLazyText $ builder_Ymd (Just '-') date

persistent-postgresql/benchmark/Main.hs

@@ -0,0 +1,76 @@
+{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+
+module Main where
+
+import Criterion.Main
+import Control.Exception (SomeException)
+import Control.Monad (void, replicateM, liftM, when, forM_)
+import Control.Monad.Trans.Reader
+import Data.Aeson (Value(..))
+import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..))
+import Database.Persist.Sql.Raw.QQ
+import Database.Persist.Postgresql.JSON()
+import Data.Time.Clock (getCurrentTime)
+import Control.Monad.IO.Class
+import Control.Monad.IO.Unlift (MonadUnliftIO)
+import UTCTimeSetup
+import Control.Monad.Logger
+import Database.Persist.Sql
+import Database.Persist.Postgresql
+import System.Log.FastLogger (fromLogStr)
+import Chronos (now, Offset(..), timeToOffsetDatetime)
+
+
+runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m ()
+runConn f = runConn_ f >>= const (return ())
+
+runConn_ :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m t
+runConn_ f = do
+  let debugPrint = False
+  let printDebug = if debugPrint then print . fromLogStr else void . return
+  flip runLoggingT (\_ _ _ s -> printDebug s) $ do
+    withPostgresqlPool ("host=" <> "localhost" <> " port=5432 user=postgres dbname=test") 1 $ runSqlPool f
+
+setup :: MonadIO m => Migration -> ReaderT SqlBackend m ()
+setup migration = do
+  printMigration migration
+  runMigrationUnsafe migration
+
+-- Our benchmark harness.
+main = do
+
+  runConn $ do
+    mapM_ setup
+      [ utcTimeBenchmarkMigration
+      ]
+
+  runConn $ do
+    deleteWhere ([] :: [Filter UserWithTimestamps])
+
+  -- currTime <- getCurrentTime
+  currTime <- now
+  let utcNow = timeToOffsetDatetime (Offset 0) currTime
+  let manyUsers = replicate 10000 $ UserWithTimestamps "first" "last" utcNow utcNow
+  runConn $ do
+    insertMany_ manyUsers
+
+  let debugPrint = False
+  let printDebug = if debugPrint then print . fromLogStr else void . return
+  -- flip runLoggingT (\_ _ _ s -> printDebug s) $ do
+  runNoLoggingT $ do
+    withPostgresqlPool ("host=" <> "localhost" <> " port=5432 user=postgres dbname=test") 1 $ \pool -> do
+
+      NoLoggingT (defaultMain
+        [ bench "postAdminOrganizationsStatusR" $ whnfIO (runSqlPool (selectList ([] :: [Filter UserWithTimestamps]) []) pool)
+        ])

persistent-postgresql/benchmark/UTCTimeSetup.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+
+module UTCTimeSetup where
+
+import Control.Exception (SomeException)
+import Control.Monad (void, replicateM, liftM, when, forM_)
+import Control.Monad.Trans.Reader
+import Data.Aeson (Value(..))
+import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..))
+import Database.Persist.Sql.Raw.QQ
+import Database.Persist.Postgresql.JSON()
+import Test.Hspec
+import Test.QuickCheck.Instances ()
+import Data.Time
+import Data.Text
+import Chronos (OffsetDatetime)
+import ChronosPersistent
+
+share [mkPersist sqlSettings, mkMigrate "utcTimeBenchmarkMigration"] [persistLowerCase|
+  UserWithTimestamps
+    firstName Text
+    lastName Text
+    createdAt OffsetDatetime
+    updatedAt OffsetDatetime
+|]