

HRR を使ってファイルからスキーマを読み込ませたいのですが、上手くいきません。どうしたら良いのでしょうか。

### 背景

HRR
を使う場合にはコンパイル時にデータベースにアクセスすることになるのですが、リモートのデータベースを触りにいきたくないことがあり、データベースからのスキーマ読み込みとコードのコンパイルとを分離したいのです。

丁度手許に mysql-dump によるダンプファイルがあるのでこれを HRR に読み込ませようとしています。

### 手法

HRR はファイルからスキーマを読み込む機能が無いため、以下の方針でそれを実現しようとしました。

  * ローカルに一時的なディレクトリを作り、そのディレクトリ以下で動作するように MySQL を設定する
  * MySQL を起動し、ダンプファイルを読み込ませることで、所望のデータベースを構築する
  * HRR に構築したデータベースを読み込ませる
  * MySQL を止める

以下の様に `defineTableFromFile` を定義し、`$(defineTableFromFile
("path/to/dump.schema", "dbname") [] "table_name")` でスキーマを読み込もうとします。

[code]

    import Control.Concurrent (forkIO, threadDelay)
    import Control.Exception (bracket)
    import Control.Monad (unless)
    import Database.HDBC (runRaw)
    import Database.HDBC.MySQL (MySQLConnectInfo, connectMySQL, defaultMySQLConnectInfo, mysqlUser, mysqlPassword, mysqlHost, mysqlDatabase, mysqlUnixSocket)
    import System.Directory (createDirectory)
    import System.Exit
    import System.FilePath
    import System.IO.Temp
    import System.Process
    
    logFile :: FilePath -> FilePath
    logFile prefix = prefix </>  "log"
    
    spawnInstance :: FilePath -> IO ProcessHandle
    spawnInstance prefix = do
      -- For MySQL 5.7 and later
      -- run with --initialize
      createDirectory $ datadir prefix
      (exitCode, _, _) <- readProcessWithExitCode  "which" ["mysql_install_db"] ""
      let newMySql = case exitCode of
            ExitSuccess -> False
            ExitFailure _ -> True
      putStrLn $ "New MySQL: " ++ show newMySql
      unless newMySql $
        putStrLn =<< readProcess "mysql_install_db" [ "--datadir", datadir prefix ] ""
      spawnProcess "mysqld" $
        [ "--datadir", datadir prefix
        , "--socket", socketFile prefix
        , "--pid-file", pidFile prefix
        , "--skip-networking"
        ] ++ if newMySql
            then [ "--initialize-insecure" ]
            else [ "--log-error", logFile prefix
                 ]
    
    
    withInstance :: FilePath -> (MySQLConnectInfo -> ProcessHandle -> IO c) -> IO c
    withInstance prefix f = bracket (spawnInstance prefix) term (f connection)
      where
        term h = do
          putStrLn "Terminating MySQL"
          terminateProcess h
          waitForProcess h
        connection = defaultMySQLConnectInfo
          { mysqlUser     = "root"
          , mysqlPassword = ""
          , mysqlHost = ""
          , mysqlDatabase = "INFORMATION_SCHEMA"
          , mysqlUnixSocket = socketFile prefix
          }
    
    withTempInstance :: (MySQLConnectInfo -> ProcessHandle -> IO a) -> IO a
    withTempInstance f = withSystemTempDirectory "MysqlInstance" (`withInstance` f)
    
    prepareTable :: String -> MySQLConnectInfo -> IO ()
    prepareTable sql mc = do
      c <- connectMySQL mc
      runRaw c sql
    
    defineTableFromFile :: (FilePath, String) -> [(String, TypeQ)] -> String -> Q [Dec]
    defineTableFromFile (schemaFile, schemaName) tmap tableName = do
        sql <- runIO $ readFile schemaFile
        runIO $ MI.withTempInstance $ f sql
      where
        term h = do
          putStrLn "Terminating MySQL"
          terminateProcess h
          waitForProcess h
        f sql connectInfo ph = do
          MI.prepareTable sql connectInfo
          runQ $ defineTableFromDB
            (connectMySQL mySQLConnectInfo)
            (driverMySQL { driverConfig = defaultConfig { normalizedTableName = False }
                        , typeMap = tmap
                        })
            schemaName
            tableName
            [''Show, ''Generic]
    
[/code]

### 結果

HRR が MySQL にアクセスする以前に MySQL が殺されてしまい、できませんでした。

[code]

    ...
    New MySQL: True
    Terminating MySQL
    
    /Users/noriaki/devel/test/src/TblTest.hs:1:1: error:
        Exception when trying to run compile-time code:
          SqlError {seState = "", seNativeError = 2002, seErrorMsg = "Can't connect to local MySQL server through socket '/private/var/folders/s7/64kkg4ld6kl_k3f408lp9bd00000gn/T/MySQLInstance62897/sock' (2)"}
        Code: defineTableFromFile schema [] "tbl_test"
      |
    1 | {-# LANGUAGE DataKinds, FlexibleInstances, TemplateHaskell, MultiParamTypeClasses, DeriveGeneric #-}
      | ^
    
[/code]


CC BY-SA 4.0
2019-04-29T18:03:30.443
54580
2019-04-29T18:03:30.443
27069
question
mysql database haskell
Haskell Relational-Record で MySQL を用い、ファイルからスキーマを読み込む方法