module PostgREST.Admin
  ( runAdmin
  ) where

import qualified Data.Aeson                as JSON
import qualified Network.HTTP.Types.Status as HTTP
import qualified Network.Wai               as Wai
import qualified Network.Wai.Handler.Warp  as Warp

import Control.Monad.Extra       (whenJust)
import Network.Socket            hiding (addrFamily)
import Network.Socket.ByteString

import PostgREST.AppState    (AppState, getConfig, getMainThreadId)
import PostgREST.Config      (AppConfig (..))
import PostgREST.MediaType   (MediaType (..), toContentType)
import PostgREST.Metrics     (metricsToText)
import PostgREST.Network     (resolveSocketToAddress)
import PostgREST.Observation (Observation (..))

import qualified PostgREST.AppState as AppState

import qualified Network.Socket as NS
import           Protolude

runAdmin :: AppState -> Maybe NS.Socket -> NS.Socket -> Warp.Settings -> IO ()
runAdmin appState maybeAdminSocket socketREST settings = do
  conf <- getConfig appState
  whenJust maybeAdminSocket $ \adminSocket -> do
    address <- resolveSocketToAddress adminSocket
    void . forkIO $ handle onError $
      Warp.runSettingsSocket (adminServerSettings conf address) adminSocket adminApp
  where
    adminApp = admin appState socketREST
    observer = AppState.getObserver appState
    adminServerSettings config addr =
      settings
        & Warp.setBeforeMainLoop (observer $ AdminStartObs addr)
        & maybe identity Warp.setPort (configAdminServerPort config)

    onError ex = do
      observer $ AdminServerCrashedObs ex
      killThread (getMainThreadId appState) -- Admin server crash is deemed unrecoverable, so we kill postgrest

-- | PostgREST admin application
admin :: AppState.AppState -> NS.Socket -> Wai.Application
admin appState socketREST req respond  = do
  isMainAppReachable  <- isRight <$> reachMainApp socketREST
  isLoaded <- AppState.isLoaded appState
  isPending <- AppState.isPending appState

  case Wai.pathInfo req of
    ["live"] ->
      respond $ Wai.responseLBS (if isMainAppReachable then HTTP.status200 else HTTP.status500) [] mempty
    ["ready"] ->
      let
        status | not isMainAppReachable = HTTP.status500
               | isPending              = HTTP.status503
               | isLoaded               = HTTP.status200
               | otherwise              = HTTP.status500
      in
      respond $ Wai.responseLBS status [] mempty
    ["schema_cache"] -> do
      sCache <- AppState.getSchemaCache appState
      respond $ Wai.responseLBS HTTP.status200 [] (maybe mempty JSON.encode sCache)
    ["metrics"] -> do
      mets <- metricsToText
      respond $ Wai.responseLBS HTTP.status200 [toContentType MTTextPlain] mets -- Content-Type is required for prometheus compliance
    _ ->
      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 :: 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
    addrFamily (SockAddrInet _ _) = AF_INET
    addrFamily (SockAddrInet6 {}) = AF_INET6
    addrFamily (SockAddrUnix _)   = AF_UNIX