module Hack.Handler.SimpleServer
( run
) where
import Hack
import qualified System.IO
import Web.Encodings.StringLike (takeUntilBlank)
import Web.Encodings.MimeHeader (parseHeader, lookupHeader)
import qualified Data.ByteString.Lazy as BL
import Network
( listenOn, accept, sClose, PortID(PortNumber), Socket
, withSocketsDo)
import Control.Exception (bracket, finally, Exception)
import System.IO (Handle, hClose)
import Control.Concurrent
import Control.Monad (unless)
import Data.Maybe (isJust, fromJust)
import Control.Failure
import Data.Typeable (Typeable)
import Web.Encodings.StringLike (StringLike)
import qualified Web.Encodings.StringLike as SL
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, remoteHost', _) <- accept socket
forkIO $ serveConnection port app conn remoteHost'
serveConnections port app socket
serveConnection :: Port -> Application -> Handle -> String -> IO ()
serveConnection port app conn remoteHost' =
finally
serveConnection'
(hClose conn)
where
serveConnection' = do
env <- hParseEnv port conn remoteHost'
res <- app env
sendResponse conn res
hParseEnv :: Port -> Handle -> String -> IO Env
hParseEnv port conn remoteHost' = do
content' <- BL.hGetContents conn
let (headers', body') = takeUntilBlank content'
parseEnv port headers' body' remoteHost'
safeRead :: Read a => a -> String -> a
safeRead d s =
case reads s of
((x, _):_) -> x
[] -> d
data InvalidRequest =
NotEnoughLines [String]
| HostNotIncluded
| BadFirstLine String
| NonHttp11
deriving (Show, Typeable)
instance Exception InvalidRequest
parseEnv :: (MonadFailure InvalidRequest m)
=> Port
-> [BL.ByteString]
-> BL.ByteString
-> String
-> m Env
parseEnv port lines' body' remoteHost' = do
case lines' of
(_:_:_) -> return ()
_ -> failure $ NotEnoughLines $ map SL.unpack lines'
(method', rpath', gets) <- parseFirst $ head lines'
let method = safeRead GET (SL.unpack method')
let rpath = '/' : case SL.unpack rpath' of
('/':x) -> x
_ -> SL.unpack rpath'
let heads = map parseHeaderNoAttr $ tail lines'
heads' = map (\(x, y) -> (SL.unpack x, SL.unpack y)) heads
let host' = lookup (SL.pack "Host") heads
unless (isJust host') $ failure HostNotIncluded
let host = fromJust host'
let len = maybe "0" SL.unpack
$ lookup (SL.pack "Content-Length") heads
let body'' = BL.take (safeRead 0 len) body'
let (serverName', _) = SL.breakChar ':' host
return $ Env
{ requestMethod = method
, scriptName = ""
, pathInfo = rpath
, queryString = SL.unpack gets
, serverName = SL.unpack serverName'
, serverPort = port
, http = heads'
, hackVersion = [2009, 10, 30]
, hackUrlScheme = HTTP
, hackInput = body''
, hackErrors = System.IO.hPutStr System.IO.stderr
, hackHeaders = []
, hackCache = []
, remoteHost = remoteHost'
}
parseFirst :: (StringLike s, MonadFailure InvalidRequest m) =>
s
-> m (s, s, s)
parseFirst s = do
let pieces = SL.split ' ' s
(method, query, http') <-
case pieces of
[x, y, z] -> return (x, y, z)
_ -> failure $ BadFirstLine $ SL.unpack s
unless (http' == SL.pack "HTTP/1.1") $ failure NonHttp11
let (rpath, qstring) = SL.breakChar '?' query
return (method, rpath, qstring)
sendResponse :: Handle -> Response -> IO ()
sendResponse h res = do
BL.hPut h $ SL.pack "HTTP/1.1 "
BL.hPut h $ SL.pack $ show $ status res
BL.hPut h $ SL.pack "\r\n"
mapM_ putHeader $ headers res
BL.hPut h $ SL.pack "\r\n"
BL.hPut h $ body res
where
putHeader (x, y) = do
BL.hPut h $ SL.pack x
BL.hPut h $ SL.pack ": "
BL.hPut h $ SL.pack y
BL.hPut h $ SL.pack "\r\n"
parseHeaderNoAttr :: StringLike a => a -> (a, a)
parseHeaderNoAttr s =
let (k, rest) = SL.span (/= ':') s
in (k, SL.dropPrefix' (SL.pack ": ") rest)