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

背景

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

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

手法

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

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

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

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]

結果

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

...
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 #-}
  | ^