Repository: hasura/graphql-engine
File: server/src-lib/Hasura/RQL/DDL/Schema.hs (Haskell)

Code before:

data RunSQL
  = RunSQL
  { rSql                      :: Text
  , rCascade                  :: !(Maybe Bool)
  , rCheckMetadataConsistency :: !(Maybe Bool)
  , rReadOnly                 :: !(Maybe Bool)
  } deriving (Show, Eq, Lift)
$(deriveJSON (aesonDrop 1 snakeCase){omitNothingFields=True} ''RunSQL)

runRunSQL :: (CacheBuildM m, UserInfoM m) => RunSQL -> m EncJSON
runRunSQL (RunSQL sql cascade mChkMDCnstcy (fromMaybe False -> isReadOnly)) = do
  adminOnly
  isMDChkNeeded <- maybe (if isReadOnly then pure False else isAltrDropReplace sql) return mChkMDCnstcy
  bool (execRawSQL sql) (withMetadataCheck (or cascade) $ execRawSQL sql) isMDChkNeeded
  where
    execRawSQL :: (MonadTx m) => Text -> m EncJSON
    execRawSQL =
      fmap (encJFromJValue @RunSQLRes) . liftTx . setTransactionAccess . Q.multiQE rawSqlErrHandler . Q.fromText
      where
        rawSqlErrHandler txe =
          let e = err400 PostgresError "query execution failed"
          in e {qeInternal = Just $ toJSON txe}
    setTransactionAccess tx = if isReadOnly then setReadOnly >> tx else tx

    setReadOnly =  Q.unitQE defaultTxErrorHandler "SET TRANSACTION READ ONLY" () False

    isAltrDropReplace :: QErrM m => T.Text -> m Bool
    isAltrDropReplace = either throwErr return . matchRegex regex False
      where
        throwErr s = throw500 $ "compiling regex failed: " <> T.pack s
        regex = "alter|drop|replace|create function|comment on"

data RunSQLRes
  = RunSQLRes
  { rrResultType :: !Text
  , rrResult     :: !Value
  } deriving (Show, Eq)
$(deriveJSON (aesonDrop 2 snakeCase) ''RunSQLRes)

instance Q.FromRes RunSQLRes where
  fromRes (Q.ResultOkEmpty _) =
    return $ RunSQLRes "CommandOk" Null
  fromRes (Q.ResultOkData res) = do
    csvRows <- resToCSV res
    return $ RunSQLRes "TuplesOk" $ toJSON csvRows
    where
      resToCSV :: PQ.Result -> ExceptT T.Text IO [[Text]]
      resToCSV r =  do
        nr  <- liftIO $ PQ.ntuples r
        nc  <- liftIO $ PQ.nfields r

Review comment (refactor):
One issue I foresee with this is using read-only `run_sql` queries in `bulk` queries, since we run entire `bulk` queries in one transaction, so setting the transaction to read-only will cause problems for other queries that come later if they made modifications.

Personally, I think it would be nice to add some sort of scoped `withAccessMode` abstraction somewhere in  `Hasura/SQL/` with a type like

```haskell
withAccessMode :: (MonadTx m) => TxAccess -> m a -> m a
```

that gets the current access mode, sets it if necessary, and then resets it to the old value when control leaves the function. (Using some form of lifted `bracket` operation is probably the right thing to implement `withAccessMode`, which would additionally require something like `MonadMask` or `MonadBaseControl`.)

Code after:

data RunSQL
  = RunSQL
  { rSql                          :: Text
  , rCascade                      :: !Bool
  , rCheckMetadataConsistency     :: !(Maybe Bool)
  , rTxAccessMode                 :: !Q.TxAccess
  } deriving (Show, Eq, Lift)

instance FromJSON RunSQL where
  parseJSON = withObject "RunSQL" $ \o -> do
    rSql <- o .: "sql"
    rCascade <- o .:? "cascade" .!= False
    rCheckMetadataConsistency <- o .:? "check_metadata_consistency"
    isReadOnly <- o .:? "read_only" .!= False
    let rTxAccessMode = if isReadOnly then Q.ReadOnly else Q.ReadWrite
    pure RunSQL{..}

instance ToJSON RunSQL where
  toJSON RunSQL {..} =
    object
      [ "sql" .= rSql
      , "cascade" .= rCascade
      , "check_metadata_consistency" .= rCheckMetadataConsistency
      , "read_only" .=
        case rTxAccessMode of
          Q.ReadOnly -> True
          Q.ReadWrite -> False
      ]

runRunSQL :: (CacheBuildM m, UserInfoM m) => RunSQL -> m EncJSON
runRunSQL RunSQL {..} = do
  adminOnly
  metadataCheckNeeded <- onNothing rCheckMetadataConsistency $ isAltrDropReplace rSql
  bool (execRawSQL rSql) (withMetadataCheck rCascade $ execRawSQL rSql) metadataCheckNeeded
  where
    execRawSQL :: (MonadTx m) => Text -> m EncJSON
    execRawSQL =
      fmap (encJFromJValue @RunSQLRes) . liftTx . Q.multiQE rawSqlErrHandler . Q.fromText
      where
        rawSqlErrHandler txe =
          let e = err400 PostgresError "query execution failed"
           in e {qeInternal = Just $ toJSON txe}

    isAltrDropReplace :: QErrM m => T.Text -> m Bool
    isAltrDropReplace = either throwErr return . matchRegex regex False
      where
        throwErr s = throw500 $ "compiling regex failed: " <> T.pack s
        regex = "alter|drop|replace|create function|comment on"

data RunSQLRes