maoeのブログ

htmlcatをwai + warpだけでなくsnap-core + snap-serverでも動くようにしてみました。なるべく似たようなコードになるように書いてみました。とても似ています。

Snapだとこんな感じ。

{-# LANGUAGE OverloadedStrings #-}
module HtmlCat.Snap (feedStdIn, runHtmlCat) where
import Control.Concurrent (Chan, writeChan, forkIO)
import Control.Monad (void)
import Control.Monad.Trans (MonadIO(..))
import Data.Text (Text)
import System.IO (stdin)
import qualified Data.ByteString.Char8 as B8

import Data.Enumerator (Iteratee, Enumeratee, ($$), ($=))
import Snap.Core
import Snap.Http.Server (simpleHttpServe)
import Snap.Http.Server.Config
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
import qualified Blaze.ByteString.Builder.Char.Utf8 as B
import qualified Data.Enumerator as E (run_)
import qualified Data.Enumerator.List as E (map, foldM)
import qualified Data.Enumerator.Text as E (enumHandle)

import HtmlCat.Html (html)
import Snap.EventSource (ServerEvent(..), eventSourceApp)

feedStdIn :: Chan ServerEvent -> IO ()
feedStdIn chan = void . forkIO $ E.run_ $
  sourceStdIn $= textsToEventSource $$ sinkChan chan

runHtmlCat :: Chan ServerEvent -> String -> Int -> IO ()
runHtmlCat chan host port =
  simpleHttpServe (setPort port $ setBind (B8.pack host)
                                $ defaultConfig :: Config Snap ())
                  (app chan)

app :: Chan ServerEvent -> Snap ()
app chan = route [ ("",       appTop)
                 , ("stream", appStream chan)
                 ]

appTop :: Snap ()
appTop = writeBuilder $ renderHtmlBuilder html

appStream :: Chan ServerEvent -> Snap ()
appStream = eventSourceApp

sourceStdIn :: MonadIO m => Enumerator Text m a
sourceStdIn = E.enumHandle stdin

textsToEventSource :: Monad m => Enumeratee Text ServerEvent m a
textsToEventSource = E.map f
  where
    f text = ServerEvent { eventName = Nothing
                         , eventId   = Nothing
                         , eventData = [B.fromText text] }

sinkChan :: MonadIO m => Chan a -> Iteratee a m ()
sinkChan chan = E.foldM go ()
  where
    go () a = liftIO $ writeChan chan a

WAIだとこんな感じ。

{-# LANGUAGE OverloadedStrings #-}
module HtmlCat.Wai (feedStdIn, runHtmlCat) where
import Control.Concurrent (Chan, writeChan, forkIO)
import Control.Monad (void)
import Control.Monad.Trans (MonadIO(..))
import Data.Text (Text)
import Prelude hiding (lines)
import System.IO (stdin)
import qualified Data.Text as T

import Data.Conduit (($$), ($=), ResourceIO, Source, Sink, SinkResult(..), Conduit, runResourceT, sinkIO)
import Data.Conduit.Binary (sourceHandle)
import Data.Conduit.Text (decode, utf8)
import Network.HTTP.Types (headerContentType, statusOK, statusNotFound)
import Network.Wai (Application, Request(..), Response(..), responseLBS)
import Network.Wai.EventSource (ServerEvent(..), eventSourceApp)
import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsHost, settingsPort)
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
import qualified Blaze.ByteString.Builder.Char.Utf8 as B
import qualified Data.Conduit.List as CL

import HtmlCat.Html (html)

feedStdIn :: Chan ServerEvent -> IO ()
feedStdIn chan = void . forkIO . runResourceT $
  sourceStdIn $= lines $= textsToEventSource $$ sinkChan chan

runHtmlCat :: Chan ServerEvent -> String -> Int -> IO ()
runHtmlCat chan host port =
  runSettings (defaultSettings { settingsHost = host
                               , settingsPort = port })
              (app chan)

app :: Chan ServerEvent -> Application
app chan req =
  case pathInfo req of
    []         -> appTop req
    ["stream"] -> appStream chan req
    _          -> app404 req

appTop :: Application
appTop _ = return $
  ResponseBuilder statusOK
                  [headerContentType "text/html; charset=utf-8"]
                  (renderHtmlBuilder html)

appStream :: Chan ServerEvent -> Application
appStream = eventSourceApp

app404 :: Application
app404 _ = return $ responseLBS statusNotFound [] "Not found"

sourceStdIn :: ResourceIO m => Source m Text
sourceStdIn = sourceHandle stdin $= decode utf8

lines :: Monad m => Conduit Text m [Text]
lines = CL.map T.lines

textsToEventSource :: Monad m => Conduit [Text] m ServerEvent
textsToEventSource = CL.map f
  where
    f texts = ServerEvent { eventName = Nothing
                          , eventId   = Nothing
                          , eventData = map B.fromText texts }

sinkChan :: ResourceIO m => Chan a -> Sink a m ()
sinkChan chan = sinkIO noop (const noop) push return
  where
    noop = return ()
    push _ a = do
      liftIO $ writeChan chan a
      return Processing

snap-coreがwaiと、snap-serverがwarpと対応しています。HTMLのレンダリングはSnapフレームワークにはheistというライブラリがあるのですが、どう見てもYesod陣営のhamletの方が使いやすいので、Snapでもhamletを使っています。

Server-sent eventsの対応はwai-eventsourceに相当するものがSnapにないので、Snap.EventSourceをほぼコピペして入れてあります。snap-eventsourceとしてHackageにあげておこうかと思っています。

Permalink | コメント(0) | トラックバック(0) | 19:11

idトラックバック

2012-01-20

標準入力をブラウザでtail -fできるhtmlcatをHaskellで書いた

haskell

GNU screen 使っているとはいえ開発中に諸々のログを流しておくのにウィンドウ使うのに慣れてなくて、タブ開きまくるならやっぱりブラウザを使いたいってことで、標準入力をブラウザに出してくれるツールを書きました。
標準入力をブラウザで tail -f できる htmlcat というのを書いた - NaN days - subtech

というのを動かしてみたかったのですが、Perlの環境整備がうまくいかなかったので、Haskellで書いてみました。コードは短いのでここに貼っておきます。

maoe/htmlcat - GitHub

{-# LANGUAGE ScopedTypeVariables, QuasiQuotes, OverloadedStrings, RecordWildCards, DeriveDataTypeable #-}
module Main where
import Control.Concurrent (Chan, newChan, writeChan, forkIO)
import Control.Exception (IOException, try)
import Control.Monad (void)
import Control.Monad.Trans (MonadIO(..), MonadTrans(..))
import Data.Foldable (forM_)
import Data.Maybe (maybeToList)
import Data.Text (Text)
import Network (PortID(..), listenOn, sClose)
import System.IO (stdin)
import System.Process (rawSystem)
import qualified Data.Text as T
import Prelude hiding (lines)

import Blaze.ByteString.Builder.Char.Utf8 (fromText)
import Data.Conduit (($$), (=$), ($=), (=$=), ResourceIO, Source, Sink, SinkResult(..), Conduit, runResourceT, sinkIO)
import Data.Conduit.Binary (sourceHandle)
import Data.Conduit.Text (decode, utf8)
import Network.HTTP.Types (headerContentType, statusOK, statusNotFound)
import Network.Wai (Application, Request(..), Response(..), responseLBS)
import Network.Wai.EventSource (ServerEvent(..), eventSourceApp)
import Network.Wai.Handler.Warp (runSettings, defaultSettings, settingsHost, settingsPort)
import System.Console.CmdArgs
import Text.Blaze.Renderer.Utf8 (renderHtmlBuilder)
import Text.Hamlet (Html, shamlet)
import qualified Data.Conduit.List as CL

main :: IO ()
main = do
  HtmlCat {..} <- cmdArgs htmlCat
  port <- newPort _port
  let url = "http://" ++ _host ++ ":" ++ show port
  putStrLn url
  whenJust _exec $ \exec ->
    forkIO $ void $ rawSystem exec [url]
  chan <- newChan
  runSettings (defaultSettings { settingsHost = _host
                               , settingsPort = port })
              (app chan)
  where
    whenJust = forM_

newPort :: Maybe Int -> IO Int
newPort port'm = foldr tryListening
                       (error "no available port")
                       (maybeToList port'm ++ [45192..60000])
  where
    tryListening p next = do
      r <- try . listenOn $ PortNumber (fromIntegral p)
      case r of
        Left (_ :: IOException) -> next
        Right sock -> do
          sClose sock
          return p

app :: Chan ServerEvent -> Application
app chan req =
  case pathInfo req of
    []         -> appTop req
    ["stream"] -> appStream chan req
    _          -> app404 req

appTop :: Application
appTop _ = return $
  ResponseBuilder statusOK
                  [headerContentType "text/html; charset=utf-8"]
                  (renderHtmlBuilder html)

appStream :: Chan ServerEvent -> Application
appStream chan req = do
  lift . void . forkIO . runResourceT $
    sourceStdIn $$ (lines =$= textsToEventSource) =$ sinkChan chan
  eventSourceApp chan req

app404 :: Application
app404 _ = return $ responseLBS statusNotFound [] "Not found"

sourceStdIn :: ResourceIO m => Source m Text
sourceStdIn = sourceHandle stdin $= decode utf8

lines :: Monad m => Conduit Text m [Text]
lines = CL.map T.lines

textsToEventSource :: Monad m => Conduit [Text] m ServerEvent
textsToEventSource = CL.map f
  where
    f texts = ServerEvent { eventName = Nothing
                          , eventId   = Nothing
                          , eventData = map fromText texts }

sinkChan :: ResourceIO m => Chan a -> Sink a m ()
sinkChan chan = sinkIO noop (const noop) push return
  where
    noop = return ()
    push _ a = do
      liftIO $ writeChan chan a
      return Processing

data HtmlCat = HtmlCat
  { _port :: Maybe Int
  , _host :: String
  , _exec :: Maybe String
  } deriving (Show, Data, Typeable)

htmlCat :: HtmlCat
htmlCat = HtmlCat
  { _port = Nothing     &= explicit &= name "port"
  , _host = "127.0.0.1" &= explicit &= name "host"
  , _exec = Nothing     &= explicit &= name "exec"
  }

html :: Html
html = [shamlet|
!!!
<html>
  <head>
    <title>htmlcat
    <script type="text/javascript">
      window.onload = function () {
        var es = new EventSource("/stream");
        es.onmessage = function(event) {
          var data = {};
          data.html = event.data;
          if (!data.html) {
            return;
          }
      
          if (window.scrollY + document.documentElement.clientHeight >= document.documentElement.scrollHeight) {
            var scrollToBottom = true;
          }
  
          var div = document.createElement('div');
          div.innerHTML = data.html + "\n";
  
          var out = document.getElementById('out');
          while (div.firstChild) {
            out.appendChild(div.firstChild);
          }
  
          document.title = data.html.replace(/<.*?>/g, '') + ' - htmlcat';
  
          if (scrollToBottom) {
            window.scrollTo(0, document.body.scrollHeight);
          }
        };
      };
  <body>
    <pre id="out">
|]

cloneしてcabal installすればhtmlcatコマンドが使えるようになります。

色付け
~~--execオプション~~

はまだ実装してません。

Haskellでもserver-sent evnetsなどのpush技術は普通に使えますというデモでした。

追記

コマンドラインオプションを追加しました。

--execでコマンド実行。引数にURLを渡す。
--hostでリッスンするアドレスを指定。
--portでリッスンするポートを指定。

色づけは大変そうな気がするので、気が向いた方は実装してpullリクエスト送ってください。

追記

入力が複数行の時バグってたのを直しました。上のコードも差し替えました。

Permalink | コメント(0) | トラックバック(1) | 21:14

idトラックバック

2011-12-07

モナドトランスフォーマーとmonad-control

Haskell

アドベントカレンダーのいいネタが無いなあと思っていたところ、ちょうど週末にあたらしいmonad-controlがリリースされたので、これを紹介したいなと思いました。

その前に、モナドトランスフォーマーというかっこいい名前の代物の話をちょっとだけしましょう。

モナド トランスフォーマーと例外処理

Haskellerの皆さんはきっと息をするかのように自然にモナドを使っていることと思います。標準で提供されているモナドは単機能なので、組み合わせたくなってきます。必然的に皆モナドトランスフォーマーに手を伸ばすわけです。実際のアプリケーションのコードを書くと、多くのモナドではベースモナドがIOになるでしょうから、今度は自作したカスタムモナドスタックでIOが投げる例外をハンドルしたくなるわけです。

ここでふとControl.Exception.catchの型をみると

Prelude> :t Control.Exception.catch
Control.Exception.catch
  :: Exception e => IO a -> (e -> IO a) -> IO a

catchに渡すアクションはIO aで、例外ハンドラはException e => e -> IO aという型です。

一方あなたの書いたアプリケーションは例えばこんな感じになっていることでしょう。

newtype MyAppT m a = MyAppT { runMyAppT :: StateT MyAppState (ReaderT MyAppEnv m) a }
  deriving (Functor, Applicative, Monad, MonadIO, ...)

runMyApp :: Monad m => MyAppT m a -> MyAppState -> MyAppEnv -> m a
runMyApp act st = runReaderT (runStateT (runMyAppT act) st)

app :: MonadIO m => MyAppT m a
app = do
  liftIO $ putStrLn "Hello, MyApp!"
  ...

main :: IO ()
main = do
  env <- setupMyAppEnv -- getArgsなどして必要な環境を作る
  runMyApp app initialMyAppState env -- 初期状態と一緒に渡してappを走らせる

このアプリ内で例外を扱いたい場合、catchの型は

catch :: Exception e => IO a -> (e -> IO a) -> IO a

ではなく

catch :: (Exception e, MonadIO m) => MyAppT m a -> (e -> MyAppT m a) -> MyAppT m a

より一般的には

catch :: (Exception e, MonadIO m) => m a -> (e -> m a) -> m a

みたいな一般的な型になっていると便利です。これを統一的に扱う仕組みがmonad-controlというわけです。

monad-control

最新のmonad-controlでは主要なパッケージが3つに分かれています。

monad-controlパッケージ
- MonadTransControlクラスとMonadBaseControlクラスおよびそれらのインスタンスを提供
transformers-baseパッケージ
- MonadBaseControlクラスの親となるMonadBaseクラスとそのインスタンスを提供
lifted-baseパッケージ
- Control.ExceptionやControl.ConcurrentあるいはSystem.Timeoutの関数をmonad-controlで一般化した関数を提供

先の例に適用するとこんな感じになります。

newtype MyAppT m a = MyAppT
  { runMyAppT :: ReaderT MyAppEnv (StateT MyAppState m) a
  } deriving ( Functor
             , Applicative
             , Monad
             , MonadIO
             , MonadState MyAppState
             , MonadReader MyAppEnv
             , MonadBase base
             )

instance MonadTrans MyAppT where
  lift = MyAppT . lift . lift

instance MonadTransControl MyAppT where
  newtype StT MyAppT a = StMyApp { unStMyApp :: (a, MyAppState) }
  liftWith f = MyAppT . ReaderT $ \r -> StateT $ \s ->
    liftM (\x -> (x, s))
          (f $ \t -> liftM StMyApp
            (runStateT (runReaderT (runMyAppT t) r) s))
  restoreT = MyAppT . ReaderT . const . StateT . const . liftM unStMyApp

instance MonadBaseControl base m => MonadBaseControl base (MyAppT m) where
  newtype StM (MyAppT m) a = StMMyAppT { unStMMyAppT :: ComposeSt MyAppT m a }
  liftBaseWith = defaultLiftBaseWith StMMyAppT
  restoreM = defaultRestoreM unStMMyAppT

どうしてこれでうまくいくかは、MonadTransControlのIdentityTに対するインスタンスと、上のコードをじっくり読めばわかります。

簡単に解説すると、MonadTransControlクラスのliftWith :: Monad m => (Run t -> m a) -> t m aはモナドスタックt m aを一つpopした型m aを弄れるようにする役割を持ち、MonadBaseControlのliftBaseWith :: (RunInBase m b -> b a) -> m aは、スタックの最下部までpopしたベースモナドの型b aを弄れるようにする役割を持っています。デフォルトではMonadBaseControlの関数はMonadTransControlの関数を使って定義するので、自作のモナドトランスフォーマーは両方のインスタンスを定義してあげましょう。

これで準備は整いました。lifted-baseを使うと先のコードで上げられた例外を、MyAppT m aの中で綺麗にキャッチできるようになりました。めでたしめでたし。

import Control.Exception.Lifted (catch)

-- この例を実際に書くときはbracketを使おう
app :: MonadIO m => MyAppT m ()
app = do
  liftIO $ putStrLn "Hello, MyApp!"
  liftIO $ do
        h <- openFile "/home/maoe/NoSuchFile" ReadMode
        hGetContents h
        hClose h
    `catch` \(e :: SomeException) -> putStrLn $ "Caught " ++ show e

参考リンク

モナドトランスフォーマーの使い方
- 個人的にはMonad Transformers Step by Stepがとてもわかりやすかったです。
- RWHやLearn you a Haskellなども良い資料になるでしょう。
monad-control
- 面倒になって端折ってしまった導入の動機付けとカラクリはmonad-controlに丁寧に解説されています。
  - ただし想定しているmonad-controlが古いインタフェースなので、実際のコードを書くときは上のコードを参考にすると良いと思います。