Network.Wai Middleware example

myMiddleware.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Network.Wai
import Network.HTTP.Types
import Network.Wai.Handler.Warp (run)

import qualified Data.ByteString.Lazy       as LBS(fromStrict)
import qualified Data.ByteString            as SBS(ByteString)
import qualified Data.ByteString.Char8      as SBS(snoc)
import Blaze.ByteString.Builder (toByteString)
import Data.IORef

myApp :: Application
myApp _ respond = do
  respond $ responseLBS
    status200
    [("Content-Type", "text/plain")]
    "hello"

myMiddleware :: Middleware
myMiddleware = modifyBody (`SBS.snoc` '!')

main :: IO ()
main = do
  putStrLn $ "http://localhost:18080"
  run 18080 $ myMiddleware myApp

--------------------------------------------------------------------------------

modifyBody :: (SBS.ByteString -> SBS.ByteString) -> Middleware
modifyBody cnv = modifyBodyIO cnvIO
  where cnvIO = return . cnv

modifyBodyIO :: (SBS.ByteString -> IO SBS.ByteString) -> Middleware
modifyBodyIO cnvIO app req respond = do
  app req $ \res -> do
    ref <- newIORef ""
    let (status, headers, applyWithBody) = responseToStream res
        write   = writeIORef ref . toByteString
        flush   = return ()
        wb stbd = do
          stbd write flush
          body <- readIORef ref

          LBS.fromStrict <$> cnvIO body

    body <- applyWithBody wb
    respond $ responseLBS status headers body

IORef をなんとかしたい