module Main where

import Control.Monad.State
import Data.List
import Data.Maybe
import Network
import Network.BSD
import Network.Socket
import Network.URI
import qualified Data.Map as M
import System.IO
import qualified System.IO.Error as IOE
import Control.Concurrent
import System.Time
import System.Posix.IO
import System.Posix.Types
import System.Locale
import System.Posix.Signals
import System.Posix.User

listenAddr = "0.0.0.0"
port = 3128
httpdVer = "rephtpr/0.1"

data ParserState = ParserState {
    method :: String,
    location :: String,
    headers :: M.Map String String,
    httpVer :: String,
    err :: Int,
    clientHost :: String
  } deriving (Show)

type Parser = StateT ParserState IO

emptyState = ParserState "" "" M.empty "" 0 ""

parseHttp :: String -> Parser ()
parseHttp x =
    case (last $ head $ words x) of
	     ':' -> parseHeader x
	     _ -> parseMethod x

parseHeader :: String -> Parser ()
parseHeader x =
    get >>= \s -> put $ s { headers = M.insert k v (headers s) }
	where (y:ys) = words x
	      k = reverse $ tail $ reverse y
	      v = filter (/= '\r') $ concat $ intersperse " " ys 

parseMethod :: String -> Parser ()
parseMethod x =
    parseMethod' (words x)
	where
	parseMethod' (m:l:v:[]) = get >>= \s -> put $
				  s { method = m, location = l, httpVer = v }
	parseMethod' _ = get >>= \s -> put $ s { err = 400 } -- Bad request

sendCommonHeaders :: Handle -> IO ()
sendCommonHeaders h =
    do ctime <- getClockTime
       caltime <- toCalendarTime ctime
       hPutStr h $ "Date: " ++ calendarTimeToString caltime ++ "\r\n"
       hPutStr h $ "Server: " ++ httpdVer ++ "\r\n"

doConnect :: String -> IO (Maybe Handle)
doConnect a = do
	h' <- IOE.try $ connectTo a $ PortNumber 80
	case h' of
		Right h -> do
			--putStrLn $ "connected to " ++ a
			return $ Just h
		Left h -> return Nothing

doSend :: Handle -> String -> ParserState -> IO (Maybe String)
doSend h path s = do
	hPutStr h $ (method s) ++ " " ++ path ++ " " ++ httpVer s ++ "\r\n"
	hPutStr h headers'
	hPutStr h "\r\n"
	hFlush h
	reply <- IOE.try $ hGetContents h
	case reply of
		Right str -> return $ Just str
		Left _ -> return Nothing
	where
	headers' = M.foldWithKey (\k a b -> k ++ ": " ++ a ++ "\r\n" ++ b) [] $ M.mapWithKey (\k a -> if k == "Connection" then "close" else a) $ headers s

processRequest :: Handle -> ParserState -> IO Integer
processRequest h s = do 
	case parseURI $ location s of
		Just u -> case uriAuthority u of
			Just a -> do
				h2 <- doConnect (host a)
				str <- maybe (return Nothing) (\x -> doSend x (uriPath u) s) h2
				case str of
					Just str' -> hPutStr h str' >> hFlush h >> hClose (fromJust h2) >> return 200
					Nothing -> err
			Nothing -> err
		Nothing -> err
	where
	host a = uriRegName a
	p u = uriPath u
	err = sendError h s 404 >> (return 404)

sendError :: Handle -> ParserState -> Int -> IO ()
sendError h s n =
    do hPutStr h $ "HTTP/1.1 " ++ (show n) ++ " Not Found\r\n" -- XXX
       sendCommonHeaders h
       hPutStr h "Content-Type: text/html; charset=iso-8859-1\r\n"
       hPutStr h "\r\n"
       hPutStr h $ "ERROR " ++ (show n) ++ "\r\n"
       hClose h

logRequest :: ParserState -> IO ()
logRequest s =
    do ctime <- getClockTime
       caltime <- toCalendarTime ctime
       putStrLn $ clientHost s ++ " " ++ formatCalendarTime defaultTimeLocale 
		    "[%D:%T]" caltime ++ " \"" ++ method s ++
		    " " ++ location s ++ " " ++ httpVer s ++ "\" "
       hFlush stdout

processConnection :: Handle -> Parser ()
processConnection h =
    do txt <- lift $ catch (hGetLine h) (const $ return "")
       case txt of
	      "\r" -> do s <- get
			 lift $ logRequest s
			 lift $ processRequest h s
                         (lift $ IOE.try $ hFlush h) >>=
                              either (const $ return ()) (const $ keepAlive s)
			     where
			     keepAlive s =
                                 case (M.findWithDefault ""
                                            "Connection"(headers s)) of
                                          "close" -> lift $ hClose h
		                          "keep-alive" -> do put emptyState { clientHost = clientHost s }
				                             processConnection h
		                          _ -> lift $ hClose h
              "" -> return ()
	      _ -> do parseHttp txt
		      s <- get
		      if (err s /= 0)
			 then do
			   lift $ sendError h s $ err s
			   lift $ logRequest s
			 else processConnection h

mainLoop :: Socket -> IO ()
mainLoop sock =
    do (s, saddr) <- Network.Socket.accept sock
       handle <- fdToHandle $ Fd $ fdSocket s
       addr <- inet_ntoa $ ip saddr
       forkIO $ evalStateT (processConnection handle)
		  $ emptyState { clientHost = addr }
       mainLoop sock
	   where ip (SockAddrInet _ a) = a
main =
    do sock <- socket AF_INET Stream 0
       setSocketOption sock ReuseAddr 1
       addr <- inet_addr listenAddr
       bindSocket sock (SockAddrInet port addr)
       listen sock (-1)

       installHandler sigPIPE Ignore Nothing
       --setUserID user
       mainLoop sock