graphql-engine/server/src-lib/Hasura/Server/App.hs

632 lines
23 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
2018-06-27 16:11:32 +03:00
module Hasura.Server.App where
import Control.Concurrent.MVar
import Control.Exception (IOException, try)
import Data.Aeson hiding (json)
import Data.Int (Int64)
import Data.IORef
import Data.Time.Clock (UTCTime,
getCurrentTime)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Network.Mime (defaultMimeLookup)
import Network.Wai (requestHeaders,
strictRequestBody)
import System.Exit (exitFailure)
import System.FilePath (joinPath, takeFileName)
2018-06-27 16:11:32 +03:00
import Web.Spock.Core
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as M
import qualified Data.HashSet as S
import qualified Data.Text as T
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as N
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.WebSockets as WS
import qualified Network.WebSockets as WS
import qualified System.Metrics as EKG
import qualified System.Metrics.Json as EKG
import qualified Text.Mustache as M
import qualified Text.Mustache.Compile as M
2018-06-27 16:11:32 +03:00
import qualified Database.PG.Query as Q
2019-04-17 12:48:41 +03:00
import qualified Hasura.GraphQL.Execute as E
import qualified Hasura.GraphQL.Execute.LiveQuery as EL
import qualified Hasura.GraphQL.Explain as GE
import qualified Hasura.GraphQL.Transport.HTTP as GH
import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH
import qualified Hasura.GraphQL.Transport.WebSocket as WS
add support for jwt authorization (close #186) (#255) The API: 1. HGE has `--jwt-secret` flag or `HASURA_GRAPHQL_JWT_SECRET` env var. The value of which is a JSON. 2. The structure of this JSON is: `{"type": "<standard-JWT-algorithms>", "key": "<the-key>"}` `type` : Standard JWT algos : `HS256`, `RS256`, `RS512` etc. (see jwt.io). `key`: i. Incase of symmetric key, the key as it is. ii. Incase of asymmetric keys, only the public key, in a PEM encoded string or as a X509 certificate. 3. The claims in the JWT token must contain the following: i. `x-hasura-default-role` field: default role of that user ii. `x-hasura-allowed-roles` : A list of allowed roles for the user. The default role is overriden by `x-hasura-role` header. 4. The claims in the JWT token, can have other `x-hasura-*` fields where their values can only be strings. 5. The JWT tokens are sent as `Authorization: Bearer <token>` headers. --- To test: 1. Generate a shared secret (for HMAC-SHA256) or RSA key pair. 2. Goto https://jwt.io/ , add the keys 3. Edit the claims to have `x-hasura-role` (mandatory) and other `x-hasura-*` fields. Add permissions related to the claims to test permissions. 4. Start HGE with `--jwt-secret` flag or `HASURA_GRAPHQL_JWT_SECRET` env var, which takes a JSON string: `{"type": "HS256", "key": "mylongsharedsecret"}` or `{"type":"RS256", "key": "<PEM-encoded-public-key>"}` 5. Copy the JWT token from jwt.io and use it in the `Authorization: Bearer <token>` header. --- TODO: Support EC public keys. It is blocked on frasertweedale/hs-jose#61
2018-08-30 13:32:09 +03:00
import qualified Hasura.Logging as L
import qualified Hasura.Server.PGDump as PGD
2018-06-27 16:11:32 +03:00
import Hasura.EncJSON
import Hasura.Prelude hiding (get, put)
import Hasura.RQL.DDL.Schema
2018-06-27 16:11:32 +03:00
import Hasura.RQL.Types
import Hasura.Server.Auth (AuthMode (..),
getUserInfo)
import Hasura.Server.Config (runGetConfig)
import Hasura.Server.Context
import Hasura.Server.Cors
2018-06-27 16:11:32 +03:00
import Hasura.Server.Init
import Hasura.Server.Logging
import Hasura.Server.Middleware (corsMiddleware)
2018-06-27 16:11:32 +03:00
import Hasura.Server.Query
import Hasura.Server.Utils
import Hasura.Server.Version
2018-06-27 16:11:32 +03:00
import Hasura.SQL.Types
consoleTmplt :: M.Template
consoleTmplt = $(M.embedSingleTemplate "src-rsr/console.html")
2019-01-28 16:55:28 +03:00
boolToText :: Bool -> T.Text
boolToText = bool "false" "true"
isAdminSecretSet :: AuthMode -> T.Text
isAdminSecretSet AMNoAuth = boolToText False
isAdminSecretSet _ = boolToText True
data SchemaCacheRef
= SchemaCacheRef
2019-04-17 12:48:41 +03:00
{ _scrLock :: MVar ()
, _scrCache :: IORef (SchemaCache, SchemaCacheVer)
-- an action to run when schemacache changes
, _scrOnChange :: IO ()
}
getSCFromRef :: SchemaCacheRef -> IO SchemaCache
getSCFromRef scRef = fst <$> readIORef (_scrCache scRef)
logInconsObjs :: L.Logger -> [InconsistentMetadataObj] -> IO ()
logInconsObjs logger objs =
unless (null objs) $ L.unLogger logger $ mkInconsMetadataLog objs
withSCUpdate
:: (MonadIO m, MonadError e m)
=> SchemaCacheRef -> L.Logger -> m (a, SchemaCache) -> m a
withSCUpdate scr logger action = do
acquireLock
(res, newSC) <- action `catchError` onError
liftIO $ do
-- update schemacache in IO reference
modifyIORef' cacheRef $
\(_, prevVer) -> (newSC, incSchemaCacheVer prevVer)
-- log any inconsistent objects
logInconsObjs logger $ scInconsistentObjs newSC
onChange
releaseLock
return res
where
2019-04-17 12:48:41 +03:00
SchemaCacheRef lk cacheRef onChange = scr
onError e = releaseLock >> throwError e
acquireLock = liftIO $ takeMVar lk
releaseLock = liftIO $ putMVar lk ()
2018-06-27 16:11:32 +03:00
data ServerCtx
= ServerCtx
{ scPGExecCtx :: !PGExecCtx
, scConnInfo :: !Q.ConnInfo
, scLogger :: !L.Logger
, scCacheRef :: !SchemaCacheRef
, scAuthMode :: !AuthMode
, scManager :: !HTTP.Manager
, scSQLGenCtx :: !SQLGenCtx
, scEnabledAPIs :: !(S.HashSet API)
, scInstanceId :: !InstanceId
, scPlanCache :: !E.PlanCache
, scLQState :: !EL.LiveQueriesState
, scEnableAllowlist :: !Bool
, scEkgStore :: !EKG.Store
2018-06-27 16:11:32 +03:00
}
data HandlerCtx
= HandlerCtx
{ hcServerCtx :: !ServerCtx
, hcUser :: !UserInfo
, hcReqHeaders :: ![N.Header]
, hcRequestId :: !RequestId
2018-06-27 16:11:32 +03:00
}
type Handler = ExceptT QErr (ReaderT HandlerCtx IO)
data APIResp
= JSONResp !(HttpResponse EncJSON)
| RawResp !(HttpResponse BL.ByteString)
apiRespToLBS :: APIResp -> BL.ByteString
apiRespToLBS = \case
JSONResp (HttpResponse j _) -> encJToLBS j
RawResp (HttpResponse b _) -> b
data APIHandler a
= AHGet !(Handler APIResp)
| AHPost !(a -> Handler APIResp)
mkGetHandler :: Handler APIResp -> APIHandler ()
mkGetHandler = AHGet
mkPostHandler :: (a -> Handler APIResp) -> APIHandler a
mkPostHandler = AHPost
mkAPIRespHandler :: (a -> Handler (HttpResponse EncJSON)) -> (a -> Handler APIResp)
mkAPIRespHandler = (fmap . fmap) JSONResp
isMetadataEnabled :: ServerCtx -> Bool
isMetadataEnabled sc = S.member METADATA $ scEnabledAPIs sc
isGraphQLEnabled :: ServerCtx -> Bool
isGraphQLEnabled sc = S.member GRAPHQL $ scEnabledAPIs sc
isPGDumpEnabled :: ServerCtx -> Bool
isPGDumpEnabled sc = S.member PGDUMP $ scEnabledAPIs sc
isConfigEnabled :: ServerCtx -> Bool
isConfigEnabled sc = S.member CONFIG $ scEnabledAPIs sc
isDeveloperAPIEnabled :: ServerCtx -> Bool
isDeveloperAPIEnabled sc = S.member DEVELOPER $ scEnabledAPIs sc
-- {-# SCC parseBody #-}
parseBody :: (FromJSON a, MonadError QErr m) => BL.ByteString -> m a
parseBody reqBody =
case eitherDecode' reqBody of
Left e -> throw400 InvalidJSON (T.pack e)
Right jVal -> decodeValue jVal
2018-06-27 16:11:32 +03:00
onlyAdmin :: Handler ()
onlyAdmin = do
uRole <- asks (userRole . hcUser)
2018-06-27 16:11:32 +03:00
when (uRole /= adminRole) $
throw400 AccessDenied "You have to be an admin to access this endpoint"
buildQCtx :: Handler QCtx
buildQCtx = do
scRef <- scCacheRef . hcServerCtx <$> ask
userInfo <- asks hcUser
2019-04-17 12:48:41 +03:00
cache <- fmap fst $ liftIO $ readIORef $ _scrCache scRef
sqlGenCtx <- scSQLGenCtx . hcServerCtx <$> ask
return $ QCtx userInfo cache sqlGenCtx
2018-06-27 16:11:32 +03:00
logResult
:: (MonadIO m)
=> L.Logger
-> Maybe UserInfo
-> RequestId
-> Wai.Request
-> Maybe Value
-> Either QErr BL.ByteString
-> Maybe (UTCTime, UTCTime)
-> m ()
logResult logger userInfoM reqId httpReq req res qTime = do
let logline = case res of
Right res' -> mkHttpAccessLog userInfoM reqId httpReq res' qTime
Left e -> mkHttpErrorLog userInfoM reqId httpReq e req qTime
liftIO $ L.unLogger logger logline
logSuccess
:: (MonadIO m)
=> L.Logger
-> Maybe UserInfo
-> RequestId
-> Wai.Request
-> BL.ByteString
-> Maybe (UTCTime, UTCTime)
-> m ()
logSuccess logger userInfoM reqId httpReq res qTime =
liftIO $ L.unLogger logger $ mkHttpAccessLog userInfoM reqId httpReq res qTime
logError
:: (MonadIO m)
=> L.Logger
-> Maybe UserInfo
-> RequestId
-> Wai.Request
-> Maybe Value
-> QErr -> m ()
logError logger userInfoM reqId httpReq req qErr =
liftIO $ L.unLogger logger $ mkHttpErrorLog userInfoM reqId httpReq qErr req Nothing
2018-06-27 16:11:32 +03:00
mkSpockAction
:: (MonadIO m, FromJSON a, ToJSON a)
=> (Bool -> QErr -> Value)
-> (QErr -> QErr)
2018-06-27 16:11:32 +03:00
-> ServerCtx
-> APIHandler a
2018-06-27 16:11:32 +03:00
-> ActionT m ()
mkSpockAction qErrEncoder qErrModifier serverCtx apiHandler = do
2018-06-27 16:11:32 +03:00
req <- request
reqBody <- liftIO $ strictRequestBody req
let headers = requestHeaders req
authMode = scAuthMode serverCtx
manager = scManager serverCtx
-- convert ByteString to Maybe Value for logging
reqTxt = Just $ String $ bsToTxt $ BL.toStrict reqBody
2018-06-27 16:11:32 +03:00
requestId <- getRequestId headers
userInfoE <- liftIO $ runExceptT $ getUserInfo logger manager headers authMode
userInfo <- either (logErrorAndResp Nothing requestId req reqTxt False . qErrModifier)
return userInfoE
2018-06-27 16:11:32 +03:00
let handlerState = HandlerCtx serverCtx userInfo headers requestId
curRole = userRole userInfo
2018-06-27 16:11:32 +03:00
t1 <- liftIO getCurrentTime -- for measuring response time purposes
(result, q) <- case apiHandler of
AHGet handler -> do
res <- liftIO $ runReaderT (runExceptT handler) handlerState
return (res, Nothing)
AHPost handler -> do
parsedReqE <- runExceptT $ parseBody reqBody
parsedReq <- either (logErrorAndResp (Just userInfo) requestId req reqTxt (isAdmin curRole) . qErrModifier) return parsedReqE
res <- liftIO $ runReaderT (runExceptT $ handler parsedReq) handlerState
return (res, Just parsedReq)
2018-06-27 16:11:32 +03:00
t2 <- liftIO getCurrentTime -- for measuring response time purposes
-- apply the error modifier
let modResult = fmapL qErrModifier result
-- log and return result
case modResult of
Left err -> logErrorAndResp (Just userInfo) requestId req (toJSON <$> q) (isAdmin curRole) err
Right res -> logSuccessAndResp (Just userInfo) requestId req res (Just (t1, t2))
2018-06-27 16:11:32 +03:00
where
logger = scLogger serverCtx
logErrorAndResp
:: (MonadIO m)
=> Maybe UserInfo -> RequestId -> Wai.Request -> Maybe Value -> Bool -> QErr -> ActionCtxT ctx m a
logErrorAndResp userInfo reqId req reqBody includeInternal qErr = do
logError logger userInfo reqId req reqBody qErr
2018-06-27 16:11:32 +03:00
setStatus $ qeStatus qErr
json $ qErrEncoder includeInternal qErr
logSuccessAndResp userInfo reqId req result qTime = do
logSuccess logger userInfo reqId req (apiRespToLBS result) qTime
case result of
JSONResp (HttpResponse j h) -> do
uncurry setHeader jsonHeader
uncurry setHeader (requestIdHeader, unRequestId reqId)
mapM_ (mapM_ (uncurry setHeader . unHeader)) h
lazyBytes $ encJToLBS j
RawResp (HttpResponse b h) -> do
uncurry setHeader (requestIdHeader, unRequestId reqId)
mapM_ (mapM_ (uncurry setHeader . unHeader)) h
lazyBytes b
v1QueryHandler :: RQLQuery -> Handler (HttpResponse EncJSON)
2018-06-27 16:11:32 +03:00
v1QueryHandler query = do
scRef <- scCacheRef . hcServerCtx <$> ask
logger <- scLogger . hcServerCtx <$> ask
res <- bool (fst <$> dbAction) (withSCUpdate scRef logger dbAction) $
queryNeedsReload query
return $ HttpResponse res Nothing
2018-06-27 16:11:32 +03:00
where
-- Hit postgres
dbAction = do
userInfo <- asks hcUser
2018-06-27 16:11:32 +03:00
scRef <- scCacheRef . hcServerCtx <$> ask
2019-04-17 12:48:41 +03:00
schemaCache <- fmap fst $ liftIO $ readIORef $ _scrCache scRef
httpMgr <- scManager . hcServerCtx <$> ask
sqlGenCtx <- scSQLGenCtx . hcServerCtx <$> ask
2019-04-17 12:48:41 +03:00
pgExecCtx <- scPGExecCtx . hcServerCtx <$> ask
instanceId <- scInstanceId . hcServerCtx <$> ask
runQuery pgExecCtx instanceId userInfo schemaCache httpMgr sqlGenCtx query
2018-06-27 16:11:32 +03:00
v1Alpha1GQHandler :: GH.GQLReqUnparsed -> Handler (HttpResponse EncJSON)
2018-06-27 16:11:32 +03:00
v1Alpha1GQHandler query = do
userInfo <- asks hcUser
reqHeaders <- asks hcReqHeaders
manager <- scManager . hcServerCtx <$> ask
2018-06-27 16:11:32 +03:00
scRef <- scCacheRef . hcServerCtx <$> ask
2019-04-17 12:48:41 +03:00
(sc, scVer) <- liftIO $ readIORef $ _scrCache scRef
pgExecCtx <- scPGExecCtx . hcServerCtx <$> ask
sqlGenCtx <- scSQLGenCtx . hcServerCtx <$> ask
2019-04-17 12:48:41 +03:00
planCache <- scPlanCache . hcServerCtx <$> ask
enableAL <- scEnableAllowlist . hcServerCtx <$> ask
logger <- scLogger . hcServerCtx <$> ask
requestId <- asks hcRequestId
let execCtx = E.ExecutionCtx logger sqlGenCtx pgExecCtx planCache
sc scVer manager enableAL
flip runReaderT execCtx $ GH.runGQ requestId userInfo reqHeaders query
v1GQHandler
:: GH.GQLReqUnparsed
-> Handler (HttpResponse EncJSON)
v1GQHandler = v1Alpha1GQHandler
gqlExplainHandler :: GE.GQLExplain -> Handler (HttpResponse EncJSON)
gqlExplainHandler query = do
onlyAdmin
scRef <- scCacheRef . hcServerCtx <$> ask
2019-04-17 12:48:41 +03:00
sc <- fmap fst $ liftIO $ readIORef $ _scrCache scRef
pgExecCtx <- scPGExecCtx . hcServerCtx <$> ask
sqlGenCtx <- scSQLGenCtx . hcServerCtx <$> ask
enableAL <- scEnableAllowlist . hcServerCtx <$> ask
res <- GE.explainGQLQuery pgExecCtx sc sqlGenCtx enableAL query
return $ HttpResponse res Nothing
2018-06-27 16:11:32 +03:00
v1Alpha1PGDumpHandler :: PGD.PGDumpReqBody -> Handler APIResp
v1Alpha1PGDumpHandler b = do
onlyAdmin
ci <- scConnInfo . hcServerCtx <$> ask
output <- PGD.execPGDump b ci
return $ RawResp $ HttpResponse output (Just [Header sqlHeader])
consoleAssetsHandler :: L.Logger -> Text -> FilePath -> ActionT IO ()
consoleAssetsHandler logger dir path = do
-- '..' in paths need not be handed as it is resolved in the url by
-- spock's routing. we get the expanded path.
eFileContents <- liftIO $ try $ BL.readFile $
joinPath [T.unpack dir, path]
either onError onSuccess eFileContents
where
onSuccess c = do
mapM_ (uncurry setHeader) headers
lazyBytes c
onError :: IOException -> ActionT IO ()
onError = raiseGenericApiError logger . err404 NotFound . T.pack . show
fn = T.pack $ takeFileName path
-- set gzip header if the filename ends with .gz
(fileName, encHeader) = case T.stripSuffix ".gz" fn of
Just v -> (v, [gzipHeader])
Nothing -> (fn, [])
mimeType = bsToTxt $ defaultMimeLookup fileName
headers = ("Content-Type", mimeType) : encHeader
mkConsoleHTML :: T.Text -> AuthMode -> Bool -> Maybe Text -> Either String T.Text
mkConsoleHTML path authMode enableTelemetry consoleAssetsDir =
bool (Left errMsg) (Right res) $ null errs
where
(errs, res) = M.checkedSubstitute consoleTmplt $
-- variables required to render the template
object [ "isAdminSecretSet" .= isAdminSecretSet authMode
, "consolePath" .= consolePath
, "enableTelemetry" .= boolToText enableTelemetry
, "cdnAssets" .= boolToText (isNothing consoleAssetsDir)
, "assetsVersion" .= consoleVersion
, "serverVersion" .= currentVersion
]
consolePath = case path of
"" -> "/console"
r -> "/console/" <> r
errMsg = "console template rendering failed: " ++ show errs
newtype LegacyQueryParser
= LegacyQueryParser
{ getLegacyQueryParser :: QualifiedTable -> Object -> Handler RQLQueryV1 }
2018-06-27 16:11:32 +03:00
queryParsers :: M.HashMap T.Text LegacyQueryParser
2018-06-27 16:11:32 +03:00
queryParsers =
M.fromList
[ ("select", mkLegacyQueryParser RQSelect)
, ("insert", mkLegacyQueryParser RQInsert)
, ("update", mkLegacyQueryParser RQUpdate)
, ("delete", mkLegacyQueryParser RQDelete)
, ("count", mkLegacyQueryParser RQCount)
2018-06-27 16:11:32 +03:00
]
where
mkLegacyQueryParser f =
LegacyQueryParser $ \qt obj -> do
2018-06-27 16:11:32 +03:00
let val = Object $ M.insert "table" (toJSON qt) obj
q <- decodeValue val
return $ f q
legacyQueryHandler :: TableName -> T.Text -> Object
-> Handler (HttpResponse EncJSON)
legacyQueryHandler tn queryType req =
2018-06-27 16:11:32 +03:00
case M.lookup queryType queryParsers of
Just queryParser -> getLegacyQueryParser queryParser qt req >>= (v1QueryHandler . RQV1)
Nothing -> throw404 "No such resource exists"
2018-06-27 16:11:32 +03:00
where
qt = QualifiedObject publicSchema tn
2018-06-27 16:11:32 +03:00
initErrExit :: QErr -> IO a
initErrExit e = do
putStrLn $
"failed to build schema-cache because of inconsistent metadata: "
<> T.unpack (qeError e)
exitFailure
data HasuraApp
= HasuraApp
{ _hapApplication :: !Wai.Application
, _hapSchemaRef :: !SchemaCacheRef
, _hapCacheBuildTime :: !(Maybe UTCTime)
, _hapShutdown :: !(IO ())
}
mkWaiApp
:: Q.TxIsolation
-> L.LoggerCtx
-> SQLGenCtx
-> Bool
-> Q.PGPool
-> Q.ConnInfo
-> HTTP.Manager
-> AuthMode
-> CorsConfig
-> Bool
-> Maybe Text
-> Bool
-> InstanceId
-> S.HashSet API
-> EL.LiveQueriesOptions
-> IO HasuraApp
mkWaiApp isoLevel loggerCtx sqlGenCtx enableAL pool ci httpManager mode corsCfg
enableConsole consoleAssetsDir enableTelemetry instanceId apis lqOpts = do
2019-04-17 12:48:41 +03:00
let pgExecCtx = PGExecCtx pool isoLevel
pgExecCtxSer = PGExecCtx pool Q.Serializable
(cacheRef, cacheBuiltTime) <- do
pgResp <- runExceptT $ peelRun emptySchemaCache adminUserInfo
httpManager sqlGenCtx pgExecCtxSer $ do
buildSchemaCache
liftTx fetchLastUpdate
(time, sc) <- either initErrExit return pgResp
2019-04-17 12:48:41 +03:00
scRef <- newIORef (sc, initSchemaCacheVer)
return (scRef, snd <$> time)
2018-06-27 16:11:32 +03:00
cacheLock <- newMVar ()
2019-04-17 12:48:41 +03:00
planCache <- E.initPlanCache
2019-04-17 12:48:41 +03:00
let corsPolicy = mkDefaultCorsPolicy corsCfg
logger = L.mkLogger loggerCtx
2019-04-17 12:48:41 +03:00
lqState <- EL.initLiveQueriesState lqOpts pgExecCtx
wsServerEnv <- WS.createWSServerEnv logger pgExecCtx lqState cacheRef
httpManager corsPolicy sqlGenCtx enableAL planCache
ekgStore <- EKG.newStore
2019-04-17 12:48:41 +03:00
let schemaCacheRef =
SchemaCacheRef cacheLock cacheRef (E.clearPlanCache planCache)
serverCtx = ServerCtx pgExecCtx ci logger
2019-04-17 12:48:41 +03:00
schemaCacheRef mode httpManager
sqlGenCtx apis instanceId planCache
lqState enableAL ekgStore
when (isDeveloperAPIEnabled serverCtx) $ do
EKG.registerGcMetrics ekgStore
EKG.registerCounter "ekg.server_timestamp_ms" getTimeMs ekgStore
2018-06-27 16:11:32 +03:00
2019-04-17 12:48:41 +03:00
spockApp <- spockAsApp $ spockT id $
httpApp corsCfg serverCtx enableConsole
consoleAssetsDir enableTelemetry
let wsServerApp = WS.createWSServerApp mode wsServerEnv
stopWSServer = WS.stopWSServerApp wsServerEnv
return $ HasuraApp
(WS.websocketsOr WS.defaultConnectionOptions wsServerApp spockApp)
schemaCacheRef
cacheBuiltTime
stopWSServer
where
getTimeMs :: IO Int64
getTimeMs = (round . (* 1000)) `fmap` getPOSIXTime
2018-06-27 16:11:32 +03:00
httpApp :: CorsConfig -> ServerCtx -> Bool -> Maybe Text -> Bool -> SpockT IO ()
httpApp corsCfg serverCtx enableConsole consoleAssetsDir enableTelemetry = do
2018-06-27 16:11:32 +03:00
-- cors middleware
unless (isCorsDisabled corsCfg) $
middleware $ corsMiddleware (mkDefaultCorsPolicy corsCfg)
2018-06-27 16:11:32 +03:00
-- API Console and Root Dir
when (enableConsole && enableMetadata) serveApiConsole
-- Health check endpoint
get "healthz" $ do
sc <- liftIO $ getSCFromRef $ scCacheRef serverCtx
if null $ scInconsistentObjs sc
then setStatus N.status200 >> lazyBytes "OK"
else setStatus N.status500 >> lazyBytes "ERROR"
get "v1/version" $ do
uncurry setHeader jsonHeader
lazyBytes $ encode $ object [ "version" .= currentVersion ]
when enableMetadata $ do
2018-06-27 16:11:32 +03:00
post "v1/query" $ mkSpockAction encodeQErr id serverCtx $
mkPostHandler $ mkAPIRespHandler v1QueryHandler
2018-06-27 16:11:32 +03:00
post ("api/1/table" <//> var <//> var) $ \tableName queryType ->
mkSpockAction encodeQErr id serverCtx $ mkPostHandler $
mkAPIRespHandler $ legacyQueryHandler (TableName tableName) queryType
2018-06-27 16:11:32 +03:00
when enablePGDump $
post "v1alpha1/pg_dump" $ mkSpockAction encodeQErr id serverCtx $
mkPostHandler v1Alpha1PGDumpHandler
when enableConfig $
get "v1alpha1/config" $ mkSpockAction encodeQErr id serverCtx $
mkGetHandler $ do
onlyAdmin
let res = encJFromJValue $ runGetConfig (scAuthMode serverCtx)
return $ JSONResp $ HttpResponse res Nothing
when enableGraphQL $ do
post "v1alpha1/graphql/explain" gqlExplainAction
2018-06-27 16:11:32 +03:00
post "v1alpha1/graphql" $ mkSpockAction GH.encodeGQErr id serverCtx $
mkPostHandler $ mkAPIRespHandler v1Alpha1GQHandler
2018-06-27 16:11:32 +03:00
post "v1/graphql/explain" gqlExplainAction
post "v1/graphql" $ mkSpockAction GH.encodeGQErr allMod200 serverCtx $
mkPostHandler $ mkAPIRespHandler v1GQHandler
when (isDeveloperAPIEnabled serverCtx) $ do
get "dev/ekg" $ mkSpockAction encodeQErr id serverCtx $
mkGetHandler $ do
onlyAdmin
respJ <- liftIO $ EKG.sampleAll $ scEkgStore serverCtx
return $ JSONResp $ HttpResponse (encJFromJValue $ EKG.sampleToJson respJ) Nothing
get "dev/plan_cache" $ mkSpockAction encodeQErr id serverCtx $
mkGetHandler $ do
onlyAdmin
respJ <- liftIO $ E.dumpPlanCache $ scPlanCache serverCtx
return $ JSONResp $ HttpResponse (encJFromJValue respJ) Nothing
get "dev/subscriptions" $ mkSpockAction encodeQErr id serverCtx $
mkGetHandler $ do
onlyAdmin
respJ <- liftIO $ EL.dumpLiveQueriesState False $ scLQState serverCtx
return $ JSONResp $ HttpResponse (encJFromJValue respJ) Nothing
get "dev/subscriptions/extended" $ mkSpockAction encodeQErr id serverCtx $
mkGetHandler $ do
onlyAdmin
respJ <- liftIO $ EL.dumpLiveQueriesState True $ scLQState serverCtx
return $ JSONResp $ HttpResponse (encJFromJValue respJ) Nothing
2018-06-27 16:11:32 +03:00
forM_ [GET,POST] $ \m -> hookAny m $ \_ -> do
let qErr = err404 NotFound "resource does not exist"
raiseGenericApiError logger qErr
2018-06-27 16:11:32 +03:00
where
logger = scLogger serverCtx
-- all graphql errors should be of type 200
allMod200 qe = qe { qeStatus = N.status200 }
gqlExplainAction =
mkSpockAction encodeQErr id serverCtx $ mkPostHandler $
mkAPIRespHandler gqlExplainHandler
enableGraphQL = isGraphQLEnabled serverCtx
enableMetadata = isMetadataEnabled serverCtx
enablePGDump = isPGDumpEnabled serverCtx
enableConfig = isConfigEnabled serverCtx
serveApiConsole = do
-- redirect / to /console
get root $ redirect "console"
-- serve static files if consoleAssetsDir is set
onJust consoleAssetsDir $ \dir ->
get ("console/assets" <//> wildcard) $ \path ->
consoleAssetsHandler logger dir (T.unpack path)
-- serve console html
get ("console" <//> wildcard) $ \path ->
either (raiseGenericApiError logger . err500 Unexpected . T.pack) html $
mkConsoleHTML path (scAuthMode serverCtx) enableTelemetry consoleAssetsDir
raiseGenericApiError :: L.Logger -> QErr -> ActionT IO ()
raiseGenericApiError logger qErr = do
req <- request
reqBody <- liftIO $ strictRequestBody req
let reqTxt = toJSON $ String $ bsToTxt $ BL.toStrict reqBody
reqId <- getRequestId $ requestHeaders req
logError logger Nothing reqId req (Just reqTxt) qErr
uncurry setHeader jsonHeader
setStatus $ qeStatus qErr
lazyBytes $ encode qErr