git.iko.soy/typeable/wai
on master help sign in
Initial code import from wai-extra
781d400Michael Snoyman
LICENSEnew file+25
compare with master
unifiedsplit
@@ -0,0 +1,25 @@
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
3+
4+Copyright 2010, Suite Solutions. All rights reserved.
5+
6+Redistribution and use in source and binary forms, with or without
7+modification, are permitted provided that the following conditions are met:
8+
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Network/Wai/Handler/Warp.hsnew file+233
@@ -0,0 +1,233 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+---------------------------------------------------------
5+-- |
6+-- Module : Network.Wai.Handler.Warp
7+-- Copyright : Michael Snoyman
8+-- License : BSD3
9+--
10+-- Maintainer : Michael Snoyman <michael@snoyman.com>
11+-- Stability : Stable
12+-- Portability : portable
13+--
14+-- A fast, light-weight HTTP server handler for WAI.
15+--
16+---------------------------------------------------------
17+module Network.Wai.Handler.Warp
18+ ( run
19+ , sendResponse
20+ , parseRequest
21+ ) where
22+
23+import Network.Wai
24+import qualified System.IO
25+
26+import Data.ByteString (ByteString)
27+import qualified Data.ByteString.Char8 as B
28+import Network
29+ ( listenOn, accept, sClose, PortID(PortNumber), Socket
30+ , withSocketsDo)
31+import Control.Exception (bracket, finally, Exception, throwIO)
32+import System.IO (Handle, hClose, hFlush)
33+import System.IO.Error (isEOFError, ioeGetHandle)
34+import Control.Concurrent (forkIO)
35+import Control.Monad (unless)
36+import Data.Maybe (fromMaybe)
37+
38+import Data.Typeable (Typeable)
39+
40+import Control.Arrow (first)
41+
42+import Data.Enumerator (($$), (>>==))
43+import qualified Data.Enumerator as E
44+import Data.Enumerator.IO (iterHandle)
45+import Blaze.ByteString.Builder.Enumerator (builderToByteString)
46+import Blaze.ByteString.Builder.HTTP
47+ (chunkedTransferEncoding, chunkedTransferTerminator)
48+import Blaze.ByteString.Builder (fromByteString, Builder)
49+import Blaze.ByteString.Builder.Char8 (fromChar, fromString)
50+import Data.Monoid (mconcat)
51+
52+import Control.Monad.IO.Class (liftIO)
53+import Data.ByteString.Lazy.Internal (defaultChunkSize)
54+
55+run :: Port -> Application -> IO ()
56+run port = withSocketsDo .
57+ bracket
58+ (listenOn $ PortNumber $ fromIntegral port)
59+ sClose .
60+ serveConnections port
61+type Port = Int
62+
63+serveConnections :: Port -> Application -> Socket -> IO ()
64+serveConnections port app socket = do
65+ (conn, remoteHost', _) <- accept socket -- FIXME use sockets directly instead of Handlers?
66+ _ <- forkIO $ serveConnection port app conn remoteHost'
67+ serveConnections port app socket
68+
69+serveConnection :: Port -> Application -> Handle -> String -> IO ()
70+serveConnection port app conn remoteHost' = do
71+ catch
72+ (finally
73+ serveConnection'
74+ (hClose conn))
75+ catchEOFError
76+ where serveConnection' = do
77+ env <- parseRequest port conn remoteHost'
78+ res <- app env
79+ sendResponse (httpVersion env) conn res
80+ -- FIXME drain request body
81+ hFlush conn
82+ serveConnection'
83+
84+ catchEOFError :: IOError -> IO ()
85+ catchEOFError e | isEOFError e = case ioeGetHandle e of
86+ Just h -> unless (h == conn) (ioError e)
87+ Nothing -> ioError e
88+ | otherwise = ioError e
89+
90+parseRequest :: Port -> Handle -> String -> IO Request
91+parseRequest port conn remoteHost' = do
92+ headers' <- takeUntilBlank conn id
93+ parseRequest' port headers' conn remoteHost'
94+
95+takeUntilBlank :: Handle
96+ -> ([ByteString] -> [ByteString])
97+ -> IO [ByteString]
98+takeUntilBlank h front = do
99+ l <- stripCR `fmap` B.hGetLine h
100+ if B.null l
101+ then return $ front []
102+ else takeUntilBlank h $ front . (:) l
103+
104+stripCR :: ByteString -> ByteString
105+stripCR bs
106+ | B.null bs = bs
107+ | B.last bs == '\r' = B.init bs
108+ | otherwise = bs
109+
110+data InvalidRequest =
111+ NotEnoughLines [String]
112+ | BadFirstLine String
113+ | NonHttp
114+ deriving (Show, Typeable)
115+instance Exception InvalidRequest
116+
117+-- | Parse a set of header lines and body into a 'Request'.
118+parseRequest' :: Port
119+ -> [ByteString]
120+ -> Handle
121+ -> String
122+ -> IO Request
123+parseRequest' port lines' handle remoteHost' = do
124+ (firstLine, otherLines) <-
125+ case lines' of
126+ x:xs -> return (x, xs)
127+ [] -> throwIO $ NotEnoughLines $ map B.unpack lines'
128+ (method, rpath', gets, httpversion) <- parseFirst firstLine
129+ let rpath = '/' : case B.unpack rpath' of
130+ ('/':x) -> x
131+ _ -> B.unpack rpath'
132+ let heads = map (first mkCIByteString . parseHeaderNoAttr) otherLines
133+ let host = fromMaybe "" $ lookup "host" heads
134+ let len = fromMaybe 0 $ do
135+ bs <- lookup "Content-Length" heads
136+ let str = B.unpack bs
137+ case reads str of
138+ (x, _):_ -> Just x
139+ _ -> Nothing
140+ let (serverName', _) = B.break (== ':') host
141+ return $ Request
142+ { requestMethod = method
143+ , httpVersion = httpversion
144+ , pathInfo = B.pack rpath
145+ , queryString = gets
146+ , serverName = serverName'
147+ , serverPort = port
148+ , requestHeaders = heads
149+ , isSecure = False
150+ , requestBody = requestBodyHandle handle len
151+ , errorHandler = System.IO.hPutStr System.IO.stderr
152+ , remoteHost = B.pack remoteHost'
153+ }
154+
155+parseFirst :: ByteString
156+ -> IO (ByteString, ByteString, ByteString, HttpVersion)
157+parseFirst s = do
158+ let pieces = B.words s
159+ (method, query, http') <-
160+ case pieces of
161+ [x, y, z] -> return (x, y, z)
162+ _ -> throwIO $ BadFirstLine $ B.unpack s
163+ let (hfirst, hsecond) = B.splitAt 5 http'
164+ unless (hfirst == B.pack "HTTP/") $ throwIO NonHttp
165+ let (rpath, qstring) = B.break (== '?') query
166+ return (method, rpath, qstring, hsecond)
167+
168+headers :: HttpVersion -> Status -> ResponseHeaders -> Builder
169+headers httpversion status responseHeaders = mconcat
170+ [ fromByteString "HTTP/"
171+ , fromByteString httpversion
172+ , fromChar ' '
173+ , fromString $ show $ statusCode status
174+ , fromChar ' '
175+ , fromByteString $ statusMessage status
176+ , fromByteString "\r\n"
177+ , mconcat $ map go responseHeaders
178+ , fromByteString "Transfer-Encoding: chunked\r\n\r\n" -- FIXME perhaps put in non-chunked for HTTP 1.0 clients?
179+ ]
180+ where
181+ go (x, y) = mconcat
182+ [ fromByteString $ ciOriginal x
183+ , fromByteString ": "
184+ , fromByteString y
185+ , fromByteString "\r\n"
186+ ]
187+
188+sendResponse :: HttpVersion -> Handle -> Response -> IO ()
189+sendResponse hv handle res = do
190+ responseEnumerator res $ \s hs ->
191+ E.joinI $ chunk
192+ $$ E.enumList 1 [headers hv s hs]
193+ $$ E.joinI $ builderToByteString
194+ $$ iterHandle handle
195+ where
196+ chunk :: E.Enumeratee Builder Builder IO ()
197+ chunk = E.checkDone $ E.continue . step
198+ step k E.EOF = k (E.Chunks [chunkedTransferTerminator]) >>== return
199+ step k (E.Chunks []) = E.continue $ step k
200+ step k (E.Chunks builders) =
201+ k (E.Chunks [chunked]) >>== chunk
202+ where
203+ chunked = chunkedTransferEncoding $ mconcat builders
204+
205+parseHeaderNoAttr :: ByteString -> (ByteString, ByteString)
206+parseHeaderNoAttr s =
207+ let (k, rest) = B.span (/= ':') s
208+ rest' = if not (B.null rest) &&
209+ B.head rest == ':' &&
210+ not (B.null $ B.tail rest) &&
211+ B.head (B.tail rest) == ' '
212+ then B.drop 2 rest
213+ else rest
214+ in (k, rest')
215+
216+requestBodyHandle :: Handle -> Int -> E.Enumerator B.ByteString IO a
217+requestBodyHandle h =
218+ requestBodyFunc go
219+ where
220+ go i = Just `fmap` B.hGet h (min i defaultChunkSize)
221+
222+requestBodyFunc :: (Int -> IO (Maybe B.ByteString))
223+ -> Int
224+ -> E.Enumerator B.ByteString IO a
225+requestBodyFunc _ 0 step = E.returnI step
226+requestBodyFunc h len (E.Continue k) = do
227+ mbs <- liftIO $ h len
228+ case mbs of
229+ Nothing -> E.continue k
230+ Just bs -> do
231+ let newLen = len - B.length bs
232+ k (E.Chunks [bs]) >>== requestBodyFunc h newLen
233+requestBodyFunc _ _ step = E.returnI step
Setup.lhsnew file+7
@@ -0,0 +1,7 @@
1+#!/usr/bin/env runhaskell
2+
3+> module Main where
4+> import Distribution.Simple
5+
6+> main :: IO ()
7+> main = defaultMain
warp.cabalnew file+28
@@ -0,0 +1,28 @@
1+Name: warp
2+Version: 0.3.0
3+Synopsis: A fast, light-weight web server for WAI applications.
4+License: BSD3
5+License-file: LICENSE
6+Author: Michael Snoyman
7+Maintainer: michael@snoyman.com
8+Homepage: http://github.com/snoyberg/warp
9+Category: Web, Yesod
10+Build-Type: Simple
11+Cabal-Version: >=1.6
12+Stability: Stable
13+
14+Library
15+ Build-Depends: base >= 3 && < 5
16+ , bytestring >= 0.9 && < 0.10
17+ , wai >= 0.3.0 && < 0.4
18+ , network >= 2.2.1.5 && < 2.4
19+ , blaze-builder-enumerator >= 0.2 && < 0.3
20+ , transformers >= 0.2 && < 0.3
21+ , enumerator >= 0.4 && < 0.5
22+ , blaze-builder >= 0.2.1.3 && < 0.3
23+ Exposed-modules: Network.Wai.Handler.Warp
24+ ghc-options: -Wall
25+
26+source-repository head
27+ type: git
28+ location: git://github.com/snoyberg/warp.git