Yesod の動的リロードの仕組みだけ利用する

wai-handler-devel がエラーでインストールできない。
どうやら削除された Network.Wai.Middleware.Debug を参照している模様。
https://github.com/yesodweb/wai/issues/25
https://github.com/yesodweb/wai/blob/master/wai-handler-devel/Network/Wai/Handler/DevelServer.hs
yesod は独自コマンドで開発サーバーを立ち上げるようになったので、もう wai-handler-devel は古くなっているのかもしれない(バージョンは更新されているが)

そもそも動的リロードはどうやっているのだろうと思って探した。
どうやら https://github.com/yesodweb/yesod/tree/master/yesod ここの Devel.hs と Build.hs のようだ。
Devel.hs はシンプルに devel 関数だけ提供しているので、このファイルだけあれば良さそう。
これらのファイルを作業ディレクトリにコピーして、リロード可能な単純なプログラムを書いてみる。

共通のmain.hs(暫定テスト用)と devel.hs ファイル。
main.hs

import Devel

main :: IO ()
main = devel False []

とりあえずdevel関数ベタ書きで。

devel.hs

{-# LANGUAGE PackageImports #-}
module Main where

import Prelude
import Network.Wai (Application)
import Network.Wai.Handler.Warp
    (runSettings, defaultSettings, settingsPort)
import Control.Concurrent (forkIO)
import Control.Concurrent (threadDelay)
import Network.Wai.Middleware.RequestLogger (logStdoutDev)
import System.Directory (doesFileExist)
import System.Exit (exitSuccess)
import Application


main :: IO ()
main = do
  putStrLn "Starting devel application on localhost:3000"
  forkIO $ runSettings defaultSettings
    { settingsPort = 3000 } getApplicationDev
  loop

loop :: IO ()
loop = do
  threadDelay 100000
  e <- doesFileExist "dist/devel-terminate"
  if e then terminateDevel else loop

terminateDevel :: IO ()
terminateDevel = exitSuccess

getApplicationDev :: Application
getApplicationDev = logStdoutDev getApplication

devel.hs が無いと怒られるので。だいたいyesodのテンプレートのまま。

Application.hs

{-# LANGUAGE OverloadedStrings #-}
module Application (getApplication) where

import Prelude
import Network.Wai (Application, Request, responseLBS, pathInfo)
import qualified Network.HTTP.Types as HT
import qualified Data.ByteString.Lazy.UTF8 as LBS
import qualified Data.Text as T
import Data.Monoid (Monoid (mappend))

infixr 5 <>
(<>) :: Monoid m => m -> m -> m
(<>) = mappend

getApplication :: Application
getApplication req = return $  responseLBS HT.status200 [] $ contents req

contents :: Request -> LBS.ByteString
contents req = "Path Info is " <> parse req <> "!"

parse :: Request -> LBS.ByteString
parse req = textToBS $ T.concat (pathInfo req)

textToBS :: T.Text -> LBS.ByteString
textToBS t = LBS.fromString $ T.unpack t