optimise 'run_sql' query, closes #1362 (#1406)

server/src-lib/Hasura/RQL/DDL/Schema/Table.hs

@@ -12,6 +12,7 @@ import           Hasura.RQL.DDL.Schema.Diff
 import           Hasura.RQL.DDL.Subscribe
 import           Hasura.RQL.DDL.Utils
 import           Hasura.RQL.Types
+import           Hasura.Server.Utils                (matchRegex)
 import           Hasura.SQL.Types
 
 import qualified Database.PG.Query                  as Q
@@ -375,8 +376,9 @@ buildSchemaCache = do
 
 data RunSQL
   = RunSQL
-  { rSql     :: T.Text
-  , rCascade :: !(Maybe Bool)
+  { rSql                      :: T.Text
+  , rCascade                  :: !(Maybe Bool)
+  , rCheckMetadataConsistency :: !(Maybe Bool)
   } deriving (Show, Eq, Lift)
 
 $(deriveJSON (aesonDrop 1 snakeCase){omitNothingFields=True} ''RunSQL)
@@ -389,10 +391,18 @@ data RunSQLRes
 
 $(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''RunSQLRes)
 
-runSqlP2
+execRawSQL :: (MonadTx m) => T.Text -> m RunSQLRes
+execRawSQL =
+  liftTx . Q.multiQE rawSqlErrHandler . Q.fromText
+  where
+    rawSqlErrHandler txe =
+      let e = err400 PostgresError "query execution failed"
+      in e {qeInternal = Just $ toJSON txe}
+
+execWithMDCheck
   :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m)
-  => RunSQL -> m RespBody
-runSqlP2 (RunSQL t cascade) = do
+  => RunSQL -> m RunSQLRes
+execWithMDCheck (RunSQL t cascade _) = do
 
   -- Drop hdb_views so no interference is caused to the sql query
   liftTx $ Q.catchE defaultTxErrorHandler clearHdbViews
@@ -401,7 +411,7 @@ runSqlP2 (RunSQL t cascade) = do
   oldMetaU <- liftTx $ Q.catchE defaultTxErrorHandler fetchTableMeta
 
   -- Run the SQL
-  res <- liftTx $ Q.multiQE rawSqlErrHandler $ Q.fromText t
+  res <- execRawSQL t
 
   -- Get the metadata after the sql query
   newMeta <- liftTx $ Q.catchE defaultTxErrorHandler fetchTableMeta
@@ -440,19 +450,21 @@ runSqlP2 (RunSQL t cascade) = do
   -- refresh the gCtxMap in schema cache
   refreshGCtxMapInSchema
 
-  return $ encode (res :: RunSQLRes)
+  return res
 
+isAltrDropReplace :: QErrM m => T.Text -> m Bool
+isAltrDropReplace = either throwErr return . matchRegex regex False
   where
-    rawSqlErrHandler :: Q.PGTxErr -> QErr
-    rawSqlErrHandler txe =
-      let e = err400 PostgresError "query execution failed"
-      in e {qeInternal = Just $ toJSON txe}
+    throwErr s = throw500 $ "compiling regex failed: " <> T.pack s
+    regex = "alter|drop|replace"
 
 runRunSQL
   :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m)
   => RunSQL -> m RespBody
-runRunSQL q =
-  adminOnly >> runSqlP2 q
+runRunSQL q@(RunSQL t _ mChkMDCnstcy) = do
+  adminOnly
+  isMDChkNeeded <- maybe (isAltrDropReplace t) return mChkMDCnstcy
+  encode <$> bool (execRawSQL t) (execWithMDCheck q) isMDChkNeeded
 
 -- Should be used only after checking the status
 resToCSV :: PQ.Result -> ExceptT T.Text IO [[T.Text]]

server/src-lib/Hasura/Server/Utils.hs

@@ -15,6 +15,8 @@ import qualified Data.Text.Encoding.Error     as TE
 import qualified Data.Text.IO                 as TI
 import qualified Language.Haskell.TH.Syntax   as TH
 import qualified Text.Ginger                  as TG
+import qualified Text.Regex.TDFA              as TDFA
+import qualified Text.Regex.TDFA.ByteString   as TDFA
 
 import           Hasura.Prelude
 
@@ -111,3 +113,16 @@ _2 (_, y, _) = y
 
 _3 :: (a, b, c) -> c
 _3 (_, _, z) = z
+
+-- regex related
+matchRegex :: B.ByteString -> Bool -> T.Text -> Either String Bool
+matchRegex regex caseSensitive src =
+  fmap (`TDFA.match` TE.encodeUtf8 src) compiledRegexE
+  where
+    compOpt = TDFA.defaultCompOpt
+      { TDFA.caseSensitive = caseSensitive
+      , TDFA.multiline = True
+      , TDFA.lastStarGreedy = True
+      }
+    execOption = TDFA.defaultExecOpt {TDFA.captureGroups = False}
+    compiledRegexE = TDFA.compile compOpt execOption regex