git.iko.soy/typeable/wai
on master help sign in
First version with simpleserver and sample app
5c9f4a0Michael Snoyman
Network/Wai.hsnew file+74
compare with master
unifiedsplit
@@ -0,0 +1,74 @@
1+{-# LANGUAGE ExistentialQuantification #-}
2+module Network.Wai
3+ ( RequestMethod (..)
4+ , UrlScheme (..)
5+ , Request (..)
6+ , Response (..)
7+ , Application
8+ , Middleware
9+ , RequestBody (..)
10+ , RequestBodyClass (..)
11+ , ResponseBody (..)
12+ , ResponseBodyClass (..)
13+ ) where
14+
15+import qualified Data.ByteString.Lazy as L
16+import qualified Data.ByteString as B
17+
18+data RequestMethod =
19+ OPTIONS
20+ | GET
21+ | HEAD
22+ | POST
23+ | PUT
24+ | DELETE
25+ | TRACE
26+ | CONNECT
27+ deriving (Show, Read, Eq)
28+
29+data UrlScheme = HTTP | HTTPS deriving (Show, Eq)
30+
31+data Request = Request
32+ { requestMethod :: RequestMethod
33+ , pathInfo :: B.ByteString
34+ , queryString :: B.ByteString
35+ , serverName :: B.ByteString
36+ , serverPort :: Int
37+ , httpHeaders :: [(B.ByteString, B.ByteString)]
38+ , urlScheme :: UrlScheme
39+ , requestBody :: RequestBody
40+ , errorHandler :: String -> IO ()
41+ , remoteHost :: String
42+ }
43+
44+data Response = Response
45+ { status :: Int
46+ , statusMessage :: B.ByteString
47+ , headers :: [(B.ByteString, B.ByteString)]
48+ , body :: ResponseBody -> IO ()
49+ }
50+
51+type Application = Request -> IO Response
52+
53+type Middleware = Application -> Application
54+
55+data RequestBody = forall a. RequestBodyClass a => RequestBody a
56+class RequestBodyClass a where
57+ receiveByteString :: a -> IO (Maybe B.ByteString)
58+instance RequestBodyClass RequestBody where
59+ receiveByteString (RequestBody a) = receiveByteString a
60+
61+data ResponseBody = forall a. ResponseBodyClass a => ResponseBody a
62+class ResponseBodyClass a where
63+ sendByteString :: a -> B.ByteString -> IO ()
64+
65+ sendLazyByteString :: a -> L.ByteString -> IO ()
66+ sendLazyByteString a bs = mapM_ (sendByteString a) $ L.toChunks bs
67+
68+ sendFile :: a -> FilePath -> IO ()
69+ -- FIXME do not use lazy I/O
70+ sendFile a fp = L.readFile fp >>= sendLazyByteString a
71+instance ResponseBodyClass ResponseBody where
72+ sendByteString (ResponseBody a) = sendByteString a
73+ sendLazyByteString (ResponseBody a) = sendLazyByteString a
74+ sendFile (ResponseBody a) = sendFile a
Network/Wai/Handler/SimpleServer.hsnew file+180
@@ -0,0 +1,180 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+---------------------------------------------------------
4+-- |
5+-- Module : Network.Wai.Handler.SimpleServer
6+-- Copyright : Michael Snoyman
7+-- License : BSD3
8+--
9+-- Maintainer : Michael Snoyman <michael@snoyman.com>
10+-- Stability : Stable
11+-- Portability : portable
12+--
13+-- A simplistic HTTP server handler for Wai.
14+--
15+---------------------------------------------------------
16+module Network.Wai.Handler.SimpleServer
17+ ( run
18+ ) where
19+
20+import Network.Wai
21+import qualified System.IO
22+
23+import qualified Data.ByteString as BS
24+import qualified Data.ByteString.Char8 as B8
25+import Network
26+ ( listenOn, accept, sClose, PortID(PortNumber), Socket
27+ , withSocketsDo)
28+import Control.Exception (bracket, finally, Exception)
29+import System.IO (Handle, hClose)
30+import Control.Concurrent
31+import Control.Monad (unless)
32+import Data.Maybe (isJust, fromJust)
33+
34+import Control.Failure
35+import Data.Typeable (Typeable)
36+
37+import Web.Encodings.StringLike (StringLike)
38+import qualified Web.Encodings.StringLike as SL
39+
40+run :: Port -> Application -> IO ()
41+run port = withSocketsDo .
42+ bracket
43+ (listenOn $ PortNumber $ fromIntegral port)
44+ sClose .
45+ serveConnections port
46+type Port = Int
47+
48+serveConnections :: Port -> Application -> Socket -> IO ()
49+serveConnections port app socket = do
50+ (conn, remoteHost', _) <- accept socket
51+ _ <- forkIO $ serveConnection port app conn remoteHost'
52+ serveConnections port app socket
53+
54+serveConnection :: Port -> Application -> Handle -> String -> IO ()
55+serveConnection port app conn remoteHost' =
56+ finally
57+ serveConnection'
58+ (hClose conn)
59+ where
60+ serveConnection' = do
61+ env <- hParseRequest port conn remoteHost'
62+ res <- app env
63+ sendResponse conn res
64+
65+hParseRequest :: Port -> Handle -> String -> IO Request
66+hParseRequest port conn remoteHost' = do
67+ headers' <- takeUntilBlank conn id
68+ parseRequest port headers' conn remoteHost'
69+
70+takeUntilBlank :: Handle
71+ -> ([BS.ByteString] -> [BS.ByteString])
72+ -> IO [BS.ByteString]
73+takeUntilBlank h front = do
74+ l <- stripCR `fmap` BS.hGetLine h
75+ if BS.null l
76+ then return $ front []
77+ else takeUntilBlank h $ front . (:) l
78+
79+stripCR :: BS.ByteString -> BS.ByteString
80+stripCR bs
81+ | BS.null bs = bs
82+ | B8.last bs == '\r' = BS.init bs
83+ | otherwise = bs
84+
85+safeRead :: Read a => a -> String -> a
86+safeRead d s =
87+ case reads s of
88+ ((x, _):_) -> x
89+ [] -> d
90+
91+data InvalidRequest =
92+ NotEnoughLines [String]
93+ | HostNotIncluded
94+ | BadFirstLine String
95+ | NonHttp11
96+ deriving (Show, Typeable)
97+instance Exception InvalidRequest
98+
99+-- | Parse a set of header lines and body into a 'Request'.
100+parseRequest :: (MonadFailure InvalidRequest m)
101+ => Port
102+ -> [BS.ByteString]
103+ -> Handle
104+ -> String
105+ -> m Request
106+parseRequest port lines' handle remoteHost' = do
107+ case lines' of
108+ (_:_:_) -> return ()
109+ _ -> failure $ NotEnoughLines $ map SL.unpack lines'
110+ (method', rpath', gets) <- parseFirst $ head lines'
111+ let method = safeRead GET (SL.unpack method')
112+ let rpath = '/' : case SL.unpack rpath' of
113+ ('/':x) -> x
114+ _ -> SL.unpack rpath'
115+ let heads = map parseHeaderNoAttr $ tail lines'
116+ let host' = lookup (SL.pack "Host") heads
117+ unless (isJust host') $ failure HostNotIncluded
118+ let host = fromJust host'
119+ {- FIXME use length somewhere?
120+ let len = maybe "0" SL.unpack
121+ $ lookup (SL.pack "Content-Length") heads
122+ -}
123+ let (serverName', _) = SL.breakChar ':' host
124+ return $ Request
125+ { requestMethod = method
126+ , pathInfo = SL.pack rpath
127+ , queryString = gets
128+ , serverName = serverName'
129+ , serverPort = port
130+ , httpHeaders = heads
131+ , urlScheme = HTTP
132+ , requestBody = RequestBody $ SSRequestBody handle
133+ , errorHandler = System.IO.hPutStr System.IO.stderr
134+ , remoteHost = remoteHost'
135+ }
136+
137+newtype SSRequestBody = SSRequestBody Handle
138+instance RequestBodyClass SSRequestBody where
139+ receiveByteString (SSRequestBody h) = do
140+ bs <- BS.hGet h 1024 -- FIXME find a good chunk size
141+ if BS.null bs
142+ then return Nothing
143+ else return $ Just bs
144+
145+parseFirst :: (StringLike s, MonadFailure InvalidRequest m) =>
146+ s
147+ -> m (s, s, s)
148+parseFirst s = do
149+ let pieces = SL.split ' ' s
150+ (method, query, http') <-
151+ case pieces of
152+ [x, y, z] -> return (x, y, z)
153+ _ -> failure $ BadFirstLine $ SL.unpack s
154+ unless (http' == SL.pack "HTTP/1.1") $ failure NonHttp11
155+ let (rpath, qstring) = SL.breakChar '?' query
156+ return (method, rpath, qstring)
157+
158+sendResponse :: Handle -> Response -> IO ()
159+sendResponse h res = do
160+ BS.hPut h $ SL.pack "HTTP/1.1 "
161+ BS.hPut h $ SL.pack $ show $ status res
162+ BS.hPut h $ SL.pack "\r\n"
163+ mapM_ putHeader $ headers res
164+ BS.hPut h $ SL.pack "\r\n"
165+ body res $ ResponseBody $ SSResponseBody h
166+ where
167+ putHeader (x, y) = do
168+ BS.hPut h x
169+ BS.hPut h $ SL.pack ": "
170+ BS.hPut h y
171+ BS.hPut h $ SL.pack "\r\n"
172+
173+newtype SSResponseBody = SSResponseBody Handle
174+instance ResponseBodyClass SSResponseBody where
175+ sendByteString (SSResponseBody h) = BS.hPut h
176+
177+parseHeaderNoAttr :: StringLike a => a -> (a, a)
178+parseHeaderNoAttr s =
179+ let (k, rest) = SL.span (/= ':') s
180+ in (k, SL.dropPrefix' (SL.pack ": ") rest)
index.htmlnew file+11
@@ -0,0 +1,11 @@
1+<!DOCTYPE html>
2+<html>
3+ <head>
4+ <title>WAI Test Page!</title>
5+ <meta charset="utf-8">
6+ </head>
7+ <body>
8+ <p>It works</p>
9+ <p>Here's some Unicode stuff: שלום</p>
10+ </body>
11+</html>
test.hsnew file+17
@@ -0,0 +1,17 @@
1+import Network.Wai
2+import Network.Wai.Handler.SimpleServer
3+import qualified Data.ByteString.Char8 as B8
4+
5+main :: IO ()
6+main = putStrLn "http://localhost:3000/" >> run 3000 app
7+
8+app :: Application
9+app _ = return $ Response
10+ { status = 200
11+ , statusMessage = B8.pack "OK"
12+ , headers = [(B8.pack "Content-Type", B8.pack "text/html")]
13+ , body = index
14+ }
15+
16+index :: ResponseBody -> IO ()
17+index rb = sendFile rb "index.html"