module Hasura.Backends.MySQL.Connection
  ( runJSONPathQuery,
    resolveSourceConfig,
    resolveDatabaseMetadata,
    postDropSourceHook,
    fetchAllRows,
    runQueryYieldingRows,
    withMySQLPool,
    parseTextRows,
  )
where

import Data.Aeson hiding (Result)
import Data.Aeson qualified as J
import Data.Aeson.Key qualified as K
import Data.Aeson.KeyMap qualified as KM
import Data.Aeson.Text (encodeToTextBuilder)
import Data.ByteString (ByteString)
import Data.HashMap.Strict.InsOrd qualified as OMap
import Data.Pool
import Data.Scientific (fromFloatDigits)
import Data.Text qualified as T
import Data.Text.Encoding (decodeUtf8)
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder (toLazyText)
import Data.Vector (Vector)
import Data.Vector qualified as V
import Database.MySQL.Base
import Database.MySQL.Base.Types (Field (..))
import Database.MySQL.Simple.Result qualified as MySQL
import Hasura.Backends.MySQL.DataLoader.Plan qualified as DataLoaderPlan
import Hasura.Backends.MySQL.Meta (getMetadata)
import Hasura.Backends.MySQL.ToQuery (Query (..))
import Hasura.Backends.MySQL.Types
import Hasura.Base.Error
import Hasura.Logging (Hasura, Logger)
import Hasura.Prelude
import Hasura.RQL.Types.Backend (BackendConfig)
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Source
import Hasura.RQL.Types.SourceCustomization
import Hasura.RQL.Types.Table (TableEventTriggers)
import Hasura.SQL.Backend

resolveSourceConfig :: (MonadIO m) => Logger Hasura -> SourceName -> ConnSourceConfig -> BackendSourceKind 'MySQL -> BackendConfig 'MySQL -> environment -> manager -> m (Either QErr SourceConfig)
resolveSourceConfig :: Logger Hasura
-> SourceName
-> ConnSourceConfig
-> BackendSourceKind 'MySQL
-> BackendConfig 'MySQL
-> environment
-> manager
-> m (Either QErr SourceConfig)
resolveSourceConfig Logger Hasura
_logger SourceName
_name csc :: ConnSourceConfig
csc@ConnSourceConfig {_cscPoolSettings :: ConnSourceConfig -> ConnPoolSettings
_cscPoolSettings = ConnPoolSettings {Word
_cscMaxConnections :: ConnPoolSettings -> Word
_cscIdleTimeout :: ConnPoolSettings -> Word
_cscMaxConnections :: Word
_cscIdleTimeout :: Word
..}, Word16
Text
_cscDatabase :: ConnSourceConfig -> Text
_cscPassword :: ConnSourceConfig -> Text
_cscUser :: ConnSourceConfig -> Text
_cscPort :: ConnSourceConfig -> Word16
_cscHost :: ConnSourceConfig -> Text
_cscDatabase :: Text
_cscPassword :: Text
_cscUser :: Text
_cscPort :: Word16
_cscHost :: Text
..} BackendSourceKind 'MySQL
_backendKind BackendConfig 'MySQL
_backendConfig environment
_env manager
_manager = do
  let connectInfo :: ConnectInfo
connectInfo =
        ConnectInfo
defaultConnectInfo
          { connectHost :: String
connectHost = Text -> String
T.unpack Text
_cscHost,
            connectPort :: Word16
connectPort = Word16
_cscPort,
            connectUser :: String
connectUser = Text -> String
T.unpack Text
_cscUser,
            connectPassword :: String
connectPassword = Text -> String
T.unpack Text
_cscPassword,
            connectDatabase :: String
connectDatabase = Text -> String
T.unpack Text
_cscDatabase
          }
  ExceptT QErr m SourceConfig -> m (Either QErr SourceConfig)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr m SourceConfig -> m (Either QErr SourceConfig))
-> ExceptT QErr m SourceConfig -> m (Either QErr SourceConfig)
forall a b. (a -> b) -> a -> b
$
    ConnSourceConfig -> Pool Connection -> SourceConfig
SourceConfig ConnSourceConfig
csc
      (Pool Connection -> SourceConfig)
-> ExceptT QErr m (Pool Connection) -> ExceptT QErr m SourceConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Pool Connection) -> ExceptT QErr m (Pool Connection)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        ( IO Connection
-> (Connection -> IO ())
-> Int
-> NominalDiffTime
-> Int
-> IO (Pool Connection)
forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
createPool
            (ConnectInfo -> IO Connection
connect ConnectInfo
connectInfo)
            Connection -> IO ()
close
            Int
1
            (Word -> NominalDiffTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
_cscIdleTimeout)
            (Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
_cscMaxConnections)
        )

resolveDatabaseMetadata :: (MonadIO m) => SourceConfig -> SourceTypeCustomization -> m (Either QErr (ResolvedSource 'MySQL))
resolveDatabaseMetadata :: SourceConfig
-> SourceTypeCustomization
-> m (Either QErr (ResolvedSource 'MySQL))
resolveDatabaseMetadata sc :: SourceConfig
sc@SourceConfig {Pool Connection
ConnSourceConfig
scConnectionPool :: SourceConfig -> Pool Connection
scConfig :: SourceConfig -> ConnSourceConfig
scConnectionPool :: Pool Connection
scConfig :: ConnSourceConfig
..} SourceTypeCustomization
sourceCustomization =
  ExceptT QErr m (ResolvedSource 'MySQL)
-> m (Either QErr (ResolvedSource 'MySQL))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT QErr m (ResolvedSource 'MySQL)
 -> m (Either QErr (ResolvedSource 'MySQL)))
-> ExceptT QErr m (ResolvedSource 'MySQL)
-> m (Either QErr (ResolvedSource 'MySQL))
forall a b. (a -> b) -> a -> b
$ do
    HashMap TableName (DBTableMetadata 'MySQL)
metadata <- IO (HashMap TableName (DBTableMetadata 'MySQL))
-> ExceptT QErr m (HashMap TableName (DBTableMetadata 'MySQL))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (HashMap TableName (DBTableMetadata 'MySQL))
 -> ExceptT QErr m (HashMap TableName (DBTableMetadata 'MySQL)))
-> IO (HashMap TableName (DBTableMetadata 'MySQL))
-> ExceptT QErr m (HashMap TableName (DBTableMetadata 'MySQL))
forall a b. (a -> b) -> a -> b
$ Pool Connection
-> (Connection -> IO (HashMap TableName (DBTableMetadata 'MySQL)))
-> IO (HashMap TableName (DBTableMetadata 'MySQL))
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
withResource Pool Connection
scConnectionPool (ConnSourceConfig -> Connection -> IO (DBTablesMetadata 'MySQL)
getMetadata ConnSourceConfig
scConfig)
    ResolvedSource 'MySQL -> ExceptT QErr m (ResolvedSource 'MySQL)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResolvedSource 'MySQL -> ExceptT QErr m (ResolvedSource 'MySQL))
-> ResolvedSource 'MySQL -> ExceptT QErr m (ResolvedSource 'MySQL)
forall a b. (a -> b) -> a -> b
$ SourceConfig 'MySQL
-> SourceTypeCustomization
-> DBTablesMetadata 'MySQL
-> DBFunctionsMetadata 'MySQL
-> ScalarMap 'MySQL
-> ResolvedSource 'MySQL
forall (b :: BackendType).
SourceConfig b
-> SourceTypeCustomization
-> DBTablesMetadata b
-> DBFunctionsMetadata b
-> ScalarMap b
-> ResolvedSource b
ResolvedSource SourceConfig 'MySQL
SourceConfig
sc SourceTypeCustomization
sourceCustomization DBTablesMetadata 'MySQL
HashMap TableName (DBTableMetadata 'MySQL)
metadata DBFunctionsMetadata 'MySQL
forall a. Monoid a => a
mempty ScalarMap 'MySQL
forall a. Monoid a => a
mempty

postDropSourceHook ::
  (MonadIO m) =>
  SourceConfig ->
  TableEventTriggers 'MySQL ->
  m ()
postDropSourceHook :: SourceConfig -> TableEventTriggers 'MySQL -> m ()
postDropSourceHook SourceConfig
_ TableEventTriggers 'MySQL
_ =
  -- As of now, we do not add any Hasura related stuff to source DB hence
  -- no need to clean things up.
  () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

parseFieldResult :: Field -> Maybe ByteString -> Value
parseFieldResult :: Field -> Maybe ByteString -> Value
parseFieldResult f :: Field
f@Field {Word
ByteString
Type
FieldFlags
fieldType :: Field -> Type
fieldTable :: Field -> ByteString
fieldOrigTable :: Field -> ByteString
fieldOrigName :: Field -> ByteString
fieldName :: Field -> ByteString
fieldMaxLength :: Field -> Word
fieldLength :: Field -> Word
fieldFlags :: Field -> FieldFlags
fieldDecimals :: Field -> Word
fieldDB :: Field -> ByteString
fieldCharSet :: Field -> Word
fieldCatalog :: Field -> ByteString
fieldType :: Type
fieldCharSet :: Word
fieldDecimals :: Word
fieldFlags :: FieldFlags
fieldMaxLength :: Word
fieldLength :: Word
fieldCatalog :: ByteString
fieldDB :: ByteString
fieldOrigTable :: ByteString
fieldTable :: ByteString
fieldOrigName :: ByteString
fieldName :: ByteString
..} Maybe ByteString
mBs =
  case Type
fieldType of
    Type
Long ->
      let Double
fvalue :: Double = Field -> Maybe ByteString -> Double
forall a. Result a => Field -> Maybe ByteString -> a
MySQL.convert Field
f Maybe ByteString
mBs
       in Scientific -> Value
Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Double -> Scientific
forall a. RealFloat a => a -> Scientific
fromFloatDigits Double
fvalue
    Type
VarString ->
      let Text
fvalue :: Text = Field -> Maybe ByteString -> Text
forall a. Result a => Field -> Maybe ByteString -> a
MySQL.convert Field
f Maybe ByteString
mBs
       in Text -> Value
J.String Text
fvalue
    Type
Blob ->
      let Text
fvalue :: Text = Field -> Maybe ByteString -> Text
forall a. Result a => Field -> Maybe ByteString -> a
MySQL.convert Field
f Maybe ByteString
mBs
       in Text -> Value
J.String Text
fvalue
    Type
DateTime -> Value -> (ByteString -> Value) -> Maybe ByteString -> Value
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Value
J.Null (Text -> Value
J.String (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8) Maybe ByteString
mBs
    Type
_ -> String -> Value
forall a. HasCallStack => String -> a
error (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"parseResult: not implemented yet " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Field -> String
forall a. Show a => a -> String
show Field
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Maybe ByteString -> String
forall a. Show a => a -> String
show Maybe ByteString
mBs

-- TODO: handle remaining cases

fieldsToAeson :: [Field] -> [[Maybe ByteString]] -> [Value]
fieldsToAeson :: [Field] -> [[Maybe ByteString]] -> [Value]
fieldsToAeson [Field]
column [[Maybe ByteString]]
rows =
  [ Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$
      [(Key, Value)] -> Object
forall v. [(Key, v)] -> KeyMap v
KM.fromList ([(Key, Value)] -> Object) -> [(Key, Value)] -> Object
forall a b. (a -> b) -> a -> b
$
        [ (Text -> Key
K.fromText (ByteString -> Text
decodeUtf8 (Field -> ByteString
fieldName Field
c))) Key -> Value -> (Key, Value)
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Field -> Maybe ByteString -> Value
parseFieldResult Field
c Maybe ByteString
r)
          | (Field
c, Maybe ByteString
r) <- ([Field] -> [Maybe ByteString] -> [(Field, Maybe ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Field]
column [Maybe ByteString]
row :: [(Field, Maybe ByteString)])
        ]
    | [Maybe ByteString]
row <- ([[Maybe ByteString]]
rows :: [[Maybe ByteString]])
  ]

runJSONPathQuery ::
  (MonadError QErr m, MonadIO m) =>
  (Pool Connection) ->
  Query ->
  m Text
runJSONPathQuery :: Pool Connection -> Query -> m Text
runJSONPathQuery Pool Connection
pool (Query ByteString
querySql) = do
  [Value]
result <- IO [Value] -> m [Value]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Value] -> m [Value]) -> IO [Value] -> m [Value]
forall a b. (a -> b) -> a -> b
$
    Pool Connection -> (Connection -> IO [Value]) -> IO [Value]
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
withResource Pool Connection
pool ((Connection -> IO [Value]) -> IO [Value])
-> (Connection -> IO [Value]) -> IO [Value]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
      Connection -> ByteString -> IO ()
query Connection
conn ByteString
querySql
      Result
result <- Connection -> IO Result
storeResult Connection
conn
      [Field]
fields <- Result -> IO [Field]
fetchFields Result
result
      [[Maybe ByteString]]
rows <- Result -> IO [[Maybe ByteString]]
fetchAllRows Result
result
      [Value] -> IO [Value]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Value] -> IO [Value]) -> [Value] -> IO [Value]
forall a b. (a -> b) -> a -> b
$ [Field] -> [[Maybe ByteString]] -> [Value]
fieldsToAeson [Field]
fields [[Maybe ByteString]]
rows
  Text -> m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Builder -> Text
toLazyText (Builder -> Text) -> Builder -> Text
forall a b. (a -> b) -> a -> b
$ Value -> Builder
forall a. ToJSON a => a -> Builder
encodeToTextBuilder (Value -> Builder) -> Value -> Builder
forall a b. (a -> b) -> a -> b
$ [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON [Value]
result

-- | Used by the dataloader to produce rows of records. Those rows of
-- records are then manipulated by the dataloader to do Haskell-side
-- joins. Is a Vector of HashMaps the most efficient choice? A
-- pandas-style data frame could also be more efficient,
-- dependingly. However, this is a legible approach; efficiency
-- improvements can be added later.
parseAndCollectRows ::
  [Field] ->
  [[Maybe ByteString]] ->
  Vector (InsOrdHashMap DataLoaderPlan.FieldName J.Value)
parseAndCollectRows :: [Field]
-> [[Maybe ByteString]] -> Vector (InsOrdHashMap FieldName Value)
parseAndCollectRows [Field]
columns [[Maybe ByteString]]
rows =
  [InsOrdHashMap FieldName Value]
-> Vector (InsOrdHashMap FieldName Value)
forall a. [a] -> Vector a
V.fromList
    [ [(FieldName, Value)] -> InsOrdHashMap FieldName Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
OMap.fromList
        [ (Text -> FieldName
DataLoaderPlan.FieldName (Text -> FieldName) -> (Field -> Text) -> Field -> FieldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text) -> (Field -> ByteString) -> Field -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> ByteString
fieldName (Field -> FieldName) -> Field -> FieldName
forall a b. (a -> b) -> a -> b
$ Field
column, Field -> Maybe ByteString -> Value
parseFieldResult Field
column Maybe ByteString
value)
          | (Field
column, Maybe ByteString
value) <- [Field] -> [Maybe ByteString] -> [(Field, Maybe ByteString)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Field]
columns [Maybe ByteString]
row :: [(Field, Maybe ByteString)]
        ]
      | [Maybe ByteString]
row <- [[Maybe ByteString]]
rows :: [[Maybe ByteString]]
    ]

-- | Run a query immediately and parse up the results into a vector.
runQueryYieldingRows ::
  (MonadIO m) =>
  Pool Connection ->
  Query ->
  m (Vector (InsOrdHashMap DataLoaderPlan.FieldName J.Value))
runQueryYieldingRows :: Pool Connection
-> Query -> m (Vector (InsOrdHashMap FieldName Value))
runQueryYieldingRows Pool Connection
pool (Query ByteString
querySql) = do
  IO (Vector (InsOrdHashMap FieldName Value))
-> m (Vector (InsOrdHashMap FieldName Value))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Vector (InsOrdHashMap FieldName Value))
 -> m (Vector (InsOrdHashMap FieldName Value)))
-> IO (Vector (InsOrdHashMap FieldName Value))
-> m (Vector (InsOrdHashMap FieldName Value))
forall a b. (a -> b) -> a -> b
$
    Pool Connection
-> (Connection -> IO (Vector (InsOrdHashMap FieldName Value)))
-> IO (Vector (InsOrdHashMap FieldName Value))
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
withResource Pool Connection
pool ((Connection -> IO (Vector (InsOrdHashMap FieldName Value)))
 -> IO (Vector (InsOrdHashMap FieldName Value)))
-> (Connection -> IO (Vector (InsOrdHashMap FieldName Value)))
-> IO (Vector (InsOrdHashMap FieldName Value))
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
      Connection -> ByteString -> IO ()
query Connection
conn ByteString
querySql
      Result
result <- Connection -> IO Result
storeResult Connection
conn
      [Field]
fields <- Result -> IO [Field]
fetchFields Result
result
      [[Maybe ByteString]]
rows <- Result -> IO [[Maybe ByteString]]
fetchAllRows Result
result
      Vector (InsOrdHashMap FieldName Value)
-> IO (Vector (InsOrdHashMap FieldName Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Field]
-> [[Maybe ByteString]] -> Vector (InsOrdHashMap FieldName Value)
parseAndCollectRows [Field]
fields [[Maybe ByteString]]
rows)

fetchAllRows :: Result -> IO [[Maybe ByteString]]
fetchAllRows :: Result -> IO [[Maybe ByteString]]
fetchAllRows Result
r = [[Maybe ByteString]] -> [[Maybe ByteString]]
forall a. [a] -> [a]
reverse ([[Maybe ByteString]] -> [[Maybe ByteString]])
-> IO [[Maybe ByteString]] -> IO [[Maybe ByteString]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Maybe ByteString]] -> Result -> IO [[Maybe ByteString]]
go [] Result
r
  where
    go :: [[Maybe ByteString]] -> Result -> IO [[Maybe ByteString]]
go [[Maybe ByteString]]
acc Result
res =
      Result -> IO [Maybe ByteString]
fetchRow Result
res IO [Maybe ByteString]
-> ([Maybe ByteString] -> IO [[Maybe ByteString]])
-> IO [[Maybe ByteString]]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        [] -> [[Maybe ByteString]] -> IO [[Maybe ByteString]]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [[Maybe ByteString]]
acc
        [Maybe ByteString]
r' -> [[Maybe ByteString]] -> Result -> IO [[Maybe ByteString]]
go ([Maybe ByteString]
r' [Maybe ByteString] -> [[Maybe ByteString]] -> [[Maybe ByteString]]
forall a. a -> [a] -> [a]
: [[Maybe ByteString]]
acc) Result
res

parseTextRows :: [Field] -> [[Maybe ByteString]] -> [[Text]]
parseTextRows :: [Field] -> [[Maybe ByteString]] -> [[Text]]
parseTextRows [Field]
columns [[Maybe ByteString]]
rows = (Field -> [Maybe ByteString] -> [Text])
-> [Field] -> [[Maybe ByteString]] -> [[Text]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Field
column [Maybe ByteString]
row -> (Maybe ByteString -> Text) -> [Maybe ByteString] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Field -> Maybe ByteString -> Text
forall a. Result a => Field -> Maybe ByteString -> a
MySQL.convert Field
column) [Maybe ByteString]
row) [Field]
columns [[Maybe ByteString]]
rows

withMySQLPool :: (MonadIO m) => Pool Connection -> (Connection -> IO a) -> m a
withMySQLPool :: Pool Connection -> (Connection -> IO a) -> m a
withMySQLPool Pool Connection
pool = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a)
-> ((Connection -> IO a) -> IO a) -> (Connection -> IO a) -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pool Connection -> (Connection -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
withResource Pool Connection
pool