Taimoor ZaeemandSteve Chavez
a9a1763328
The `--ready` flag is a wrapper around the admin server `/ready` request. This is done through using an http client library in postgrest. Signed-off-by: Taimoor Zaeem <taimoorzaeem@gmail.com>
101 lines
4.1 KiB
Haskell
101 lines
4.1 KiB
Haskell
{-|
|
|
Module : PostgREST.Client
|
|
Description : PostgREST HTTP client
|
|
-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
module PostgREST.Client
|
|
( ready
|
|
) where
|
|
|
|
import qualified Data.Text as T
|
|
import qualified Network.HTTP.Client as HC
|
|
import qualified Network.HTTP.Types.Status as HTTP
|
|
|
|
import Network.HTTP.Client (HttpException (..))
|
|
import System.IO (hFlush)
|
|
|
|
import PostgREST.Config (AppConfig (..))
|
|
import PostgREST.Network (isSpecialHostName)
|
|
|
|
import Protolude
|
|
|
|
data PgrstClientError
|
|
= NoAdminServer
|
|
| NoSpecialHostNamesAllowed Text
|
|
| PostgRESTNotReady Text
|
|
| HTTPConnectionRefused Text
|
|
| HTTPExceptionInvalidURL Text
|
|
|
|
-- | This is invoked by the CLI "--ready" flag.
|
|
-- The http-client sends and a request to /ready endpoint
|
|
-- and exits with success or failure.
|
|
ready :: AppConfig -> IO ()
|
|
ready AppConfig{configAdminServerHost, configAdminServerPort} = do
|
|
|
|
client <- HC.newManager HC.defaultManagerSettings
|
|
readyURL <- getURL
|
|
req <- HC.parseRequest (T.unpack readyURL) `catch` handleHttpException
|
|
resp <- HC.httpLbs req client `catch` handleHttpException
|
|
|
|
let status = HC.responseStatus resp
|
|
|
|
if status >= HTTP.status200 && status < HTTP.status300
|
|
then printAndExitWithSuccess $ "OK: " <> readyURL
|
|
else printAndExitWithFailure $ clientErrorMsg (PostgRESTNotReady readyURL)
|
|
where
|
|
getURL :: IO Text
|
|
getURL =
|
|
-- Here, we have three cases:
|
|
-- 1. If the admin port config is not defined, we exit
|
|
-- with "no admin server error"
|
|
-- 2. Otherwise, if admin server is running, then we check if
|
|
-- postgrest server-host is configured with special hostname like "*4",
|
|
-- if it is, we fail with "no special hostname allowed with "--ready".
|
|
-- The reason for this is that we can't know the actual address.
|
|
-- 3. Finally, if we know the "actual" hostname and the port, then we
|
|
-- construct the URL and return it.
|
|
case configAdminServerPort of
|
|
Nothing -> printAndExitWithFailure $ clientErrorMsg NoAdminServer
|
|
Just port ->
|
|
if isSpecialHostName configAdminServerHost
|
|
then printAndExitWithFailure $ clientErrorMsg (NoSpecialHostNamesAllowed configAdminServerHost)
|
|
else return $ makeReadyUrl port
|
|
|
|
-- NOTE: http-client automatically resolves hostnames
|
|
makeReadyUrl :: Int -> Text
|
|
makeReadyUrl p = "http://" <> wrapIfIpv6 configAdminServerHost <> ":" <> (T.pack . show) p <> "/ready"
|
|
where
|
|
-- IPv6 needs to wrapped in [], it has ':' as separator
|
|
wrapIfIpv6 :: Text -> Text
|
|
wrapIfIpv6 s
|
|
| T.any (== ':') s = "[" <> s <> "]"
|
|
| otherwise = s
|
|
|
|
-- | Handle HTTP exception for "http-client" requests
|
|
handleHttpException :: HttpException -> IO a
|
|
handleHttpException (HttpExceptionRequest req _) = do
|
|
let url = show (HC.getUri req)
|
|
printAndExitWithFailure $ clientErrorMsg (HTTPConnectionRefused $ T.pack url)
|
|
handleHttpException (InvalidUrlException url _) = do
|
|
printAndExitWithFailure $ clientErrorMsg (HTTPExceptionInvalidURL $ T.pack url)
|
|
|
|
-- | Print the message on stdout and exit with success
|
|
printAndExitWithSuccess :: Text -> IO a
|
|
printAndExitWithSuccess msg = putStrLn (T.unpack msg) >> hFlush stdout >> exitSuccess
|
|
|
|
-- | Print the message on stderr and exit with failure
|
|
printAndExitWithFailure :: Text -> IO a
|
|
printAndExitWithFailure msg = hPutStrLn stderr (T.unpack msg) >> hFlush stderr >> exitWith (ExitFailure 1)
|
|
|
|
-- | Pgrst client error to error message
|
|
clientErrorMsg :: PgrstClientError -> Text
|
|
clientErrorMsg err = "ERROR: " <>
|
|
case err of
|
|
NoAdminServer -> "Admin server is not running. Please check admin-server-port config."
|
|
NoSpecialHostNamesAllowed host ->
|
|
"The `--ready` flag cannot be used when server-host is configured as \"" <> host <> "\". "
|
|
<> "Please update your server-host config to \"localhost\"."
|
|
PostgRESTNotReady url -> url
|
|
HTTPConnectionRefused url -> "connection refused to " <> url
|
|
HTTPExceptionInvalidURL url -> "invalid url - " <> url
|