86 lines
3.4 KiB
Haskell
86 lines
3.4 KiB
Haskell
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
|