From 9cd65a40336ccb326c849f5a9d5be822f65e1fe1 Mon Sep 17 00:00:00 2001
From: Joe Nelson <cred+github@begriffs.com>
Date: Mon, 3 Oct 2016 09:48:39 -0700
Subject: [PATCH] Avoid calling getPOSIXTime more than necessary

---
 main/Main.hs         |  8 +++++++-
 postgrest.cabal      |  2 ++
 src/PostgREST/App.hs |  9 +++++----
 test/Main.hs         | 16 +++++++++++-----
 4 files changed, 25 insertions(+), 10 deletions(-)

diff --git a/main/Main.hs b/main/Main.hs
index 938b6d5ab..f580ffb61 100644
--- a/main/Main.hs
+++ b/main/Main.hs
@@ -11,9 +11,11 @@ import           PostgREST.Config                     (AppConfig (..),
 import           PostgREST.OpenAPI                    (isMalformedProxyUri)
 import           PostgREST.DbStructure
 
+import           Control.AutoUpdate
 import           Data.String                          (IsString (..))
 import           Data.Text                            (stripPrefix)
 import           Data.Function                        (id)
+import           Data.Time.Clock.POSIX                (getPOSIXTime)
 import qualified Hasql.Query                          as H
 import qualified Hasql.Session                        as H
 import qualified Hasql.Decoders                       as HD
@@ -83,7 +85,11 @@ main = do
    ) Nothing
 #endif
 
-  runSettings appSettings $ postgrest conf refDbStructure pool
+  -- ask for the OS time at most once per second
+  getTime <- mkAutoUpdate
+    defaultUpdateSettings { updateAction = getPOSIXTime }
+
+  runSettings appSettings $ postgrest conf refDbStructure pool getTime
 
 loadSecretFile :: AppConfig -> IO AppConfig
 loadSecretFile conf = do
diff --git a/postgrest.cabal b/postgrest.cabal
index 8619ee999..119428bbb 100644
--- a/postgrest.cabal
+++ b/postgrest.cabal
@@ -30,6 +30,7 @@ executable postgrest
     "-with-rtsopts=-N -I2"
   default-language:    Haskell2010
   build-depends:       aeson (>= 0.8 && < 0.10) || (>= 0.11 && < 0.12)
+                     , auto-update
                      , base >= 4.8 && < 6
                      , bytestring
                      , bytestring-tree-builder == 0.2.7
@@ -152,6 +153,7 @@ Test-Suite spec
                      , SpecHelper
                      , TestTypes
   Build-Depends:       aeson
+                     , auto-update
                      , aeson-qq
                      , async
                      , base
diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs
index b2b2b065e..f3e898371 100644
--- a/src/PostgREST/App.hs
+++ b/src/PostgREST/App.hs
@@ -13,6 +13,7 @@ import           Data.List                 (delete, lookup)
 import           Data.Maybe                (fromJust)
 import           Data.Ranged.Ranges        (emptyRange)
 import           Data.Text                 (replace, strip, isInfixOf, dropWhile, drop, intercalate)
+import           Data.Time.Clock.POSIX     (POSIXTime)
 import           Data.Tree
 
 import qualified Hasql.Pool                as P
@@ -32,7 +33,6 @@ import           Web.JWT                   (secret)
 
 import           Data.Aeson
 import           Data.Aeson.Types          (emptyArray)
-import           Data.Time.Clock.POSIX     (getPOSIXTime)
 import qualified Data.Vector               as V
 import qualified Hasql.Transaction         as H
 
@@ -69,12 +69,13 @@ import           Data.Foldable (foldr1)
 import           Data.Function (id)
 import           Protolude                hiding (dropWhile, drop, intercalate, Proxy)
 
-postgrest :: AppConfig -> IORef DbStructure -> P.Pool -> Application
-postgrest conf refDbStructure pool =
+postgrest :: AppConfig -> IORef DbStructure -> P.Pool -> IO POSIXTime ->
+             Application
+postgrest conf refDbStructure pool getTime =
   let middle = (if configQuiet conf then id else logStdout) . defaultMiddle in
 
   middle $ \ req respond -> do
-    time <- getPOSIXTime
+    time <- getTime
     body <- strictRequestBody req
     dbStructure <- readIORef refDbStructure
 
diff --git a/test/Main.hs b/test/Main.hs
index 6334ac88a..63d5aa158 100644
--- a/test/Main.hs
+++ b/test/Main.hs
@@ -7,8 +7,10 @@ import qualified Hasql.Pool as P
 
 import PostgREST.DbStructure (getDbStructure)
 import PostgREST.App (postgrest)
+import Control.AutoUpdate
 import Data.IORef
 import Data.String.Conversions (cs)
+import Data.Time.Clock.POSIX   (getPOSIXTime)
 
 import qualified Feature.AuthSpec
 import qualified Feature.ConcurrentSpec
@@ -28,14 +30,18 @@ main = do
   setupDb
 
   pool <- P.acquire (3, 10, cs testDbConn)
+  -- ask for the OS time at most once per second
+  getTime <- mkAutoUpdate
+    defaultUpdateSettings { updateAction = getPOSIXTime }
+
 
   result <- P.use pool $ getDbStructure "test"
   refDbStructure <- newIORef $ either (error.show) id result
-  let withApp = return $ postgrest testCfg refDbStructure pool
-      ltdApp  = return $ postgrest testLtdRowsCfg refDbStructure pool
-      unicodeApp = return $ postgrest testUnicodeCfg refDbStructure pool
-      proxyApp = return $ postgrest testProxyCfg refDbStructure pool
-      noJwtApp = return $ postgrest testCfgNoJWT refDbStructure pool
+  let withApp = return $ postgrest testCfg refDbStructure pool getTime
+      ltdApp  = return $ postgrest testLtdRowsCfg refDbStructure pool getTime
+      unicodeApp = return $ postgrest testUnicodeCfg refDbStructure pool getTime
+      proxyApp = return $ postgrest testProxyCfg refDbStructure pool getTime
+      noJwtApp = return $ postgrest testCfgNoJWT refDbStructure pool getTime
 
   hspec $ do
     mapM_ (beforeAll_ resetDb . before withApp) specs