POST -> EventSource over Reverse Proxy in Haskell

evtsrc-revpxy.cabal

name:                evtsrc-revpxy
version:             0.1.0.0
synopsis:            Simple project template from stack
description:         Please see README.md
homepage:            https://github.com/konn/evtsrc-revpxy#readme
license:             BSD3
license-file:        LICENSE
author:              Hiromi ISHII
maintainer:          konn.jinro _at_ gmail.com
copyright:           2015 (c) Hiromi ISHII
category:            Web
build-type:          Simple
cabal-version:       >=1.10

executable evtsrc-revpxy
  hs-source-dirs:      src
  main-is:             Main.hs
  default-language:    Haskell2010
  build-depends:       async
                     , base >= 4.7 && < 5
                     , blaze-html
                     , bytestring >= 0.10.6.0
                     , http-client
                     , http-types
                     , random >= 1.1
                     , shakespeare
                     , text >= 1.2.2.1
                     , wai
                     , wai-app-file-cgi
                     , wai-extra
                     , warp
                     , stm
                     , stm-containers
  ghc-options:         -Wall

evtsrc-revpxy.hs

{-# LANGUAGE OverloadedStrings, QuasiQuotes #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Main where
import           Control.Applicative
import           Control.Concurrent
import           Control.Concurrent.Async
import           Control.Concurrent.STM
import           Control.Monad                       (forM_, join)
import           Control.Monad.Fix                   (fix)
import qualified Data.ByteString.Char8               as BS
import           Data.ByteString.Lazy.Builder        (byteString)
import qualified Data.ByteString.Lazy.Char8          as LBS
import qualified Data.Text.Lazy.Encoding             as T
import           Network.HTTP.Client                 (defaultManagerSettings)
import           Network.HTTP.Client                 (newManager)
import           Network.HTTP.Types.Header
import           Network.HTTP.Types.Status
import           Network.Wai
import           Network.Wai.Application.Classic
import           Network.Wai.EventSource
import           Network.Wai.EventSource.EventStream
import           Network.Wai.Handler.Warp            (run)
import qualified STMContainers.Map                   as TM
import           System.Random                       (randomRIO)
import           Text.Blaze.Html.Renderer.Utf8       (renderHtml)
import           Text.Hamlet
import           Text.Julius

main :: IO ()
main = subApp `race_` revPxy

revPxy :: IO ()
revPxy = do
  man <- newManager defaultManagerSettings
  run 4946 $ revProxyApp defaultClassicAppSpec (RevProxyAppSpec man) $
    RevProxyRoute { revProxySrc = ""
                  , revProxyDst = ""
                  , revProxyDomain  = "127.0.0.1"
                  , revProxyPort    = 2929
                  }

jsSrc :: JavascriptUrl ()
jsSrc = [js|
  function putLog(str) {
    $('#message').append($('<span>').text(str)).append('<br>')
  }
  $(document).ready(function(){
    $.post('/post', String(new Date()), function(pid,stat,xhr){
      var src = new EventSource('http://127.0.0.1:4946/src?pid='+encodeURIComponent(pid));
      src.onmessage = function (event) {
        putLog(event.data);
      };
      src.onerror = function(evt) {
        if (src.readyState === EventSource.CONNECTING) {
          putLog("reconnecting..")
        } else if (src.readyState === EventSource.CLOSED) {
          putLog("closed.")
        }
      };
    });
  });
|]

subApp :: IO ()
subApp = do
  procDic <- TM.newIO
  pid     <- newTVarIO (0 :: Integer)
  run 2929 $ \req send -> do
    print $ pathInfo req
    case pathInfo req of
      ["doit.js"] ->
        send $ responseLBS ok200 [] $
        T.encodeUtf8 $ renderJavascript $ jsSrc (const $ const "")
      ["post"]
        | requestMethod req == "POST" -> do
          bdy <- requestBody req
          i <- atomically $ do
            i <- readTVar pid <* modifyTVar' pid succ
            TM.insert bdy i procDic
            return i
          send $ responseLBS ok200 [(hContentType, "text/plain")] $ LBS.pack $ show i
        | otherwise -> send $ responseLBS status405 [] "Only POST method is allowed"
      ["src"] | Just i <- readM . BS.unpack =<< join (lookup "pid" (queryString req)) -> do
        case lookup "Last-Event-ID" $ requestHeaders req of
          Just "3" -> send $ responseLBS status404 [] "just stop it."
          _ -> do
            ch <- newChan
            mecho <- atomically $ TM.lookup i procDic
            case mecho of
              Nothing -> send $ responseLBS status404 [] "I don't know you at all."
              Just echo -> do
                fst <$> eventSourceAppChan' ch req send `concurrently` do
                  forM_ (zip [0..] ( echo : ["hello", "how", "are", "you"])) $ \(mi, msg) -> do
                    threadDelay =<< randomRIO (10^5,10^6)
                    writeChan ch (ServerEvent Nothing (Just $ fromString $ show mi)
                                  [byteString msg])
                  writeChan ch CloseEvent
                  atomically $ TM.delete i procDic
      _ -> send $ responseLBS ok200 [("Access-Control-Allow-Origin", "*")] $
        renderHtml
        [shamlet|
         $doctype 5
         <html>
           <head>
             <title>Check it!
             <script src="https://raw.githubusercontent.com/remy/polyfills/master/EventSource.js" type="text/javascript">
             <script src="https://code.jquery.com/jquery-1.12.3.min.js"   integrity="sha256-aaODHAgvwQW1bFOGXMeX+pC4PZIPsvn2h1sArYOhgXQ=" crossorigin="anonymous">
             <script src="/doit.js">
           <body>
             <h1>Simple Checker
             <div #message>
        |]

readM :: (Read a, Alternative f) => String -> f a
readM str =
  case reads str of
    [(a, "")] -> pure a
    _ -> empty

eventSourceAppChan' :: Chan ServerEvent -> Application
eventSourceAppChan' src _ sendResponse =
    sendResponse $ responseStream
        status200
        [(hContentType, "text/event-stream")
        ,("Access-Control-Allow-Origin", "*")
        ]
        $ \sendChunk flush -> fix $ \loop -> do
            se <- readChan src
            case eventToBuilder se of
                Nothing -> return ()
                Just b  -> sendChunk b >> flush >> loop