pubsub-0.10: examples/Main.hs

--------------------------------------------------------------------
-- |
-- Module    : PubSub
-- Copyright : (c) Sigbjorn Finne, 2009
-- License   : BSD3
--
-- Maintainer: Sigbjorn Finne <sof@forkIO.com>
-- Stability : provisional
-- Portability:
--
-- FastCGI wrapper for forwarding incoming request to local network
-- server for processing. For fun, serialize the requests and responses
-- via JSON.
--
--------------------------------------------------------------------
module Main(main) where

import Control.Concurrent
import Network.FastCGI

import Data.Char
import Data.Maybe
import Web.Utils.HTTP
import Web.Utils.Fetch ( addDefaultHeaders )

-- local
import Utils.Data.List
import Utils.Data.String


import System.IO ( hPutStrLn, hGetLine )
import Network.Connection
import Text.JSON

clientConn :: ClientOptions
clientConn = clientOpts{host="localhost",port=Just 8080}

processRequest :: Request -> CGI CGIResult
processRequest req = do
  conn  <- liftIO $ clientConnection clientConn
  liftIO $ hPutStrLn (coHandle conn) (encode req)
  v <- liftIO $ hGetLine (coHandle conn)
--  logIt ("incoming: " ++ v)
--  liftIO $ closeConnection conn
  case decode v of
    Error s -> outputNotFound s
    Ok re   -> fromResponse re

action :: CGI CGIResult
action = do
  req <- mkRequest
  res <- processRequest req
  return res

main :: IO ()
main = runFastCGIConcurrent' forkIO 10 action

-- going from an incoming CGI context to a @Request@ value;
-- some magic and a bit brittle (cf. derivation of HTTP headers.)
mkRequest :: CGI Request
mkRequest = do
  m    <- requestMethod
  u    <- requestURI
  body <- getBody
  ls   <- getInputs
  vs   <- getVars
--  logIt (show (m,u,ls,vs,body))
  let hdrs = mapMaybe toHeader vs
  return Request { reqMethod  = m
                 , reqURL     = show u
		 , reqHeaders = hdrs
		 , reqBody    = body
		 , reqVars    = ls
		 }

toHeader :: (String,String) -> Maybe (String,String)
toHeader (a,b) =
  case matchPrefix "HTTP_" a of
    Just a' -> Just (toHeaderName a', b)
    _ -> Nothing
 where
  toHeaderName ls =
   unwordsWith "-" $
    map capitalize $
    words $ map (transElem '_' ' ') $ map toLower ls


fromResponse :: Response -> CGI CGIResult
fromResponse r = do
--  setStatus (fromIntegral (respStatus r)) (toStatusString (respStatus r))
  let hdrs = addDefaultHeaders (length (respBody r)) (respHeaders r)
--  mapM_ (\ (a,b) -> setHeader a b) hdrs
  output (respBody r)


logFile :: FilePath
logFile = "hs-pubsub.log"
  -- you want to make this writable by the account running your CGI scripts
  -- (plus possibly make the path absolute..)

logIt :: String -> CGI ()
logIt s = liftIO (appendFile logFile (s++"\n"))