puttyへの細工とoperational monadでputtyをマクロ操作する

私の昼間の仕事は残念なことにHaskellとはまだ距離のある分野であろう組み込み屋さんに分類される．当然シリアルコンソールを叩く機会が多い．ターミナルとしては周囲ではTeraTerm様が幅を利かせている．というかTeraTerm様以外を使ってシリアルコンソールに繋いでる人をまだ見たことがない．たぶんTeraTerm様が使われている要因としてはTeraTermマクロの存在が大きい．開発中のハードだとおきまりの定型処理を叩き込んで起床させることが多く，それにはやはりマクロ機能があるターミナルソフトを使うのが適している．

だが，私はputty使いなのだ．puttyもシリアルコンソールは叩ける．となると，TeraTerm様とputtyを両方開発環境に入れておくのはとてもかっこわるい(と自分は思っているのだがどうか？)．「putty入ってるのに！」と思いながらTeraTerm様をインストールしたときのあの屈辱感ったらない．悔しい！マクロのためだけに追加でTeraTerm様を入れるのはダサいと言わざるを得ない．ここは我らがputtyにマクロ機能を追加するのが筋ではないのか？

ということで，puttyに標準入力からの簡単なコマンド待ち受けと，標準出力/エラー出力へGUIターミナルへの出力と同等の出力を行う細工を入れ，任意言語からパイプを通して操作できるようにしたhacked puttyを用意した．パイプ操作なので別に何言語通してでもかまわないのだが，操作言語はHaskellがいいなぁということで，今回はoperational monadで簡単にputtyをマクロを定義しHaskellプログラムから操作できるようにしてあげる．

https://github.com/notogawa/putty/tree/patch/macro

まずputty側への細工は，window.cがターゲットとなる．GUIターミナル画面への文字出力はfrom_backend関数なので，ここに同じ内容を標準出力/エラー出力するコードを入れ込む．

int from_backend(void *frontend, int is_stderr, const char *data, int len)
{
    if (pipe_out)
    {
        FILE* outfile = is_stderr ? stderr : stdout;
        fwrite(data, sizeof(char), len, outfile);
        fflush(outfile);
    }
    return term_data(term, is_stderr, data, len);
}

標準入力のためのスレッドを立ててreceive_message関数で読み込む．読み込んだ文字列はSendMessageでウィンドウメッセージにしてしまう．これだけ．

static DWORD WINAPI receive_message(void* data)
{
    char line[8192];
    while(fgets(line, sizeof(line), stdin))
    {
        const int length = strlen(line);
        if (line == strstr(line, "BEGIN")) pipe_out = TRUE;
        if (line == strstr(line, "END")) pipe_out = FALSE;
        if (line == strstr(line, "SENDLN"))
        {
            int i = 0;
            for (i = strlen("SENDLN "); i < length; ++i)
                SendMessage(hwnd, WM_CHAR, line[i], 0);
        }
    }
    return 0;
}

次にoperational monadでマクロ定義．今回は特定出力待ち(主にプロンプト待ちが目的)のwaitと，1行実行用のsendLnを定義する．このへんはもちろんTeraTermマクロ意識のネーミングとした．waitは前回のwait後から検出対象文字列が出るまでにターミナル標準出力に出た文字が取れるようにしておいた．出力結果で何か分岐したりする処理あるかもとか思ったのでね．その他，細かいことは何も気にしていない．

{-# LANGUAGE GADTs, Rank2Types #-}
module PuttyMacro(PuttyMacro,runPuttyMacro,sendLn,wait) where

import System.IO
    (Handle, hPutStrLn, hGetBufNonBlocking, hFlush,
     hSetBuffering, BufferMode(NoBuffering))
import System.Process
    (CreateProcess(..), createProcess, proc, StdStream(CreatePipe))
import Data.List(isInfixOf,isSuffixOf)
import Foreign.Ptr(Ptr)
import Foreign.C.String(castCCharToChar)
import Foreign.Marshal.Array(mallocArray, peekArray, pokeArray)
import Control.Concurrent(forkIO)
import Control.Concurrent.STM
    (newTVarIO, readTVarIO, readTVar, writeTVar, atomically, TVar(..), retry)
import Control.Monad(forever)
import Control.Monad.Operational
    (ProgramT, singleton, viewT, ProgramViewT(Return, (:>>=)))
import Control.Applicative((<$>))

data PuttyMacroI a where
    SendLn :: String -> PuttyMacroI ()
    Wait :: String -> PuttyMacroI String

type PuttyMacro m a = ProgramT PuttyMacroI m a

sendLn :: String -> PuttyMacro m ()
sendLn = singleton . SendLn

wait :: String -> PuttyMacro m String
wait = singleton . Wait

runPuttyMacro :: String -> [String] -> PuttyMacro IO () -> IO ()
runPuttyMacro putty opts macro = do
  (Just i, Just o, Just e, pid) <-
      createProcess (proc putty opts) { std_in = CreatePipe,
                                        std_out = CreatePipe,
                                        std_err = CreatePipe,
                                        close_fds = True }
  hSetBuffering o NoBuffering
  hSetBuffering e NoBuffering
  termData <- newTVarIO ""
  let putStrLnFlush str = hPutStrLn i str >> hFlush i
      eval m = viewT m >>= eval'
      eval' :: ProgramViewT PuttyMacroI IO () -> IO ()
      eval' (Return _) = return ()
      eval' (SendLn str :>>= m) = putStrLnFlush ("SENDLN "++str) >>= eval . m
      eval' (Wait str :>>= m) = waitWhile str >>= eval . m
      readTerm :: IO ()
      readTerm = forever $ do
                   buf <- mallocArray 65536
                   s <- map castCCharToChar <$>
                        (hGetBufNonBlocking o buf 65536 >>=
                         flip peekArray buf)
                   atomically $ readTVar termData >>= writeTVar termData . (++s)
      waitWhile :: String -> IO String
      waitWhile str = atomically $
                      do
                        buf <- readTVar termData
                        if str `isInfixOf` buf
                        then let (a, b) = splitBy str buf
                             in writeTVar termData b >> return a
                        else retry
  forkIO readTerm
  putStrLnFlush "BEGIN"
  eval macro
  putStrLnFlush "END"

splitBy str target = head [ (a, b) |
                            i <- [0..length target],
                            let (a, b) = splitAt i target,
                            str `isSuffixOf` a]

で，これ使ってマクロを書くと以下のような感じ．

module Main where

import PuttyMacro

main :: IO ()
main = runPuttyMacro "putty.exe" ["-load","scarlet"] userMacro

userMacro :: PuttyMacro IO ()
userMacro = do
  wait "$ "
  sendLn "ls"
  wait "$ "
  sendLn "pwd"

runPuttyMacroは，与えられたputtyの実行パスとオプションでputtyを起動して定義されたマクロを走らせる処理になっている．マクロを実行し終えるとputtyは残して自分は終わる．

(CゲンゴとかWindowsとかよくわからないため)puttyにあまり手を(目も)入れない方針での作業なので，(TeraTerm様では可能な)起動中puttyからマクロのロード実行はできない．欲を言えば，フルスクリーン化イベント(特殊キーイベント)を投げたりしたいところだが，puttyのソースともっとにらめっこしなきゃならなさそう．まぁ，当面の目的は達成できるのでとりあえずはここまででいいかなーといったところ．