{-|
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