module Network.HTTP.RedHandler.Httpd
    (runHttpServer) where

import Control.Concurrent (ThreadId, forkIO)
import Control.Monad (forever, replicateM)
import Network.HTTP.RedHandler.HTTP_Fork.HTTP (Result, receiveHTTP, respondHTTP, Request, Response, Stream, close, readLine, readBlock, writeBlock, writeBlockWithFile)
import Network
import System.IO
import Data.Array.IO
import Control.Exception as Exception

import Network.HTTP.RedHandler.RequestContext (RequestContext, mkRqCtx)
import Network.HTTP.RedHandler.Handler (IORqHandler, getResponse, anyOf)
import Network.HTTP.RedHandler.Response (BasicRsp)


runHttpServer :: PortNumber -> [IORqHandler BasicRsp] -> IO ()
runHttpServer port hans = withSocketsDo $ do
                   sock    <- listenOn (PortNumber $ port)
                   forever $ acceptConnection sock $ handleConnection hans


handleConnection :: [IORqHandler BasicRsp] -> Handle -> IO ()
handleConnection rhans h = do requestCtx <- getRequestContext h
                              response <- runRequestHandler (anyOf rhans) requestCtx
			      responseSend h response


getRequestContext :: Handle -> IO (Result RequestContext)
getRequestContext h = receiveHTTP h >>= mkRqCtx'


mkRqCtx' :: Result Request-> IO (Result RequestContext)
mkRqCtx' (Left e)   = return $ Left e
mkRqCtx' (Right rq) = fmap Right (mkRqCtx rq)

 
runRequestHandler :: IORqHandler BasicRsp -> Result RequestContext -> IO (Result Response)
runRequestHandler han (Left e)   = return $ Left e
runRequestHandler han (Right rq) = fmap Right (getResponse han rq)

responseSend :: Handle -> Result Response -> IO ()
responseSend h rsp = either print (respondHTTP h) rsp >> close h

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


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
  writeBlockWithFile conn _ filename = sendFile conn filename >>= return . Right
  close          = hClose

{- for debugging -}
{-
  readLine   h   = do l <- hGetLine h
                      sniff_received l
                      return $ Right $ l ++ "\n"

  readBlock  h n = do s <- replicateM n (hGetChar h)
                      sniff_received s
                      return $ Right s

  writeBlock h s = sniff_sent s >> mapM_ (hPutChar h) s >>= return . Right
  writeBlockWithFile conn _size filename = sniff_sent ("file: " ++ filename) >> sendFile conn filename >>= return . Right)
  close          = hClose
-}


{-----------------------}
{- auxiliary functions -}
{-----------------------}

sendFile :: Handle -> String -> IO ()
sendFile conn filename = Exception.bracket
                             (openFile filename ReadMode)
                             hClose
                             (\handle -> squirt handle conn >> hFlush conn)

-- squirt data from 'rd' into 'wr' as fast as possible.  We use a 4k
-- single buffer.
squirt :: Handle -> Handle -> IO ()
squirt rd wr = do
                 arr <- newArray_ (0, bufsize-1)
                 let loop = do
                              r <- hGetArray rd arr bufsize
                              if (r == 0)
                                then return ()
                                else if (r < bufsize)
                                       then hPutArray wr arr r
                                       else hPutArray wr arr bufsize >> loop
                 loop
               where
                 bufsize = 4 * 1024 :: Int


sniff_received = sniff . ("\n{{Received}}"++)
sniff_sent = sniff . ("\n{{Sent}}"++)

sniff :: String -> IO ()
sniff s = Exception.bracket
      (openFile "sniff.log" AppendMode)
      hClose
      (\hdl -> hPutStr hdl s)