超単純 HTTP サーバ (練習)

去年から,仕事の合間に時間を見つけてはちまちまと Haskell の勉強をしていました.
でも本を読むだけでは今一なので,ここら辺で一回まとまったものを書いてみようかと.初心者なのは承知の上でコードをさらそうかと.
あと Haskell 良いですね.まだうまく表現できませんがおもしろいです.

環境

書いたコード

仕様は「HTTP リクエストの Request-Line を解釈*2し,要求されたファイルの内容を返す」だけです.セキュリティ関連も対応していません.大変に単純です.

{- 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"
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"

gist はこちら → https://gist.github.com/1573839

ビルド&実行

***> ghc --make -Wall -fno-warn-unused-do-bind -o thin_http_server.exe Main.hs
[2 of 2] Compiling Main             ( Main.hs, Main.o )
Linking thin_http_server.exe ...

***>thin_http_server.exe 8888
listening on: 8888


はい見えました.

疑問とかいろいろ

細かな疑問はもっといっぱいありますが...

  1. エラー処理のやり方あってるかなぁ...?
  2. 文字の扱いが雑すぎて反省
  3. スレッド間の通信はどうやるの?(STM?)
  4. I/O 多重化は?
  5. Parser Combinator はどのパッケージが流行なんだろう?

どんどんコード書いて探っていこうかな,と.

おわりに

最初から最後まで躓きっぱなしでした...orz
今回書いたコードが Haskell っぽいコードになっているかどうか,今はまだ正しく評価できません.
未来の自分がみたとき,何て思うのかなぁ...

*1:結構古い?アップグレードしておこう...

*2:Request-URI は abs_path のみを解釈