module Hack.Handler.SimpleServer
( run
) where
import Prelude ( ($), map, IO, String, return
, length, (==), fail, break, tail, Monad, Int
, fromIntegral, head, (>=), (.), words, show
, Read, reads, dropWhile, takeWhile, (/=))
import Hack
import Data.Default
import Data.ByteString.Lazy.Util (takeUntilBlank)
import Data.Mime.Header (parseHeader, lookupHeader)
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.UTF8 as BSLU
import Network
( listenOn, accept, sClose, PortID(PortNumber), Socket
, withSocketsDo)
import Control.Exception (bracket, finally)
import System.IO (Handle, hClose)
import Control.Concurrent
import Control.Monad (unless)
import Data.Maybe (isJust, fromJust, fromMaybe)
run :: Port -> Application -> IO ()
run port = withSocketsDo .
bracket
(listenOn $ PortNumber $ fromIntegral port)
sClose .
serveConnections port
type Port = Int
serveConnections :: Port -> Application -> Socket -> IO ()
serveConnections port app socket = do
(conn, _, _) <- accept socket
forkIO $ serveConnection port app conn
serveConnections port app socket
serveConnection :: Port -> Application -> Handle -> IO ()
serveConnection port app conn =
finally
serveConnection'
(hClose conn)
where
serveConnection' = do
env <- hParseEnv port conn
res <- app env
sendResponse conn res
hParseEnv :: Port -> Handle -> IO Env
hParseEnv port conn = do
content' <- BS.hGetContents conn
let (headers', body') = takeUntilBlank content'
parseEnv port headers' body'
safeRead :: Read a => a -> String -> a
safeRead d s =
case reads s of
((x, _):_) -> x
[] -> d
parseEnv :: Monad m => Port -> [BS.ByteString] -> BS.ByteString -> m Env
parseEnv port lines' body' = do
let lines = map BSLU.toString lines'
unless (length lines >= 2) $ fail "Invalid request (not enough lines)"
(method', rpath', gets) <- parseFirst $ head lines
let method = safeRead GET method'
let rpath = '/' : case rpath' of
('/':x) -> x
_ -> rpath'
let heads = map parseHeader $ tail lines'
let host' = lookupHeader "Host" heads
unless (isJust host') $ fail "Invalid request (does not include host)"
let host = fromJust host'
let len = fromMaybe "0" $ lookupHeader "Content-Length" heads
let body'' = BS.take (safeRead 0 len) body'
return $ def
{ requestMethod = method
, pathInfo = rpath
, queryString = dropWhile (== '?') gets
, serverName = takeWhile (/= ':') host
, serverPort = port
, http = heads
, hackInput = body''
}
parseFirst :: Monad m =>
String
-> m (String, String, String)
parseFirst s = do
let pieces = words s
unless (length pieces == 3) $ fail "Invalid request (bad first line)"
let [method, query, http'] = pieces
unless (http' == "HTTP/1.1") $
fail "Invalid request (only handle HTTP/1.1)"
let (rpath, qstring) = break (== '?') query
return (method, rpath, qstring)
bsFromResponse :: Response -> BS.ByteString
bsFromResponse res = BS.concat
[ f "HTTP/1.1 "
, f $ show $ status res
, f "\r\n"
, BS.concat $ map (\(x, y) -> BS.concat
[ f x
, f ": "
, f y
, f "\r\n"
]) $ headers res
, f "\r\n"
, body res
] where f = BSLU.fromString
sendResponse :: Handle -> Response -> IO ()
sendResponse conn = do
BS.hPut conn . bsFromResponse