-- |
-- Module      :  Network.HTTP.SimpleWebServer
-- Copyright   :  (c) Alexandru Scvortov 2009
-- License     :  LGPL (see LICENSE file)
-- Maintainer  :  scvalex@gmail.com
--
-- SEE: http://lstephen.wordpress.com/2008/02/14/a-simple-haskell-web-server/
--

-- FIXME: I have a feeling N.H.SimpleWebServer doesn't use the HTTP
-- library the way it should.

module Network.HTTP.SimpleWebServer
    ( runHttpServer
    , RequestHandler
    , okResponse, plainTextResponse
    , notFoundResponse, jsonResponse, htmlResponse
    ) where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Network
import Network.HTTP hiding ( receiveHTTP, respondHTTP )
import Network.HTTP.Stream
import System.IO

instance Stream Handle where
    readLine h = hGetLine h >>= \l -> return $ Right $ l ++ "\n"
    readBlock h n = replicateM n (hGetChar h) >>= return . Right
    writeBlock h s = mapM_ (hPutChar h) s >>= return . Right
    close = hClose

-- FIXME: RequestHandler should use ByteStrings instead of Strings
type RequestHandler = Request String -> IO (Response String)

-- | Listen for incoming connections and fork a request handler for
-- each.  Note that the request handlers are expected to take care
-- of their own errors.
runHttpServer :: Int -> RequestHandler -> IO ()
runHttpServer p r = withSocketsDo $ do
                      sock <- listenOn (PortNumber $ fromIntegral p)
                      forever $ acceptConnection sock $ handleHttpConnection r

acceptConnection :: Socket -> (Handle -> IO ()) -> IO ()
acceptConnection s k = accept s >>= (\(h, _, _) -> forkIO $ k h) >> return ()

handleHttpConnection :: RequestHandler -> Handle -> IO ()
handleHttpConnection rh h = doHandle `finally` Network.HTTP.Stream.close h
    where
      doHandle = do
        putStrLn "Handling connection..."
        resp <- receiveHTTP h
        case resp of
          Left _ -> return ()
          Right req -> rh req >>= respondHTTP h

-- | Make a plain text response (i.e. an Ok response with the
-- content-type set to text/plain).
plainTextResponse :: String -> Response String
plainTextResponse s = okResponse [ctText] s
    where
      ctText = Header HdrContentType "text/plain"

jsonResponse :: String -> Response String
jsonResponse s = okResponse [ctJson] s
    where
      ctJson = Header HdrContentType "application/json"

htmlResponse :: String -> Response String
htmlResponse = okResponse [ctHtml]
    where
      ctHtml = Header HdrContentType "text/html"

-- FIXME: Make handlers combinators in SimpleWebServer.

-- | Make a "200 Ok" response.
--
-- Automatically adds the following headers:
--   * Length
okResponse :: [Header] -> String -> Response String
okResponse hs s = Response (2, 0, 0) "Ok" (lh : hs) s
    where
      lh = Header HdrContentLength (show . length $ s)

notFoundResponse :: [Header] -> String -> Response String
notFoundResponse hs s = Response (4, 0, 4) "Not Found" (lh : hs) s
    where
      lh = Header HdrContentLength (show . length $ s)