Display an actual TCP port app is bound to (#3034)

src/PostgREST/AppState.hs

@@ -14,7 +14,10 @@ module PostgREST.AppState
   , getRetryNextIn
   , getTime
   , getJwtCache
+  , getSocketREST
+  , getSocketAdmin
   , init
+  , initSockets
   , initWithPool
   , logWithZTime
   , putSchemaCache
@@ -32,12 +35,14 @@ import qualified Data.ByteString.Char8      as BS
 import qualified Data.ByteString.Lazy       as LBS
 import qualified Data.Cache                 as C
 import           Data.Either.Combinators    (whenLeft)
+import qualified Data.Text                  as T (unpack)
 import qualified Data.Text.Encoding         as T
 import           Hasql.Connection           (acquire)
 import qualified Hasql.Notifications        as SQL
 import qualified Hasql.Pool                 as SQL
 import qualified Hasql.Session              as SQL
 import qualified Hasql.Transaction.Sessions as SQL
+import qualified Network.Socket             as NS
 import qualified PostgREST.Error            as Error
 import           PostgREST.Version          (prettyVersion)
 
@@ -63,10 +68,12 @@ import PostgREST.Config.PgVersion        (PgVersion (..),
 import PostgREST.SchemaCache             (SchemaCache,
                                           querySchemaCache)
 import PostgREST.SchemaCache.Identifiers (dumpQi)
+import PostgREST.Unix                    (createAndBindDomainSocket)
 
+import Data.Streaming.Network (bindPortTCP, bindRandomPortTCP)
+import Data.String            (IsString (..))
 import Protolude
 
-
 data AuthResult = AuthResult
   { authClaims :: KM.KeyMap JSON.Value
   , authRole   :: BS.ByteString
@@ -99,15 +106,23 @@ data AppState = AppState
   , debounceLogAcquisitionTimeout :: IO ()
   -- | JWT Cache
   , jwtCache                      :: C.Cache ByteString AuthResult
+  -- | Network socket for REST API
+  , stateSocketREST               :: NS.Socket
+  -- | Network socket for the admin UI
+  , stateSocketAdmin              :: Maybe NS.Socket
   }
 
+type AppSockets = (NS.Socket, Maybe NS.Socket)
+
 init :: AppConfig -> IO AppState
 init conf = do
   pool <- initPool conf
-  initWithPool pool conf
+  (sock, adminSock) <- initSockets conf
+  state' <- initWithPool (sock, adminSock) pool conf
+  pure state' { stateSocketREST = sock, stateSocketAdmin = adminSock }
 
-initWithPool :: SQL.Pool -> AppConfig -> IO AppState
-initWithPool pool conf = do
+initWithPool :: AppSockets -> SQL.Pool -> AppConfig -> IO AppState
+initWithPool (sock, adminSock) pool conf = do
   appState <- AppState pool
     <$> newIORef minimumPgVersion -- assume we're in a supported version when starting, this will be corrected on a later step
     <*> newIORef Nothing
@@ -121,6 +136,8 @@ initWithPool pool conf = do
     <*> newIORef 0
     <*> pure (pure ())
     <*> C.newCache Nothing
+    <*> pure sock
+    <*> pure adminSock
 
 
   debLogTimeout <-
@@ -144,6 +161,39 @@ initWithPool pool conf = do
 destroy :: AppState -> IO ()
 destroy = destroyPool
 
+initSockets :: AppConfig -> IO AppSockets
+initSockets AppConfig{..} = do
+  let
+    cfg'usp = configServerUnixSocket
+    cfg'uspm = configServerUnixSocketMode
+    cfg'host = configServerHost
+    cfg'port = configServerPort
+    cfg'adminport = configAdminServerPort
+
+  sock <- case cfg'usp of
+    -- I'm not using `streaming-commons`' bindPath function here because it's not defined for Windows,
+    -- but we need to have runtime error if we try to use it in Windows, not compile time error
+    Just path -> createAndBindDomainSocket path cfg'uspm
+    Nothing -> do
+      (_, sock) <-
+        if cfg'port /= 0
+          then do
+            sock <- bindPortTCP cfg'port (fromString $ T.unpack cfg'host)
+            pure (cfg'port, sock)
+          else do
+            -- explicitly bind to a random port, returning bound port number
+            (num, sock) <- bindRandomPortTCP (fromString $ T.unpack cfg'host)
+            pure (num, sock)
+      pure sock
+
+  adminSock <- case cfg'adminport of
+    Just adminPort -> do
+      adminSock <- bindPortTCP adminPort (fromString $ T.unpack cfg'host)
+      pure $ Just adminSock
+    Nothing -> pure Nothing
+
+  pure (sock, adminSock)
+
 initPool :: AppConfig -> IO SQL.Pool
 initPool AppConfig{..} =
   SQL.acquire
@@ -204,6 +254,12 @@ getTime = stateGetTime
 getJwtCache :: AppState -> C.Cache ByteString AuthResult
 getJwtCache = jwtCache
 
+getSocketREST :: AppState -> NS.Socket
+getSocketREST = stateSocketREST
+
+getSocketAdmin :: AppState -> Maybe NS.Socket
+getSocketAdmin = stateSocketAdmin
+
 -- | Log to stderr with local time
 logWithZTime :: AppState -> Text -> IO ()
 logWithZTime appState txt = do