practice: thin HTTP server implementation

thin_http_parser.hs

module ThinHttpParser (
    HttpRequest(..),
    Method(..),
    parseRequest
  ) where

import Control.Applicative
import Control.Monad (MonadPlus(..), ap)
import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))
import Numeric (readHex)
import Control.Monad (liftM4)
import System.IO (Handle)

instance Applicative (GenParser s a) where
  pure  = return
  (<*>) = ap

instance Alternative (GenParser s a) where
  empty = mzero
  (<|>) = mplus

data Method = Get | Post deriving (Eq, Ord, Show)

data HttpRequest = HttpRequest {
    reqMethod  :: Method,
    reqUrl     :: String,
    reqHeaders :: [(String, String)],
    reqBody    :: Maybe String
  } deriving (Eq, Show)

parseRequest :: CharParser () HttpRequest
parseRequest = q "GET"  Get  (pure Nothing)
           <|> q "POST" Post (Just <$> many anyChar)
  where
    q name ctor body = liftM4 HttpRequest req url parseHeaders body
      where
        req = ctor <$ string name <* char ' '
    url = optional (char '/') *>
          manyTill notEOL (try $ char ' ') <* (try $ string "HTTP/1." <* oneOf "01")
          <* crlf

parseHeaders :: CharParser st [(String, String)]
parseHeaders = pure [] -- XXX

crlf :: CharParser st ()
crlf = () <$ string "\r\n"

notEOL :: CharParser st Char
notEOL = noneOf "\r\n"

thin_http_server.hs

{- thin HTTP server implementation -}
module Main where

import Prelude hiding (catch)
import Network (listenOn, accept, sClose, Socket, withSocketsDo, PortID(..), PortNumber)
import System.IO
import System.Environment (getArgs)
import Control.Exception (catch, finally, SomeException(..))
import Control.Concurrent (forkIO)
import Control.Applicative ((*>))
import Control.Monad (forM_)

import ThinHttpParser
import Text.ParserCombinators.Parsec

main :: IO ()
main = do
  (portStr:_) <- getArgs
  runServer $ fromIntegral (read portStr :: Int)

runServer :: PortNumber -> IO ()
runServer port = withSocketsDo $ do
  lSock <- listenOn $ PortNumber port
  putStrLn $ "listening on: " ++ show port
  acceptLoop lSock `finally` (sClose lSock >> putStrLn "stopped.")

acceptLoop :: Socket -> IO ()
acceptLoop lSock = do
  (cHandle, _, _) <- accept lSock
  forkIO $ clientHandler cHandle
  acceptLoop lSock

clientHandler :: Handle -> IO ()
clientHandler handle = service handle
  `catch`   (\(SomeException e) -> putStrLn $ show e)
  `finally` hClose handle

service :: Handle -> IO ()
service handle = do
  rawReq  <- hGetContents handle
  case parse parseRequest "parse http-request" rawReq of
    Right httpReq -> do
      let path   = reqUrl httpReq
      -- putStrLn $ "request: " ++ (show $ reqMethod httpReq) ++ " " ++ path -- XXX debug
      (readFile ("./" ++ path) >>= responseOk handle (contentType $ fileExt path))
        `catch` (\(SomeException _) -> responseError handle 404)
      hFlush handle
    Left err -> do
      putStrLn $ show err
      responseError handle 400

-- 成功
responseOk :: Handle -> String -> String -> IO ()
responseOk handle ctype content = forM_ [
    "HTTP/1.1 200 OK\r\n" 
      ++ "Content-Type: " ++ ctype ++ "\r\n"
      ++ "\r\n",
    content
  ] (hPutStr handle)

-- XXX 失敗
responseError :: Handle -> Int -> IO ()
responseError handle scode = hPutStr handle $ "HTTP/1.1 " ++ show scode ++ " " ++ reasonPhrase scode ++ "\r\n\r\n"

-- helper --

fileExt :: String -> String
fileExt path = case parse parseExt "parse path" path of
  Right ext -> ext
  Left  _   -> ""

parseExt :: CharParser st String
parseExt = manyTill anyChar (char '.') *> many anyChar

-- XXX Map?
contentType :: String -> String
contentType "html" = "text/html"
contentType _      = "text/plain"

-- XXX Map?
reasonPhrase :: Int -> String
reasonPhrase 400 = "Bad Request"
reasonPhrase 404 = "Not Found"
reasonPhrase _   = error "unknown status code"