module Ketchup.Httpd
( HTTPRequest (..)
, Headers (..)
, Handler (..)
, listenHTTP
) where
import Control.Concurrent (forkIO)
import qualified Data.ByteString.Char8 as B
import Network
import qualified Network.Socket as NS
import Network.Socket.ByteString
import Ketchup.Utils
type Headers = [(B.ByteString, [B.ByteString])]
type Handler = Socket -> HTTPRequest -> IO ()
data HTTPRequest = HTTPRequest
{ method :: B.ByteString
, uri :: B.ByteString
, httpver :: B.ByteString
, headers :: Headers
, body :: B.ByteString
} deriving (Show)
parseRequestLine :: B.ByteString -> (B.ByteString, [B.ByteString])
parseRequestLine line =
(property, values)
where
property = head items
values = B.split ',' $ (trim . last) items
items = B.split ':' line
parseRequestBody :: B.ByteString -> [(B.ByteString, B.ByteString)]
parseRequestBody body =
map sep items
where
sep = breakBS "="
items = B.split '&' body
getRequest :: Socket -> IO ([B.ByteString], B.ByteString)
getRequest client = do
content <- recv client 1024
let (headers, body) = breakBS "\r\n\r\n" content
return (B.lines headers, body)
parseRequest :: ([B.ByteString], B.ByteString) -> HTTPRequest
parseRequest reqlines =
HTTPRequest { method=met, uri=ur, httpver=ver, headers=heads, body=body }
where
[met, ur, ver] = B.words $ head headers
heads = map parseRequestLine $ tail headers
body = snd reqlines
headers = fst reqlines
handleRequest :: Socket -> Handler -> IO ()
handleRequest client cback = do
reqlines <- getRequest client
case length (fst reqlines) of
0 -> sendBadRequest client
_ -> cback client $ parseRequest reqlines
sClose client
acceptAll :: Socket -> Handler -> IO ()
acceptAll sock cback = do
(client, _) <- NS.accept sock
handleRequest client cback
acceptAll sock cback
createAcceptorPool :: Socket -> Int -> Handler -> IO ()
createAcceptorPool sock max cback =
case max of
0 -> acceptAll sock cback
x -> do
forkIO $ acceptAll sock cback
createAcceptorPool sock (x1) cback
getHostaddr :: String -> IO NS.HostAddress
getHostaddr "*" = return NS.iNADDR_ANY
getHostaddr host = NS.inet_addr host
listenHTTP :: String
-> PortNumber
-> Handler
-> IO ()
listenHTTP hostname port cback = withSocketsDo $ do
host <- getHostaddr hostname
let addr = NS.SockAddrInet port host
sock <- NS.socket NS.AF_INET NS.Stream 0
NS.setSocketOption sock NS.ReuseAddr 1
NS.setSocketOption sock NS.NoDelay 1
NS.bindSocket sock addr
NS.listen sock 128
createAcceptorPool sock 128 cback
sClose sock