From fa37faf30b3a26f9696905325b9b52122dd8ae57 Mon Sep 17 00:00:00 2001 From: SteveBash Date: Thu, 27 Apr 2017 17:43:37 -0500 Subject: [PATCH 1/6] Add connection retrying on startup and SIGHUP, Fix #742 --- CHANGELOG.md | 2 ++ main/Main.hs | 76 +++++++++++++++++++++++++++++++++--------- postgrest.cabal | 1 + src/PostgREST/App.hs | 33 +++++++++--------- src/PostgREST/Error.hs | 5 +++ 5 files changed, 86 insertions(+), 31 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f480e6938d..a21289ca92 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,8 @@ This project adheres to [Semantic Versioning](http://semver.org/). ### Added +- #742, Add connection retrying on startup and SIGHUP - @steve-chavez + ### Fixed ## [0.4.1.0] - 2017-04-25 diff --git a/main/Main.hs b/main/Main.hs index b9035d9481..417f7d61af 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -12,14 +12,15 @@ import PostgREST.Config (AppConfig (..), import PostgREST.Error (encodeError) import PostgREST.OpenAPI (isMalformedProxyUri) import PostgREST.DbStructure +import PostgREST.Types (DbStructure, Schema) import Control.AutoUpdate +import Control.Retry import Data.ByteString.Base64 (decode) import Data.String (IsString (..)) import Data.Text (stripPrefix, pack, replace) import Data.Text.Encoding (encodeUtf8, decodeUtf8) import Data.Text.IO (hPutStrLn, readFile) -import Data.Function (id) import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Hasql.Query as H import qualified Hasql.Session as H @@ -43,6 +44,59 @@ isServerVersionSupported = do H.statement "SELECT current_setting('server_version_num')::integer" HE.unit (HD.singleRow $ HD.value HD.int4) False +{-| + Background thread that does the following : + 1. Tries to connect to pg server and will keep trying until success. + 2. Checks if the pg version is supported and if it's not it kills the main program. + 3. Obtains the dbStructure. + 4. If 2 or 3 fail to give their result it means the connection is down so it goes back to 1, + otherwise it finishes his work successfully. +-} +connectionWorker :: ThreadId -> P.Pool -> Schema -> IORef (Maybe DbStructure) -> IO () +connectionWorker mainTid pool schema refDbStructure = void $ forkIO work + where + work = do + atomicWriteIORef refDbStructure Nothing + putStrLn ("Attempting to connect to the database..." :: Text) + connected <- connectingSucceeded pool + when connected $ do + result <- P.use pool $ do + supported <- isServerVersionSupported + unless supported $ liftIO $ do + hPutStrLn stderr + ("Cannot run in this PostgreSQL version, PostgREST needs at least " + <> pgvName minimumPgVersion) + killThread mainTid + dbStructure <- getDbStructure schema + liftIO $ atomicWriteIORef refDbStructure $ Just dbStructure + case result of + Left e -> do + putStrLn ("Failed to query the database. Retrying." :: Text) + hPutStrLn stderr (toS $ encodeError e) + work + Right _ -> putStrLn ("Connection successful" :: Text) + +-- | Connect to pg server if it fails retry with capped exponential backoff until success +connectingSucceeded :: P.Pool -> IO Bool +connectingSucceeded pool = + retrying (capDelay 32000000 $ exponentialBackoff 1000000) + shouldRetry + (const $ P.release pool >> isConnectionSuccessful) + where + isConnectionSuccessful :: IO Bool + isConnectionSuccessful = do + testConn <- P.use pool $ H.sql "SELECT 1" + case testConn of + Left e -> hPutStrLn stderr (toS $ encodeError e) >> pure False + _ -> pure True + shouldRetry :: RetryStatus -> Bool -> IO Bool + shouldRetry rs isConnSucc = do + delay <- pure $ fromMaybe 0 (rsPreviousDelay rs) `div` 1000000 + itShould <- pure $ not isConnSucc + when itShould $ + putStrLn $ "Attempting to reconnect to the database in " <> (show delay::Text) <> " seconds..." + return itShould + main :: IO () main = do hSetBuffering stdout LineBuffering @@ -67,31 +121,21 @@ main = do pool <- P.acquire (configPool conf, 10, pgSettings) - result <- P.use pool $ do - supported <- isServerVersionSupported - unless supported $ panic ( - "Cannot run in this PostgreSQL version, PostgREST needs at least " - <> pgvName minimumPgVersion) - getDbStructure (toS $ configSchema conf) + refDbStructure <- newIORef Nothing - forM_ (lefts [result]) $ \e -> do - hPutStrLn stderr (toS $ encodeError e) - exitFailure + mainTid <- myThreadId - refDbStructure <- newIORef $ either (panic . show) id result + connectionWorker mainTid pool (configSchema conf) refDbStructure #ifndef mingw32_HOST_OS - tid <- myThreadId forM_ [sigINT, sigTERM] $ \sig -> void $ installHandler sig (Catch $ do P.release pool - throwTo tid UserInterrupt + throwTo mainTid UserInterrupt ) Nothing void $ installHandler sigHUP ( - Catch . void . P.use pool $ do - s <- getDbStructure (toS $ configSchema conf) - liftIO $ atomicWriteIORef refDbStructure s + Catch $ connectionWorker mainTid pool (configSchema conf) refDbStructure ) Nothing #endif diff --git a/postgrest.cabal b/postgrest.cabal index 0848b93ca6..925444cbfe 100644 --- a/postgrest.cabal +++ b/postgrest.cabal @@ -40,6 +40,7 @@ executable postgrest , warp , bytestring , base64-bytestring + , retry if !os(windows) build-depends: unix diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 938a4590b1..a1241c85c5 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -45,6 +45,7 @@ import PostgREST.DbRequestBuilder( readRequest import PostgREST.Error ( simpleError, pgError , apiRequestError , singularityError, binaryFieldError + , connectionLostError ) import PostgREST.RangeQuery (allRange, rangeOffset) import PostgREST.Middleware @@ -62,7 +63,7 @@ import Data.Function (id) import Protolude hiding (intercalate, Proxy) import Safe (headMay) -postgrest :: AppConfig -> IORef DbStructure -> P.Pool -> IO POSIXTime -> +postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO POSIXTime -> Application postgrest conf refDbStructure pool getTime = let middle = (if configQuiet conf then id else logStdout) . defaultMiddle in @@ -70,20 +71,22 @@ postgrest conf refDbStructure pool getTime = middle $ \ req respond -> do time <- getTime body <- strictRequestBody req - dbStructure <- readIORef refDbStructure - - response <- case userApiRequest (configSchema conf) req body of - Left err -> return $ apiRequestError err - Right apiRequest -> do - let jwtSecret = binarySecret <$> configJwtSecret conf - eClaims = jwtClaims jwtSecret (iJWT apiRequest) time - authed = containsRole eClaims - handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest - txMode = transactionMode dbStructure - (iTarget apiRequest) (iAction apiRequest) - response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq - return $ either (pgError authed) identity response - respond response + maybeDbStructure <- readIORef refDbStructure + case maybeDbStructure of + Nothing -> respond connectionLostError + Just dbStructure -> do + response <- case userApiRequest (configSchema conf) req body of + Left err -> return $ apiRequestError err + Right apiRequest -> do + let jwtSecret = binarySecret <$> configJwtSecret conf + eClaims = jwtClaims jwtSecret (iJWT apiRequest) time + authed = containsRole eClaims + handleReq = runWithClaims conf eClaims (app dbStructure conf) apiRequest + txMode = transactionMode dbStructure + (iTarget apiRequest) (iAction apiRequest) + response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq + return $ either (pgError authed) identity response + respond response transactionMode :: DbStructure -> Target -> Action -> H.Mode transactionMode structure target action = diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index dbb8ba485e..c214d8dc40 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -8,6 +8,7 @@ module PostgREST.Error ( , simpleError , singularityError , binaryFieldError +, connectionLostError , encodeError ) where @@ -73,6 +74,10 @@ binaryFieldError = simpleError HT.status406 (toS (toMime CTOctetStream) <> " requested but a single column was not selected") +connectionLostError :: Response +connectionLostError = + simpleError HT.status503 "Database connection lost, retrying the connection." + encodeError :: JSON.ToJSON a => a -> LByteString encodeError = JSON.encode From 832365587faf979f86d419e0b3451ebf72cf6a5a Mon Sep 17 00:00:00 2001 From: SteveBash Date: Sun, 30 Apr 2017 02:25:43 -0500 Subject: [PATCH 2/6] Fix test suite --- test/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Main.hs b/test/Main.hs index 849a5072d9..55d18ec02d 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -41,7 +41,7 @@ main = do result <- P.use pool $ getDbStructure "test" - refDbStructure <- newIORef $ either (panic.show) id result + refDbStructure <- newIORef $ Just $ either (panic.show) id result let withApp = return $ postgrest (testCfg testDbConn) refDbStructure pool getTime ltdApp = return $ postgrest (testLtdRowsCfg testDbConn) refDbStructure pool getTime unicodeApp = return $ postgrest (testUnicodeCfg testDbConn) refDbStructure pool getTime From 1dd2c35c429b89483d0e509b78d16ad18d3e72e7 Mon Sep 17 00:00:00 2001 From: SteveBash Date: Tue, 2 May 2017 12:54:29 -0500 Subject: [PATCH 3/6] Ensure that only one connection worker can run at a time --- main/Main.hs | 23 ++++++++++++++++------- 1 file changed, 16 insertions(+), 7 deletions(-) diff --git a/main/Main.hs b/main/Main.hs index 417f7d61af..4b567ca78e 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -52,8 +52,12 @@ isServerVersionSupported = do 4. If 2 or 3 fail to give their result it means the connection is down so it goes back to 1, otherwise it finishes his work successfully. -} -connectionWorker :: ThreadId -> P.Pool -> Schema -> IORef (Maybe DbStructure) -> IO () -connectionWorker mainTid pool schema refDbStructure = void $ forkIO work +connectionWorker :: ThreadId -> P.Pool -> Schema -> IORef (Maybe DbStructure) -> IORef Bool -> IO () +connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do + isWorkerOn <- readIORef refIsWorkerOn + when (not isWorkerOn) $ do + atomicWriteIORef refIsWorkerOn True + void $ forkIO work where work = do atomicWriteIORef refDbStructure Nothing @@ -63,8 +67,8 @@ connectionWorker mainTid pool schema refDbStructure = void $ forkIO work result <- P.use pool $ do supported <- isServerVersionSupported unless supported $ liftIO $ do - hPutStrLn stderr - ("Cannot run in this PostgreSQL version, PostgREST needs at least " + hPutStrLn stderr + ("Cannot run in this PostgreSQL version, PostgREST needs at least " <> pgvName minimumPgVersion) killThread mainTid dbStructure <- getDbStructure schema @@ -74,7 +78,9 @@ connectionWorker mainTid pool schema refDbStructure = void $ forkIO work putStrLn ("Failed to query the database. Retrying." :: Text) hPutStrLn stderr (toS $ encodeError e) work - Right _ -> putStrLn ("Connection successful" :: Text) + Right _ -> do + atomicWriteIORef refIsWorkerOn False + putStrLn ("Connection successful" :: Text) -- | Connect to pg server if it fails retry with capped exponential backoff until success connectingSucceeded :: P.Pool -> IO Bool @@ -123,9 +129,12 @@ main = do refDbStructure <- newIORef Nothing + -- Helper ref to make sure just one connectionWorker can run at a time + refIsWorkerOn <- newIORef False + mainTid <- myThreadId - connectionWorker mainTid pool (configSchema conf) refDbStructure + connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn #ifndef mingw32_HOST_OS forM_ [sigINT, sigTERM] $ \sig -> @@ -135,7 +144,7 @@ main = do ) Nothing void $ installHandler sigHUP ( - Catch $ connectionWorker mainTid pool (configSchema conf) refDbStructure + Catch $ connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn ) Nothing #endif From 7c83a57cef7f91c1fc5f417ceebef91f86f28a4b Mon Sep 17 00:00:00 2001 From: SteveBash Date: Tue, 2 May 2017 15:52:31 -0500 Subject: [PATCH 4/6] Fix hlint suggestion --- main/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/main/Main.hs b/main/Main.hs index 4b567ca78e..072d4e1e21 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -55,7 +55,7 @@ isServerVersionSupported = do connectionWorker :: ThreadId -> P.Pool -> Schema -> IORef (Maybe DbStructure) -> IORef Bool -> IO () connectionWorker mainTid pool schema refDbStructure refIsWorkerOn = do isWorkerOn <- readIORef refIsWorkerOn - when (not isWorkerOn) $ do + unless isWorkerOn $ do atomicWriteIORef refIsWorkerOn True void $ forkIO work where From dacfc9d00578cd8f73937e4371d831fda9abcc8c Mon Sep 17 00:00:00 2001 From: SteveBash Date: Thu, 4 May 2017 13:15:43 -0500 Subject: [PATCH 5/6] Change ConnectionError status code to 503 and add automatic connection retrying --- main/Main.hs | 1 + src/PostgREST/App.hs | 13 ++++++++++--- src/PostgREST/Error.hs | 2 +- test/Main.hs | 12 ++++++------ 4 files changed, 18 insertions(+), 10 deletions(-) diff --git a/main/Main.hs b/main/Main.hs index 072d4e1e21..09f8ce5ec4 100644 --- a/main/Main.hs +++ b/main/Main.hs @@ -153,6 +153,7 @@ main = do defaultUpdateSettings { updateAction = getPOSIXTime } runSettings appSettings $ postgrest conf refDbStructure pool getTime + (connectionWorker mainTid pool (configSchema conf) refDbStructure refIsWorkerOn) loadSecretFile :: AppConfig -> IO AppConfig loadSecretFile conf = extractAndTransform mSecret diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index a1241c85c5..385fc7f3e0 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -64,8 +64,8 @@ import Protolude hiding (intercalate, Proxy) import Safe (headMay) postgrest :: AppConfig -> IORef (Maybe DbStructure) -> P.Pool -> IO POSIXTime -> - Application -postgrest conf refDbStructure pool getTime = + IO () -> Application +postgrest conf refDbStructure pool getTime worker = let middle = (if configQuiet conf then id else logStdout) . defaultMiddle in middle $ \ req respond -> do @@ -86,7 +86,14 @@ postgrest conf refDbStructure pool getTime = (iTarget apiRequest) (iAction apiRequest) response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq return $ either (pgError authed) identity response - respond response + if isResponse503 response then do + worker + respond response + else + respond response + +isResponse503 :: Response -> Bool +isResponse503 resp = statusCode (responseStatus resp) == 503 transactionMode :: DbStructure -> Target -> Action -> H.Mode transactionMode structure target action = diff --git a/src/PostgREST/Error.hs b/src/PostgREST/Error.hs index c214d8dc40..ab11e1f47e 100644 --- a/src/PostgREST/Error.hs +++ b/src/PostgREST/Error.hs @@ -133,7 +133,7 @@ instance JSON.ToJSON H.Error where "details" .= (fmap toS d::Maybe Text)] httpStatus :: Bool -> P.UsageError -> HT.Status -httpStatus _ (P.ConnectionError _) = HT.status500 +httpStatus _ (P.ConnectionError _) = HT.status503 httpStatus authed (P.SessionError (H.ResultError (H.ServerError c _ _ _))) = case toS c of '0':'8':_ -> HT.status503 -- pg connection err diff --git a/test/Main.hs b/test/Main.hs index 55d18ec02d..cdcb9d3c19 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -42,12 +42,12 @@ main = do result <- P.use pool $ getDbStructure "test" refDbStructure <- newIORef $ Just $ either (panic.show) id result - let withApp = return $ postgrest (testCfg testDbConn) refDbStructure pool getTime - ltdApp = return $ postgrest (testLtdRowsCfg testDbConn) refDbStructure pool getTime - unicodeApp = return $ postgrest (testUnicodeCfg testDbConn) refDbStructure pool getTime - proxyApp = return $ postgrest (testProxyCfg testDbConn) refDbStructure pool getTime - noJwtApp = return $ postgrest (testCfgNoJWT testDbConn) refDbStructure pool getTime - binaryJwtApp = return $ postgrest (testCfgBinaryJWT testDbConn) refDbStructure pool getTime + let withApp = return $ postgrest (testCfg testDbConn) refDbStructure pool getTime $ pure () + ltdApp = return $ postgrest (testLtdRowsCfg testDbConn) refDbStructure pool getTime $ pure () + unicodeApp = return $ postgrest (testUnicodeCfg testDbConn) refDbStructure pool getTime $ pure () + proxyApp = return $ postgrest (testProxyCfg testDbConn) refDbStructure pool getTime $ pure () + noJwtApp = return $ postgrest (testCfgNoJWT testDbConn) refDbStructure pool getTime $ pure () + binaryJwtApp = return $ postgrest (testCfgBinaryJWT testDbConn) refDbStructure pool getTime $ pure () let reset = resetDb testDbConn hspec $ do From cf5abfed98657558a5417c6b9a10563159ed39cb Mon Sep 17 00:00:00 2001 From: SteveBash Date: Sat, 6 May 2017 12:41:40 -0500 Subject: [PATCH 6/6] Refactor if statement to when --- src/PostgREST/App.hs | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs index 385fc7f3e0..44d5dcced5 100644 --- a/src/PostgREST/App.hs +++ b/src/PostgREST/App.hs @@ -86,11 +86,8 @@ postgrest conf refDbStructure pool getTime worker = (iTarget apiRequest) (iAction apiRequest) response <- P.use pool $ HT.transaction HT.ReadCommitted txMode handleReq return $ either (pgError authed) identity response - if isResponse503 response then do - worker - respond response - else - respond response + when (isResponse503 response) worker + respond response isResponse503 :: Response -> Bool isResponse503 resp = statusCode (responseStatus resp) == 503