hasura/graphql-engine
1
0
Fork 0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-14 17:02:49 +03:00
Code Issues Projects Releases Wiki Activity

server: use relative paths in TH splices

Browse Source 
While debugging issues with HLS, Reed Mullanix noticed that we don't use relative paths. This leads to problems when using HLS + Emacs due to a bug in `lsp-mode` which prevents it from finding the correct project root.

However, it is still a good practice to use relative paths in TH for other reasons, including being able to import these modules in GHCI.

This PR should make it so HLS-1.0 & emacs provide type inference, imports, etc., in all modules in our codebase.

GitOrigin-RevId: 5f53b9a7ccf46df1ea7be94ff0a5c6ec861f4ead
This commit is contained in:
Vladimir Ciobanu 2021-03-16 19:35:35 +02:00 committed by hasura-bot
parent 881cc55e0e
commit 91710bba58
11 changed files with 52 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
server/src-lib/Hasura/App.hs
View File

@ -37,6 +37,7 @@ import Control.Monad.Stateless
import Control.Monad.Trans.Control (MonadBaseControl (..))
import Control.Monad.Trans.Managed (ManagedT (..), allocate)
import Control.Monad.Unique
import Data.FileEmbed (makeRelativeToProject)
import Data.Time.Clock (UTCTime)
#ifndef PROFILING
import GHC.AssertNF
@ -809,7 +810,7 @@ instance MonadMetadataStorage (MetadataStorageT PGMetadataStorageApp) where
setCatalogState a b = runInSeparateTx $ setCatalogStateTx a b
getDatabaseUid = runInSeparateTx getDbId
checkMetadataStorageHealth = (lift (asks fst)) >>= checkDbConnection
checkMetadataStorageHealth = lift (asks fst) >>= checkDbConnection
getDeprivedCronTriggerStats = runInSeparateTx getDeprivedCronTriggerStatsTx
getScheduledEventsForDelivery = runInSeparateTx getScheduledEventsForDeliveryTx
@ -848,7 +849,7 @@ mkConsoleHTML path authMode enableTelemetry consoleAssetsDir =
"" -> "/console"
r -> "/console/" <> r
consoleTmplt = $(M.embedSingleTemplate "src-rsr/console.html")
consoleTmplt = $(makeRelativeToProject "src-rsr/console.html" >>= M.embedSingleTemplate)
telemetryNotice :: String
telemetryNotice =

8
server/src-lib/Hasura/Backends/MSSQL/Meta.hs
View File

@ -8,14 +8,16 @@ module Hasura.Backends.MSSQL.Meta
import Hasura.Prelude
import Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HM
import qualified Data.HashSet as HS
import Data.String
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Database.PG.Query as Q (sqlFromFile)
import Data.Aeson as Aeson
import Data.FileEmbed (makeRelativeToProject)
import Data.String
import Hasura.Backends.MSSQL.Connection
import Hasura.Backends.MSSQL.Instances.Types ()
import Hasura.Backends.MSSQL.Types
@ -33,7 +35,7 @@ loadDBMetadata
:: (MonadError QErr m, MonadIO m)
=> MSSQLPool -> m (DBTablesMetadata 'MSSQL)
loadDBMetadata pool = do
let sql = $(Q.sqlFromFile "src-rsr/mssql_table_metadata.sql")
let sql = $(makeRelativeToProject "src-rsr/mssql_table_metadata.sql" >>= Q.sqlFromFile)
sysTablesText <- runJSONPathQuery pool (fromString sql)
case Aeson.eitherDecodeStrict (T.encodeUtf8 sysTablesText) of
Left e -> throw500 $ T.pack $ "error loading sql server database schema: " <> e

11
server/src-lib/Hasura/Backends/Postgres/DDL/Source.hs
View File

@ -11,6 +11,7 @@ import qualified Language.Haskell.TH.Syntax as TH
import Control.Lens hiding (from, index, op, to, (.=))
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.FileEmbed (makeRelativeToProject)
import Hasura.Backends.Postgres.Connection
import Hasura.Backends.Postgres.SQL.Types
@ -66,7 +67,7 @@ initSource = do
| otherwise -> migrateSourceCatalog
where
initPgSourceCatalog = do
() <- Q.multiQE defaultTxErrorHandler $(Q.sqlFromFile "src-rsr/init_pg_source.sql")
() <- Q.multiQE defaultTxErrorHandler $(makeRelativeToProject "src-rsr/init_pg_source.sql" >>= Q.sqlFromFile)
setSourceCatalogVersion
createVersionTable = do
@ -97,7 +98,7 @@ upMigrationsUntil43 :: MonadTx m => [(Text, m ())]
upMigrationsUntil43 =
$(let migrationFromFile from to =
let path = "src-rsr/migrations/" <> from <> "_to_" <> to <> ".sql"
in [| runTx $(Q.sqlFromFile path) |]
in [| runTx $(makeRelativeToProject path >>= Q.sqlFromFile) |]
migrationsFromFile = map $ \(to :: Integer) ->
let from = to - 1
@ -131,7 +132,7 @@ getSourceCatalogVersion = liftTx $ runIdentity . Q.getRow <$> Q.withQE defaultTx
fetchTableMetadata :: (MonadTx m) => m (DBTablesMetadata 'Postgres)
fetchTableMetadata = do
results <- liftTx $ Q.withQE defaultTxErrorHandler
$(Q.sqlFromFile "src-rsr/pg_table_metadata.sql") () True
$(makeRelativeToProject "src-rsr/pg_table_metadata.sql" >>= Q.sqlFromFile) () True
pure $ Map.fromList $ flip map results $
\(schema, table, Q.AltJ info) -> (QualifiedObject schema table, info)
@ -139,7 +140,7 @@ fetchTableMetadata = do
fetchFunctionMetadata :: (MonadTx m) => m (DBFunctionsMetadata 'Postgres)
fetchFunctionMetadata = do
results <- liftTx $ Q.withQE defaultTxErrorHandler
$(Q.sqlFromFile "src-rsr/pg_function_metadata.sql") () True
$(makeRelativeToProject "src-rsr/pg_function_metadata.sql" >>= Q.sqlFromFile) () True
pure $ Map.fromList $ flip map results $
\(schema, table, Q.AltJ infos) -> (QualifiedObject schema table, infos)
@ -170,7 +171,7 @@ postDropSourceHook sourceConfig = do
-- being used as metadata storage (--metadata-database-url option). In this case
-- drop only source related tables and not "hdb_catalog" schema
| hdbMetadataTableExist ->
Q.multiQE defaultTxErrorHandler $(Q.sqlFromFile "src-rsr/drop_pg_source.sql")
Q.multiQE defaultTxErrorHandler $(makeRelativeToProject "src-rsr/drop_pg_source.sql" >>= Q.sqlFromFile)
-- Otherwise, drop "hdb_catalog" schema.
| otherwise -> dropHdbCatalogSchema

3
server/src-lib/Hasura/Backends/Postgres/DDL/Table.hs
View File

@ -24,6 +24,7 @@ import qualified Text.Shakespeare.Text as ST
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Validate
import Data.FileEmbed (makeRelativeToProject)
import Data.List (delete)
import Data.Text.Extended
@ -159,7 +160,7 @@ mkTriggerQ trn qt@(QualifiedObject schema table) allCols op (SubscribeOpSpec col
oldPayloadExpression = toSQLTxt oldDataExp
newPayloadExpression = toSQLTxt newDataExp
in $(ST.stextFile "src-rsr/trigger.sql.shakespeare")
in $(makeRelativeToProject "src-rsr/trigger.sql.shakespeare" >>= ST.stextFile )
where
applyRowToJson' e = SEFnApp "row_to_json" [e] Nothing
applyRow e = SEFnApp "row" [e] Nothing

16
server/src-lib/Hasura/GraphQL/RemoteServer.hs
View File

@ -4,11 +4,6 @@ module Hasura.GraphQL.RemoteServer
, execRemoteGQ
) where
import Control.Exception (try)
import Control.Lens ((^.))
import Control.Monad.Unique
import Data.Aeson ((.:), (.:?))
import Hasura.HTTP
import Hasura.Prelude
import qualified Data.Aeson as J
@ -24,10 +19,17 @@ import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as N
import qualified Network.Wreq as Wreq
import Control.Exception (try)
import Control.Lens ((^.))
import Control.Monad.Unique
import Data.Aeson ((.:), (.:?))
import Data.FileEmbed (makeRelativeToProject)
import qualified Hasura.GraphQL.Parser.Monad as P
import Hasura.GraphQL.Schema.Remote
import Hasura.GraphQL.Transport.HTTP.Protocol
import Hasura.HTTP
import Hasura.RQL.DDL.Headers (makeHeadersFromConf)
import Hasura.RQL.Types
import Hasura.Server.Utils
@ -37,7 +39,7 @@ import Hasura.Session
introspectionQuery :: GQLReqParsed
introspectionQuery =
$(do
let fp = "src-rsr/introspection.json"
fp <- makeRelativeToProject "src-rsr/introspection.json"
TH.qAddDependentFile fp
eitherResult <- TH.runIO $ J.eitherDecodeFileStrict fp
case eitherResult of
@ -360,6 +362,6 @@ execRemoteGQ env manager userInfo reqHdrs rsi gqlReq@GQLReq{..} = do
httpThrow :: (MonadError QErr m) => HTTP.HttpException -> m a
httpThrow = \case
HTTP.HttpExceptionRequest _req content -> throw500 $ tshow content
HTTP.InvalidUrlException _url reason -> throw500 $ tshow reason
HTTP.InvalidUrlException _url reason -> throw500 $ tshow reason
userInfoToHdrs = sessionVariablesToHeaders $ _uiSession userInfo

6
server/src-lib/Hasura/RQL/DDL/Schema/Common.hs
View File

@ -5,6 +5,8 @@ import Hasura.Prelude
import qualified Data.HashMap.Strict as HM
import qualified Database.PG.Query as Q
import Data.FileEmbed (makeRelativeToProject)
import qualified Hasura.SQL.AnyBackend as AB
import Hasura.Backends.Postgres.SQL.Types
@ -40,7 +42,7 @@ purgeDependentObject source sourceObjId = case sourceObjId of
fetchTableMetadata :: (MonadTx m) => m (DBTablesMetadata 'Postgres)
fetchTableMetadata = do
results <- liftTx $ Q.withQE defaultTxErrorHandler
$(Q.sqlFromFile "src-rsr/pg_table_metadata.sql") () True
$(makeRelativeToProject "src-rsr/pg_table_metadata.sql" >>= Q.sqlFromFile) () True
pure $ HM.fromList $ flip map results $
\(schema, table, Q.AltJ info) -> (QualifiedObject schema table, info)
@ -48,7 +50,7 @@ fetchTableMetadata = do
fetchFunctionMetadata :: (MonadTx m) => m (DBFunctionsMetadata 'Postgres)
fetchFunctionMetadata = do
results <- liftTx $ Q.withQE defaultTxErrorHandler
$(Q.sqlFromFile "src-rsr/pg_function_metadata.sql") () True
$(makeRelativeToProject "src-rsr/pg_function_metadata.sql" >>= Q.sqlFromFile) () True
pure $ HM.fromList $ flip map results $
\(schema, table, Q.AltJ infos) -> (QualifiedObject schema table, infos)

3
server/src-lib/Hasura/RQL/DDL/Schema/LegacyCatalog.hs
View File

@ -15,6 +15,7 @@ import qualified Database.PG.Query as Q
import Control.Lens hiding ((.=))
import Data.Aeson
import Data.FileEmbed (makeRelativeToProject)
import Data.Text.NonEmpty
import Hasura.Backends.Postgres.Connection
@ -557,7 +558,7 @@ fetchMetadataFromHdbTables = liftTx do
-- instead.
recreateSystemMetadata :: (MonadTx m) => m ()
recreateSystemMetadata = do
() <- liftTx $ Q.multiQE defaultTxErrorHandler $(Q.sqlFromFile "src-rsr/clear_system_metadata.sql")
() <- liftTx $ Q.multiQE defaultTxErrorHandler $(makeRelativeToProject "src-rsr/clear_system_metadata.sql" >>= Q.sqlFromFile)
runHasSystemDefinedT (SystemDefined True) $ for_ systemMetadata \(tableName, tableRels) -> do
saveTableToCatalog tableName False emptyTableConfig
for_ tableRels \case

14
server/src-lib/Hasura/Server/Init.hs
View File

@ -15,7 +15,7 @@ import qualified Database.PG.Query as Q
import qualified Language.Haskell.TH.Syntax as TH
import qualified Text.PrettyPrint.ANSI.Leijen as PP
import Data.FileEmbed (embedStringFile)
import Data.FileEmbed (embedStringFile, makeRelativeToProject)
import Data.Time (NominalDiffTime)
import Data.URL.Template
import Network.Wai.Handler.Warp (HostPreference)
@ -41,7 +41,7 @@ import Network.URI (parseURI)
getDbId :: Q.TxE QErr Text
getDbId =
(runIdentity . Q.getRow) <$>
runIdentity . Q.getRow <$>
Q.withQE defaultTxErrorHandler
[Q.sql|
SELECT (hasura_uuid :: text) FROM hdb_catalog.hdb_version
@ -180,7 +180,7 @@ mkServeOptions rso = do
logHeadersFromEnv <- withEnvBool (rsoLogHeadersFromEnv rso) (fst logHeadersFromEnvEnv)
enableRemoteSchemaPerms <-
bool RemoteSchemaPermsDisabled RemoteSchemaPermsEnabled <$>
(withEnvBool (rsoEnableRemoteSchemaPermissions rso) (fst enableRemoteSchemaPermsEnv))
withEnvBool (rsoEnableRemoteSchemaPermissions rso) (fst enableRemoteSchemaPermsEnv)
webSocketCompressionFromEnv <- withEnvBool (rsoWebSocketCompression rso) $
fst webSocketCompressionEnv
@ -197,7 +197,7 @@ mkServeOptions rso = do
experimentalFeatures <- maybe mempty Set.fromList <$> withEnv (rsoExperimentalFeatures rso) (fst experimentalFeaturesEnv)
inferFunctionPerms <-
maybe FunctionPermissionsInferred (bool FunctionPermissionsManual FunctionPermissionsInferred) <$>
(withEnv (rsoInferFunctionPermissions rso) (fst inferFunctionPermsEnv))
withEnv (rsoInferFunctionPermissions rso) (fst inferFunctionPermsEnv)
maintenanceMode <-
bool MaintenanceModeDisabled MaintenanceModeEnabled
@ -616,8 +616,8 @@ parseRawConnDetails = do
dbName' <- dbName
options' <- options
pure $ PostgresRawConnDetails
<$> host' <*> port' <*> user' <*> (pure password')
<*> dbName' <*> (pure options')
<$> host' <*> port' <*> user' <*> pure password'
<*> dbName' <*> pure options'
where
host = optional $
strOption ( long "host" <>
@ -1102,7 +1102,7 @@ serveOptionsParser =
-- and catalog schema versions.
downgradeShortcuts :: [(String, String)]
downgradeShortcuts =
$(do let s = $(embedStringFile "src-rsr/catalog_versions.txt")
$(do let s = $(makeRelativeToProject "src-rsr/catalog_versions.txt" >>= embedStringFile)
parseVersions = map (parseVersion . words) . lines

11
server/src-lib/Hasura/Server/Migrate.hs
View File

@ -33,6 +33,7 @@ import qualified Language.Haskell.TH.Lib as TH
import qualified Language.Haskell.TH.Syntax as TH
import Control.Monad.Trans.Control (MonadBaseControl)
import Data.FileEmbed (makeRelativeToProject)
import Data.Time.Clock (UTCTime)
import System.Directory (doesFileExist)
@ -126,7 +127,7 @@ migrateCatalog maybeDefaultSourceConfig maintenanceMode migrationTime = do
liftTx $ Q.catchE defaultTxErrorHandler $
when createSchema $ Q.unitQ "CREATE SCHEMA hdb_catalog" () False
enablePgcryptoExtension
runTx $(Q.sqlFromFile "src-rsr/initialise.sql")
runTx $(makeRelativeToProject "src-rsr/initialise.sql" >>= Q.sqlFromFile)
updateCatalogVersion
let emptyMetadata' = case maybeDefaultSourceConfig of
@ -235,9 +236,9 @@ migrations maybeDefaultSourceConfig dryRun maintenanceMode =
-- compile-time), but putting a `let` inside the splice itself is allowed.
$(let migrationFromFile from to =
let path = "src-rsr/migrations/" <> from <> "_to_" <> to <> ".sql"
in [| runTxOrPrint $(Q.sqlFromFile path) |]
in [| runTxOrPrint $(makeRelativeToProject path >>= Q.sqlFromFile) |]
migrationFromFileMaybe from to = do
let path = "src-rsr/migrations/" <> from <> "_to_" <> to <> ".sql"
path <- makeRelativeToProject $ "src-rsr/migrations/" <> from <> "_to_" <> to <> ".sql"
exists <- TH.runIO (doesFileExist path)
if exists
then [| Just (runTxOrPrint $(Q.sqlFromFile path)) |]
@ -269,7 +270,7 @@ migrations maybeDefaultSourceConfig dryRun maintenanceMode =
from42To43 = do
when (maintenanceMode == MaintenanceModeEnabled) $
throw500 "cannot migrate to catalog version 43 in maintenance mode"
let query = $(Q.sqlFromFile "src-rsr/migrations/42_to_43.sql")
let query = $(makeRelativeToProject "src-rsr/migrations/42_to_43.sql" >>= Q.sqlFromFile)
if dryRun then (liftIO . TIO.putStrLn . Q.getQueryText) query
else do
metadataV2 <- fetchMetadataFromHdbTables
@ -286,7 +287,7 @@ migrations maybeDefaultSourceConfig dryRun maintenanceMode =
liftTx $ insertMetadataInCatalog metadataV3
from43To42 = do
let query = $(Q.sqlFromFile "src-rsr/migrations/43_to_42.sql")
let query = $(makeRelativeToProject "src-rsr/migrations/43_to_42.sql" >>= Q.sqlFromFile)
if dryRun then (liftIO . TIO.putStrLn . Q.getQueryText) query
else do
Metadata{..} <- liftTx fetchMetadataFromCatalog

4
server/src-lib/Hasura/Server/Migrate/Version.hs
View File

@ -12,14 +12,14 @@ import Hasura.Prelude
import qualified Data.Text as T
import qualified Language.Haskell.TH.Syntax as TH
import Data.FileEmbed (embedStringFile)
import Data.FileEmbed (embedStringFile, makeRelativeToProject)
-- | The current catalog schema version. We store this in a file
-- because we want to append the current verson to the catalog_versions file
-- when tagging a new release, in @tag-release.sh@.
latestCatalogVersion :: Integer
latestCatalogVersion =
$(do let s = $(embedStringFile "src-rsr/catalog_version.txt")
$(do let s = $(makeRelativeToProject "src-rsr/catalog_version.txt" >>= embedStringFile)
TH.lift (read s :: Integer))
latestCatalogVersionString :: Text

11
server/src-lib/Hasura/Server/Version.hs
View File

@ -17,10 +17,11 @@ import qualified Data.SemVer as V
import qualified Data.Text as T
import qualified Language.Haskell.TH.Syntax as TH
import Text.Regex.TDFA ((=~~))
import Control.Lens ((^.), (^?))
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.FileEmbed (makeRelativeToProject)
import Data.Text.Conversions (FromText (..), ToText (..))
import Text.Regex.TDFA ((=~~))
import Hasura.RQL.Instances ()
import Hasura.Server.Utils (getValFromEnvOrScript)
@ -32,7 +33,7 @@ data Version
instance ToText Version where
toText = \case
VersionDev txt -> txt
VersionDev txt -> txt
VersionRelease version -> "v" <> V.toText version
instance FromText Version where
@ -48,7 +49,7 @@ instance FromJSON Version where
getVersionFromEnvironment :: TH.Q (TH.TExp Version)
getVersionFromEnvironment = do
let txt = getValFromEnvOrScript "VERSION" "../scripts/get-version.sh"
txt <- getValFromEnvOrScript "VERSION" <$> makeRelativeToProject "../scripts/get-version.sh"
[|| fromText $ T.dropWhileEnd (== '\n') $ T.pack $$(txt) ||]
-- | Lots of random things need access to the current version. It would be very convenient to define
@ -87,8 +88,8 @@ consoleAssetsVersion = case currentVersion of
(mr:_) -> case getTextFromId mr of
Nothing -> Nothing
Just r -> if
| T.null r -> Nothing
| otherwise -> T.pack <$> getChannelFromPreRelease (T.unpack r)
| T.null r -> Nothing
| otherwise -> T.pack <$> getChannelFromPreRelease (T.unpack r)
getChannelFromPreRelease :: String -> Maybe String
getChannelFromPreRelease sv = sv =~~ ("^([a-z]+)"::String)