Connect to main app socket on health check

src/PostgREST/Admin.hs

@@ -0,0 +1,53 @@
+module PostgREST.Admin
+  ( postgrestAdmin
+  ) where
+
+import qualified Data.Text as T
+
+import Network.Socket
+import Network.Socket.ByteString
+
+import qualified Network.HTTP.Types.Status as HTTP
+import qualified Network.Wai               as Wai
+
+import qualified Hasql.Pool    as SQL
+import qualified Hasql.Session as SQL
+
+import qualified PostgREST.AppState as AppState
+import           PostgREST.Config   (AppConfig (..))
+
+import Protolude
+
+-- | PostgREST admin application
+postgrestAdmin :: AppState.AppState -> AppConfig -> Wai.Application
+postgrestAdmin appState appConfig req respond  = do
+  isMainAppReachable <- isRight <$> reachMainApp appConfig
+
+  case Wai.pathInfo req of
+    ["health"] ->
+      if configDbChannelEnabled appConfig then do
+        listenerOn <- AppState.getIsListenerOn appState
+        respond $ Wai.responseLBS (if listenerOn && isMainAppReachable then HTTP.status200 else HTTP.status503) [] mempty
+      else do
+        result <- SQL.use (AppState.getPool appState) $ SQL.sql "SELECT 1"
+        respond $ Wai.responseLBS (if isRight result && isMainAppReachable then HTTP.status200 else HTTP.status503) [] mempty
+    _ -> respond $ Wai.responseLBS HTTP.status404 [] mempty
+
+-- Try to connect to the main app socket
+-- Note that it doesn't even send a valid HTTP request, we just want to check that the main app is accepting connections
+reachMainApp :: AppConfig -> IO (Either IOException ())
+reachMainApp appConfig =
+  try . withSocketsDo $ bracket open close sendEmpty
+  where
+    open = case configServerUnixSocket appConfig of
+      Just path ->  do
+        sock <- socket AF_UNIX Stream 0
+        connect sock $ SockAddrUnix path
+        return sock
+      Nothing -> do
+        let hints = defaultHints { addrSocketType = Stream }
+        addr:_ <- getAddrInfo (Just hints) (Just . T.unpack $ configServerHost appConfig) (Just . show $ configServerPort appConfig)
+        sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
+        connect sock $ addrAddress addr
+        return sock
+    sendEmpty sock = void $ send sock mempty

src/PostgREST/App.hs

@@ -32,8 +32,7 @@ import qualified Data.HashMap.Strict             as M
 import qualified Data.Set                        as S
 import qualified Hasql.DynamicStatements.Snippet as SQL (Snippet)
 import qualified Hasql.Pool                      as SQL
-import qualified Hasql.Session                   as SQL (sql)
-import qualified Hasql.Transaction               as SQL hiding (sql)
+import qualified Hasql.Transaction               as SQL
 import qualified Hasql.Transaction.Sessions      as SQL
 import qualified Network.HTTP.Types.Header       as HTTP
 import qualified Network.HTTP.Types.Status       as HTTP
@@ -41,6 +40,7 @@ import qualified Network.HTTP.Types.URI          as HTTP
 import qualified Network.Wai                     as Wai
 import qualified Network.Wai.Handler.Warp        as Warp
 
+import qualified PostgREST.Admin                    as Admin
 import qualified PostgREST.AppState                 as AppState
 import qualified PostgREST.Auth                     as Auth
 import qualified PostgREST.DbStructure              as DbStructure
@@ -88,7 +88,6 @@ import qualified PostgREST.DbStructure.Proc as Proc
 
 import Protolude hiding (Handler)
 
-
 data RequestContext = RequestContext
   { ctxConfig      :: AppConfig
   , ctxDbStructure :: DbStructure
@@ -114,7 +113,7 @@ run installHandlers maybeRunWithSocket appState = do
   when configDbChannelEnabled $ listener appState
 
   let app = postgrest configLogLevel appState (connectionWorker appState)
-      adminApp = postgrestAdmin appState configDbChannelEnabled
+      adminApp = Admin.postgrestAdmin appState conf
 
   whenJust configAdminServerPort $ \adminPort -> do
     AppState.logWithZTime appState $ "Admin server listening on port " <> show adminPort
@@ -144,19 +143,6 @@ serverSettings AppConfig{..} =
     & setPort configServerPort
     & setServerName ("postgrest/" <> prettyVersion)
 
--- | PostgREST admin application
-postgrestAdmin :: AppState.AppState -> Bool -> Wai.Application
-postgrestAdmin appState configDbChannelEnabled req respond  =
-  case Wai.pathInfo req of
-    ["health"] ->
-      if configDbChannelEnabled then do
-        listenerOn <- AppState.getIsListenerOn appState
-        respond $ Wai.responseLBS (if listenerOn then HTTP.status200 else HTTP.status503) [] mempty
-      else do
-        result <- SQL.use (AppState.getPool appState) $ SQL.sql "SELECT 1"
-        respond $ Wai.responseLBS (if isRight result then HTTP.status200 else HTTP.status503) [] mempty
-    _ -> respond $ Wai.responseLBS HTTP.status404 [] mempty
-
 -- | PostgREST application
 postgrest :: LogLevel -> AppState.AppState -> IO () -> Wai.Application
 postgrest logLev appState connWorker =