Display an actual TCP port app is bound to

main/Main.hs

@@ -1,37 +1,16 @@
-{-# LANGUAGE CPP #-}
-
 module Main (main) where
 
 import System.IO (BufferMode (..), hSetBuffering)
 
-import qualified PostgREST.App as App
 import qualified PostgREST.CLI as CLI
 
 import Protolude
 
-#ifndef mingw32_HOST_OS
-import qualified PostgREST.Unix as Unix
-#endif
-
 main :: IO ()
 main = do
   setBuffering
   opts <- CLI.readCLIShowHelp
-  CLI.main installSignalHandlers runAppInSocket opts
-
-installSignalHandlers :: App.SignalHandlerInstaller
-#ifndef mingw32_HOST_OS
-installSignalHandlers = Unix.installSignalHandlers
-#else
-installSignalHandlers _ = pass
-#endif
-
-runAppInSocket :: Maybe App.SocketRunner
-#ifndef mingw32_HOST_OS
-runAppInSocket = Just Unix.runAppWithSocket
-#else
-runAppInSocket = Nothing
-#endif
+  CLI.main opts
 
 setBuffering :: IO ()
 setBuffering = do

postgrest.cabal

@@ -64,6 +64,7 @@ library
                       PostgREST.Plan.ReadPlan
                       PostgREST.Plan.Types
                       PostgREST.RangeQuery
+                      PostgREST.Unix
                       PostgREST.ApiRequest
                       PostgREST.ApiRequest.Preferences
                       PostgREST.ApiRequest.QueryParams
@@ -89,6 +90,7 @@ library
                     , containers                >= 0.5.7 && < 0.7
                     , contravariant-extras      >= 0.3.3 && < 0.4
                     , cookie                    >= 0.4.2 && < 0.5
+                    , directory                 >= 1.2.6 && < 1.4
                     , either                    >= 4.4.1 && < 5.1
                     , extra                     >= 1.7.0 && < 2.0
                     , fuzzyset                  >= 0.2.3
@@ -114,11 +116,13 @@ library
                     , regex-tdfa                >= 1.2.2 && < 1.4
                     , retry                     >= 0.7.4 && < 0.10
                     , scientific                >= 0.3.4 && < 0.4
+                    , streaming-commons         >= 0.1.1 && < 0.3
                     , swagger2                  >= 2.4 && < 2.9
                     , text                      >= 1.2.2 && < 1.3
                     , time                      >= 1.6 && < 1.12
                     , timeit                    >= 2.0 && < 2.1
                     , unordered-containers      >= 0.2.8 && < 0.3
+                    , unix-compat               >= 0.5.4 && < 0.6
                     , vault                     >= 0.3.1.5 && < 0.4
                     , vector                    >= 0.11 && < 0.14
                     , wai                       >= 3.2.1 && < 3.3
@@ -148,9 +152,6 @@ library
   if !os(windows)
     build-depends:
       unix
-      , directory >= 1.2.6 && < 1.4
-    exposed-modules:
-      PostgREST.Unix
 
 executable postgrest
   default-language:   Haskell2010

src/PostgREST/Admin.hs

@@ -1,11 +1,9 @@
-{-# LANGUAGE NamedFieldPuns  #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE NamedFieldPuns #-}
 
 module PostgREST.Admin
   ( runAdmin
   ) where
 
-import qualified Data.Text                 as T
 import qualified Hasql.Session             as SQL
 import qualified Network.HTTP.Types.Status as HTTP
 import qualified Network.Wai               as Wai
@@ -22,19 +20,20 @@ import PostgREST.Config   (AppConfig (..))
 import qualified PostgREST.AppState as AppState
 
 import Protolude
+import Protolude.Partial (fromJust)
 
 runAdmin :: AppConfig -> AppState -> Warp.Settings -> IO ()
 runAdmin conf@AppConfig{configAdminServerPort} appState settings =
-  whenJust configAdminServerPort $ \adminPort -> do
-    AppState.logWithZTime appState $ "Admin server listening on port " <> show adminPort
-    void . forkIO $ Warp.runSettings (settings & Warp.setPort adminPort) adminApp
+  whenJust (AppState.getSocketAdmin appState) $ \adminSocket -> do
+    AppState.logWithZTime appState $ "Admin server listening on port " <> show (fromIntegral (fromJust configAdminServerPort) :: Integer)
+    void . forkIO $ Warp.runSettingsSocket settings adminSocket adminApp
   where
     adminApp = admin appState conf
 
 -- | PostgREST admin application
 admin :: AppState.AppState -> AppConfig -> Wai.Application
 admin appState appConfig req respond  = do
-  isMainAppReachable  <- any isRight <$> reachMainApp appConfig
+  isMainAppReachable  <- isRight <$> reachMainApp (AppState.getSocketREST appState)
   isSchemaCacheLoaded <- isJust <$> AppState.getSchemaCache appState
   isConnectionUp      <-
     if configDbChannelEnabled appConfig
@@ -53,35 +52,16 @@ admin appState appConfig req respond  = do
 -- Note that it doesn't even send a valid HTTP request, we just want to check that the main app is accepting connections
 -- The code for resolving the "*4", "!4", "*6", "!6", "*" special values is taken from
 -- https://hackage.haskell.org/package/streaming-commons-0.2.2.4/docs/src/Data.Streaming.Network.html#bindPortGenEx
-reachMainApp :: AppConfig -> IO [Either IOException ()]
-reachMainApp AppConfig{..} =
-  case configServerUnixSocket of
-    Just path ->  do
-      sock <- socket AF_UNIX Stream 0
-      (:[]) <$> try (do
-        connect sock $ SockAddrUnix path
-        withSocketsDo $ bracket (pure sock) close sendEmpty)
-    Nothing -> do
-      let
-        host | configServerHost `elem` ["*4", "!4", "*6", "!6", "*"] = Nothing
-             | otherwise                                             = Just configServerHost
-        filterAddrs xs =
-          case configServerHost of
-              "*4" -> ipv4Addrs xs ++ ipv6Addrs xs
-              "!4" -> ipv4Addrs xs
-              "*6" -> ipv6Addrs xs ++ ipv4Addrs xs
-              "!6" -> ipv6Addrs xs
-              _    -> xs
-        ipv4Addrs = filter ((/=) AF_INET6 . addrFamily)
-        ipv6Addrs = filter ((==) AF_INET6 . addrFamily)
-
-      addrs <- getAddrInfo (Just $ defaultHints { addrSocketType = Stream }) (T.unpack <$> host) (Just . show $ configServerPort)
-      tryAddr `traverse` filterAddrs addrs
+reachMainApp :: Socket -> IO (Either IOException ())
+reachMainApp appSock = do
+  sockAddr <- getSocketName appSock
+  sock <- socket (addrFamily sockAddr) Stream defaultProtocol
+  try $ do
+    connect sock sockAddr
+    withSocketsDo $ bracket (pure sock) close sendEmpty
   where
     sendEmpty sock = void $ send sock mempty
-    tryAddr :: AddrInfo -> IO (Either IOException ())
-    tryAddr addr = do
-      sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
-      try $ do
-        connect sock $ addrAddress addr
-        withSocketsDo $ bracket (pure sock) close sendEmpty
+    addrFamily (SockAddrInet _ _) = AF_INET
+    addrFamily (SockAddrInet6 {}) = AF_INET6
+    addrFamily (SockAddrUnix _)   = AF_UNIX
+

src/PostgREST/App.hs

@@ -12,9 +12,7 @@ Some of its functionality includes:
 {-# LANGUAGE NamedFieldPuns  #-}
 {-# LANGUAGE RecordWildCards #-}
 module PostgREST.App
-  ( SignalHandlerInstaller
-  , SocketRunner
-  , postgrest
+  ( postgrest
   , run
   ) where
 
@@ -25,7 +23,6 @@ import Data.Maybe               (fromJust)
 import Data.String              (IsString (..))
 import Network.Wai.Handler.Warp (defaultSettings, setHost, setPort,
                                  setServerName)
-import System.Posix.Types       (FileMode)
 
 import qualified Data.HashMap.Strict        as HM
 import qualified Data.Text.Encoding         as T
@@ -44,6 +41,7 @@ import qualified PostgREST.Logger           as Logger
 import qualified PostgREST.Plan             as Plan
 import qualified PostgREST.Query            as Query
 import qualified PostgREST.Response         as Response
+import qualified PostgREST.Unix             as Unix (installSignalHandlers)
 
 import PostgREST.ApiRequest           (Action (..), ApiRequest (..),
                                        Mutation (..), Target (..))
@@ -64,40 +62,32 @@ import qualified Data.ByteString.Char8 as BS
 import qualified Data.List             as L
 import qualified Data.Map              as Map (fromList)
 import qualified Network.HTTP.Types    as HTTP
+import qualified Network.Socket        as NS
 import           Protolude             hiding (Handler)
 import           System.TimeIt         (timeItT)
 
 type Handler = ExceptT Error
 
-type SignalHandlerInstaller = AppState -> IO()
-
-type SocketRunner = Warp.Settings -> Wai.Application -> FileMode -> FilePath -> IO()
-
-run :: SignalHandlerInstaller -> Maybe SocketRunner -> AppState -> IO ()
-run installHandlers maybeRunWithSocket appState = do
+run :: AppState -> IO ()
+run appState = do
   conf@AppConfig{..} <- AppState.getConfig appState
   AppState.connectionWorker appState -- Loads the initial SchemaCache
-  installHandlers appState
+  Unix.installSignalHandlers (AppState.getMainThreadId appState) (AppState.connectionWorker appState) (AppState.reReadConfig False appState)
   -- reload schema cache + config on NOTIFY
   AppState.runListener conf appState
 
   Admin.runAdmin conf appState $ serverSettings conf
 
   let app = postgrest conf appState (AppState.connectionWorker appState)
 
-  case configServerUnixSocket of
-    Just socket ->
-      -- run the postgrest application with user defined socket. Only for UNIX systems
-      case maybeRunWithSocket of
-        Just runWithSocket -> do
-          AppState.logWithZTime appState $ "Listening on unix socket " <> show socket
-          runWithSocket (serverSettings conf) app configServerUnixSocketMode socket
-        Nothing ->
-          panic "Cannot run with unix socket on non-unix platforms."
-    Nothing ->
-      do
-        AppState.logWithZTime appState $ "Listening on port " <> show configServerPort
-        Warp.runSettings (serverSettings conf) app
+  what <- case configServerUnixSocket of
+    Just path -> pure $ "unix socket " <> show path
+    Nothing   -> do
+      port <- NS.socketPort $ AppState.getSocketREST appState
+      pure $ "port " <> show port
+  AppState.logWithZTime appState $ "Listening on " <> what
+
+  Warp.runSettingsSocket (serverSettings conf) (AppState.getSocketREST appState) app
 
 serverSettings :: AppConfig -> Warp.Settings
 serverSettings AppConfig{..} =

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

src/PostgREST/CLI.hs

@@ -29,8 +29,8 @@ import qualified PostgREST.Config   as Config
 import Protolude hiding (hPutStrLn)
 
 
-main :: App.SignalHandlerInstaller -> Maybe App.SocketRunner -> CLI -> IO ()
-main installSignalHandlers runAppWithSocket CLI{cliCommand, cliPath} = do
+main :: CLI -> IO ()
+main CLI{cliCommand, cliPath} = do
   conf@AppConfig{..} <-
     either panic identity <$> Config.readAppConfig mempty cliPath Nothing mempty mempty
 
@@ -45,7 +45,7 @@ main installSignalHandlers runAppWithSocket CLI{cliCommand, cliPath} = do
         when configDbConfig $ AppState.reReadConfig True appState
         putStr . Config.toText =<< AppState.getConfig appState
       CmdDumpSchema -> putStrLn =<< dumpSchema appState
-      CmdRun -> App.run installSignalHandlers runAppWithSocket appState)
+      CmdRun -> App.run appState)
 
 -- | Dump SchemaCache schema to JSON
 dumpSchema :: AppState -> IO LBS.ByteString