├── LICENSE ├── README.md ├── Setup.hs ├── Test └── Hyperdrive.hs ├── attic ├── FreeServe.hs ├── Main.hs ├── ParseRequestHand.hs ├── ParseRequestPipe.hs ├── Pong.hs ├── Request.hs ├── Response.hs ├── Serve.hs └── Types.hs ├── experiments ├── HyperIO.hs ├── HyperIO3.hs ├── HyperIORef.hs ├── HyperIORef2.hs ├── HyperMonad.hs ├── ProducerIORef.hs ├── ProducerTwice.hs ├── SubProducer.hs ├── Twice.lhs ├── pipes-delimited.hs ├── pipes-delimited2.hs ├── pipes-delimited3.hs ├── pipes-delimited4.hs ├── pipes-delimited5.hs └── pipes-delimited6.hs ├── hyperdrive-core ├── Hyperdrive │ └── Types.hs ├── LICENSE ├── Setup.hs └── hyperdrive-core.cabal ├── hyperdrive-parser-abnf ├── Hyperdrive │ └── Parser │ │ └── ABNF │ │ ├── Attoparsec.hs │ │ └── Parser.hs ├── LICENSE ├── Setup.hs └── hyperdrive-parser-abnf.cabal └── hyperdrive ├── Hyperdrive ├── FakeParser.hs ├── Serve.hs └── Simple.hs ├── LICENSE ├── Main.hs ├── Setup.hs └── hyperdrive.cabal /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2013, Jeremy Shaw 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Jeremy Shaw nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | hyperdrive is a fast, low-level HTTP server written in 2 | Haskell. hyperdrive will use a variety of techniques to ensure that it 3 | provides a correct implementation and reliable performance. 4 | 5 | This code is not yet fit for human consumption. 6 | 7 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | import Distribution.Simple 3 | main = defaultMainWithHooks simpleUserHooks 4 | -------------------------------------------------------------------------------- /Test/Hyperdrive.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | module Test.Hyperdrive ( tests ) where 3 | 4 | import Distribution.TestSuite 5 | 6 | test1 :: TestInstance 7 | test1 = 8 | TestInstance { run = return (Finished Pass) 9 | , name = "test1" 10 | , tags = [] 11 | , options = [] 12 | , setOption = \_ _ -> Right test1 13 | } 14 | 15 | tests :: IO [Test] 16 | tests = 17 | return $ 18 | [ testGroup "tests" 19 | [ Test test1 20 | ] 21 | ] 22 | -------------------------------------------------------------------------------- /attic/FreeServe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor, RecordWildCards, OverloadedStrings, RankNTypes #-} 2 | module FreeServe where 3 | 4 | import Control.Monad 5 | import Control.Monad.Trans.Free (FreeT(..),FreeF(Free, Pure)) 6 | import Data.ByteString (ByteString) 7 | import qualified Data.ByteString.Char8 as C 8 | import qualified Data.ByteString as B 9 | import Pipes 10 | import Pipes.Network.TCP 11 | import qualified Pipes.Parse as P 12 | import Response (statusLine, renderHeaders) 13 | import Request (parseRequest) 14 | import Types 15 | import Network (Socket) 16 | import Network.Socket.ByteString (sendAll) 17 | 18 | -- Each request is an effectful stream of `ByteString` chunks associated with a 19 | -- request header 20 | data RequestF next = RequestF 21 | { requestHead :: Request 22 | , requestBody :: Producer ByteString IO next 23 | } deriving (Functor) 24 | -- Note that the `next` type parameter indicats where the next request will be located. 25 | -- In this case we require that the next request is located inside the return value of 26 | -- the producer in order to enforce that we can't begin reading the next request until 27 | -- we first drain this request in its entirety. 28 | 29 | -- Each response is also a header and effectful stream of `ByteString` chunks 30 | data ResponseF next = ResponseF 31 | { responseHead :: Response 32 | , responseBody :: Producer ByteString IO next 33 | } deriving (Functor) 34 | 35 | -- A stream of requests uses `FreeT` to delimit each request. 36 | -- This preserves the original chunking and laziness while still 37 | -- allowing you to logically group the chunks into separate requests. 38 | -- `FreeT` ensures that each subsequent request is embedded within 39 | -- the `next` field of the `Request` type. The reason it knows how to 40 | -- do this is because of the `deriving (Functor)` stuff. `FreeT` uses the 41 | -- `Functor` instance of the `Request` type to detect where to insert the 42 | -- next request. 43 | type Requests = FreeT RequestF IO () 44 | 45 | -- The stream of responses also uses `FreeT` to delimit each responses 46 | type Responses = FreeT ResponseF IO () 47 | 48 | writeResponses :: Consumer ByteString IO Responses -> Responses -> IO () 49 | writeResponses consumer responses = 50 | do x <- runFreeT responses 51 | case x of 52 | (Pure ()) -> return () 53 | (Free (ResponseF Response{..} body)) -> 54 | do let header = B.concat [ statusLine rsCode 55 | , renderHeaders rsHeaders 56 | , "\r\n" 57 | ] 58 | res <- runEffect $ (yield header >> body) >-> consumer 59 | writeResponses consumer res 60 | 61 | readRequests :: Producer ByteString IO () -> SockAddr -> Requests 62 | readRequests producer clientAddr = 63 | do (r, p) <- P.runStateT (parseRequest False clientAddr) (hoist lift $ producer) 64 | case r of 65 | (Left parseError) -> error $ show parseError 66 | (Right (bytesRead, request)) -> 67 | let requestBody :: Producer ByteString IO Requests 68 | requestBody = 69 | do readRequestBody request 70 | return (readRequests producer clientAddr) 71 | in FreeT $ return (Free (RequestF request requestBody)) 72 | 73 | -- | for POST and PUT requests this should actually parse the message body and 'yield' the contents 74 | readRequestBody :: Request -> Producer ByteString IO () 75 | readRequestBody _ = 76 | do return () 77 | 78 | server :: (Request -> IO (Response, Pipe ByteString ByteString IO ())) 79 | -> (Requests -> Responses) 80 | server f requests = FreeT $ do 81 | x <- runFreeT requests 82 | case x of 83 | Pure r -> return (Pure r) 84 | Free (RequestF request producer) -> 85 | do (header, p) <- f request 86 | let newProducer = do 87 | remainingRequests <- producer >-> (p >> forever await) 88 | return (server f remainingRequests) 89 | return (Free (ResponseF header newProducer)) 90 | 91 | pong :: Request -> IO (Response, Pipe ByteString ByteString IO ()) 92 | pong req = 93 | do let body = "PONG" 94 | res = Response { rsCode = 200 95 | , rsHeaders = [("Content-Length", C.pack (show (B.length body)))] 96 | } 97 | return (res, yield body) 98 | 99 | main :: IO () 100 | main = 101 | let port = "8000" in 102 | listen (Host "127.0.0.1") port $ \(listenSocket, listenAddr) -> 103 | forever $ 104 | acceptFork listenSocket $ \(acceptedSocket, clientAddr) -> 105 | let writer = toSocket acceptedSocket 106 | reader = fromSocket acceptedSocket 4096 107 | in writeResponses writer ((server pong) (readRequests reader clientAddr)) 108 | -------------------------------------------------------------------------------- /attic/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Pipes 4 | import qualified Pipes.Prelude as P 5 | import qualified Network.Socket as NS 6 | import qualified Pipes.Network.TCP as T 7 | import qualified Pipes.Network.TCP.Safe as T' 8 | 9 | host1 = "127.0.0.1" :: NS.HostName 10 | host1p = T.Host host1 :: T.HostPreference 11 | 12 | main :: IO () 13 | main = 14 | NS.withSocketsDo $ 15 | T.listen host1p "8000" $ \(lsock, _laddr) -> 16 | T.accept lsock $ \(csock, _caddr) -> 17 | runEffect $ (T.socketReadS 4096 csock >-> P.print) () 18 | 19 | -- T.socketReadS 4096 csock 20 | 21 | -- printD () = 22 | -- return () 23 | -------------------------------------------------------------------------------- /attic/ParseRequestHand.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} 2 | module ParseRequestHand where 3 | 4 | import Control.Monad (forever) 5 | import Control.Proxy (Proxy, liftP, request, respond) 6 | import Control.Proxy.Trans.State (StateP, get, put) 7 | import Control.Exception.Extensible (Exception, throw) 8 | 9 | import Data.ByteString (ByteString, elemIndex, empty, split, uncons) 10 | import qualified Data.ByteString as B 11 | import Data.ByteString.Lex.Integral (readDecimal) 12 | import Data.ByteString.Internal (c2w) 13 | import Data.ByteString.Unsafe (unsafeDrop, unsafeIndex, unsafeTake) 14 | import Data.Monoid (mappend) 15 | import Data.Typeable (Typeable) 16 | import Data.Word (Word8) 17 | import Network.Socket (SockAddr(..)) 18 | import Types (Method(..), Request(..), HTTPVersion(..)) 19 | 20 | ------------------------------------------------------------------------------ 21 | -- 'Word8' constants for popular characters 22 | ------------------------------------------------------------------------------ 23 | 24 | colon, cr, nl, space :: Word8 25 | colon = c2w ':' 26 | cr = c2w '\r' 27 | nl = c2w '\n' 28 | space = c2w ' ' 29 | 30 | ------------------------------------------------------------------------------ 31 | -- Parse Exception 32 | ------------------------------------------------------------------------------ 33 | 34 | data ParseError 35 | = Unexpected 36 | | MalformedRequestLine ByteString 37 | | MalformedHeader ByteString 38 | | UnknownHTTPVersion ByteString 39 | deriving (Typeable, Show, Eq) 40 | 41 | instance Exception ParseError 42 | 43 | ------------------------------------------------------------------------------ 44 | -- Request Parser 45 | ------------------------------------------------------------------------------ 46 | 47 | {- 48 | Request = Request-Line ; Section 5.1 49 | *(( general-header ; Section 4.5 50 | | request-header ; Section 5.3 51 | | entity-header ) CRLF) ; Section 7.1 52 | CRLF 53 | [ message-body ] ; Section 4.3 54 | -} 55 | parseRequest :: (Proxy p, Monad m) => 56 | Bool -- ^ is this an HTTPS connection? 57 | -> SockAddr 58 | -> StateP ByteString p () ByteString a b m Request 59 | parseRequest secure addr = 60 | do line <- takeLine 61 | let (method, requestURI, httpVersion) = parseRequestLine line 62 | headers <- parseHeaders 63 | let req = 64 | Request { rqMethod = method 65 | , rqURIbs = requestURI 66 | , rqHTTPVersion = httpVersion 67 | , rqHeaders = headers 68 | , rqSecure = secure 69 | , rqClient = addr 70 | } 71 | return $! req 72 | 73 | -- | currently if you consume the entire request body this will 74 | -- terminate and return the 'ret' value that you supplied. But, that 75 | -- seems wrong, because that will tear down the whole pipeline and 76 | -- return that value instead of what you really wanted to return. 77 | -- 78 | -- Perhaps this should return a 'Maybe ByteString' instead so you can 79 | -- detect when the body ends? But that interfers with using 80 | -- 'parseRequest' in 'httpPipe'. For now we will just return 'empty' 81 | -- forever when you get to the end. 82 | -- 83 | -- Perhaps pipes 2.5 will provide a better solution as it is supposed 84 | -- to allow you to catch termination of the upstream pipe. 85 | pipeBody :: (Proxy p, Monad m) => 86 | Request 87 | -> () 88 | -> StateP ByteString p () ByteString a ByteString m r 89 | pipeBody req () = 90 | case lookup "Content-Length" (rqHeaders req) of 91 | Nothing -> 92 | do error "chunked bodies not supported yet" 93 | (Just value) -> 94 | case readDecimal (B.drop 1 value) of 95 | Nothing -> error $ "Failed to read Content-Length" 96 | (Just (n, _)) -> 97 | do unconsumed <- get 98 | go n unconsumed 99 | where 100 | go remaining unconsumed 101 | | remaining == 0 = 102 | do put unconsumed 103 | done 104 | 105 | | remaining >= B.length unconsumed = 106 | do liftP $ respond unconsumed 107 | bs <- liftP $ request () 108 | go (remaining - B.length unconsumed) bs 109 | 110 | | remaining == B.length unconsumed = 111 | do liftP $ respond unconsumed 112 | put empty 113 | done 114 | 115 | | otherwise = 116 | do let (bs', remainder) = B.splitAt remaining unconsumed 117 | liftP $ respond bs' 118 | put remainder 119 | done 120 | 121 | done = forever $ liftP $ respond empty 122 | 123 | {- 124 | The Request-Line begins with a method token, followed by the Request-URI and the protocol version, and ending with CRLF. The elements are separated by SP characters. No CR or LF is allowed except in the final CRLF sequence. 125 | 126 | Request-Line = Method SP Request-URI SP HTTP-Version CRLF 127 | -} 128 | parseRequestLine :: ByteString -> (Method, ByteString, HTTPVersion) 129 | parseRequestLine bs = 130 | case split space bs of 131 | [method, requestURI, httpVersion] -> 132 | (parseMethod method, requestURI, parseHTTPVersion httpVersion) 133 | _ -> throw (MalformedRequestLine bs) 134 | 135 | 136 | {- 137 | 138 | The Method token indicates the method to be performed on the resource identified by the Request-URI. The method is case-sensitive. 139 | 140 | Method = "OPTIONS" ; Section 9.2 141 | | "GET" ; Section 9.3 142 | | "HEAD" ; Section 9.4 143 | | "POST" ; Section 9.5 144 | | "PUT" ; Section 9.6 145 | | "DELETE" ; Section 9.7 146 | | "TRACE" ; Section 9.8 147 | | "CONNECT" ; Section 9.9 148 | | extension-method 149 | extension-method = token 150 | -} 151 | 152 | parseMethod :: ByteString -> Method 153 | parseMethod bs 154 | | bs == "OPTIONS" = OPTIONS 155 | | bs == "GET" = GET 156 | | bs == "HEAD" = HEAD 157 | | bs == "POST" = POST 158 | | bs == "PUT" = PUT 159 | | bs == "DELETE" = DELETE 160 | | bs == "TRACE" = TRACE 161 | | bs == "CONNECT" = CONNECT 162 | | otherwise = EXTENSION bs 163 | 164 | parseHTTPVersion :: ByteString -> HTTPVersion 165 | parseHTTPVersion bs 166 | | bs == "HTTP/1.1" = HTTP11 167 | | bs == "HTTP/1.0" = HTTP10 168 | | otherwise = throw (UnknownHTTPVersion bs) 169 | 170 | -- FIXME: add max header size checks 171 | -- parseHeaders :: (Monad m) => ByteString -> Pipe ByteString b m ([(ByteString, ByteString)], ByteString) 172 | parseHeaders :: (Proxy p, Monad m) => StateP ByteString p () ByteString a b m [(ByteString, ByteString)] 173 | parseHeaders = 174 | do line <- takeLine 175 | if B.null line 176 | then do return [] 177 | else do headers <- parseHeaders 178 | return (parseHeader line : headers) 179 | 180 | 181 | {- 182 | message-header = field-name ":" [ field-value ] 183 | field-name = token 184 | field-value = *( field-content | LWS ) 185 | field-content = 188 | -} 189 | 190 | parseHeader :: ByteString -> (ByteString, ByteString) 191 | parseHeader bs = 192 | let (fieldName, remaining) = parseToken bs 193 | in case uncons remaining of 194 | (Just (c, fieldValue)) 195 | | c == colon -> (fieldName, fieldValue) 196 | _ -> throw (MalformedHeader bs) 197 | 198 | {- 199 | token = 1* 200 | separators = "(" | ")" | "<" | ">" | "@" 201 | | "," | ";" | ":" | "\" | <"> 202 | | "/" | "[" | "]" | "?" | "=" 203 | | "{" | "}" | SP | HT 204 | CTL = 206 | -} 207 | 208 | -- FIXME: follow the spec 209 | parseToken :: ByteString -> (ByteString, ByteString) 210 | parseToken bs = B.span (/= colon) bs 211 | 212 | -- | find a line terminated by a '\r\n' 213 | takeLine :: (Proxy p, Monad m) => 214 | StateP ByteString p () ByteString a b m ByteString 215 | takeLine = 216 | do bs <- get 217 | case elemIndex nl bs of 218 | Nothing -> 219 | do x <- liftP $ request () 220 | put (bs `mappend` x) 221 | takeLine 222 | (Just 0) -> throw Unexpected 223 | (Just i) -> 224 | if unsafeIndex bs (i - 1) /= cr 225 | then throw Unexpected 226 | else do put $ unsafeDrop (i + 1) bs 227 | return $ unsafeTake (i - 1) bs 228 | 229 | {- 230 | 231 | parse :: (Monad m) => Pipe ByteString b m a -> String -> m (Maybe a) 232 | parse parser str = 233 | runPipe $ (yield (C.pack str) >> return Nothing) 234 | >+> (fmap Just parser) 235 | >+> discard 236 | -} -------------------------------------------------------------------------------- /attic/ParseRequestPipe.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} 2 | module ParseRequestPipe where 3 | 4 | import Control.Applicative 5 | import Control.Exception 6 | import Control.Monad (forever) 7 | import Pipes -- (C, Consumer, Pipe, Proxy, ProxyFast, (>->), liftP, request, respond, mapD, unitD, unitU) 8 | import Pipes.Parse 9 | import Control.Exception.Extensible (Exception, throw) 10 | import Data.ByteString (ByteString) 11 | import qualified Data.ByteString as B 12 | import qualified Data.ByteString.Char8 as C 13 | import Data.ByteString.Lex.Integral (readDecimal) 14 | import Data.ByteString.Internal (c2w) 15 | import Data.ByteString.Unsafe (unsafeDrop, unsafeIndex, unsafeTake) 16 | import Data.Monoid (mappend) 17 | -- import Data.Text (Text, unpack) 18 | import Data.Typeable (Typeable) 19 | import Data.Word (Word8) 20 | import Network.Socket (SockAddr(..)) 21 | import Types (Method(..), Request(..), Response(..), HTTPPipe(..), HTTPVersion(..)) 22 | 23 | sp :: (Monad m) => ParseT ProxyFast String m Char 24 | sp = char ' ' 25 | {- 26 | crlf :: (Monad m) => ParseT ProxyFast String m String 27 | crlf = string "\r\n" 28 | 29 | requestLine :: (Monad m) => ParseT ProxyFast String m (Method, ByteString, HTTPVersion) 30 | requestLine = 31 | do m <- method 32 | sp 33 | uri <- requestURI 34 | sp 35 | v <- httpVersion 36 | crlf 37 | return (m, uri, v) 38 | 39 | 40 | 41 | {- 42 | 43 | The Method token indicates the method to be performed on the resource identified by the Request-URI. The method is case-sensitive. 44 | 45 | Method = "OPTIONS" ; Section 9.2 46 | | "GET" ; Section 9.3 47 | | "HEAD" ; Section 9.4 48 | | "POST" ; Section 9.5 49 | | "PUT" ; Section 9.6 50 | | "DELETE" ; Section 9.7 51 | | "TRACE" ; Section 9.8 52 | | "CONNECT" ; Section 9.9 53 | | extension-method 54 | extension-method = token 55 | -} 56 | 57 | method :: (Monad m) => ParseT ProxyFast String m Method 58 | method = 59 | string "GET" *> pure GET 60 | <|> string "POST" *> pure POST 61 | <|> string "HEAD" *> pure HEAD 62 | <|> string "OPTIONS" *> pure OPTIONS 63 | <|> string "PUT" *> pure PUT 64 | <|> string "DELETE" *> pure DELETE 65 | <|> string "CONNECT" *> pure CONNECT 66 | <|> ((EXTENSION . C.pack) <$> token) 67 | 68 | {- 69 | token = 1* 70 | separators = "(" | ")" | "<" | ">" | "@" 71 | | "," | ";" | ":" | "\" | <"> 72 | | "/" | "[" | "]" | "?" | "=" 73 | | "{" | "}" | SP | HT 74 | CTL = 76 | -} 77 | 78 | token :: (Monad m) => ParseT ProxyFast String m String 79 | token = some tokenChar 80 | 81 | tokenChar :: (Monad m) => ParseT ProxyFast String m Char 82 | tokenChar = 83 | do c <- draw 84 | if not (c `elem` notTokenChar) 85 | then return c 86 | else empty 87 | 88 | notTokenChar :: [Char] 89 | notTokenChar = separators ++ ctl 90 | 91 | separators :: [Char] 92 | separators = "()<>@,;:\\\"/[]?={} \t" 93 | 94 | ctl :: [Char] 95 | ctl = ['\0' .. '\31'] ++ ['\127'] 96 | 97 | requestURI :: (Monad m) => ParseT ProxyFast String m ByteString 98 | requestURI = C.pack <$> some notSP 99 | where 100 | notSP = 101 | do c <- draw 102 | if c /= ' ' 103 | then return c 104 | else empty 105 | 106 | httpVersion :: (Monad m) => ParseT ProxyFast String m HTTPVersion 107 | httpVersion = 108 | do string "HTTP/1." 109 | (char '1' >> return HTTP11) <|> (char '0' >> return HTTP10) 110 | 111 | {- 112 | message-header = field-name ":" [ field-value ] 113 | field-name = token 114 | field-value = *( field-content | LWS ) 115 | field-content = 118 | -} 119 | 120 | messageHeader :: (Monad m) => ParseT ProxyFast String m (ByteString, ByteString) 121 | messageHeader = 122 | do fieldName <- token 123 | char ':' 124 | fieldValue <- some notCR 125 | crlf 126 | return (C.pack fieldName, C.pack fieldValue) 127 | where 128 | notCR = 129 | do c <- draw 130 | if c /= '\r' 131 | then return c 132 | else empty 133 | 134 | ------------------------------------------------------------------------------ 135 | -- Request Parser 136 | ------------------------------------------------------------------------------ 137 | 138 | {- 139 | Request = Request-Line ; Section 5.1 140 | *(( general-header ; Section 4.5 141 | | request-header ; Section 5.3 142 | | entity-header ) CRLF) ; Section 7.1 143 | CRLF 144 | [ message-body ] ; Section 4.3 145 | -} 146 | 147 | pRequest :: (Monad m) => 148 | Bool 149 | -> SockAddr 150 | -> ParseT ProxyFast String m Request 151 | pRequest secure addr = 152 | do (m, u, v) <- requestLine 153 | headers <- many messageHeader 154 | crlf 155 | let req = Request { rqMethod = m 156 | , rqURIbs = u 157 | , rqHTTPVersion = v 158 | , rqHeaders = headers 159 | , rqSecure = secure 160 | , rqClient = addr 161 | } 162 | return $! req 163 | 164 | parseRequest' :: Monad m => 165 | Bool 166 | -> SockAddr 167 | -> (() -> Pipe ProxyFast (Maybe String) Request m ()) 168 | parseRequest' secure addr = 169 | evalParseT (pRequest secure addr) 170 | 171 | -- FIXME: the 'return undefined' seems a bit wrong. 172 | parseRequest :: Monad m => 173 | Bool 174 | -> SockAddr 175 | -> (() -> Pipe ProxyFast ByteString b m Request) 176 | parseRequest secure addr = 177 | onlyK (mapD C.unpack) >-> (\() -> parseRequest' secure addr () >> return undefined) >-> go 178 | where 179 | go :: (Monad m) => (() -> Pipe ProxyFast Request b m Request) 180 | go () = 181 | do r <- request () 182 | return r 183 | 184 | pr :: (Monad m) => 185 | Bool 186 | -> SockAddr 187 | -> Consumer (ParseP String ProxyFast) (Maybe String) m Request 188 | pr secure addr = commit "whoa-mama" (pRequest secure addr) 189 | 190 | pr' :: Monad m => 191 | Bool 192 | -> SockAddr 193 | -> (() -> EitherP SomeException ProxyFast () (Maybe String) () C m Request) 194 | pr' secure addr () = evalParseP $ pr secure addr 195 | 196 | 197 | pr'' :: Monad m => 198 | Bool 199 | -> SockAddr 200 | -> () -> Consumer ProxyFast (Maybe String) m (Either SomeException Request) 201 | pr'' secure addr = runEitherK $ pr' secure addr 202 | 203 | pr''' :: Monad m => 204 | Bool 205 | -> SockAddr 206 | -> () -> Pipe ProxyFast ByteString c m (Either SomeException Request) 207 | pr''' secure addr = onlyK (mapD C.unpack) >-> pr'' secure addr >-> unitU 208 | 209 | ignoreMaybeString :: (Monad m) => () -> Pipe ProxyFast a b m r 210 | ignoreMaybeString () = 211 | do ms <- request () 212 | ignoreMaybeString () 213 | {- 214 | pr''' :: Monad m => 215 | Bool 216 | -> SockAddr 217 | -> (() -> Consumer ProxyFast c m (Either SomeException Request)) 218 | pr''' secure addr = pr'' secure addr >-> ignoreMaybeString 219 | -} 220 | 221 | {- 222 | ------------------------------------------------------------------------------ 223 | -- 'Word8' constants for popular characters 224 | ------------------------------------------------------------------------------ 225 | 226 | colon, cr, nl, space :: Word8 227 | colon = c2w ':' 228 | cr = c2w '\r' 229 | nl = c2w '\n' 230 | space = c2w ' ' 231 | 232 | ------------------------------------------------------------------------------ 233 | -- Parse Exception 234 | ------------------------------------------------------------------------------ 235 | 236 | data ParseError 237 | = Unexpected 238 | | MalformedRequestLine ByteString 239 | | MalformedHeader ByteString 240 | | UnknownHTTPVersion ByteString 241 | deriving (Typeable, Show, Eq) 242 | 243 | instance Exception ParseError 244 | 245 | ------------------------------------------------------------------------------ 246 | -- Request Parser 247 | ------------------------------------------------------------------------------ 248 | 249 | {- 250 | Request = Request-Line ; Section 5.1 251 | *(( general-header ; Section 4.5 252 | | request-header ; Section 5.3 253 | | entity-header ) CRLF) ; Section 7.1 254 | CRLF 255 | [ message-body ] ; Section 4.3 256 | -} 257 | parseRequest :: (Proxy p, Monad m) => 258 | Bool -- ^ is this an HTTPS connection? 259 | -> SockAddr 260 | -> StateP ByteString p () ByteString a b m Request 261 | parseRequest secure addr = 262 | do line <- takeLine 263 | let (method, requestURI, httpVersion) = parseRequestLine line 264 | headers <- parseHeaders 265 | let req = 266 | Request { rqMethod = method 267 | , rqURIbs = requestURI 268 | , rqHTTPVersion = httpVersion 269 | , rqHeaders = headers 270 | , rqSecure = secure 271 | , rqClient = addr 272 | } 273 | return $! req 274 | 275 | -- | currently if you consume the entire request body this will 276 | -- terminate and return the 'ret' value that you supplied. But, that 277 | -- seems wrong, because that will tear down the whole pipeline and 278 | -- return that value instead of what you really wanted to return. 279 | -- 280 | -- Perhaps this should return a 'Maybe ByteString' instead so you can 281 | -- detect when the body ends? But that interfers with using 282 | -- 'parseRequest' in 'httpPipe'. For now we will just return 'empty' 283 | -- forever when you get to the end. 284 | -- 285 | -- Perhaps pipes 2.5 will provide a better solution as it is supposed 286 | -- to allow you to catch termination of the upstream pipe. 287 | pipeBody :: (Proxy p, Monad m) => 288 | Request 289 | -> () 290 | -> StateP ByteString p () ByteString a ByteString m r 291 | pipeBody req () = 292 | case lookup "Content-Length" (rqHeaders req) of 293 | Nothing -> 294 | do error "chunked bodies not supported yet" 295 | (Just value) -> 296 | case readDecimal (B.drop 1 value) of 297 | Nothing -> error $ "Failed to read Content-Length" 298 | (Just (n, _)) -> 299 | do unconsumed <- get 300 | go n unconsumed 301 | where 302 | go remaining unconsumed 303 | | remaining == 0 = 304 | do put unconsumed 305 | done 306 | 307 | | remaining >= B.length unconsumed = 308 | do liftP $ respond unconsumed 309 | bs <- liftP $ request () 310 | go (remaining - B.length unconsumed) bs 311 | 312 | | remaining == B.length unconsumed = 313 | do liftP $ respond unconsumed 314 | put empty 315 | done 316 | 317 | | otherwise = 318 | do let (bs', remainder) = B.splitAt remaining unconsumed 319 | liftP $ respond bs' 320 | put remainder 321 | done 322 | 323 | done = forever $ liftP $ respond empty 324 | 325 | {- 326 | The Request-Line begins with a method token, followed by the Request-URI and the protocol version, and ending with CRLF. The elements are separated by SP characters. No CR or LF is allowed except in the final CRLF sequence. 327 | 328 | Request-Line = Method SP Request-URI SP HTTP-Version CRLF 329 | -} 330 | parseRequestLine :: ByteString -> (Method, ByteString, HTTPVersion) 331 | parseRequestLine bs = 332 | case split space bs of 333 | [method, requestURI, httpVersion] -> 334 | (parseMethod method, requestURI, parseHTTPVersion httpVersion) 335 | _ -> throw (MalformedRequestLine bs) 336 | 337 | 338 | {- 339 | 340 | The Method token indicates the method to be performed on the resource identified by the Request-URI. The method is case-sensitive. 341 | 342 | Method = "OPTIONS" ; Section 9.2 343 | | "GET" ; Section 9.3 344 | | "HEAD" ; Section 9.4 345 | | "POST" ; Section 9.5 346 | | "PUT" ; Section 9.6 347 | | "DELETE" ; Section 9.7 348 | | "TRACE" ; Section 9.8 349 | | "CONNECT" ; Section 9.9 350 | | extension-method 351 | extension-method = token 352 | -} 353 | 354 | parseMethod :: ByteString -> Method 355 | parseMethod bs 356 | | bs == "OPTIONS" = OPTIONS 357 | | bs == "GET" = GET 358 | | bs == "HEAD" = HEAD 359 | | bs == "POST" = POST 360 | | bs == "PUT" = PUT 361 | | bs == "DELETE" = DELETE 362 | | bs == "TRACE" = TRACE 363 | | bs == "CONNECT" = CONNECT 364 | | otherwise = EXTENSION bs 365 | 366 | parseHTTPVersion :: ByteString -> HTTPVersion 367 | parseHTTPVersion bs 368 | | bs == "HTTP/1.1" = HTTP11 369 | | bs == "HTTP/1.0" = HTTP10 370 | | otherwise = throw (UnknownHTTPVersion bs) 371 | 372 | -- FIXME: add max header size checks 373 | -- parseHeaders :: (Monad m) => ByteString -> Pipe ByteString b m ([(ByteString, ByteString)], ByteString) 374 | parseHeaders :: (Proxy p, Monad m) => StateP ByteString p () ByteString a b m [(ByteString, ByteString)] 375 | parseHeaders = 376 | do line <- takeLine 377 | if B.null line 378 | then do return [] 379 | else do headers <- parseHeaders 380 | return (parseHeader line : headers) 381 | 382 | 383 | {- 384 | message-header = field-name ":" [ field-value ] 385 | field-name = token 386 | field-value = *( field-content | LWS ) 387 | field-content = 390 | -} 391 | 392 | parseHeader :: ByteString -> (ByteString, ByteString) 393 | parseHeader bs = 394 | let (fieldName, remaining) = parseToken bs 395 | in case uncons remaining of 396 | (Just (c, fieldValue)) 397 | | c == colon -> (fieldName, fieldValue) 398 | _ -> throw (MalformedHeader bs) 399 | 400 | {- 401 | token = 1* 402 | separators = "(" | ")" | "<" | ">" | "@" 403 | | "," | ";" | ":" | "\" | <"> 404 | | "/" | "[" | "]" | "?" | "=" 405 | | "{" | "}" | SP | HT 406 | CTL = 408 | -} 409 | 410 | -- FIXME: follow the spec 411 | parseToken :: ByteString -> (ByteString, ByteString) 412 | parseToken bs = B.span (/= colon) bs 413 | 414 | -- | find a line terminated by a '\r\n' 415 | takeLine :: (Proxy p, Monad m) => 416 | StateP ByteString p () ByteString a b m ByteString 417 | takeLine = 418 | do bs <- get 419 | case elemIndex nl bs of 420 | Nothing -> 421 | do x <- liftP $ request () 422 | put (bs `mappend` x) 423 | takeLine 424 | (Just 0) -> throw Unexpected 425 | (Just i) -> 426 | if unsafeIndex bs (i - 1) /= cr 427 | then throw Unexpected 428 | else do put $ unsafeDrop (i + 1) bs 429 | return $ unsafeTake (i - 1) bs 430 | 431 | {- 432 | 433 | parse :: (Monad m) => Pipe ByteString b m a -> String -> m (Maybe a) 434 | parse parser str = 435 | runPipe $ (yield (C.pack str) >> return Nothing) 436 | >+> (fmap Just parser) 437 | >+> discard 438 | -} 439 | -} 440 | -} -------------------------------------------------------------------------------- /attic/Pong.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import Pipes 5 | import qualified Data.ByteString as B 6 | import qualified Data.ByteString.Char8 as C 7 | import Serve (serve) 8 | import Types (Handler, Response(..)) 9 | 10 | ------------------------------------------------------------------------------ 11 | -- pong handler 12 | ------------------------------------------------------------------------------ 13 | 14 | -- pong :: Handler IO 15 | pong = 16 | do let body = "PONG" 17 | res = Response { rsCode = 200 18 | , rsHeaders = [("Content-Length", C.pack (show (B.length body)))] 19 | , rsBody = yield body 20 | } 21 | yield res 22 | pong 23 | 24 | ------------------------------------------------------------------------------ 25 | -- main 26 | ------------------------------------------------------------------------------ 27 | 28 | main :: IO () 29 | main = serve "8000" pong 30 | -------------------------------------------------------------------------------- /attic/Request.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, DeriveDataTypeable, OverloadedStrings #-} 2 | module Request where 3 | 4 | import Control.Applicative 5 | import Control.Exception 6 | import Control.Monad (forever) 7 | import Pipes 8 | import Pipes.Attoparsec 9 | import Pipes.Parse 10 | import qualified Pipes.Prelude as P 11 | import Control.Exception (Exception, throw) 12 | import Control.Monad.Trans 13 | import Control.Monad.Trans.Error (ErrorT(runErrorT)) 14 | import Data.Attoparsec.ByteString.Char8 (Parser, string) 15 | import qualified Data.Attoparsec.ByteString.Char8 as A 16 | import Data.ByteString (ByteString) 17 | import qualified Data.ByteString as B 18 | import qualified Data.ByteString.Char8 as C 19 | import Data.ByteString.Lex.Integral (readDecimal) 20 | import Data.ByteString.Internal (c2w) 21 | import Data.ByteString.Unsafe (unsafeDrop, unsafeIndex, unsafeTake) 22 | import Data.Monoid (mappend) 23 | import Data.Typeable (Typeable) 24 | import Data.Word (Word8) 25 | import Network.Socket (SockAddr(..)) 26 | import Types (Method(..), Request(..), Response(..), HTTPPipe(..), HTTPVersion(..)) 27 | import Pipes.Parse 28 | 29 | {- 30 | 31 | Concerns: 32 | 33 | Header Limits 34 | ------------- 35 | 36 | We need to limit the size of headers we accept. If we know that we are 37 | going to reject headers over a certain size, and that total header 38 | size is rather small, should we start by drawing all the header data 39 | before we start parsing. 40 | 41 | The downside to doing that is we might block on waiting for data when 42 | we could be busy parsing stuff. In general we do not reject headers 43 | for being too big, so we don't care about wasting CPU decoding headers 44 | that could be rejected. 45 | 46 | With pipes we are, in theory, interleaving the fetching and 47 | parsing. We fetch data when it is available, parse as much as we can, 48 | and then if we need more, we fetch more. If the parsing is faster than 49 | the transfers, then we willspend time blocked on the fetching, but 50 | when that is happening, we will not have any work around we could be 51 | doing. 52 | 53 | Also, while we are parsing,that gives time for more data to arrive. If 54 | transfer is faster than parsing, then the parser will be kept at 100%, 55 | since there will always be data available when it tries to fetch. If 56 | the parsing is slow compared to the fetching, then we might want to 57 | start the parsing as soon as possible. However, if it is much larger, 58 | then waiting a little bit for the data to arrive will not matter. So, 59 | by getting it all at once, we can perhaps eliminate some extra runtime 60 | overhead which will make up for the initial latency in starting to 61 | parse. 62 | 63 | If we do not know the relative speeds then jumping back and forth will 64 | give us good performance at the cost of some pontential overhead. 65 | 66 | Character Oriented Parsing Efficiency 67 | ------------------------------------- 68 | 69 | parsing HTTP involves a lot of character orientedp parsing. But we get 70 | ByteStrings in chunks, and don't really want to draw/undraw a single 71 | character at a time from a bytestring. 72 | 73 | Additionally, we want to makes sure that when working with a 74 | ByteString, we do not pin the whole thing in RAM when we do not mean 75 | to. That may mean calling an explicit copy on the ByteString values we 76 | want to use directly in our data structure. 77 | 78 | When parsing something like the method line, we have two different 79 | types of behaviors. We match on a string that defines a method like 80 | GET or PUT, but we return a constructor value. So, the original 81 | ByteString value is not retained. But for the URI, we want to copy 82 | that part of the bytestring into our Request type. So, there we could 83 | be pinning things. 84 | 85 | And, for most headers, we will be copying the key/value pairs into the 86 | Request type. Doing that can cause sneaky problems though.If we are 87 | not careful, we could pin the rest of the ByteString in RAM. Except, 88 | wait! We are not processing a lazy ByteString but rather a stream of 89 | strict ByteString chunks. So each time we draw a new ByteString, we 90 | are getting a new, unconnected ByteString value. So, perhaps that is 91 | not an issue. 92 | 93 | Partial Chunk 94 | ------------- 95 | 96 | When parsing something like the request method, we need to match on a 97 | string like GET, PUT, POST, etc. But, we may not have a complete thing 98 | to match on. 99 | 100 | 101 | 102 | drawWhile :: (Monad m, Proxy p) => 103 | (Char -> Bool) 104 | -> Consumer (StateP [ByteString] p) (Maybe ByteString) m (Maybe ByteString) 105 | drawWhile p = 106 | do bs <- draw 107 | case C.span p bs of 108 | (before, after) 109 | | C.null after -> 110 | do rest <- drawWhile p 111 | return Nothing 112 | -} 113 | 114 | pMethod :: Parser Method 115 | pMethod = 116 | string "GET" *> pure GET 117 | <|> string "POST" *> pure POST 118 | <|> string "HEAD" *> pure HEAD 119 | <|> string "OPTIONS" *> pure OPTIONS 120 | <|> string "PUT" *> pure PUT 121 | <|> string "DELETE" *> pure DELETE 122 | <|> string "CONNECT" *> pure CONNECT 123 | -- <|> ((EXTENSION . C.pack) <$> token) 124 | 125 | -- pMethod_testD = runEffect $ evalStateK [] $ runEitherK $ (\() -> respond $ Just "GET") >-> parse pMethod 126 | 127 | {- 128 | pMethod_test :: IO (Either ParsingError (), [ByteString]) 129 | pMethod_test = runStateT (runErrorT $ runEffect $ ((wrap (\_ -> yield "GET")) >-> parse pMethod >-> (\() -> do c <- await () ; liftIO (print c))) ()) [] 130 | -} 131 | pRequestURI :: Parser ByteString 132 | pRequestURI = A.takeWhile (/= ' ') 133 | 134 | pHTTPVersion :: Parser HTTPVersion 135 | pHTTPVersion = 136 | string "HTTP/1.1" >> return HTTP11 137 | 138 | 139 | -- | an almost completely wrong implementation of pToken 140 | pToken :: Parser ByteString 141 | pToken = A.takeWhile (\c -> notElem c " :\r\n") 142 | 143 | crlf = A.string "\r\n" 144 | 145 | notCR = A.takeWhile (/= '\r') 146 | 147 | {- 148 | message-header = field-name ":" [ field-value ] 149 | field-name = token 150 | field-value = *( field-content | LWS ) 151 | field-content = 154 | -} 155 | 156 | 157 | -- | this is also wrong 158 | pMessageHeader :: Parser (ByteString, ByteString) 159 | pMessageHeader = 160 | do fieldName <- pToken 161 | A.char8 ':' 162 | fieldValue <- notCR 163 | crlf 164 | return (fieldName, fieldValue) 165 | 166 | pRequestHead :: Bool -> SockAddr -> Parser Request 167 | pRequestHead secure addr = 168 | do m <- pMethod 169 | A.char8 ' ' 170 | uri <- pRequestURI 171 | A.char8 ' ' 172 | httpVersion <- pHTTPVersion 173 | crlf 174 | hdrs <- many pMessageHeader 175 | crlf 176 | let request = Request { rqMethod = m 177 | , rqURIbs = uri 178 | , rqHTTPVersion = httpVersion 179 | , rqHeaders = hdrs 180 | , rqSecure = secure 181 | , rqClient = addr 182 | , rqBody = return () 183 | } 184 | return request 185 | 186 | {- 187 | pRequest_test :: IO (Either ParsingError (), [ByteString]) 188 | pRequest_test = runStateT (runEitherT $ runEffect $ ((wrap (\_ -> respond "GET /foo HTTP/1.1")) >-> parse pRequest >-> (\() -> do c <- request () ; liftIO (print c))) ()) [] 189 | -} 190 | -- parseRequest :: forall m y y'. (Monad m) => Bool -> SockAddr -> Proxy () (Maybe ByteString) y' y (ErrorT ParsingError (StateT [ByteString] m)) Request 191 | parseRequestHead :: Monad m => 192 | Bool 193 | -> SockAddr 194 | -> StateT (Producer ByteString m r) m (Either ParsingError (Int, Request)) 195 | parseRequestHead secure clientAddr = parse (pRequestHead secure clientAddr) 196 | 197 | ------------------------------------------------------------------------------ 198 | -- will remove this garbage shortly, not quite ready to yet 199 | ------------------------------------------------------------------------------ 200 | 201 | -- pMethod_test :: Proxy p => () -> p a b c Method f (Either e r) 202 | --pMethod_test :: (Monad m, Proxy p) => 203 | -- () 204 | -- -> p () (Maybe ByteString) () Method m (Either ParsingError (), [ByteString]) 205 | -- pMethod_testD = runEffect $ evalStateK [] $ runEitherK $ (\() -> respond $ Just "GET") >-> parseD pMethod 206 | {- 207 | -- pMethod_test2 = runProxy $ evalStateK [] $ runEitherK $ (\() -> respond $ Just "GET") >-> parse pMethod 208 | 209 | -- pMethod_test2 = evalStateP [] $ runEitherP $ parse pMethod 210 | -- pMethod_test2 = (wrap (\_ -> respond "GET")) >-> (\_ -> parse pMethod) 211 | --pMethod_test = 212 | -- runProxy $ evalStateK [] $ runEitherK $ 213 | -- (\() -> wrap (respond "G" >> respond "ET")) >-> (\() -> parse pMethod) 214 | 215 | test_p p bs= 216 | runProxy $ evalStateK [] $ runEitherK $ 217 | (\() -> wrap (respond bs)) >-> (\() -> parse p) 218 | 219 | pMethod_test_1 = test_p pMethod "GET" 220 | pMethod_test_2 = test_p pMethod "GOT" 221 | 222 | 223 | 224 | 225 | {- 226 | method :: (Monad m, Proxy p) => StateP [ByteString] p () (Maybe ByteString) y' y m (Maybe Method) 227 | method = 228 | do mbs <- draw 229 | case mbs of 230 | Nothing -> return Nothing 231 | (Just bs) 232 | | bs == "GET" -> return (Just GET) 233 | 234 | -- requestLine :: (Monad m, Proxy p) => StateP String m (Method, ByteString, HTTPVersion) 235 | 236 | requestLine :: (Monad m, Proxy p) => StateP [ByteString] p () (Maybe ByteString) y' y m (Maybe (Method, ByteString, HTTPVersion)) 237 | requestLine = 238 | do Just m <- method 239 | return $ Just (m, empty, HTTP11) 240 | -} 241 | 242 | {- 243 | do m <- method 244 | sp 245 | uri <- requestURI 246 | sp 247 | v <- httpVersion 248 | crlf 249 | return (m, uri, v) 250 | -} 251 | 252 | {- 253 | sp :: (Monad m) => ParseT ProxyFast String m Char 254 | sp = char ' ' 255 | 256 | crlf :: (Monad m) => ParseT ProxyFast String m String 257 | crlf = string "\r\n" 258 | o 259 | requestLine :: (Monad m) => ParseT ProxyFast String m (Method, ByteString, HTTPVersion) 260 | requestLine = 261 | do m <- method 262 | sp 263 | uri <- requestURI 264 | sp 265 | v <- httpVersion 266 | crlf 267 | return (m, uri, v) 268 | 269 | 270 | 271 | {- 272 | 273 | The Method token indicates the method to be performed on the resource identified by the Request-URI. The method is case-sensitive. 274 | 275 | Method = "OPTIONS" ; Section 9.2 276 | | "GET" ; Section 9.3 277 | | "HEAD" ; Section 9.4 278 | | "POST" ; Section 9.5 279 | | "PUT" ; Section 9.6 280 | | "DELETE" ; Section 9.7 281 | | "TRACE" ; Section 9.8 282 | | "CONNECT" ; Section 9.9 283 | | extension-method 284 | extension-method = token 285 | -} 286 | 287 | method :: (Monad m) => ParseT ProxyFast String m Method 288 | method = 289 | string "GET" *> pure GET 290 | <|> string "POST" *> pure POST 291 | <|> string "HEAD" *> pure HEAD 292 | <|> string "OPTIONS" *> pure OPTIONS 293 | <|> string "PUT" *> pure PUT 294 | <|> string "DELETE" *> pure DELETE 295 | <|> string "CONNECT" *> pure CONNECT 296 | <|> ((EXTENSION . C.pack) <$> token) 297 | 298 | {- 299 | token = 1* 300 | separators = "(" | ")" | "<" | ">" | "@" 301 | | "," | ";" | ":" | "\" | <"> 302 | | "/" | "[" | "]" | "?" | "=" 303 | | "{" | "}" | SP | HT 304 | CTL = 306 | -} 307 | 308 | token :: (Monad m) => ParseT ProxyFast String m String 309 | token = some tokenChar 310 | 311 | tokenChar :: (Monad m) => ParseT ProxyFast String m Char 312 | tokenChar = 313 | do c <- draw 314 | if not (c `elem` notTokenChar) 315 | then return c 316 | else empty 317 | 318 | notTokenChar :: [Char] 319 | notTokenChar = separators ++ ctl 320 | 321 | separators :: [Char] 322 | separators = "()<>@,;:\\\"/[]?={} \t" 323 | 324 | ctl :: [Char] 325 | ctl = ['\0' .. '\31'] ++ ['\127'] 326 | 327 | requestURI :: (Monad m) => ParseT ProxyFast String m ByteString 328 | requestURI = C.pack <$> some notSP 329 | where 330 | notSP = 331 | do c <- draw 332 | if c /= ' ' 333 | then return c 334 | else empty 335 | 336 | httpVersion :: (Monad m) => ParseT ProxyFast String m HTTPVersion 337 | httpVersion = 338 | do string "HTTP/1." 339 | (char '1' >> return HTTP11) <|> (char '0' >> return HTTP10) 340 | 341 | {- 342 | message-header = field-name ":" [ field-value ] 343 | field-name = token 344 | field-value = *( field-content | LWS ) 345 | field-content = 348 | -} 349 | 350 | messageHeader :: (Monad m) => ParseT ProxyFast String m (ByteString, ByteString) 351 | messageHeader = 352 | do fieldName <- token 353 | char ':' 354 | fieldValue <- some notCR 355 | crlf 356 | return (C.pack fieldName, C.pack fieldValue) 357 | where 358 | notCR = 359 | do c <- draw 360 | if c /= '\r' 361 | then return c 362 | else empty 363 | 364 | ------------------------------------------------------------------------------ 365 | -- Request Parser 366 | ------------------------------------------------------------------------------ 367 | 368 | {- 369 | Request = Request-Line ; Section 5.1 370 | *(( general-header ; Section 4.5 371 | | request-header ; Section 5.3 372 | | entity-header ) CRLF) ; Section 7.1 373 | CRLF 374 | [ message-body ] ; Section 4.3 375 | -} 376 | 377 | pRequest :: (Monad m) => 378 | Bool 379 | -> SockAddr 380 | -> ParseT ProxyFast String m Request 381 | pRequest secure addr = 382 | do (m, u, v) <- requestLine 383 | headers <- many messageHeader 384 | crlf 385 | let req = Request { rqMethod = m 386 | , rqURIbs = u 387 | , rqHTTPVersion = v 388 | , rqHeaders = headers 389 | , rqSecure = secure 390 | , rqClient = addr 391 | } 392 | return $! req 393 | 394 | parseRequest' :: Monad m => 395 | Bool 396 | -> SockAddr 397 | -> (() -> Pipe ProxyFast (Maybe String) Request m ()) 398 | parseRequest' secure addr = 399 | evalParseT (pRequest secure addr) 400 | 401 | -- FIXME: the 'return undefined' seems a bit wrong. 402 | parseRequest :: Monad m => 403 | Bool 404 | -> SockAddr 405 | -> (() -> Pipe ProxyFast ByteString b m Request) 406 | parseRequest secure addr = 407 | onlyK (mapD C.unpack) >-> (\() -> parseRequest' secure addr () >> return undefined) >-> go 408 | where 409 | go :: (Monad m) => (() -> Pipe ProxyFast Request b m Request) 410 | go () = 411 | do r <- request () 412 | return r 413 | 414 | pr :: (Monad m) => 415 | Bool 416 | -> SockAddr 417 | -> Consumer (ParseP String ProxyFast) (Maybe String) m Request 418 | pr secure addr = commit "whoa-mama" (pRequest secure addr) 419 | 420 | pr' :: Monad m => 421 | Bool 422 | -> SockAddr 423 | -> (() -> EitherP SomeException ProxyFast () (Maybe String) () C m Request) 424 | pr' secure addr () = evalParseP $ pr secure addr 425 | 426 | 427 | pr'' :: Monad m => 428 | Bool 429 | -> SockAddr 430 | -> () -> Consumer ProxyFast (Maybe String) m (Either SomeException Request) 431 | pr'' secure addr = runEitherK $ pr' secure addr 432 | 433 | pr''' :: Monad m => 434 | Bool 435 | -> SockAddr 436 | -> () -> Pipe ProxyFast ByteString c m (Either SomeException Request) 437 | pr''' secure addr = onlyK (mapD C.unpack) >-> pr'' secure addr >-> unitU 438 | 439 | ignoreMaybeString :: (Monad m) => () -> Pipe ProxyFast a b m r 440 | ignoreMaybeString () = 441 | do ms <- request () 442 | ignoreMaybeString () 443 | {- 444 | pr''' :: Monad m => 445 | Bool 446 | -> SockAddr 447 | -> (() -> Consumer ProxyFast c m (Either SomeException Request)) 448 | pr''' secure addr = pr'' secure addr >-> ignoreMaybeString 449 | -} 450 | 451 | {- 452 | ------------------------------------------------------------------------------ 453 | -- 'Word8' constants for popular characters 454 | ------------------------------------------------------------------------------ 455 | 456 | colon, cr, nl, space :: Word8 457 | colon = c2w ':' 458 | cr = c2w '\r' 459 | nl = c2w '\n' 460 | space = c2w ' ' 461 | 462 | ------------------------------------------------------------------------------ 463 | -- Parse Exception 464 | ------------------------------------------------------------------------------ 465 | 466 | data ParseError 467 | = Unexpected 468 | | MalformedRequestLine ByteString 469 | | MalformedHeader ByteString 470 | | UnknownHTTPVersion ByteString 471 | deriving (Typeable, Show, Eq) 472 | 473 | instance Exception ParseError 474 | 475 | ------------------------------------------------------------------------------ 476 | -- Request Parser 477 | ------------------------------------------------------------------------------ 478 | 479 | {- 480 | Request = Request-Line ; Section 5.1 481 | *(( general-header ; Section 4.5 482 | | request-header ; Section 5.3 483 | | entity-header ) CRLF) ; Section 7.1 484 | CRLF 485 | [ message-body ] ; Section 4.3 486 | -} 487 | parseRequest :: (Proxy p, Monad m) => 488 | Bool -- ^ is this an HTTPS connection? 489 | -> SockAddr 490 | -> StateP ByteString p () ByteString a b m Request 491 | parseRequest secure addr = 492 | do line <- takeLine 493 | let (method, requestURI, httpVersion) = parseRequestLine line 494 | headers <- parseHeaders 495 | let req = 496 | Request { rqMethod = method 497 | , rqURIbs = requestURI 498 | , rqHTTPVersion = httpVersion 499 | , rqHeaders = headers 500 | , rqSecure = secure 501 | , rqClient = addr 502 | } 503 | return $! req 504 | 505 | -- | currently if you consume the entire request body this will 506 | -- terminate and return the 'ret' value that you supplied. But, that 507 | -- seems wrong, because that will tear down the whole pipeline and 508 | -- return that value instead of what you really wanted to return. 509 | -- 510 | -- Perhaps this should return a 'Maybe ByteString' instead so you can 511 | -- detect when the body ends? But that interfers with using 512 | -- 'parseRequest' in 'httpPipe'. For now we will just return 'empty' 513 | -- forever when you get to the end. 514 | -- 515 | -- Perhaps pipes 2.5 will provide a better solution as it is supposed 516 | -- to allow you to catch termination of the upstream pipe. 517 | pipeBody :: (Proxy p, Monad m) => 518 | Request 519 | -> () 520 | -> StateP ByteString p () ByteString a ByteString m r 521 | pipeBody req () = 522 | case lookup "Content-Length" (rqHeaders req) of 523 | Nothing -> 524 | do error "chunked bodies not supported yet" 525 | (Just value) -> 526 | case readDecimal (B.drop 1 value) of 527 | Nothing -> error $ "Failed to read Content-Length" 528 | (Just (n, _)) -> 529 | do unconsumed <- get 530 | go n unconsumed 531 | where 532 | go remaining unconsumed 533 | | remaining == 0 = 534 | do put unconsumed 535 | done 536 | 537 | | remaining >= B.length unconsumed = 538 | do liftP $ respond unconsumed 539 | bs <- liftP $ request () 540 | go (remaining - B.length unconsumed) bs 541 | 542 | | remaining == B.length unconsumed = 543 | do liftP $ respond unconsumed 544 | put empty 545 | done 546 | 547 | | otherwise = 548 | do let (bs', remainder) = B.splitAt remaining unconsumed 549 | liftP $ respond bs' 550 | put remainder 551 | done 552 | 553 | done = forever $ liftP $ respond empty 554 | 555 | {- 556 | The Request-Line begins with a method token, followed by the Request-URI and the protocol version, and ending with CRLF. The elements are separated by SP characters. No CR or LF is allowed except in the final CRLF sequence. 557 | 558 | Request-Line = Method SP Request-URI SP HTTP-Version CRLF 559 | -} 560 | parseRequestLine :: ByteString -> (Method, ByteString, HTTPVersion) 561 | parseRequestLine bs = 562 | case split space bs of 563 | [method, requestURI, httpVersion] -> 564 | (parseMethod method, requestURI, parseHTTPVersion httpVersion) 565 | _ -> throw (MalformedRequestLine bs) 566 | 567 | 568 | {- 569 | 570 | The Method token indicates the method to be performed on the resource identified by the Request-URI. The method is case-sensitive. 571 | 572 | Method = "OPTIONS" ; Section 9.2 573 | | "GET" ; Section 9.3 574 | | "HEAD" ; Section 9.4 575 | | "POST" ; Section 9.5 576 | | "PUT" ; Section 9.6 577 | | "DELETE" ; Section 9.7 578 | | "TRACE" ; Section 9.8 579 | | "CONNECT" ; Section 9.9 580 | | extension-method 581 | extension-method = token 582 | -} 583 | 584 | parseMethod :: ByteString -> Method 585 | parseMethod bs 586 | | bs == "OPTIONS" = OPTIONS 587 | | bs == "GET" = GET 588 | | bs == "HEAD" = HEAD 589 | | bs == "POST" = POST 590 | | bs == "PUT" = PUT 591 | | bs == "DELETE" = DELETE 592 | | bs == "TRACE" = TRACE 593 | | bs == "CONNECT" = CONNECT 594 | | otherwise = EXTENSION bs 595 | 596 | parseHTTPVersion :: ByteString -> HTTPVersion 597 | parseHTTPVersion bs 598 | | bs == "HTTP/1.1" = HTTP11 599 | | bs == "HTTP/1.0" = HTTP10 600 | | otherwise = throw (UnknownHTTPVersion bs) 601 | 602 | -- FIXME: add max header size checks 603 | -- parseHeaders :: (Monad m) => ByteString -> Pipe ByteString b m ([(ByteString, ByteString)], ByteString) 604 | parseHeaders :: (Proxy p, Monad m) => StateP ByteString p () ByteString a b m [(ByteString, ByteString)] 605 | parseHeaders = 606 | do line <- takeLine 607 | if B.null line 608 | then do return [] 609 | else do headers <- parseHeaders 610 | return (parseHeader line : headers) 611 | 612 | 613 | {- 614 | message-header = field-name ":" [ field-value ] 615 | field-name = token 616 | field-value = *( field-content | LWS ) 617 | field-content = 620 | -} 621 | 622 | parseHeader :: ByteString -> (ByteString, ByteString) 623 | parseHeader bs = 624 | let (fieldName, remaining) = parseToken bs 625 | in case uncons remaining of 626 | (Just (c, fieldValue)) 627 | | c == colon -> (fieldName, fieldValue) 628 | _ -> throw (MalformedHeader bs) 629 | 630 | {- 631 | token = 1* 632 | separators = "(" | ")" | "<" | ">" | "@" 633 | | "," | ";" | ":" | "\" | <"> 634 | | "/" | "[" | "]" | "?" | "=" 635 | | "{" | "}" | SP | HT 636 | CTL = 638 | -} 639 | 640 | -- FIXME: follow the spec 641 | parseToken :: ByteString -> (ByteString, ByteString) 642 | parseToken bs = B.span (/= colon) bs 643 | 644 | -- | find a line terminated by a '\r\n' 645 | takeLine :: (Proxy p, Monad m) => 646 | StateP ByteString p () ByteString a b m ByteString 647 | takeLine = 648 | do bs <- get 649 | case elemIndex nl bs of 650 | Nothing -> 651 | do x <- liftP $ request () 652 | put (bs `mappend` x) 653 | takeLine 654 | (Just 0) -> throw Unexpected 655 | (Just i) -> 656 | if unsafeIndex bs (i - 1) /= cr 657 | then throw Unexpected 658 | else do put $ unsafeDrop (i + 1) bs 659 | return $ unsafeTake (i - 1) bs 660 | 661 | {- 662 | 663 | parse :: (Monad m) => Pipe ByteString b m a -> String -> m (Maybe a) 664 | parse parser str = 665 | runPipe $ (yield (C.pack str) >> return Nothing) 666 | >+> (fmap Just parser) 667 | >+> discard 668 | -} 669 | -} 670 | -}-} -------------------------------------------------------------------------------- /attic/Response.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, RecordWildCards, OverloadedStrings #-} 2 | module Response where 3 | 4 | import Control.Monad.Error 5 | import Control.Monad.State.Strict 6 | import Pipes 7 | import Pipes.Attoparsec 8 | import Pipes.Parse 9 | import Data.ByteString (ByteString) 10 | import qualified Data.ByteString as B 11 | import Types (Response(..)) 12 | 13 | -- TODO: How do output the data in sizes that are network friendly? Should we leverage blaze builder? 14 | 15 | ------------------------------------------------------------------------------ 16 | -- responseWriter 17 | ------------------------------------------------------------------------------ 18 | {- 19 | responseWriter :: (MonadIO m) => Response -> Proxy () (Maybe ByteString) () ByteString (ErrorT ParsingError (StateT [ByteString] m)) () 20 | responseWriter Response{..} = 21 | do yield $ B.concat [ statusLine rsCode 22 | , renderHeaders rsHeaders 23 | , "\r\n" 24 | ] 25 | hoist (lift . lift . liftIO) $ rsBody 26 | -} 27 | responsePipe :: (MonadIO m) => Pipe Response ByteString m a 28 | responsePipe = 29 | forever $ 30 | do Response{..} <- await 31 | yield $ B.concat [ statusLine rsCode 32 | , renderHeaders rsHeaders 33 | , "\r\n" 34 | ] 35 | hoist liftIO rsBody 36 | 37 | ------------------------------------------------------------------------------ 38 | -- Status Lines 39 | ------------------------------------------------------------------------------ 40 | 41 | {- 42 | Status-Line = HTTP-Version SP Status-Code SP Reason-Phrase CRLF 43 | -} 44 | 45 | -- FIXME: can the http version always be 1.1 or do we need to match the caller? 46 | statusLine :: Int -> ByteString 47 | statusLine 200 = ok_status 48 | statusLine 404 = not_found_status 49 | 50 | ok_status :: ByteString 51 | ok_status = "HTTP/1.1 200 OK\r\n" 52 | 53 | not_found_status :: ByteString 54 | not_found_status = "HTTP/1.1 404 Not Found\r\n" 55 | 56 | ------------------------------------------------------------------------------ 57 | -- Headers 58 | ------------------------------------------------------------------------------ 59 | 60 | renderHeaders :: [(ByteString, ByteString)] -> ByteString 61 | renderHeaders = B.concat . map renderHeader 62 | 63 | renderHeader :: (ByteString, ByteString) -> ByteString 64 | renderHeader (fieldName, fieldValue) = 65 | B.concat [fieldName, ": ", fieldValue, "\r\n"] 66 | -------------------------------------------------------------------------------- /attic/Serve.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, OverloadedStrings #-} 2 | {- 3 | 4 | This module is intended to provide a composable API that allows the 5 | developer to put together their own accept loops, add metrics, use 6 | transport layers like SSL, create fake transport layers for testing, 7 | listen on a specific socket, etc. 8 | 9 | In the common case the user wants to listen on a specific port and possible a specific address (localhost, everything, etc). 10 | 11 | We also have to handle IPv4 vs IPv6. 12 | 13 | If the user wants TLS then the same conditions apply, plus they need readers/writers that handle TLS. 14 | 15 | In general the reader and writer will be matched. For example, reading 16 | and writing from the same socket with the same compression style. 17 | 18 | In theory someone might want to use an unmatched pair for some reason. 19 | 20 | 21 | do (reader, writer) <- initSocket 22 | reader /> runHTTP /> writer 23 | 24 | 25 | -} 26 | module Serve where 27 | 28 | import Control.Concurrent (forkIO) 29 | import Control.Monad.State.Strict (StateT(runStateT), get, evalStateT) 30 | import Control.Monad.Trans.Error (ErrorT(runErrorT)) 31 | import Control.Monad.Trans (MonadIO(liftIO)) 32 | import Control.Exception (bracket, finally) 33 | import qualified Data.ByteString as B 34 | import qualified Data.ByteString.Char8 as C 35 | import Data.Void (Void) 36 | import Pipes (Consumer, Consumer', Producer, Producer', Pipe, Proxy, (>->), hoist, lift, runEffect, await, yield) 37 | import Pipes.Attoparsec (ParsingError, parseMany, parse) 38 | import Pipes.Lift (evalStateP) 39 | import Pipes.Network.TCP 40 | import qualified Pipes.Prelude as P 41 | import Pipes.Parse (input) 42 | import Pipes.Safe (runSafeT) 43 | import Control.Monad (forever) 44 | import Data.ByteString (ByteString, empty) 45 | import Network.Socket (Socket, SockAddr, sClose) 46 | import qualified Network.Socket as NS 47 | import Request (pRequestHead) 48 | import Response (responsePipe, statusLine, renderHeaders) 49 | import Types (Handler, HTTPPipe, Method(..), Request(..), Response(..)) 50 | 51 | 52 | ------------------------------------------------------------------------------ 53 | -- serve 54 | ------------------------------------------------------------------------------ 55 | {- 56 | -- | listen on a port and handle 'Requests' 57 | serve :: String -- ^ port number to listen on 58 | -> Handler IO -- ^ handler 59 | -> IO () 60 | serve port handler = 61 | listen (Host "127.0.0.1") port $ \(listenSocket, listenAddr) -> 62 | serveSocket listenSocket httpPipe handler 63 | 64 | -- | listen on a port and handle 'Requests' 65 | serve' :: String -- ^ port number to listen on 66 | -> HTTPPipe 67 | -> Handler IO -- ^ handler 68 | -> IO () 69 | serve' port httpPipe' handler = 70 | listen (Host "127.0.0.1") port $ \(listenSocket, listenAddr) -> 71 | serveSocket listenSocket httpPipe' handler 72 | 73 | ------------------------------------------------------------------------------ 74 | -- internals 75 | ------------------------------------------------------------------------------ 76 | 77 | serveSocket :: Socket -- ^ socket to listen on 78 | -> HTTPPipe 79 | -> Handler IO -- ^ handler 80 | -> IO () 81 | serveSocket listenSocket httpPipe' handler = 82 | forever $ 83 | acceptFork listenSocket $ \(acceptedSocket, clientAddr) -> 84 | let reader = recv acceptedSocket 4096 85 | writer = send acceptedSocket 86 | in do e <- runHTTPPipe False clientAddr reader writer httpPipe' handler 87 | -- print e 88 | return () 89 | 90 | -- | this is where we construct the pipe that reads from the socket, 91 | -- processes the request, and sends the response 92 | runHTTPPipe :: Bool -- ^ is this an HTTPS connection 93 | -> SockAddr -- ^ ip of the client 94 | -> (() -> Producer ByteString IO ()) 95 | -> (() -> Consumer ByteString IO ()) 96 | -> HTTPPipe 97 | -> Handler IO -- ^ handler 98 | -> IO (Either ParsingError (), [ByteString]) 99 | runHTTPPipe secure addr reader writer httpPipe' handler = 100 | runStateT ( runErrorT (runEffect $ (hoist (lift . lift) . reader) >-> (httpPipe' secure addr handler) >-> (hoist (lift . lift) . writer) $ ())) [] 101 | 102 | 103 | httpPipe ::HTTPPipe 104 | httpPipe secure addr handler () = go 105 | where 106 | go = do eof <- hoist lift $ isEndOfParserInput 107 | -- liftIO $ putStrLn "Not eof" 108 | if eof 109 | then return () 110 | else do req <- parseRequest secure addr 111 | -- liftIO $ print req 112 | resp <- handler req 113 | responseWriter resp 114 | go 115 | -} 116 | 117 | {- 118 | runHTTPPipe :: Bool -- ^ is this an HTTPS connection 119 | -> SockAddr -- ^ ip of the client 120 | -> (() -> Producer ByteString IO ()) 121 | -> (() -> Consumer ByteString IO ()) 122 | -> HTTPPipe 123 | -> Handler IO -- ^ handler 124 | -> IO (Either ParsingError (), [ByteString]) 125 | runStateT ( runErrorT (runEffect $ (hoist (lift . lift) . reader) >-> (httpPipe' secure addr handler) >-> (hoist (lift . lift) . writer) $ ())) [] 126 | -} 127 | {- 128 | serve :: String -- ^ port number to listen on 129 | -> Pipe (Int, Request) Response IO (Either (ParsingError, Producer ByteString IO ()) ()) 130 | -> IO () 131 | serve port handler = 132 | listen (Host "127.0.0.1") port $ \(listenSocket, listenAddr) -> 133 | serveSocket listenSocket handler 134 | 135 | serveSocket :: MonadIO m => 136 | Socket 137 | -> Pipe (Int, Request) Response IO (Either (ParsingError, Producer ByteString IO ()) ()) 138 | -> m b 139 | serveSocket listenSocket handler = 140 | forever $ 141 | acceptFork listenSocket $ \(acceptedSocket, clientAddr) -> 142 | let reader = fromSocket acceptedSocket 4096 143 | writer = toSocket acceptedSocket 144 | in do e <- runHTTPPipe reader writer False clientAddr handler 145 | return () 146 | 147 | runHTTPPipe :: MonadIO m => 148 | Producer ByteString m r 149 | -> Consumer ByteString m (Either (ParsingError, Producer ByteString m r) r) 150 | -> Bool 151 | -> SockAddr 152 | -> Pipe (Int, Request) Response m (Either (ParsingError, Producer ByteString m r) r) 153 | -> m (Either (ParsingError, Producer ByteString m r) r) 154 | runHTTPPipe producer consumer secure clientAddr handler = 155 | runEffect $ httpPipe producer secure clientAddr handler >-> consumer 156 | 157 | httpPipe :: MonadIO m => 158 | Producer ByteString m r 159 | -> Bool 160 | -> SockAddr 161 | -> Pipe (Int, Request) Response m (Either (ParsingError, Producer ByteString m r) r) 162 | -> Producer ByteString m (Either (ParsingError, Producer ByteString m r) r) 163 | httpPipe producer secure clientAddr handler = 164 | (parseMany (pRequest secure clientAddr) producer) >-> handler >-> responsePipe 165 | -} 166 | 167 | {- 168 | 169 | We want the user to be able to hook into the pipeline and do things 170 | such as decide when to work a new thread to handle each request or add 171 | rate limiting or maybe just live monitoring. 172 | 173 | We also want to be able to plug in different functions for 174 | reading/writing data to the network (so we can support http, https, 175 | spdy, or even just fake it for testing). 176 | 177 | we also want to be able to plug in different code for doing the 178 | parsing serialization. 179 | 180 | and then the user needs to be able to supply their handlers. 181 | 182 | 183 | fromSocket >-> parseRequest >-> acceptLoop handler >-> serializeResponse >-> toSocket 184 | 185 | parseRequest :: Pipe ByteString Request 186 | 187 | fromSocket 188 | 189 | -} 190 | 191 | {- 192 | 193 | We start by listening on a socket. That is a blocking action. 194 | 195 | When a client connects, we can now accept the socket and starting processing one or more requests for that client. 196 | 197 | Any responses must be sent back over that same accepted socket. 198 | 199 | The traditional method is to fork a new thread to handle each accepted socket. But there are other options available. 200 | 201 | In theory we could have a single handler than handles all requests from any accepted socket, one at a time. 202 | 203 | acceptor :: Socket -> Producer m Socket r 204 | forkomatic :: (Socket -> m r) -> Consumer m Socket r 205 | 206 | -} 207 | 208 | -- FIXME: how do we ensure the socket gets closed? 209 | acceptor :: (MonadIO m) => 210 | Socket 211 | -> Producer (Socket, SockAddr) m r 212 | acceptor listenSocket = 213 | forever $ 214 | do conn@(csock,_) <- liftIO (NS.accept listenSocket) 215 | yield conn 216 | 217 | runSocket :: (MonadIO m) => Int -> (Socket, SockAddr) -> (SockAddr -> Pipe ByteString ByteString m ()) -> m () 218 | runSocket bytes (socket, sockAddr) pipe = 219 | runEffect $ fromSocket socket 4096 >-> pipe sockAddr >-> toSocket socket 220 | 221 | runSocketConsumer :: (MonadIO m) => 222 | Int 223 | -> (SockAddr -> Pipe ByteString ByteString m ()) 224 | -> Consumer' (Socket, SockAddr) m () 225 | runSocketConsumer bytes pipe = 226 | forever $ 227 | do (socket, sockAddr) <- await 228 | fromSocket socket 4096 >-> pipe sockAddr >-> toSocket socket 229 | 230 | {- 231 | 232 | Should the handler be able to await more than one request or yield more than one response? 233 | 234 | In the normal case, that can not happen -- the closest that can happen is the 100-Continue which yields one or more responses. 235 | 236 | Should the handler even be a pipe? 237 | 238 | AT the core, the handler could be, Request -> IO Response 239 | 240 | Though, we have the issue of making sure the entire body is consumed exactly once. No more -- no less. Even in the case of early termination? 241 | 242 | 243 | It might seem like having one straight pipeline would be neat: 244 | 245 | acceptor >-> fromSocket >-> parseRequests >-> handleRequests >-> printResponses >-> toSocket 246 | 247 | but, we start to see the cracks almost immediately. 248 | 249 | fromSocket and toSocket need to actually reference the accepted socket. Also, how do we know that handleRequests is producing responses 1-to-1 and in order? Also, what happens if we want to use multiple threads and cores? 250 | 251 | Instead of one big pipeline, we likely need multiple forms of composition. 252 | 253 | 254 | 255 | pipeline :: (MonadIO m) => Pipe (Int, Request) Response m a -> Pipe (Producer ByteString m (), SockAddr) ByteString m a 256 | pipeline handler = requestPipe >-> handler >-> responsePipe 257 | -} 258 | 259 | forkomatic :: (MonadIO m) => ((Socket, SockAddr) -> IO ()) -> Consumer (Socket, SockAddr) m r 260 | forkomatic handler = 261 | forever $ 262 | do s <- await 263 | _tid <- liftIO $ forkIO $ handler s 264 | return () 265 | 266 | -- parseRequest secure clientAddr = parseMany (pRequest secure clientAddr) 267 | 268 | -- pipeline listenSocket handler = 269 | -- acceptor listenSocket >-> forkomatic (\s@(sock, clientAddr) -> return ()) -- runEffect $ (requestProducer clientAddr (fromSocket sock 4096) >-> handler s >-> toSocket sock)) 270 | 271 | -- duku producer handler (_, clientAddr) = 272 | -- parseMany (pRequest False clientAddr) producer >-> handler >-> responsePipe 273 | 274 | fromSocketProducer :: (MonadIO m) => Pipe (Socket, SockAddr) (Producer ByteString m (), SockAddr) m r 275 | fromSocketProducer = 276 | forever $ 277 | do (sock, clientAddr) <- await 278 | yield (fromSocket sock 4096, clientAddr) 279 | 280 | requestLoop :: Bool -> SockAddr -> (Request -> IO ()) -> StateT (Producer ByteString IO ()) IO () 281 | requestLoop secure clientAddr handler = 282 | forever $ 283 | do erq <- parse (pRequestHead secure clientAddr) 284 | case erq of 285 | (Left e) -> error $ show e 286 | (Right (bytesRead, rq)) -> 287 | do liftIO $ print rq 288 | p <- get 289 | let rqBody' :: Producer ByteString IO () 290 | rqBody' = 291 | case rqMethod rq of 292 | POST -> case lookup "Content-Length" (rqHeaders rq) of 293 | Nothing -> return () 294 | (Just bodyLen) -> 295 | p >-> P.take (read $ C.unpack bodyLen) 296 | _ -> return () 297 | rq' = rq { rqBody = rqBody' } 298 | liftIO $ handler rq' 299 | 300 | serveHTTP :: String -- ^ port number to listen on 301 | -> (Request -> IO Response) 302 | -> IO () 303 | serveHTTP port handler = 304 | listen (Host "127.0.0.1") port $ \(listenSocket, listenAddr) -> 305 | forever $ 306 | acceptFork listenSocket $ \(acceptedSocket, clientAddr) -> 307 | do let reader :: Producer ByteString IO () 308 | reader = fromSocket acceptedSocket 4096 309 | 310 | writer :: Consumer ByteString IO () 311 | writer = toSocket acceptedSocket 312 | 313 | responseWriter :: Response -> IO () 314 | responseWriter res = 315 | runEffect $ (do yield $ B.concat [ statusLine (rsCode res) 316 | , renderHeaders (rsHeaders res) 317 | , "\r\n" 318 | ] 319 | rsBody res 320 | liftIO $ yield "\r\n" 321 | ) >-> writer 322 | evalStateT (requestLoop False clientAddr (\req -> handler req >>= responseWriter)) reader 323 | 324 | hello = 325 | serveHTTP "8000" (\rq -> let body = "PONG" 326 | res = Response { rsCode = 200 327 | , rsHeaders = [("Content-Lenth", C.pack (show (B.length body)))] 328 | , rsBody = yield body 329 | } 330 | in return res) 331 | 332 | 333 | {- 334 | requestPipe :: (Monad m) => Pipe (Producer ByteString m (), SockAddr) (Int, Request) m r 335 | requestPipe = 336 | forever $ 337 | do (p, clientAddr) <- await 338 | parseMany (pRequest False clientAddr) p 339 | -} 340 | 341 | 342 | 343 | 344 | 345 | {- 346 | 347 | We have the problem that the producer and the consumer at either end of the Effect both need to share a socket. 348 | 349 | Maybe the socket should go into a reader? 350 | 351 | singleThread listenSocket handler = 352 | acceptor listenSocket >-> fromSocketProducer >-> pipeline >-> toSocket 353 | -} 354 | 355 | 356 | -- requestProducer clientAddr producer = 357 | -- parseMany (pRequest False clientAddr) 358 | {- 359 | server port handler = 360 | listen (Host "127.0.0.1") port $ \(listenSocket, listenAddr) -> 361 | pipeline listenSocket handler 362 | 363 | pong = 364 | do let body = "PONG" 365 | res = Response { rsCode = 200 366 | , rsHeaders = [("Content-Length", C.pack (show (B.length body)))] 367 | , rsBody = yield body 368 | } 369 | yield res 370 | pong 371 | 372 | 373 | main :: IO () 374 | main = runSafeT $ runEffect $ server "8000" pong 375 | -} -------------------------------------------------------------------------------- /attic/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, RankNTypes, RecordWildCards #-} 2 | module Types where 3 | 4 | import Pipes 5 | import Data.ByteString (ByteString) 6 | import qualified Data.ByteString.Char8 as C 7 | import Data.Data 8 | import Network.Socket (SockAddr) 9 | import Text.PrettyPrint.HughesPJ 10 | import Pipes.Attoparsec 11 | import Pipes.Parse 12 | import Control.Monad.State.Strict 13 | import Control.Monad.Trans.Error (ErrorT) 14 | ------------------------------------------------------------------------------ 15 | -- HTTPVersion 16 | ------------------------------------------------------------------------------ 17 | 18 | data HTTPVersion 19 | = HTTP10 20 | | HTTP11 21 | deriving (Eq, Ord, Read, Show, Data, Typeable) 22 | 23 | ppHTTPVersion :: HTTPVersion -> Doc 24 | ppHTTPVersion HTTP10 = text "HTTP/1.0" 25 | ppHTTPVersion HTTP11 = text "HTTP/1.1" 26 | 27 | ------------------------------------------------------------------------------ 28 | -- Method 29 | ------------------------------------------------------------------------------ 30 | 31 | data Method 32 | = OPTIONS 33 | | GET 34 | | GETONLY 35 | | HEAD 36 | | POST 37 | | PUT 38 | | DELETE 39 | | TRACE 40 | | CONNECT 41 | | EXTENSION ByteString -- FIXME: don't use ByteString (use Ascii or something?) 42 | deriving (Eq, Ord, Read, Show, Data, Typeable) 43 | 44 | ppMethod :: Method -> Doc 45 | ppMethod OPTIONS = text "OPTIONS" 46 | ppMethod GET = text "GET" 47 | ppMethod GETONLY = text "GETONLY" 48 | ppMethod HEAD = text "HEAD" 49 | ppMethod POST = text "POST" 50 | ppMethod PUT = text "PUT" 51 | ppMethod DELETE = text "DELETE" 52 | ppMethod TRACE = text "TRACE" 53 | ppMethod CONNECT = text "CONNECT" 54 | ppMethod (EXTENSION ext) = text (C.unpack ext) 55 | 56 | ------------------------------------------------------------------------------ 57 | -- Handler 58 | ------------------------------------------------------------------------------ 59 | 60 | 61 | -- | a 'Handler' essentially a 'Request' and returns a 'Response' 62 | -- 63 | -- The Pipe allows use to incrementally read 'ByteString' chuncks from 64 | -- the Request body and incrementally write 'ByteString' chunks in the 65 | -- 'Response' body. 66 | type Handler m = Request -> Proxy () (Maybe ByteString) () ByteString (ErrorT ParsingError (StateT [ByteString] m)) Response 67 | 68 | ------------------------------------------------------------------------------ 69 | -- HTTPPipe 70 | ------------------------------------------------------------------------------ 71 | 72 | type HTTPPipe = Bool 73 | -> SockAddr 74 | -> Handler IO 75 | -> () -> Proxy () (Maybe ByteString) () ByteString (ErrorT ParsingError (StateT [ByteString] IO)) () 76 | 77 | ------------------------------------------------------------------------------ 78 | -- MessageBody 79 | ------------------------------------------------------------------------------ 80 | 81 | type MessageBody = ByteString 82 | 83 | ------------------------------------------------------------------------------ 84 | -- Request 85 | ------------------------------------------------------------------------------ 86 | 87 | data Request = Request 88 | { rqMethod :: !Method 89 | , rqURIbs :: !ByteString 90 | , rqHTTPVersion :: !HTTPVersion 91 | , rqHeaders :: ![(ByteString, ByteString)] 92 | , rqSecure :: !Bool 93 | , rqClient :: !SockAddr 94 | , rqBody :: Producer ByteString IO () 95 | -- , rqBody :: Producer' ByteString (StateT (Producer ByteString IO ()) IO) () 96 | } 97 | deriving Typeable 98 | 99 | instance Show Request where 100 | show = show . ppRequest 101 | 102 | ppRequest :: Request -> Doc 103 | ppRequest Request{..} = 104 | text "Request {" $+$ 105 | nest 2 ( 106 | vcat [ field " rqMethod" (ppMethod rqMethod) 107 | , field ", rqURIbs" (bytestring rqURIbs) 108 | , field ", rqHTTPVersion" (ppHTTPVersion rqHTTPVersion) 109 | , field ", rqHeaders" (vcat $ map ppHeader rqHeaders) 110 | , field ", rqSecure" (text $ show rqSecure) 111 | , field ", rqClient" (text $ show rqClient) 112 | , field ", rqBody" (text $ show "") 113 | ]) $+$ 114 | text "}" 115 | 116 | ppHeader :: (ByteString, ByteString) -> Doc 117 | ppHeader (fieldName, fieldValue) = 118 | bytestring fieldName <> char ':' <> bytestring fieldValue 119 | 120 | ------------------------------------------------------------------------------ 121 | -- Response 122 | ------------------------------------------------------------------------------ 123 | 124 | data Response = Response 125 | { rsCode :: {-# UNPACK #-} !Int 126 | , rsHeaders :: [(ByteString, ByteString)] 127 | , rsBody :: Producer' ByteString IO () 128 | } 129 | 130 | instance Show (Response) where 131 | show = show . ppResponse 132 | 133 | ppResponse :: Response -> Doc 134 | ppResponse Response{..} = 135 | text "Response {" $+$ 136 | nest 2 (vcat [ field "rsCode" (text $ show rsCode) 137 | , field "rsHeaders" (vcat $ map ppHeader rsHeaders) 138 | , field "rsBody " (text "") 139 | ]) $+$ 140 | text "}" 141 | 142 | 143 | ------------------------------------------------------------------------------ 144 | -- Misc 145 | ------------------------------------------------------------------------------ 146 | 147 | bytestring :: ByteString -> Doc 148 | bytestring = text . C.unpack 149 | 150 | field :: String -> Doc -> Doc 151 | field name doc = text name $$ nest 20 (char '=' <+> doc) 152 | -------------------------------------------------------------------------------- /experiments/HyperIO.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} 2 | module Main where 3 | 4 | import Control.Applicative ((<$>)) 5 | import Control.Monad.Trans.State.Strict (StateT(..)) 6 | import Control.Monad (when, forever) 7 | import Data.ByteString (ByteString) 8 | import qualified Data.ByteString as B 9 | import qualified Data.ByteString.Char8 as C 10 | import Data.ByteString.Lex.Integral (readDecimal) 11 | import Data.Attoparsec.ByteString.Char8 (Parser, string, char) 12 | import qualified Data.Attoparsec.ByteString.Char8 as A 13 | import Data.Maybe (isNothing) 14 | import Pipes 15 | import qualified Pipes.Prelude as P 16 | -- import Pipes.Parse (Parser) 17 | import Pipes.Attoparsec 18 | import qualified Pipes.ByteString as Pb 19 | import Lens.Family.State.Strict (zoom) 20 | import qualified Pipes.Parse as Ppi 21 | 22 | type Hyperdrive m = StateT (Producer ByteString m (Producer ByteString m ())) m 23 | 24 | data Request = Request 25 | { rqLength :: !Int 26 | -- , rqBody :: Producer ByteString IO () 27 | } 28 | 29 | request :: ByteString 30 | request = 31 | B.concat 32 | [ "Content-Length: 4\n" 33 | , "\n" 34 | , "1234\n" 35 | ] 36 | 37 | notNL :: Parser ByteString 38 | notNL = A.takeWhile (/= '\n') 39 | 40 | pRequestHead :: A.Parser Request 41 | pRequestHead = 42 | do string "Content-Length: " 43 | len <- notNL 44 | string "\n\n" 45 | case readDecimal len of 46 | Just (i,_) -> return $ Request { rqLength = i } 47 | _ -> error $ "Could not parse length: " ++ show len 48 | 49 | 50 | 51 | serve :: Producer ByteString IO () 52 | -> (a -> IO ()) 53 | -> (Producer ByteString IO () -> IO a) 54 | -> IO () 55 | serve p0 printer handler = 56 | do (r, p1) <- runStateT (parse pRequestHead) p0 57 | case r of 58 | (Left err) -> error (show err) 59 | (Right req) -> 60 | do let pBody = p1 >-> Pb.take (rqLength req + 1) -- this discards the rest of the stream, so it doesn't work 61 | a <- handler pBody 62 | printer a 63 | -- runEffect $ p1 >-> Pb.take 1 >-> drain 64 | serve p1 printer handler 65 | where 66 | drain = forever await 67 | 68 | echoBody :: Producer ByteString IO () -> IO ByteString 69 | echoBody p = 70 | do bs <- B.concat <$> P.toListM p 71 | return bs 72 | 73 | requestProducer :: Producer ByteString IO () 74 | requestProducer = (yield request >> yield request) 75 | 76 | main :: IO () 77 | main = 78 | serve requestProducer C.putStr echoBody 79 | 80 | 81 | {- 82 | parseWithBody printer handler = 83 | do eReq <- parse pRequestHead 84 | case eReq of 85 | (Left e) -> error (show e) 86 | (Right req) -> 87 | -} 88 | 89 | {- 90 | parseWithBody printer handler = 91 | do eReq <- parse pRequestHead 92 | case eReq of 93 | (Left e) -> error (show e) 94 | (Right req) -> 95 | do a <- zoom (Pb.splitAt (rqLength req)) handler 96 | lift $ printer a 97 | r <- parse (char '\n' >> (isNothing <$> A.peekChar)) 98 | case r of 99 | (Right False) -> parseWithBody printer handler 100 | (Right True) -> return () 101 | (Left e) -> error (show e) 102 | 103 | pBody = parse $ A.many' A.anyChar 104 | 105 | echoBody :: (Monad m) => Hyperdrive m String 106 | echoBody = 107 | do bd <- pBody 108 | case bd of 109 | (Left e) -> error "Malformed Request" 110 | (Right bd) -> 111 | return bd 112 | 113 | test :: IO ((), Producer ByteString IO ()) 114 | test = runStateT (parseWithBody print echoBody) (yield request >> yield request) 115 | 116 | 117 | {- 118 | parser' :: (Monad m) => 119 | StateT (Producer ByteString m x) m (Either ParsingError Int) 120 | parser' = parse pRequestHead 121 | 122 | parseOne :: Monad m => 123 | Producer ByteString m x 124 | -> m (Either ParsingError Int, Producer ByteString m x) 125 | parseOne = runStateT parser' 126 | 127 | testHead = 128 | do (r, rest) <- parseOne (yield request) 129 | print r 130 | 131 | pBody = parse $ A.many' A.anyChar 132 | 133 | type Hyperdrive m = StateT (Producer ByteString m (Producer ByteString m ())) m 134 | 135 | parseWithBody :: (Monad m) => Producer ByteString m () -> (a -> m ()) -> Hyperdrive m a -> m () 136 | parseWithBody p printer handler = 137 | do (r, rest) <- parseOne p 138 | case r of 139 | (Left e) -> error $ "Invalid Request: " ++ show e 140 | (Right len) -> 141 | do ((a, e), next) <- runStateT (do a <- zoom (Pb.splitAt len) handler 142 | r <- parse (char '\n' >> (isNothing <$> A.peekChar)) 143 | case r of 144 | (Right eof) -> return (a, eof) 145 | (Left e) -> error (show e) 146 | ) rest 147 | printer a 148 | if e 149 | then return () 150 | else parseWithBody next printer handler 151 | 152 | parseWithBody2 p printer handler = 153 | do (r, rest) <- parseOne p 154 | 155 | echoBody :: (Monad m) => Hyperdrive m String 156 | echoBody = 157 | do bd <- pBody 158 | case bd of 159 | (Left e) -> error "Malformed Request" 160 | (Right bd) -> 161 | return bd 162 | 163 | test = parseWithBody (yield request >> yield request) print echoBody 164 | -} 165 | -} -------------------------------------------------------------------------------- /experiments/HyperIO3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} 2 | module Main where 3 | 4 | import Control.Applicative ((<$>)) 5 | import Control.Monad.Trans.State.Strict (StateT(..)) 6 | import Control.Monad (when) 7 | import Data.ByteString (ByteString) 8 | import qualified Data.ByteString as B 9 | import qualified Data.ByteString.Char8 as B 10 | import Data.ByteString.Lex.Integral (readDecimal) 11 | import Data.Attoparsec.ByteString.Char8 (Parser, string, char) 12 | import qualified Data.Attoparsec.ByteString.Char8 as A 13 | import Data.Maybe (isNothing) 14 | import Pipes 15 | import qualified Pipes.Prelude as P 16 | -- import Pipes.Parse (Parser) 17 | import Pipes.Attoparsec 18 | import qualified Pipes.ByteString as Pb 19 | import Lens.Family.State.Strict (zoom) 20 | import Lens.Family (over) 21 | import qualified Pipes.Parse as Ppi 22 | 23 | type Hyperdrive m = StateT (Producer ByteString m (Producer ByteString m ())) m 24 | 25 | data Request = Request 26 | { rqLength :: Int 27 | } 28 | deriving Show 29 | 30 | request :: ByteString 31 | request = 32 | B.concat 33 | [ "Content-Length: 4\n" 34 | , "\n" 35 | , "1234\n" 36 | ] 37 | 38 | notNL :: Parser ByteString 39 | notNL = A.takeWhile (/= '\n') 40 | 41 | pRequestHead :: A.Parser Request 42 | pRequestHead = 43 | do string "Content-Length: " 44 | len <- notNL 45 | string "\n\n" 46 | case readDecimal len of 47 | Just (i,_) -> return $ Request { rqLength = i } 48 | _ -> error $ "Could not parse length: " ++ show len 49 | 50 | parseWithBody p0 printer handler = 51 | do (eReq, p1) <- runStateT (parse pRequestHead) p0 52 | case eReq of 53 | (Left e) -> error (show e) 54 | (Right req) -> 55 | do a <- handler (over (Pb.take (rqLength req)) p1) 56 | printer a 57 | {- 58 | do a <- zoom (Pb.splitAt (rqLength req)) handler 59 | 60 | lift $ printer a 61 | r <- parse (char '\n' >> (isNothing <$> A.peekChar)) 62 | case r of 63 | (Right False) -> parseWithBody printer handler 64 | (Right True) -> return () 65 | (Left e) -> error (show e) 66 | 67 | pBody = parse $ A.many' A.anyChar 68 | 69 | echoBody :: (Monad m) => Hyperdrive m String 70 | echoBody = 71 | do bd <- pBody 72 | case bd of 73 | (Left e) -> error "Malformed Request" 74 | (Right bd) -> 75 | return bd 76 | 77 | test :: IO ((), Producer ByteString IO ()) 78 | test = runStateT (parseWithBody print echoBody) (yield request >> yield request) 79 | 80 | 81 | {- 82 | parser' :: (Monad m) => 83 | StateT (Producer ByteString m x) m (Either ParsingError Int) 84 | parser' = parse pRequestHead 85 | 86 | parseOne :: Monad m => 87 | Producer ByteString m x 88 | -> m (Either ParsingError Int, Producer ByteString m x) 89 | parseOne = runStateT parser' 90 | 91 | testHead = 92 | do (r, rest) <- parseOne (yield request) 93 | print r 94 | 95 | pBody = parse $ A.many' A.anyChar 96 | 97 | type Hyperdrive m = StateT (Producer ByteString m (Producer ByteString m ())) m 98 | 99 | parseWithBody :: (Monad m) => Producer ByteString m () -> (a -> m ()) -> Hyperdrive m a -> m () 100 | parseWithBody p printer handler = 101 | do (r, rest) <- parseOne p 102 | case r of 103 | (Left e) -> error $ "Invalid Request: " ++ show e 104 | (Right len) -> 105 | do ((a, e), next) <- runStateT (do a <- zoom (Pb.splitAt len) handler 106 | r <- parse (char '\n' >> (isNothing <$> A.peekChar)) 107 | case r of 108 | (Right eof) -> return (a, eof) 109 | (Left e) -> error (show e) 110 | ) rest 111 | printer a 112 | if e 113 | then return () 114 | else parseWithBody next printer handler 115 | 116 | parseWithBody2 p printer handler = 117 | do (r, rest) <- parseOne p 118 | 119 | echoBody :: (Monad m) => Hyperdrive m String 120 | echoBody = 121 | do bd <- pBody 122 | case bd of 123 | (Left e) -> error "Malformed Request" 124 | (Right bd) -> 125 | return bd 126 | 127 | test = parseWithBody (yield request >> yield request) print echoBody 128 | -}-} -------------------------------------------------------------------------------- /experiments/HyperIORef.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} 2 | module Main where 3 | 4 | import Control.Applicative ((<$>)) 5 | import Control.Monad.Trans.State.Strict (StateT(..)) 6 | import Control.Monad (when) 7 | import Data.ByteString (ByteString) 8 | import qualified Data.ByteString as B 9 | import qualified Data.ByteString.Char8 as B 10 | import Data.ByteString.Lex.Integral (readDecimal) 11 | import Data.Attoparsec.ByteString.Char8 (Parser, string, char) 12 | import qualified Data.Attoparsec.ByteString.Char8 as A 13 | import Data.Maybe (isNothing) 14 | import Data.IORef (IORef, newIORef) 15 | import Pipes 16 | import qualified Pipes.Prelude as P 17 | -- import Pipes.Parse (Parser) 18 | import Pipes.Attoparsec 19 | import qualified Pipes.ByteString as Pb 20 | import Lens.Family.State.Strict (zoom) 21 | import qualified Pipes.Parse as Ppi 22 | 23 | type Hyperdrive m = StateT (Producer ByteString m (Producer ByteString m ())) m 24 | 25 | data Request = Request 26 | { rqLength :: Int 27 | -- , rqBody :: IORef (Producer ByteString IO ()) 28 | } 29 | 30 | request :: ByteString 31 | request = 32 | B.concat 33 | [ "Content-Length: 4\n" 34 | , "\n" 35 | , "1234\n" 36 | ] 37 | 38 | notNL :: Parser ByteString 39 | notNL = A.takeWhile (/= '\n') 40 | 41 | pRequestHead :: A.Parser Request 42 | pRequestHead = 43 | do string "Content-Length: " 44 | len <- notNL 45 | string "\n\n" 46 | case readDecimal len of 47 | Just (i,_) -> return $ Request { rqLength = i } 48 | _ -> error $ "Could not parse length: " ++ show len 49 | 50 | parseWithBody printer handler = 51 | do eReq <- parse pRequestHead 52 | case eReq of 53 | (Left e) -> error (show e) 54 | (Right req) -> 55 | undefined 56 | {- 57 | do a <- zoom (Pb.splitAt (rqLength req)) handler 58 | lift $ printer a 59 | r <- parse (char '\n' >> (isNothing <$> A.peekChar)) 60 | case r of 61 | (Right False) -> parseWithBody printer handler 62 | (Right True) -> return () 63 | (Left e) -> error (show e) 64 | 65 | pBody = parse $ A.many' A.anyChar 66 | 67 | echoBody :: (Monad m) => Hyperdrive m String 68 | echoBody = 69 | do bd <- pBody 70 | case bd of 71 | (Left e) -> error "Malformed Request" 72 | (Right bd) -> 73 | return bd 74 | 75 | test :: IO ((), Producer ByteString IO ()) 76 | test = runStateT (parseWithBody print echoBody) (yield request >> yield request) 77 | -} 78 | 79 | {- 80 | parser' :: (Monad m) => 81 | StateT (Producer ByteString m x) m (Either ParsingError Int) 82 | parser' = parse pRequestHead 83 | 84 | parseOne :: Monad m => 85 | Producer ByteString m x 86 | -> m (Either ParsingError Int, Producer ByteString m x) 87 | parseOne = runStateT parser' 88 | 89 | testHead = 90 | do (r, rest) <- parseOne (yield request) 91 | print r 92 | 93 | pBody = parse $ A.many' A.anyChar 94 | 95 | type Hyperdrive m = StateT (Producer ByteString m (Producer ByteString m ())) m 96 | 97 | parseWithBody :: (Monad m) => Producer ByteString m () -> (a -> m ()) -> Hyperdrive m a -> m () 98 | parseWithBody p printer handler = 99 | do (r, rest) <- parseOne p 100 | case r of 101 | (Left e) -> error $ "Invalid Request: " ++ show e 102 | (Right len) -> 103 | do ((a, e), next) <- runStateT (do a <- zoom (Pb.splitAt len) handler 104 | r <- parse (char '\n' >> (isNothing <$> A.peekChar)) 105 | case r of 106 | (Right eof) -> return (a, eof) 107 | (Left e) -> error (show e) 108 | ) rest 109 | printer a 110 | if e 111 | then return () 112 | else parseWithBody next printer handler 113 | 114 | parseWithBody2 p printer handler = 115 | do (r, rest) <- parseOne p 116 | 117 | echoBody :: (Monad m) => Hyperdrive m String 118 | echoBody = 119 | do bd <- pBody 120 | case bd of 121 | (Left e) -> error "Malformed Request" 122 | (Right bd) -> 123 | return bd 124 | 125 | test = parseWithBody (yield request >> yield request) print echoBody 126 | -} -------------------------------------------------------------------------------- /experiments/HyperIORef2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings #-} 2 | module Main where 3 | 4 | import Control.Applicative ((<$>)) 5 | import Control.Monad.Trans.State.Strict (StateT(..)) 6 | import Control.Monad (when, forever) 7 | import Data.ByteString (ByteString) 8 | import qualified Data.ByteString as B 9 | import qualified Data.ByteString.Char8 as C 10 | import Data.ByteString.Lex.Integral (readDecimal) 11 | import Data.Attoparsec.ByteString.Char8 (Parser, string, char) 12 | import qualified Data.Attoparsec.ByteString.Char8 as A 13 | import Data.Maybe (isNothing) 14 | import Pipes 15 | import qualified Pipes.Prelude as P 16 | -- import Pipes.Parse (Parser) 17 | import Pipes.Attoparsec 18 | import qualified Pipes.ByteString as Pb 19 | import Lens.Family.State.Strict (zoom) 20 | import Lens.Family (over) 21 | import qualified Pipes.Parse as Ppi 22 | 23 | type Hyperdrive m = StateT (Producer ByteString m (Producer ByteString m ())) m 24 | 25 | data Request = Request 26 | { rqLength :: !Int 27 | -- , rqBody :: Producer ByteString IO () 28 | } 29 | 30 | request :: ByteString 31 | request = 32 | B.concat 33 | [ "Content-Length: 4\n" 34 | , "\n" 35 | , "1234\n" 36 | ] 37 | 38 | notNL :: Parser ByteString 39 | notNL = A.takeWhile (/= '\n') 40 | 41 | pRequestHead :: A.Parser Request 42 | pRequestHead = 43 | do string "Content-Length: " 44 | len <- notNL 45 | string "\n\n" 46 | case readDecimal len of 47 | Just (i,_) -> return $ Request { rqLength = i } 48 | _ -> error $ "Could not parse length: " ++ show len 49 | 50 | 51 | 52 | serve :: Producer ByteString IO x 53 | -> (a -> IO ()) 54 | -> (Producer ByteString IO x -> IO a) 55 | -> IO () 56 | serve p0 printer handler = 57 | do (r, p1) <- runStateT (parse pRequestHead) p0 58 | case r of 59 | (Left err) -> error (show err) 60 | (Right req) -> 61 | do -- let pBody :: Int 62 | -- pBody = Pb.splitAt (rqLength req) undefined 63 | -- a <- handler pBody 64 | -- printer a 65 | -- runEffect $ p1 >-> Pb.take 1 >-> drain 66 | serve p1 printer handler 67 | where 68 | drain = forever await 69 | 70 | echoBody :: Producer ByteString IO () -> IO ByteString 71 | echoBody p = 72 | do bs <- B.concat <$> P.toListM p 73 | return bs 74 | 75 | requestProducer :: Producer ByteString IO () 76 | requestProducer = (yield request >> yield request) 77 | 78 | main :: IO () 79 | main = 80 | serve requestProducer C.putStr echoBody 81 | 82 | 83 | {- 84 | parseWithBody printer handler = 85 | do eReq <- parse pRequestHead 86 | case eReq of 87 | (Left e) -> error (show e) 88 | (Right req) -> 89 | -} 90 | 91 | {- 92 | parseWithBody printer handler = 93 | do eReq <- parse pRequestHead 94 | case eReq of 95 | (Left e) -> error (show e) 96 | (Right req) -> 97 | do a <- zoom (Pb.splitAt (rqLength req)) handler 98 | lift $ printer a 99 | r <- parse (char '\n' >> (isNothing <$> A.peekChar)) 100 | case r of 101 | (Right False) -> parseWithBody printer handler 102 | (Right True) -> return () 103 | (Left e) -> error (show e) 104 | 105 | pBody = parse $ A.many' A.anyChar 106 | 107 | echoBody :: (Monad m) => Hyperdrive m String 108 | echoBody = 109 | do bd <- pBody 110 | case bd of 111 | (Left e) -> error "Malformed Request" 112 | (Right bd) -> 113 | return bd 114 | 115 | test :: IO ((), Producer ByteString IO ()) 116 | test = runStateT (parseWithBody print echoBody) (yield request >> yield request) 117 | 118 | 119 | {- 120 | parser' :: (Monad m) => 121 | StateT (Producer ByteString m x) m (Either ParsingError Int) 122 | parser' = parse pRequestHead 123 | 124 | parseOne :: Monad m => 125 | Producer ByteString m x 126 | -> m (Either ParsingError Int, Producer ByteString m x) 127 | parseOne = runStateT parser' 128 | 129 | testHead = 130 | do (r, rest) <- parseOne (yield request) 131 | print r 132 | 133 | pBody = parse $ A.many' A.anyChar 134 | 135 | type Hyperdrive m = StateT (Producer ByteString m (Producer ByteString m ())) m 136 | 137 | parseWithBody :: (Monad m) => Producer ByteString m () -> (a -> m ()) -> Hyperdrive m a -> m () 138 | parseWithBody p printer handler = 139 | do (r, rest) <- parseOne p 140 | case r of 141 | (Left e) -> error $ "Invalid Request: " ++ show e 142 | (Right len) -> 143 | do ((a, e), next) <- runStateT (do a <- zoom (Pb.splitAt len) handler 144 | r <- parse (char '\n' >> (isNothing <$> A.peekChar)) 145 | case r of 146 | (Right eof) -> return (a, eof) 147 | (Left e) -> error (show e) 148 | ) rest 149 | printer a 150 | if e 151 | then return () 152 | else parseWithBody next printer handler 153 | 154 | parseWithBody2 p printer handler = 155 | do (r, rest) <- parseOne p 156 | 157 | echoBody :: (Monad m) => Hyperdrive m String 158 | echoBody = 159 | do bd <- pBody 160 | case bd of 161 | (Left e) -> error "Malformed Request" 162 | (Right bd) -> 163 | return bd 164 | 165 | test = parseWithBody (yield request >> yield request) print echoBody 166 | -} 167 | -} -------------------------------------------------------------------------------- /experiments/HyperMonad.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings, RankNTypes #-} 2 | {- 3 | 4 | Sample parser for a simplified HTTP. We just have a single Content-Length header, a blank line, and the body. e.g., 5 | 6 | Content-Length: 4 7 | 8 | 1234 9 | 10 | -} 11 | module Main where 12 | 13 | import Control.Applicative ((<$>)) 14 | import Control.Monad.Trans.State.Strict (StateT(..)) 15 | import Control.Monad (when) 16 | import Data.ByteString (ByteString) 17 | import qualified Data.ByteString as B 18 | import qualified Data.ByteString.Char8 as B 19 | import Data.ByteString.Lex.Integral (readDecimal) 20 | import Data.Attoparsec.ByteString.Char8 (Parser, string, char) 21 | import qualified Data.Attoparsec.ByteString.Char8 as A 22 | import Data.Maybe (isNothing) 23 | import Pipes 24 | import qualified Pipes.Prelude as P 25 | import Pipes.Attoparsec 26 | import qualified Pipes.ByteString as Pb 27 | import Lens.Family.State.Strict (zoom) 28 | import qualified Pipes.Parse as Ppi 29 | 30 | ------------------------------------------------------------------------------ 31 | -- Types 32 | ------------------------------------------------------------------------------ 33 | 34 | data Request = Request 35 | { rqLength :: Int 36 | } 37 | deriving Show 38 | 39 | -- | dummy serialized 'Request' 40 | request :: ByteString 41 | request = 42 | B.concat 43 | [ "Content-Length: 4\n" 44 | , "\n" 45 | , "1234\n" 46 | ] 47 | 48 | data Response m = Response 49 | { rsLength :: Int 50 | , rsBody :: Producer ByteString m () 51 | } 52 | 53 | 54 | type Hyperdrive m r = Ppi.Parser ByteString m r 55 | 56 | ------------------------------------------------------------------------------ 57 | -- request parser 58 | ------------------------------------------------------------------------------ 59 | 60 | pRequestHead :: A.Parser Request 61 | pRequestHead = 62 | do string "Content-Length: " 63 | len <- notNL 64 | string "\n\n" 65 | case readDecimal len of 66 | Just (i,_) -> return $ Request { rqLength = i } 67 | _ -> error $ "Could not parse length: " ++ show len 68 | where 69 | notNL :: Parser ByteString 70 | notNL = A.takeWhile (/= '\n') 71 | 72 | ------------------------------------------------------------------------------ 73 | -- parsing loop 74 | ------------------------------------------------------------------------------ 75 | 76 | parseLoop :: (Monad m) => (a -> m ()) -> (Request -> Hyperdrive m a) -> Ppi.Parser ByteString m () 77 | parseLoop sendResponse handler = 78 | do eReq <- parse pRequestHead 79 | case eReq of 80 | (Left e) -> error (show e) 81 | (Right req) -> 82 | do a <- zoom (Pb.splitAt (rqLength req)) (handler req) 83 | lift $ sendResponse a 84 | r <- parse (char '\n' >> (isNothing <$> A.peekChar)) 85 | case r of 86 | (Right False) -> parseLoop sendResponse handler 87 | (Right True) -> return () 88 | (Left e) -> error (show e) 89 | 90 | ------------------------------------------------------------------------------ 91 | -- parse body 92 | ------------------------------------------------------------------------------ 93 | 94 | -- | get the whole request body 95 | pBody :: (Monad m) => Hyperdrive m (Either ParsingError ByteString) 96 | pBody = parse A.takeByteString 97 | 98 | 99 | ------------------------------------------------------------------------------ 100 | -- 'Response IO' helpers 101 | ------------------------------------------------------------------------------ 102 | 103 | sendResponse :: Response IO 104 | -> IO () 105 | sendResponse res = 106 | runEffect $ (rsBody res) >-> P.print 107 | 108 | 109 | serve :: (Request -> Hyperdrive IO (Response IO)) 110 | -> Producer ByteString IO () 111 | -> IO () 112 | serve h p = Ppi.evalStateT (parseLoop sendResponse h) p 113 | 114 | ------------------------------------------------------------------------------ 115 | -- simple test 116 | ------------------------------------------------------------------------------ 117 | 118 | -- | echo the entire body 119 | -- 120 | -- Note: we consume the entire body before sending the 'Response'. Not 121 | -- a stellar example of streaming IO ;) 122 | echoBody :: (Monad m) => Request -> Hyperdrive m (Response m) 123 | echoBody req = 124 | do bd <- pBody 125 | case bd of 126 | (Left e) -> error "Malformed Request" 127 | (Right bd) -> 128 | return $ Response { rsLength = (rqLength req) 129 | , rsBody = yield bd 130 | } 131 | 132 | -- | simple serving example 133 | test :: IO () 134 | test = serve echoBody (yield request >> yield request) 135 | -------------------------------------------------------------------------------- /experiments/ProducerIORef.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.IORef (IORef(..), newIORef, readIORef, writeIORef) 4 | import Pipes 5 | import qualified Pipes.Prelude as P 6 | 7 | -- | this a pure producer 8 | pure10 :: (Monad m) => Producer Int m () 9 | pure10 = mapM_ yield [1..10] 10 | 11 | -- | if we run the producer twice it will produce the same results -- 12 | -- starting from 1 each time. 13 | pure10_test :: IO () 14 | pure10_test = 15 | do runEffect $ pure10 >-> P.take 5 >-> P.print 16 | putStrLn "<>" 17 | runEffect $ pure10 >-> P.take 5 >-> P.print 18 | 19 | ioify :: Producer Int IO () -> IO (Producer Int IO ()) 20 | ioify p0 = 21 | do ref <- liftIO $ newIORef p0 22 | return (go ref) 23 | where 24 | go :: IORef (Producer Int IO ()) -> Producer Int IO () 25 | go ref = 26 | do p <- liftIO $ readIORef ref 27 | x <- liftIO $ next p 28 | case x of 29 | (Right (i, p')) -> 30 | do liftIO $ writeIORef ref p' 31 | yield i 32 | go ref 33 | (Left ()) -> 34 | do liftIO $ writeIORef ref (return ()) 35 | return () 36 | 37 | impure10_test :: IO () 38 | impure10_test = 39 | do p <- ioify pure10 40 | runEffect $ p >-> P.take 5 >-> P.print 41 | putStrLn "<>" 42 | runEffect $ p >-> P.take 5 >-> P.print 43 | -------------------------------------------------------------------------------- /experiments/ProducerTwice.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Pipes 4 | import qualified Pipes.Prelude as P 5 | import Pipes.Network.TCP 6 | -- import Network.Simple.TCP (listen, accept) 7 | 8 | 9 | main :: IO () 10 | main = 11 | listen HostAny "8000" $ \(lsock, _) -> 12 | accept lsock $ \(sock, sockAddr) -> 13 | do let p = fromSocket sock 10 14 | putStrLn "running first time." 15 | runEffect $ p >-> P.take 2 >-> P.print 16 | putStrLn "running second time." 17 | runEffect $ p >-> P.take 2 >-> P.print 18 | 19 | -------------------------------------------------------------------------------- /experiments/SubProducer.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Main where 3 | 4 | import Data.IORef (IORef(..), newIORef, readIORef, writeIORef) 5 | import Pipes 6 | import qualified Pipes.Prelude as P 7 | import qualified Pipes.ByteString as Pb 8 | 9 | -- | this a pure producer 10 | pureBS :: (Monad m) => Producer ByteString m () 11 | pureBS = yield "abcdefghijklmnopqrstuvwxyz" 12 | 13 | -- | if we run the producer twice it will produce the same results -- 14 | -- starting from 1 each time. 15 | pureBS_test :: IO () 16 | pureBS_test = 17 | do runEffect $ over (Pb.take 5) pureBS 18 | {- 19 | do runEffect $ pureBS >-> P.take 5 >-> P.print 20 | putStrLn "<>" 21 | runEffect $ pureBS >-> P.take 5 >-> P.print 22 | -} 23 | 24 | -------------------------------------------------------------------------------- /experiments/Twice.lhs: -------------------------------------------------------------------------------- 1 | I have been thinking about what it means to run a 'Producer' 2 | twice. Specifically -- whether the Producer resumes where it left of 3 | or not. I think that in general the behavior is undefined. I feel like 4 | this has not been explicitly stated much -- so I am going to say it 5 | now. 6 | 7 | Consider two different cases: 8 | 9 | 1. a producer that produces values from a pure list 10 | 11 | 2. a producer that produces values from a network connection 12 | 13 | 14 | If we run the first producer twice we will get the same answer each 15 | time. If we run the second producer twice -- we will likely get 16 | different results -- depending on what data is available from the 17 | network stream. 18 | 19 | Now -- that is not entirely surprising -- one value is pure and one is 20 | based on IO. So that is no different than calling a normal pure 21 | function versus a normal IO function. 22 | 23 | But -- I think it can be easy to forget that when writing pipes 24 | code. Imagine we write some pipes code that processes a network stream 25 | -- and it relies on the fact that the network Producer automatically 26 | resumes from where it left off. 27 | 28 | Now, let's pretend we want to test our code. So we create a pure 29 | Producer that produces the same bytestring that the network pipe was 30 | producing. Alas, our code will not work because the pure Producer does 31 | not automatically resume when called multiple times. 32 | 33 | I think this means that we must assume, by default, that the Producer 34 | does not have resumable behavior. If we want to write code that relies 35 | on the resumable behavior -- then we must explictly ensure that it 36 | happens. 37 | 38 | In pipes-parse the resumability is handled by storing the 'Producer' 39 | in 'StateT'. 40 | 41 | Another alternative is to use an 'IORef'. I have an example of the 42 | 'IORef' solution below. 43 | 44 | > module Main where 45 | 46 | > import Data.IORef (IORef(..), newIORef, readIORef, writeIORef) 47 | > import Pipes 48 | > import qualified Pipes.Prelude as P 49 | 50 | Here is our pure Producer: 51 | 52 | > pure10 :: (Monad m) => Producer Int m () 53 | > pure10 = mapM_ yield [1..10] 54 | 55 | And here is a function which uses a Producer twice. 56 | 57 | > take5_twice :: Show a => Producer a IO () -> IO () 58 | > take5_twice p = 59 | > do runEffect $ p >-> P.take 5 >-> P.print 60 | > putStrLn "<>" 61 | > runEffect $ p >-> P.take 5 >-> P.print 62 | 63 | Note that we have limited ability reason about the results since we do 64 | not know if the 'Producer' is resumable or not. 65 | 66 | If we run 'take5_twice' using our pure Producer: 67 | 68 | > pure10_test :: IO () 69 | > pure10_test = 70 | > take5_twice pure10 71 | 72 | it will restart from 1 each time: 73 | 74 | > pure10_test 75 | 1 76 | 2 77 | 3 78 | 4 79 | 5 80 | <> 81 | 1 82 | 2 83 | 3 84 | 4 85 | 5 86 | 87 | Here is a (not very generalized) function that uses an 'IORef' to 88 | store the current position in the 'Producer' -- similar to how 89 | 'StateT' works: 90 | 91 | > resumable :: Producer Int IO () -> IO (Producer Int IO ()) 92 | > resumable p0 = 93 | > do ref <- liftIO $ newIORef p0 94 | > return (go ref) 95 | > where 96 | > go :: IORef (Producer Int IO ()) -> Producer Int IO () 97 | > go ref = 98 | > do p <- liftIO $ readIORef ref 99 | > x <- liftIO $ next p 100 | > case x of 101 | > (Right (i, p')) -> 102 | > do liftIO $ writeIORef ref p' 103 | > yield i 104 | > go ref 105 | > (Left ()) -> 106 | > do liftIO $ writeIORef ref (return ()) 107 | > return () 108 | 109 | Now if we call 'take5_twice' with our resumable Producer: 110 | 111 | > impure10_test :: IO () 112 | > impure10_test = 113 | > do p <- resumable pure10 114 | > take5_twice p 115 | 116 | Here we see the resuming behavior: 117 | 118 | > impure10_test 119 | 1 120 | 2 121 | 3 122 | 4 123 | 5 124 | <> 125 | 6 126 | 7 127 | 8 128 | 9 129 | 10 130 | 131 | If we call 'resumable' on a 'Producer' that already has resumable 132 | behavior -- it will still work. We can simulate that by calling resumable twice: 133 | 134 | > twice_resumable :: IO () 135 | > twice_resumable = 136 | > do p0 <- resumable pure10 137 | > p <- resumable p0 138 | > take5_twice p 139 | 140 | 141 | > twice_resumable 142 | 1 143 | 2 144 | 3 145 | 4 146 | 5 147 | <> 148 | 6 149 | 7 150 | 8 151 | 9 152 | 10 153 | 154 | Of course, we now have the overhead of *two* 'IORef' based Producers. 155 | 156 | So we are now left with some questions of style. 157 | 158 | If we are writing something like an HTTP server -- we can assume that 159 | most of the time we are going to working with a 'Producer' based on a 160 | resumable source like a network stream. So, by using the inherent 161 | resumability we can presumably get lower overhead and higher 162 | performance. If we need to use the code with a non-resumable Producer 163 | then we can use a function like 'resumable' to fake it. 164 | 165 | This is somewhat distasteful in two ways though. 166 | 167 | (1) It forces everything to be in the IO monad -- even when 168 | everything could actually be pure. 169 | 170 | (2) it relies on the resumability of the Producer -- but there is no 171 | enforcement or indication of that in the type system. 172 | 173 | 174 | The alternative is to run all our code inside a 'StateT'. Since the 175 | 'StateT' takes care of resuming we do not have to worry if the 176 | underlying Producer does or not. But.. now we always have the overhead 177 | of being inside a 'StateT' even we don't really need to be -- so we 178 | have a more complicated set of types to work with and more potential 179 | overhead. 180 | 181 | The upside is that our pure code stays pure. We only introduce the IO 182 | monad when IO is really used. 183 | 184 | This is the major decision blocking hyperdrive at the 185 | moment. (hyperdrive is my pipes based HTTP server). 186 | 187 | Any thoughts? 188 | 189 | - jeremy 190 | 191 | -------------------------------------------------------------------------------- /experiments/pipes-delimited.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} 2 | module Main where 3 | 4 | import Control.Monad.Identity 5 | import Control.Monad.State.Strict (evalStateT, get) 6 | import Control.Monad.Trans 7 | import Data.Attoparsec.ByteString.Char8 (Parser, string) 8 | import qualified Data.Attoparsec.ByteString.Char8 as A 9 | import Data.ByteString (ByteString) 10 | import qualified Data.ByteString as B 11 | import qualified Data.ByteString.Char8 as C 12 | import Data.IORef 13 | import Data.ByteString.Lex.Integral (readDecimal) 14 | import Pipes 15 | import qualified Pipes.Prelude as P 16 | import Pipes.Parse 17 | import Pipes.Attoparsec 18 | 19 | 20 | intProducer :: (Monad m) => Producer' Int m () 21 | intProducer = mapM_ yield [0..] 22 | 23 | intTest :: IO () 24 | intTest = 25 | do runEffect $ intProducer >-> P.take 5 >-> P.show >-> P.stdoutLn 26 | runEffect $ intProducer >-> P.take 5 >-> P.show >-> P.stdoutLn 27 | 28 | intProducerIO :: IO (Producer Int IO ()) 29 | intProducerIO = 30 | do ref <- newIORef 0 31 | return $ forever $ 32 | do n <- liftIO $ readIORef ref 33 | liftIO $ writeIORef ref (succ n) 34 | yield n 35 | 36 | intIOTest :: IO () 37 | intIOTest = 38 | do p <- intProducerIO 39 | runEffect $ p >-> P.take 5 >-> P.show >-> P.stdoutLn 40 | runEffect $ p >-> P.take 5 >-> P.show >-> P.stdoutLn 41 | 42 | read5 :: Producer' Int (StateT (Producer Int IO ()) IO) () 43 | read5 = 44 | do input >-> P.take 5 45 | 46 | read5_test1 :: IO () 47 | read5_test1 = 48 | evalStateT (do runEffect $ read5 >-> P.show >-> P.stdoutLn 49 | runEffect $ read5 >-> P.show >-> P.stdoutLn) 50 | intProducer 51 | 52 | read5_test2 :: IO () 53 | read5_test2 = do 54 | intP <- intProducerIO 55 | evalStateT (do runEffect $ read5 >-> P.show >-> P.stdoutLn 56 | runEffect $ read5 >-> P.show >-> P.stdoutLn) 57 | intP 58 | 59 | 60 | subProcessor :: forall a m. (Show a, Monad m, MonadIO m) => 61 | (Producer a m () -> m ()) 62 | -> Producer a (StateT (Producer a m ()) m) () 63 | subProcessor handler = 64 | do input >-> P.take 1 >-> P.show >-> P.stdoutLn 65 | p <- get :: (Monad m) => Producer a (StateT (Producer a m ()) m) (Producer a m ()) 66 | let p1 :: (Monad m) => Producer a m () 67 | p1 = (p >-> P.take 1) 68 | lift $ lift $ handler p1 69 | -- lift $ lift $ runEffect $ p1 >-> (await >> return ()) 70 | input >-> P.take 1 >-> P.show >-> P.stdoutLn 71 | 72 | 73 | subProcessor_test1 :: IO () 74 | subProcessor_test1 = 75 | evalStateT (runEffect (subProcessor (\p -> putStrLn "sub-process" >> (runEffect $ p >-> P.print) >> putStrLn "done.") >-> P.print)) intProducer 76 | 77 | subProcessor_test2 :: IO () 78 | subProcessor_test2 = 79 | do intP <- intProducerIO 80 | evalStateT (runEffect (subProcessor (\p -> putStrLn "sub-process" >> (runEffect $ p >-> P.print) >> putStrLn "done.") >-> P.print)) intP 81 | 82 | subProcessor_test3 :: IO () 83 | subProcessor_test3 = 84 | do intP <- intProducerIO 85 | evalStateT (runEffect (subProcessor (\p -> putStrLn "sub-process" >> putStrLn "done.") >-> P.print)) intP 86 | 87 | subProcessor_test4 :: IO () 88 | subProcessor_test4 = 89 | do intP <- intProducerIO 90 | evalStateT (runEffect (subProcessor (\p -> putStrLn "sub-process" >> (runEffect $ p >-> P.print) >> putStrLn "done.") >-> P.print)) intP 91 | 92 | subProcessor' :: forall a m. (Show a, Monad m, MonadIO m) => 93 | (Producer a m () -> m ()) 94 | -> Producer a (StateT (Producer a m ()) m) () 95 | subProcessor' handler = 96 | do input >-> P.take 1 >-> P.show >-> P.stdoutLn 97 | p <- get :: (Monad m) => Producer a (StateT (Producer a m ()) m) (Producer a m ()) 98 | let p1 :: (Monad m) => Producer a m () 99 | p1 = (p >-> P.take 1) 100 | lift $ lift $ handler p1 101 | -- lift $ lift $ runEffect $ p1 >-> (await >> return ()) 102 | input >-> P.take 1 >-> P.show >-> P.stdoutLn 103 | 104 | 105 | pContentLength :: Parser Int 106 | pContentLength = 107 | do A.string "Content-Length: " 108 | lenStr <- A.takeWhile (/= '\r') 109 | A.string "\r\n" 110 | case readDecimal lenStr of 111 | Nothing -> fail "could not parse length." 112 | Just (i, bs) -> return i 113 | 114 | 115 | serve' :: forall m. (Monad m) => 116 | (Producer ByteString m () -> m ()) 117 | -> StateT (Producer ByteString m ()) m () 118 | serve' handler = 119 | do e <- parse pContentLength 120 | case e of 121 | (Left e) -> error (show e) 122 | (Right (l, _)) -> 123 | do p <- get 124 | lift $ handler (p >-> P.take 1) 125 | parse "\r\n" 126 | b <- isEndOfParserInput 127 | when (not b) $ serve' handler 128 | 129 | serve :: Monad m => 130 | Producer ByteString m () 131 | -> (Producer ByteString m () -> m ()) 132 | -> m () 133 | serve p h = evalStateT (serve' h) p 134 | 135 | 136 | testStream = "Content-Length: 5\r\n12345\r\n" 137 | 138 | printBody :: Producer ByteString IO () -> IO () 139 | printBody p = runEffect $ p >-> P.print 140 | 141 | serve_test1 = serve (yield testStream) printBody 142 | 143 | -------------------------------------------------------------------------------- /experiments/pipes-delimited2.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} 2 | module Main where 3 | 4 | import Control.Monad.Identity 5 | import Control.Monad.State.Strict (evalStateT, get, put) 6 | import Control.Monad.Trans 7 | import Data.Attoparsec.ByteString.Char8 (Parser, string) 8 | import qualified Data.Attoparsec.ByteString.Char8 as A 9 | import Data.ByteString (ByteString) 10 | import qualified Data.ByteString as B 11 | import qualified Data.ByteString.Char8 as C 12 | import Data.IORef 13 | import Data.ByteString.Lex.Integral (readDecimal) 14 | import Pipes 15 | import qualified Pipes.Prelude as P 16 | import Pipes.Parse 17 | import Pipes.Attoparsec 18 | import qualified Pipes.ByteString as PB 19 | import Debug.Trace (trace) 20 | 21 | pContentLength :: Parser Int 22 | pContentLength = 23 | do A.string "Content-Length: " 24 | lenStr <- A.takeWhile (/= '\r') 25 | A.string "\r\n" 26 | case readDecimal lenStr of 27 | Nothing -> fail "could not parse length." 28 | Just (i, bs) -> return i 29 | 30 | 31 | serve' :: forall m. (Monad m) => 32 | (Producer ByteString m () -> m ()) 33 | -> StateT (Producer ByteString m ()) m () 34 | serve' handler = 35 | do e <- parse pContentLength 36 | case e of 37 | (Left e) -> error (show e) 38 | (Right (_, len)) -> 39 | do p <- get 40 | lift $ handler (p >-> PB.take len) 41 | put (p >-> PB.drop len) -- needed if the producer is pure -- FIXME 42 | parse "\r\n" 43 | b <- isEndOfParserInput 44 | when (not b) $ serve' handler 45 | 46 | serve :: Monad m => 47 | Producer ByteString m () 48 | -> (Producer ByteString m () -> m ()) 49 | -> m () 50 | serve p h = evalStateT (serve' h) p 51 | 52 | 53 | testStream = "Content-Length: 5\r\n12345\r\n" 54 | 55 | printBody :: Producer ByteString IO () -> IO () 56 | printBody p = runEffect $ p >-> P.print 57 | 58 | serve_test1 = serve (yield testStream >> yield testStream) printBody 59 | -------------------------------------------------------------------------------- /experiments/pipes-delimited3.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} 2 | module Main where 3 | 4 | import Control.Monad.Identity 5 | import Control.Monad.State.Strict (evalStateT, get, put) 6 | import Control.Monad.Trans 7 | import Data.Attoparsec.ByteString.Char8 (Parser, string) 8 | import qualified Data.Attoparsec.ByteString.Char8 as A 9 | import Data.ByteString (ByteString) 10 | import qualified Data.ByteString as B 11 | import qualified Data.ByteString.Char8 as C 12 | import Data.IORef 13 | import Data.ByteString.Lex.Integral (readDecimal) 14 | import Pipes 15 | import qualified Pipes.Prelude as P 16 | import Pipes.Parse 17 | import Pipes.Attoparsec 18 | import qualified Pipes.ByteString as PB 19 | import Debug.Trace (trace) 20 | 21 | pContentLength :: Parser Int 22 | pContentLength = 23 | do A.string "Content-Length: " 24 | lenStr <- A.takeWhile (/= '\r') 25 | A.string "\r\n" 26 | case readDecimal lenStr of 27 | Nothing -> fail "could not parse length." 28 | Just (i, bs) -> return i 29 | 30 | 31 | serve' :: forall m. (Monad m) => 32 | (Producer ByteString m () -> m ()) 33 | -> StateT (Producer ByteString m ()) m () 34 | serve' handler = 35 | do e <- parse pContentLength 36 | case e of 37 | (Left e) -> error (show e) 38 | (Right (_, len)) -> 39 | do p <- get 40 | 41 | -- lift $ handler (p >-> PB.take len) 42 | -- put (p >-> PB.drop len) -- needed if the producer is pure 43 | parse "\r\n" 44 | b <- isEndOfParserInput 45 | when (not b) $ serve' handler 46 | 47 | serve :: Monad m => 48 | Producer ByteString m () 49 | -> (Producer ByteString m () -> m ()) 50 | -> m () 51 | serve p h = evalStateT (serve' h) p 52 | 53 | 54 | testStream = "Content-Length: 5\r\n12345\r\n" 55 | 56 | printBody :: Producer ByteString IO () -> IO () 57 | printBody p = runEffect $ p >-> P.print 58 | 59 | serve_test1 :: IO () 60 | serve_test1 = serve (yield testStream) printBody 61 | -------------------------------------------------------------------------------- /experiments/pipes-delimited4.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, RankNTypes, OverloadedStrings #-} 2 | module Main where 3 | 4 | import Control.Applicative 5 | import Control.Monad.Identity 6 | import Control.Monad.State.Strict (evalStateT, get, put) 7 | import Control.Monad.Trans 8 | import Data.Attoparsec.ByteString.Char8 (Parser, string) 9 | import qualified Data.Attoparsec.ByteString.Char8 as A 10 | import Data.ByteString (ByteString) 11 | import qualified Data.ByteString as B 12 | import qualified Data.ByteString.Char8 as C 13 | import Data.IORef 14 | import Data.ByteString.Lex.Integral (readDecimal) 15 | import Pipes 16 | import qualified Pipes.Prelude as P 17 | import Pipes.Parse 18 | import Pipes.Attoparsec 19 | import qualified Pipes.ByteString as PB 20 | import Debug.Trace (trace) 21 | 22 | data RequestF m next = RequestF 23 | { reqLength :: !Int 24 | , reqBody :: !(Producer ByteString m next) 25 | } 26 | 27 | instance (Monad m) => Functor (RequestF m) where 28 | fmap f (RequestF len bdy) = RequestF len (fmap f bdy) 29 | 30 | data ResponseF m next = ResponseF 31 | { resLength :: !Int 32 | , resBody :: !(Producer ByteString m next) 33 | } 34 | 35 | instance (Monad m) => Functor (ResponseF m) where 36 | fmap f (ResponseF l bdy) = ResponseF l (fmap f bdy) 37 | 38 | 39 | data Response m = Response 40 | { rLength :: !Int 41 | , rBody :: !(Producer ByteString m ()) 42 | } 43 | 44 | 45 | parseRequests :: forall m r. Monad m => 46 | Producer ByteString m r 47 | -> FreeT (RequestF m) m () 48 | parseRequests p0 = FreeT $ do 49 | (m1, p1) <- runStateT pContentLength p0 50 | return $ case m1 of 51 | (Just (Right len)) -> 52 | let bdy :: Producer ByteString m (FreeT (RequestF m) m ()) 53 | bdy = parseRequests <$> splitBody len p1 54 | 55 | req :: RequestF m (FreeT (RequestF m) m ()) 56 | req = RequestF len bdy 57 | in Free req 58 | (Just (Left e)) -> error e 59 | Nothing -> Pure () 60 | 61 | splitBody :: (Monad m) => 62 | Int 63 | -> Producer ByteString m r 64 | -> Producer' ByteString m (Producer ByteString m r) 65 | splitBody len p0 = 66 | do p1 <- PB.splitAt len p0 67 | return (p1 >-> PB.drop 2) 68 | 69 | pContentLength' :: Parser Int 70 | pContentLength' = 71 | do A.string "Content-Length: " 72 | lenStr <- A.takeWhile (/= '\r') 73 | A.string "\r\n" 74 | case readDecimal lenStr of 75 | Nothing -> fail "could not parse length." 76 | Just (i, bs) -> return i 77 | 78 | pContentLength :: (Monad m) => StateT (Producer ByteString m r) m (Maybe (Either String Int)) 79 | pContentLength = do 80 | eof <- PB.isEndOfBytes 81 | if eof 82 | then return Nothing 83 | else do 84 | r <- parse pContentLength' 85 | return $ case r of 86 | (Left e) -> Just (Left $ show e) 87 | (Right (_, i)) -> Just (Right i) 88 | 89 | serve' :: (Monad m) => 90 | (RequestF m (FreeT (RequestF m) m a) -> m (Response m, FreeT (RequestF m) m a)) 91 | -> FreeT (RequestF m) m a 92 | -> FreeT (ResponseF m) m a 93 | serve' handler requests = FreeT $ 94 | do x <- runFreeT requests 95 | case x of 96 | Free req -> 97 | do (Response l p, remaining) <- handler req 98 | let next = serve' handler remaining 99 | return $ Free (ResponseF l (p >> return next)) 100 | Pure r -> return $ Pure r 101 | 102 | writeResponses :: Show a => FreeT (ResponseF IO) IO a -> IO () 103 | writeResponses resps = 104 | do x <- runFreeT resps 105 | case x of 106 | Pure r -> print r 107 | (Free (ResponseF len bdy)) -> 108 | do putStrLn "Response {" 109 | putStr " reqLength = " 110 | print len 111 | putStr " , reqBody = " 112 | next <- runEffect $ bdy >-> P.print 113 | putStrLn "}\n" 114 | writeResponses next 115 | 116 | hello :: (MonadIO m) => RequestF m (FreeT (RequestF m) m a) -> m (Response m, (FreeT (RequestF m) m a)) 117 | hello (RequestF len inP) = 118 | do remainingRequests <- runEffect $ inP >-> P.print 119 | let outputP = yield "hello" 120 | return (Response 5 outputP, remainingRequests) 121 | 122 | testStream :: ByteString 123 | testStream = "Content-Length: 5\r\n12345\r\n" 124 | 125 | main :: IO () 126 | main = writeResponses (serve' hello (parseRequests (yield testStream >> yield testStream))) 127 | -------------------------------------------------------------------------------- /experiments/pipes-delimited5.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, RankNTypes, OverloadedStrings #-} 2 | module Main where 3 | 4 | import Control.Applicative 5 | import Control.Monad.Identity 6 | import Control.Monad.State.Strict (evalStateT, get, put) 7 | import Control.Monad.Trans 8 | import Data.Attoparsec.ByteString.Char8 (Parser, string) 9 | import qualified Data.Attoparsec.ByteString.Char8 as A 10 | import Data.ByteString (ByteString) 11 | import qualified Data.ByteString as B 12 | import qualified Data.ByteString.Char8 as C 13 | import Data.IORef 14 | import Data.ByteString.Lex.Integral (readDecimal) 15 | import Pipes 16 | import qualified Pipes.Prelude as P 17 | import Pipes.Parse 18 | import Pipes.Attoparsec 19 | import qualified Pipes.ByteString as PB 20 | import Debug.Trace (trace) 21 | 22 | data RequestF m next = RequestF 23 | { length :: !Int 24 | , body :: !(Producer ByteString m next) 25 | } 26 | 27 | instance (Monad m) => Functor (RequestF m) where 28 | fmap f (RequestF len bdy) = RequestF len (fmap f bdy) 29 | 30 | type Request m = FreeT (RequestF m) 31 | 32 | data ResponseF m next = ResponseF 33 | { resLength :: !Int 34 | , resBody :: !(Producer ByteString m next) 35 | } 36 | 37 | instance (Monad m) => Functor (ResponseF m) where 38 | fmap f (ResponseF l bdy) = ResponseF l (fmap f bdy) 39 | 40 | type Response m = FreeT (ResponseF m) 41 | 42 | pContentLength' :: Parser Int 43 | pContentLength' = 44 | do A.string "Content-Length: " 45 | lenStr <- A.takeWhile (/= '\r') 46 | A.string "\r\n" 47 | case readDecimal lenStr of 48 | Nothing -> fail "could not parse length." 49 | Just (i, bs) -> return i 50 | 51 | pContentLength :: (Monad m) => StateT (Producer ByteString m r) m (Maybe (Either String Int)) 52 | pContentLength = do 53 | eof <- PB.isEndOfBytes 54 | if eof 55 | then return Nothing 56 | else do 57 | r <- parse pContentLength' 58 | return $ case r of 59 | (Left e) -> Just (Left $ show e) 60 | (Right (_, i)) -> Just (Right i) 61 | {- 62 | splitBody :: (Monad m) => 63 | Int 64 | -> Producer ByteString m r 65 | -> Producer' ByteString m (Producer ByteString m r) 66 | -} 67 | {- 68 | splitBody len = 69 | do p0 <- get 70 | p1 <- lift $ PB.splitAt len p0 71 | put (p1 >-> PB.drop 2) 72 | -- return (p1 >-> PB.drop 2) 73 | -} 74 | 75 | parseRequests :: Monad m => 76 | FreeT (RequestF m) (StateT (Producer ByteString m r) m) () 77 | parseRequests = FreeT $ do 78 | mLen <- pContentLength 79 | return $ case mLen of 80 | (Just (Right len)) -> 81 | let bdy :: (Monad m) => Producer ByteString m (FreeT (RequestF m) (StateT (Producer ByteString m r) m) ()) 82 | bdy = undefined 83 | 84 | req :: (Monad m) => RequestF m (FreeT (RequestF m) (StateT (Producer ByteString m r) m) ()) 85 | req = (RequestF len bdy) 86 | in Free req 87 | (Just (Left e)) -> error e 88 | Nothing -> Pure () 89 | 90 | 91 | {- 92 | serve' :: Monad m => 93 | (RequestF m (FreeT (RequestF m) m a) -> ResponseF m (FreeT (ResponseF m) m a)) 94 | -> FreeT (RequestF m) m a 95 | -> FreeT (ResponseF m) m a 96 | serve' handler requests = FreeT $ 97 | do x <- runFreeT requests 98 | case x of 99 | Free req -> 100 | return $ Free (handler req) 101 | Pure r -> return $ Pure r 102 | 103 | writeResponses :: Show a => FreeT (ResponseF IO) IO a -> IO () 104 | writeResponses resps = 105 | do x <- runFreeT resps 106 | case x of 107 | Pure r -> print r 108 | (Free (ResponseF len bdy)) -> 109 | do putStrLn "Response {" 110 | putStr " length = " 111 | print len 112 | putStr " , body = " 113 | next <- runEffect $ bdy >-> P.print 114 | putStrLn "}\n" 115 | writeResponses next 116 | 117 | echo :: (Monad m) => 118 | RequestF m (FreeT (RequestF m) m r) 119 | -> ResponseF m (FreeT (ResponseF m) m r) 120 | echo (RequestF len inP) = 121 | let outputP = 122 | do remainingRequests <- inP 123 | return (serve' echo remainingRequests) 124 | in (ResponseF len outputP) 125 | 126 | testStream :: ByteString 127 | testStream = "Content-Length: 5\r\n12345\r\n" 128 | 129 | main :: IO () 130 | main = writeResponses (serve' echo (parseRequests (yield testStream >> yield testStream))) 131 | -} -------------------------------------------------------------------------------- /experiments/pipes-delimited6.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, RankNTypes, OverloadedStrings #-} 2 | module Main where 3 | 4 | import Control.Applicative 5 | import Control.Monad.Identity 6 | import Control.Monad.State.Strict (evalStateT, get, put) 7 | import Control.Monad.Trans 8 | import Data.Attoparsec.ByteString.Char8 (Parser, string) 9 | import qualified Data.Attoparsec.ByteString.Char8 as A 10 | import Data.ByteString (ByteString) 11 | import qualified Data.ByteString as B 12 | import qualified Data.ByteString.Char8 as C 13 | import Data.IORef 14 | import Data.ByteString.Lex.Integral (readDecimal) 15 | import Pipes 16 | import qualified Pipes.Prelude as P 17 | import Pipes.Parse 18 | import Pipes.Attoparsec 19 | import qualified Pipes.ByteString as PB 20 | import Debug.Trace (trace) 21 | 22 | data RequestF m r = RequestF 23 | { length :: !Int 24 | , body :: !(Producer ByteString m r) 25 | } 26 | 27 | instance (Monad m) => Functor (RequestF m) where 28 | fmap f (RequestF len bdy) = RequestF len (fmap f bdy) 29 | 30 | type Request m = FreeT (RequestF m) m 31 | 32 | data ResponseF m r = ResponseF 33 | { resLength :: !Int 34 | , resBody :: !(Producer ByteString m r) 35 | } 36 | 37 | instance (Monad m) => Functor (ResponseF m) where 38 | fmap f (ResponseF l bdy) = ResponseF l (fmap f bdy) 39 | 40 | type Response m = FreeT (ResponseF m) 41 | 42 | parseRequests :: forall m r. Monad m => 43 | Producer ByteString m r 44 | -> FreeT (RequestF m) m () 45 | parseRequests p0 = FreeT $ do 46 | (m1, p1) <- runStateT pContentLength p0 47 | return $ case m1 of 48 | (Just (Right len)) -> 49 | let bdy :: Producer ByteString m (FreeT (RequestF m) m ()) 50 | bdy = parseRequests <$> splitBody len p1 51 | 52 | req :: RequestF m (FreeT (RequestF m) m ()) 53 | req = RequestF len bdy 54 | in Free req 55 | (Just (Left e)) -> error e 56 | Nothing -> Pure () 57 | 58 | splitBody :: (Monad m) => 59 | Int 60 | -> Producer ByteString m r 61 | -> Producer' ByteString m (Producer ByteString m r) 62 | splitBody len p0 = 63 | do p1 <- PB.splitAt len p0 64 | return (p1 >-> PB.drop 2) 65 | 66 | pContentLength' :: Parser Int 67 | pContentLength' = 68 | do A.string "Content-Length: " 69 | lenStr <- A.takeWhile (/= '\r') 70 | A.string "\r\n" 71 | case readDecimal lenStr of 72 | Nothing -> fail "could not parse length." 73 | Just (i, bs) -> return i 74 | 75 | pContentLength :: (Monad m) => StateT (Producer ByteString m r) m (Maybe (Either String Int)) 76 | pContentLength = do 77 | eof <- PB.isEndOfBytes 78 | if eof 79 | then return Nothing 80 | else do 81 | r <- parse pContentLength' 82 | return $ case r of 83 | (Left e) -> Just (Left $ show e) 84 | (Right (_, i)) -> Just (Right i) 85 | 86 | serve' :: Monad m => 87 | (RequestF m (FreeT (RequestF m) m a) -> ResponseF m (FreeT (ResponseF m) m a)) 88 | -> FreeT (RequestF m) m a 89 | -> FreeT (ResponseF m) m a 90 | serve' handler requests = FreeT $ 91 | do x <- runFreeT requests 92 | case x of 93 | Free req -> 94 | return $ Free (handler req) 95 | Pure r -> return $ Pure r 96 | 97 | writeResponses :: Show a => 98 | FreeT (ResponseF IO) IO a -> IO () 99 | writeResponses resps = 100 | do x <- runFreeT resps 101 | case x of 102 | Pure r -> print r 103 | (Free (ResponseF len bdy)) -> 104 | do putStrLn "Response {" 105 | putStr " length = " 106 | print len 107 | putStr " , body = " 108 | next <- runEffect $ bdy >-> P.print 109 | putStrLn "}\n" 110 | writeResponses next 111 | 112 | echo :: (Monad m) => 113 | RequestF m (FreeT (RequestF m) m r) 114 | -> ResponseF m (FreeT (ResponseF m) m r) 115 | echo (RequestF len inP) = 116 | let outputP = 117 | do remainingRequests <- inP 118 | return (serve' echo remainingRequests) 119 | in (ResponseF len outputP) 120 | 121 | testStream :: ByteString 122 | testStream = "Content-Length: 5\r\n12345\r\n" 123 | 124 | main :: IO () 125 | main = writeResponses (serve' echo (parseRequests (yield testStream >> yield testStream))) 126 | -------------------------------------------------------------------------------- /hyperdrive-core/Hyperdrive/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable, DeriveGeneric, RankNTypes, StandaloneDeriving, TemplateHaskell, OverloadedStrings #-} 2 | module Hyperdrive.Types where 3 | 4 | import Pipes (Producer) 5 | import Data.ByteString (ByteString) 6 | import Data.Data (Data, Typeable) 7 | import Data.Text (Text) 8 | import Data.Word (Word64) 9 | import GHC.Generics (Generic) 10 | import Network.HTTP.Types (ByteRange(..), HttpVersion(..), Method(..), Query, ResponseHeaders, RequestHeaders(..), Status(..)) 11 | import Network.Socket (SockAddr) 12 | import qualified Pipes.Parse as Pp 13 | 14 | ------------------------------------------------------------------------------ 15 | -- Request 16 | ------------------------------------------------------------------------------ 17 | 18 | data RequestBodyLength 19 | = ChunkedBody 20 | | KnownLength Word64 21 | deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) 22 | 23 | -- deriving instance Show ByteRange 24 | 25 | -- | the Request with as little parsing as possible done 26 | data RequestRaw = RequestRaw 27 | { _rrMethod :: !Method 28 | , _rrRequestUri :: !ByteString 29 | , _rrHttpVersion :: !HttpVersion 30 | , _rrHeaders :: !RequestHeaders 31 | } 32 | deriving (Show, Typeable, Generic) 33 | 34 | data Request = Request 35 | { _rqRequestRaw :: RequestRaw 36 | {- 37 | , _rqSecure :: !Bool 38 | , _rqMethod :: !Method 39 | , _rqRawPathInfo :: !ByteString 40 | , _rqRawQueryString :: !ByteString 41 | , _rqVersion :: !HttpVersion 42 | , _rqHeaders :: !RequestHeaders 43 | , _rqPeer :: !SockAddr 44 | , _rqPathInfo :: ![Text] 45 | , _rqQuery :: !Query 46 | , _rqCookies :: ![(Text, Text)] 47 | -} 48 | , _rqBodyLength :: !RequestBodyLength 49 | {- 50 | , _rqHeaderHost :: !ByteString 51 | , _rqHeaderRange :: !(Maybe ByteRange) 52 | -} 53 | } 54 | deriving (Show, Typeable, Generic) 55 | 56 | ------------------------------------------------------------------------------ 57 | -- Response 58 | ------------------------------------------------------------------------------ 59 | 60 | data Response m = Response 61 | { _rsStatus :: !Status 62 | , _rsHeaders :: !ResponseHeaders 63 | , _rsBody :: !(ResponseBody m) 64 | , _rsClose :: Bool 65 | } 66 | 67 | data ResponseBody m 68 | = ResponseProducer !(Producer ByteString m ()) 69 | 70 | type RequestParser e m = Pp.Parser ByteString m (Maybe (Either e RequestRaw)) 71 | -------------------------------------------------------------------------------- /hyperdrive-core/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Jeremy Shaw 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Jeremy Shaw nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /hyperdrive-core/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hyperdrive-core/hyperdrive-core.cabal: -------------------------------------------------------------------------------- 1 | name: hyperdrive-core 2 | version: 0.1.0.1 3 | synopsis: core types used by the hyperdrive HTTP server 4 | homepage: https://github.com/stepcut/hyperdrive 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Jeremy Shaw 8 | maintainer: jeremy@n-heptane.com 9 | category: Web 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | library 14 | exposed-modules: Hyperdrive.Types 15 | other-extensions: DeriveDataTypeable, DeriveGeneric, StandaloneDeriving, TemplateHaskell, OverloadedStrings 16 | build-depends: base >= 4.7 && < 4.12, 17 | pipes >= 4.1 && < 4.4, 18 | pipes-parse >= 3.0 && < 3.1, 19 | bytestring >= 0.10 && < 0.11, 20 | text >= 1.2 && < 1.3, 21 | http-types >= 0.8 && < 0.13, 22 | network >= 2.6 && < 2.9, 23 | wai >= 3.2 && < 3.3 24 | default-language: Haskell2010 -------------------------------------------------------------------------------- /hyperdrive-parser-abnf/Hyperdrive/Parser/ABNF/Attoparsec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | module Hyperdrive.Parser.ABNF.Attoparsec where 3 | 4 | import ABNF.ClassyParser.Gen.Attoparsec 5 | import Data.Attoparsec.ByteString.Char8 6 | import Hyperdrive.Parser.ABNF.Parser 7 | import Hyperdrive.Types (RequestParser, RequestRaw) 8 | 9 | requestParser :: Parser RequestRaw 10 | requestParser = $(runGenAttoparsec request_raw_parser) 11 | -------------------------------------------------------------------------------- /hyperdrive-parser-abnf/Hyperdrive/Parser/ABNF/Parser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, QuasiQuotes, TemplateHaskell #-} 2 | module Hyperdrive.Parser.ABNF.Parser where 3 | 4 | import ABNF.ClassyParser.Classes 5 | import ABNF.ClassyParser.Gen.Attoparsec (GenAttoparsec(..)) 6 | import ABNF.ClassyParser.Gen.ABNF (GenABNF(..), normalizeAlternation) 7 | import ABNF.Types (Rule(..), RuleName(..), RuleList(..), RuleMap(..), Alternation(..), ruleMap) 8 | import ABNF.Parser (abnf,abnfRule) 9 | import ABNF.Printer (ppElements, ppRuleList) 10 | import ABNF.CoreRules (core_ruleList) 11 | import Data.CaseInsensitive (CI, mk, original) 12 | import Control.Applicative (Applicative(pure), (<$>)) 13 | import Control.Monad.Reader (Reader(..), runReader) 14 | import Data.Maybe (fromMaybe) 15 | import Data.ByteString (ByteString, pack) 16 | import Data.Text (Text) 17 | import qualified Data.Map as Map 18 | import Data.Maybe (fromJust) 19 | import Data.Monoid ((<>), mempty) 20 | import Hyperdrive.Types (Request(..), RequestRaw(..), RequestBodyLength(..)) 21 | import Instances.TH.Lift () 22 | import Language.Haskell.TH.Syntax (Lift(lift)) 23 | import Language.Haskell.TH.Lift (deriveLift) 24 | import Network.HTTP.Types (ByteRange(..), HttpVersion(..), Method(..), Query(..), StdMethod(..), Header, HeaderName(..), RequestHeaders) 25 | import Network.Socket (SockAddr(..), PortNumber(..)) 26 | 27 | deriveLift ''ByteRange 28 | deriveLift ''RequestBodyLength 29 | deriveLift ''SockAddr 30 | deriveLift ''PortNumber 31 | 32 | ------------------------------------------------------------------------------ 33 | -- basic parsers 34 | ------------------------------------------------------------------------------ 35 | 36 | sp_rule :: Rule 37 | sp_rule = [abnfRule|SP = %x20|] 38 | 39 | sp_parser :: ClassyParser repr => repr Char 40 | sp_parser = pHexChar "20" 41 | 42 | crlf_rule :: Rule 43 | crlf_rule = [abnfRule|CRLF = CR LF |] 44 | 45 | crlf_parser :: (ClassyParser repr) => repr () 46 | crlf_parser = pHexChar "0D" `appR` pHexChar "0A" `appR` pureR () 47 | 48 | separators = "()<>@,;:\\\"/[]?={} \t" 49 | ctl = '\127':['\0'..'\31'] 50 | 51 | token_parser :: (ClassyParser repr) => repr ByteString 52 | token_parser = 53 | pTakeWhile1 (NotInClass (separators++ctl)) 54 | 55 | fieldName_rule :: Rule 56 | fieldName_rule = [abnfRule|field-name = token|] 57 | 58 | fieldName_parser :: (ClassyParser repr) => repr ByteString 59 | fieldName_parser = token_parser 60 | 61 | fieldValue_parser :: (ClassyParser repr) => repr ByteString 62 | fieldValue_parser = 63 | pTakeWhile1 (NotInClass ctl) 64 | 65 | 66 | ------------------------------------------------------------------------------ 67 | -- StdMethod 68 | ------------------------------------------------------------------------------ 69 | 70 | deriveLift ''StdMethod 71 | 72 | std_method_parser :: ClassyParser repr => repr StdMethod 73 | std_method_parser = 74 | pEnumerate [ ("OPTIONS", OPTIONS) 75 | , ("GET" , GET) 76 | , ("HEAD" , HEAD) 77 | , ("POST" , POST) 78 | , ("PUT" , PUT) 79 | , ("DELETE" , DELETE) 80 | , ("TRACE" , TRACE) 81 | , ("CONNECT", CONNECT) 82 | , ("PATCH" , PATCH) 83 | ] 84 | 85 | method_parser :: ClassyParser repr => repr ByteString 86 | method_parser = 87 | pEnumerate [ ("OPTIONS", "OPTIONS") 88 | , ("GET" , "GET") 89 | , ("HEAD" , "HEAD") 90 | , ("POST" , "POST") 91 | , ("PUT" , "PUT") 92 | , ("DELETE" , "DELETE") 93 | , ("TRACE" , "TRACE") 94 | , ("CONNECT", "CONNECT") 95 | , ("PATCH" , "PATCH") 96 | ] 97 | 98 | 99 | uri_parser :: ClassyParser repr => repr ByteString 100 | uri_parser = pCharVal "/" 101 | 102 | ------------------------------------------------------------------------------ 103 | -- HttpVersion 104 | ------------------------------------------------------------------------------ 105 | 106 | deriveLift ''HttpVersion 107 | 108 | class HttpVersionC repr where 109 | httpVersion :: repr (Int -> Int -> HttpVersion) 110 | 111 | instance HttpVersionC GenAttoparsec where 112 | httpVersion = GA [| pure HttpVersion |] 113 | 114 | instance HttpVersionC GenABNF where 115 | httpVersion = GenABNF (Alternation []) 116 | 117 | httpVersion_rule :: Rule 118 | httpVersion_rule = 119 | [abnfRule|HTTP-Version = "HTTP" "/" 1*DIGIT "." 1*DIGIT |] 120 | 121 | httpVersion_parser :: (ClassyParser repr, HttpVersionC repr) => repr HttpVersion 122 | httpVersion_parser = 123 | (pCharVal "HTTP") `appR` (pCharVal "/") `appR` (httpVersion `app` (digitsToInt (pMany1 pDigit)) `appL` pCharVal "." `app` (digitsToInt (pMany1 pDigit))) 124 | 125 | ------------------------------------------------------------------------------ 126 | -- Header 127 | ------------------------------------------------------------------------------ 128 | 129 | class CiC repr where 130 | mkCI :: repr (ByteString -> CI ByteString) 131 | 132 | instance CiC GenAttoparsec where 133 | mkCI = GA [| pure mk |] 134 | 135 | instance CiC GenABNF where 136 | mkCI = GenABNF (Alternation []) 137 | 138 | instance (Lift s) => Lift (CI s) where 139 | lift ci = 140 | let orig = original ci 141 | in [| mk orig |] 142 | 143 | class NothingIsEmpty repr where 144 | nothingIsEmpty :: repr (Maybe ByteString -> ByteString) 145 | 146 | instance NothingIsEmpty GenABNF where 147 | nothingIsEmpty = GenABNF (Alternation []) 148 | 149 | instance NothingIsEmpty GenAttoparsec where 150 | nothingIsEmpty = GA [| pure (fromMaybe mempty) |] 151 | 152 | messageHeader_Rule :: Rule 153 | messageHeader_Rule = [abnfRule|message-header = field-name ":" [ field-value ] |] 154 | 155 | messageHeader_parser :: (ClassyParser repr, CiC repr, NothingIsEmpty repr) => repr Header 156 | messageHeader_parser = 157 | pair `app` (mkCI `app` fieldName_parser) `appL` pCharVal ":" `app` (nothingIsEmpty `app` (pOptional $ fieldValue_parser)) 158 | 159 | messageHeaders_parser :: (ClassyParser repr, CiC repr, NothingIsEmpty repr) => repr [Header] 160 | messageHeaders_parser = 161 | pMany (messageHeader_parser `appL` crlf_parser) 162 | 163 | 164 | requestLine_rule = [abnfRule|Request-Line = Method SP Request-URI SP HTTP-Version CRLF|] 165 | 166 | requestLine = 167 | [abnf| 168 | Request-Line = Method SP Request-URI SP HTTP-Version CRLF 169 | 170 | HTTP-Version = "HTTP" "/" 1*DIGIT "." 1*DIGIT 171 | 172 | Method = "OPTIONS" ; Section 9.2 173 | | "GET" ; Section 9.3 174 | | "HEAD" ; Section 9.4 175 | | "POST" ; Section 9.5 176 | | "PUT" ; Section 9.6 177 | | "DELETE" ; Section 9.7 178 | | "TRACE" ; Section 9.8 179 | | "CONNECT" ; Section 9.9 180 | 181 | CRLF = CR LF 182 | |] 183 | 184 | {- 185 | Request = Request-Line ; Section 5.1 186 | *(( general-header ; Section 4.5 187 | | request-header ; Section 5.3 188 | | entity-header ) CRLF) 189 | 190 | -} 191 | {- 192 | data Request = Request 193 | { method :: StdMethod 194 | , uri :: ByteString 195 | , version :: HttpVersion 196 | , headers :: RequestHeaders 197 | } 198 | deriving Show 199 | -- $(deriveLift ''Request) 200 | -} 201 | class (HttpVersionC repr) => RequestC repr where 202 | request :: repr ( Bool 203 | -> Method 204 | -> ByteString 205 | -> ByteString 206 | -> HttpVersion 207 | -> RequestHeaders 208 | -> SockAddr 209 | -> [Text] 210 | -> Query 211 | -> [(Text, Text)] 212 | -> RequestBodyLength 213 | -> ByteString 214 | -> Maybe ByteRange 215 | -> Request) 216 | 217 | instance RequestC GenAttoparsec where 218 | request = GA [| pure Request |] 219 | 220 | instance RequestC GenABNF where 221 | request = GenABNF (Alternation []) 222 | 223 | class (HttpVersionC repr) => RequestRawC repr where 224 | requestRaw :: repr ( Method 225 | -> ByteString 226 | -> HttpVersion 227 | -> RequestHeaders 228 | -> RequestRaw) 229 | 230 | instance RequestRawC GenAttoparsec where 231 | requestRaw = GA [| pure RequestRaw |] 232 | 233 | instance RequestRawC GenABNF where 234 | requestRaw = GenABNF (Alternation []) 235 | 236 | request_raw_parser :: (ClassyParser repr, RequestRawC repr, CiC repr, NothingIsEmpty repr) => repr RequestRaw 237 | request_raw_parser = 238 | requestRaw `app` method_parser `appL` sp_parser 239 | `app` uri_parser `appL` sp_parser 240 | `app` httpVersion_parser `appL` crlf_parser 241 | `app` messageHeaders_parser `appL` crlf_parser 242 | 243 | request_parser :: (ClassyParser repr, RequestC repr, CiC repr, NothingIsEmpty repr) => repr Request 244 | request_parser = 245 | request `app` (pureR False) -- FIXME: we don't want to have to default this 246 | `app` method_parser `appL` sp_parser 247 | `app` uri_parser `appL` sp_parser 248 | `app` (pureR mempty) 249 | `app` httpVersion_parser `appL` crlf_parser 250 | `app` messageHeaders_parser `appL` crlf_parser 251 | `app` (pureR (SockAddrUnix "")) -- FIXME -- we don't want to have to default this 252 | `app` (pureR []) 253 | `app` (pureR []) 254 | `app` (pureR []) 255 | `app` (pureR ChunkedBody) 256 | `app` (pureR "") 257 | `app` (pureR Nothing) 258 | 259 | {- 260 | request `app` method_parser `appL` sp_parser 261 | `app` uri_parser `appL` sp_parser 262 | `app` httpVersion_parser `appL` crlf_parser 263 | `app` messageHeaders_parser `appL` crlf_parser 264 | 265 | 266 | testGen = 267 | do {- print $ ppElements $ runGenABNF $ pCharVal "foo" 268 | print $ ppElements $ runGenABNF $ method_parser 269 | print $ ppElements $ runGenABNF $ uri_parser 270 | print $ ppElements $ runGenABNF $ httpVersion_parser 271 | print $ ppElements $ runGenABNF $ messageHeaders_parser -} 272 | print $ ppElements $ runGenABNF $ request_parser 273 | 274 | -- check :: RuleMap -> Rule -> p -> IO () 275 | check :: RuleMap -> Rule -> GenABNF a -> IO () 276 | check rulemap rule parser = 277 | do let (Rule _ alternation) = rule 278 | method_n = runReader (normalizeAlternation alternation) rulemap 279 | method_gen = runReader (normalizeAlternation (runGenABNF parser)) rulemap 280 | putStrLn "normalized rules from spec" 281 | print $ ppElements $ method_n 282 | -- print $ method_n 283 | putStrLn "normalized generated rules" 284 | print $ ppElements $ method_gen 285 | print (method_n == method_gen) 286 | 287 | -- test_method = check Map.empty method_rule method_parser 288 | {- 289 | test_request = 290 | check (ruleMap (core_ruleList <> request_rules)) 291 | (Rule (RuleName "Request") (fromJust $ Map.lookup (RuleName "Request") (ruleMap request_rules))) 292 | request_parser 293 | -} 294 | -- check requestLine requestLine_rule 295 | 296 | 297 | test_rule rulelist rulename parser = 298 | case Map.lookup (RuleName rulename) (ruleMap rulelist) of 299 | Nothing -> error $ "rulename " ++ show rulename ++ "not found." 300 | (Just elements) -> 301 | check (ruleMap (rulelist <> core_ruleList)) 302 | (Rule (RuleName rulename) elements) 303 | parser 304 | 305 | test_method = test_rule request_rules "Method" method_parser 306 | test_request_uri = test_rule request_rules "Request-URI" uri_parser 307 | test_httpVersion = test_rule request_rules "HTTP-Version" httpVersion_parser 308 | test_fieldName = test_rule request_rules "field-name" fieldName_parser 309 | test_fieldValue = test_rule request_rules "field-value" fieldValue_parser 310 | test_messageHeader = test_rule request_rules "message-header" messageHeader_parser 311 | test_request = test_rule request_rules "Request" request_parser 312 | 313 | ------------------------------------------------------------------------------ 314 | -- ABNF Rules required to parse a Request 315 | ------------------------------------------------------------------------------ 316 | 317 | request_rules :: RuleList 318 | request_rules = 319 | [abnf| 320 | Request = Request-Line ; Section 5.1 321 | *(message-header CRLF) 322 | CRLF 323 | 324 | Request-Line = Method SP Request-URI SP HTTP-Version CRLF 325 | 326 | Request-URI = "/" 327 | 328 | HTTP-Version = "HTTP" "/" 1*DIGIT "." 1*DIGIT 329 | 330 | Method = "OPTIONS" ; Section 9.2 331 | | "GET" ; Section 9.3 332 | | "HEAD" ; Section 9.4 333 | | "POST" ; Section 9.5 334 | | "PUT" ; Section 9.6 335 | | "DELETE" ; Section 9.7 336 | | "TRACE" ; Section 9.8 337 | | "CONNECT" ; Section 9.9 338 | | "PATCH" ; hyperdrive-extension 339 | 340 | CRLF = CR LF 341 | 342 | message-header = field-name ":" [ field-value ] 343 | 344 | field-name = token 345 | 346 | token = 1*("!" / "#" / "$" / "%" / "&" / "'" / "*" / "+" / "-" / "." / "0" / "1" / "2" / "3" / "4" / "5" / "6" / "7" / "8" / "9" / "A" / "B" / "C" / "D" / "E" / "F" / "G" / "H" / "I" / "J" / "K" / "L" / "M" / "N" / "O" / "P" / "Q" / "R" / "S" / "T" / "U" / "V" / "W" / "X" / "Y" / "Z" / "^" / "_" / "`" / "a" / "b" / "c" / "d" / "e" / "f" / "g" / "h" / "i" / "j" / "k" / "l" / "m" / "n" / "o" / "p" / "q" / "r" / "s" / "t" / "u" / "v" / "w" / "x" / "y" / "z" / "|" / "~") 347 | 348 | field-value = 1*(" " / "!" / %x22 / "#" / "$" / "%" / "&" / "'" / "(" / ")" / "*" / "+" / "," / "-" / "." / "/" / "0" / "1" / "2" / "3" / "4" / "5" / "6" / "7" / "8" / "9" / ":" / ";" / "<" / "=" / ">" / "?" / "@" / "A" / "B" / "C" / "D" / "E" / "F" / "G" / "H" / "I" / "J" / "K" / "L" / "M" / "N" / "O" / "P" / "Q" / "R" / "S" / "T" / "U" / "V" / "W" / "X" / "Y" / "Z" / "[" / "\" / "]" / "^" / "_" / "`" / "a" / "b" / "c" / "d" / "e" / "f" / "g" / "h" / "i" / "j" / "k" / "l" / "m" / "n" / "o" / "p" / "q" / "r" / "s" / "t" / "u" / "v" / "w" / "x" / "y" / "z" / "{" / "|" / "}" / "~") 349 | 350 | |] 351 | -} 352 | -------------------------------------------------------------------------------- /hyperdrive-parser-abnf/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Jeremy Shaw 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Jeremy Shaw nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /hyperdrive-parser-abnf/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hyperdrive-parser-abnf/hyperdrive-parser-abnf.cabal: -------------------------------------------------------------------------------- 1 | name: hyperdrive-parser-abnf 2 | version: 0.1.0.1 3 | synopsis: A parser for hyperdrive which is machine checked against the ABNF spec 4 | homepage: https://github.com/stepcut/hyperdrive 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Jeremy Shaw 8 | maintainer: jeremy@n-heptane.com 9 | category: Web 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | 13 | library 14 | exposed-modules: Hyperdrive.Parser.ABNF.Attoparsec 15 | Hyperdrive.Parser.ABNF.Parser 16 | other-extensions: TemplateHaskell, OverloadedStrings, QuasiQuotes 17 | build-depends: base >= 4.7 && < 4.12, 18 | abnf >= 0.1 && < 0.5, 19 | abnf-parser-generator >= 0.1 && < 0.2, 20 | attoparsec >= 0.12 && < 0.14, 21 | bytestring >= 0.10 && < 0.11, 22 | case-insensitive >= 1.2 && < 1.3, 23 | containers >= 0.5 && < 0.7, 24 | hyperdrive-core >= 0.1 && < 0.2, 25 | http-types >= 0.8 && < 0.13, 26 | mtl >= 2.1 && < 2.3, 27 | network >= 2.6 && < 2.9, 28 | template-haskell >= 2.9 && < 2.14, 29 | text >= 1.2 && < 1.3, 30 | th-lift >= 0.6 && < 0.8, 31 | th-lift-instances >= 0.1 && < 0.2 32 | default-language: Haskell2010 -------------------------------------------------------------------------------- /hyperdrive/Hyperdrive/FakeParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Hyperdrive.FakeParser where 3 | 4 | import Control.Applicative ((*>), pure, many) 5 | import qualified Data.Attoparsec.ByteString.Char8 as AC 6 | import Data.ByteString (ByteString) 7 | import Data.CaseInsensitive (mk) 8 | import Hyperdrive.Types ( Request(..), RequestBodyLength(..) 9 | , Response(..), ResponseBody(..) 10 | ) 11 | import Network.HTTP.Types ( HeaderName, ResponseHeaders, Status(..) 12 | , HttpVersion(..), status200 13 | ) 14 | import Network.Socket (Socket, SockAddr(..)) 15 | 16 | 17 | ------------------------------------------------------------------------------ 18 | -- Request 19 | ------------------------------------------------------------------------------ 20 | 21 | seperators :: [Char] 22 | seperators = 23 | [ '(' , ')' , '<' , '>' , '@' 24 | , ',' , ';' , ':' , '\\' , '"' 25 | , '/' , '[' , ']' , '?' , '=' 26 | , '{' , '}' , ' ' , '\t' 27 | ] 28 | 29 | ctls :: [Char] 30 | ctls = '\DEL' : ['\0' .. '\31'] 31 | 32 | pToken :: AC.Parser ByteString 33 | pToken = AC.takeWhile1 (\c -> notElem c (seperators ++ ctls)) 34 | 35 | -- a very incorrect header parser 36 | pHeader :: AC.Parser (HeaderName, ByteString) 37 | pHeader = 38 | do n <- pToken 39 | AC.char ':' 40 | AC.skipWhile (== ' ') 41 | v <- AC.takeTill (== '\r') 42 | AC.take 1 43 | AC.char '\n' 44 | return (mk n, v) 45 | 46 | fakeParseRequest :: Bool 47 | -> AC.Parser Request 48 | fakeParseRequest secure = 49 | do method <- AC.takeWhile1 (/= ' ') 50 | AC.take 1 51 | pathInfo <- AC.takeWhile1 (/= ' ') 52 | AC.take 1 53 | httpVersion <- AC.string "HTTP/1.1\r\n" *> pure (HttpVersion 1 1) 54 | headers <- many pHeader 55 | AC.string "\r\n" 56 | let req = Request 57 | { _rqSecure = secure 58 | , _rqMethod = method 59 | , _rqRawPathInfo = pathInfo 60 | , _rqRawQueryString = "" 61 | , _rqVersion = httpVersion 62 | , _rqHeaders = headers 63 | , _rqPeer = (SockAddrUnix "") 64 | , _rqPathInfo = [] 65 | , _rqQuery = [] 66 | , _rqCookies = [] 67 | , _rqBodyLength = KnownLength 0 68 | , _rqHeaderHost = "" 69 | , _rqHeaderRange = Nothing 70 | } 71 | return req 72 | -------------------------------------------------------------------------------- /hyperdrive/Hyperdrive/Serve.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, OverloadedStrings #-} 2 | module Hyperdrive.Serve where 3 | 4 | import Control.Applicative ((<*)) 5 | import Data.ByteString (ByteString) 6 | import Data.CaseInsensitive (mk) 7 | import Data.Monoid (mempty) 8 | import Hyperdrive.Types (Request(..), RequestRaw(..), Response(..), RequestParser, RequestBodyLength(KnownLength)) 9 | import Lens.Family.State.Strict (zoom) 10 | import qualified Pipes.ByteString as Pb 11 | import qualified Pipes.Parse as Pp 12 | 13 | hasConnectionClose :: Request -> Bool 14 | hasConnectionClose req = 15 | case lookup "connection" (_rrHeaders (_rqRequestRaw req)) of 16 | Nothing -> False 17 | (Just _) -> True 18 | 19 | -- | parse a single 'Request' including the 'Request' body 20 | parseOne :: (Monad m, Functor m) => 21 | RequestParser e m -- Pp.Parser ByteString m (Maybe (Either e Request)) 22 | -> (Request -> Pp.Parser ByteString m (Either e r)) 23 | -> Pp.Parser ByteString m (Maybe (Either e r), Bool) 24 | parseOne pRequest handler = 25 | do me <- pRequest 26 | case me of 27 | Nothing -> return (Nothing, True) 28 | (Just (Left e)) -> return (Just $ Left e, True) 29 | (Just (Right rreq)) -> 30 | do let req = Request rreq (KnownLength 0) 31 | (KnownLength len) = _rqBodyLength req 32 | me' <- zoom (Pb.splitAt len) ((handler req) <* Pp.skipAll) 33 | return (Just $ me', hasConnectionClose req) 34 | 35 | 36 | addConnectionClose :: Bool -> Response m -> Response m 37 | addConnectionClose False res = res 38 | addConnectionClose True res = res { _rsHeaders = ("Connection", "close") : (_rsHeaders res) } 39 | 40 | -- | parse a single 'Request' and send a single 'Response' 41 | -- 42 | -- this should leave the parser in such a state that additional 43 | -- requests can be parsed 44 | handleOne :: (Functor m, Monad m) => 45 | RequestParser e m 46 | -> (Response m -> Pp.Parser ByteString m (Maybe e)) 47 | -> (Request -> Pp.Parser ByteString m (Either e (Response m))) 48 | -> Pp.Parser ByteString m (Maybe e, Bool) 49 | handleOne pRequest sendResponse handler = 50 | do (e, close) <- parseOne pRequest handler 51 | case e of 52 | Nothing -> return (Nothing, close) 53 | (Just (Left e)) -> return (Just e, close) 54 | (Just (Right r)) -> 55 | do e <- sendResponse (addConnectionClose (close || _rsClose r) r) 56 | return (e, close || _rsClose r) 57 | -------------------------------------------------------------------------------- /hyperdrive/Hyperdrive/Simple.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings, RankNTypes, RecordWildCards, OverloadedStrings, ScopedTypeVariables #-} 2 | {- 3 | 4 | Simple implementations for parsing Requests and generating Responses. 5 | 6 | Right now there is no attempt to make them correct. Mostly they are 7 | just dummy implementations so that we can work out the rest of the API 8 | and then later drop in a solid parser. 9 | 10 | -} 11 | module Hyperdrive.Simple where 12 | 13 | import Control.Applicative ((*>), pure, many) 14 | import Control.Concurrent (threadDelay) 15 | import Control.Monad.Catch (MonadCatch) 16 | import Control.Monad (forever, forM) 17 | import Control.Monad.Trans (MonadIO(liftIO)) 18 | import Control.Concurrent (forkFinally) 19 | import Control.Concurrent.Async (async, waitCatch) 20 | import Control.Concurrent.SSem (SSem) 21 | import Control.Concurrent.SSem as SSem 22 | import qualified Control.Concurrent.STM as STM 23 | import qualified Control.Exception as E 24 | import qualified Data.Attoparsec.ByteString as A 25 | import qualified Data.Attoparsec.ByteString.Char8 as AC 26 | import Data.ByteString (ByteString) 27 | import qualified Data.ByteString as B 28 | import Data.CaseInsensitive (mk, original) 29 | import Data.String (fromString) 30 | -- import Hyperdrive.FakeParser (fakeParseRequest) 31 | import Hyperdrive.Parser.ABNF.Attoparsec (requestParser) 32 | import Hyperdrive.Serve (handleOne) 33 | import Hyperdrive.Types ( Request(..), RequestBodyLength(..) 34 | , RequestParser, Response(..), ResponseBody(..)) 35 | import Network.HTTP.Types (HeaderName, ResponseHeaders, Status(..) 36 | , HttpVersion(..), status200) 37 | import Network.Socket (Socket, SockAddr(..), close) 38 | import Network.Simple.TCP (HostPreference(..), ServiceName(..)) 39 | import qualified Network.Socket as N 40 | import qualified Network.Simple.TCP as NS 41 | import Pipes (Producer, Producer', Consumer', Effect, (>~), (>->), each, await, runEffect, lift, yield, Proxy) 42 | import Pipes.Concurrent (Buffer(Bounded), spawn', Input(..), Output(..), performGC) 43 | import qualified Pipes.Prelude as P 44 | import qualified Pipes.Attoparsec as Pa 45 | import qualified Pipes.ByteString as Pb 46 | import qualified Pipes.Concurrent as Pc 47 | import Pipes.Network.TCP.Safe (serve, listen, accept, acceptFork, toSocket,fromSocket) 48 | import qualified Pipes.Parse as Pp 49 | import Pipes.Safe (runSafeT) 50 | import qualified Pipes.Safe as Ps 51 | 52 | ------------------------------------------------------------------------------ 53 | -- Response 54 | ------------------------------------------------------------------------------ 55 | 56 | renderStatusLine :: Status -> ByteString 57 | renderStatusLine (Status 200 msg) = 58 | "HTTP/1.1 200 OK\r\n" 59 | 60 | renderResponseHead :: Response m -> ByteString 61 | renderResponseHead Response{..} = 62 | B.concat [ renderStatusLine _rsStatus 63 | , renderResponseHeaders _rsHeaders 64 | , "\r\n" 65 | ] 66 | 67 | renderHeader :: (HeaderName, ByteString) -> ByteString 68 | renderHeader (n, v) = 69 | B.concat [ original n , ": ", v, "\r\n"] 70 | 71 | renderResponseHeaders :: ResponseHeaders -> ByteString 72 | renderResponseHeaders headers = 73 | B.concat $ map renderHeader headers 74 | 75 | responseProducer :: (Monad m) => 76 | Response m 77 | -> Producer ByteString m () 78 | responseProducer res = 79 | do yield $ renderResponseHead res 80 | case _rsBody res of 81 | (ResponseProducer p) -> p 82 | 83 | 84 | stdoutResponse :: (MonadIO m) => 85 | Response m 86 | -> Pp.Parser ByteString m (Maybe e) 87 | stdoutResponse res = 88 | (lift $ runEffect $ (responseProducer res) >-> Pb.stdout) >> return Nothing 89 | 90 | ------------------------------------------------------------------------------ 91 | -- serve 92 | ------------------------------------------------------------------------------ 93 | {- 94 | ppRequest :: (Monad m) => 95 | RequestParser Pa.ParsingError m 96 | ppRequest = Pa.parse (fakeParseRequest False) 97 | -} 98 | 99 | 100 | 101 | simpleOne :: (Functor m, MonadIO m) => 102 | RequestParser Pa.ParsingError m 103 | -> (Response m -> Pp.Parser ByteString m (Maybe Pa.ParsingError)) 104 | -> (Request -> Pp.Parser ByteString m (Either Pa.ParsingError (Response m))) 105 | -> Pp.Parser ByteString m (Maybe Pa.ParsingError, Bool) 106 | simpleOne parseRequest sendResponse handler = 107 | handleOne parseRequest (\res -> sendResponse res) handler 108 | 109 | data InOutClose e m = 110 | InOutClose { inByteString :: Producer ByteString m () 111 | , outResponse :: Response m -> Pp.Parser ByteString m (Maybe e) 112 | , closeIt :: m () 113 | } 114 | 115 | socketResponse :: (MonadIO m) => 116 | Socket 117 | -> Response m 118 | -> Pp.Parser ByteString m (Maybe e) 119 | socketResponse csock res = 120 | do -- liftIO $ putStrLn "sending response..." 121 | e <- lift $ runEffect $ ((responseProducer res) >-> (toSocket csock)) >> return Nothing 122 | -- liftIO $ putStrLn "sent." 123 | return e 124 | 125 | hello :: (Monad m) => 126 | Request 127 | -> Pp.Parser ByteString m (Either Pa.ParsingError (Response m)) 128 | hello req = 129 | let body = "hello" in 130 | return $ Right $ Response 131 | { _rsStatus = status200 132 | , _rsHeaders = [("Content-Length", fromString $ show $ B.length body) 133 | ] 134 | , _rsBody = ResponseProducer (yield body) 135 | , _rsClose = False 136 | } 137 | 138 | simpleRequest :: ByteString 139 | simpleRequest = B.concat 140 | [ "GET / HTTP/1.1\r\n" 141 | , "Host: localhost\r\n" 142 | , "User-Agent: curl/7.22.0 (x86_64-pc-linux-gnu) libcurl/7.22.0 OpenSSL/1.0.1 zlib/1.2.3.4 libidn/1.23 librtmp/2.3\r\n" 143 | , "Accept: */*\r\n" 144 | , "\r\n" 145 | ] 146 | 147 | anotherRequest :: ByteString 148 | anotherRequest = "GET / HTTP/1.1\r\nUser-Agent: curl/7.22.0 (x86_64-pc-linux-gnu) libcurl/7.22.0 OpenSSL/1.0.1 zlib/1.2.3.4 libidn/1.23 librtmp/2.3\r\nHost: localhost:8000\r\nAccept: */*\r\n\r\n" 149 | {- 150 | {- 151 | 152 | We need to read a Response and write Request. 153 | 154 | If the Requset contains a connection-close header, then we should close the connection after sending the Response. 155 | If the Response contains a connection-close header, then we should also close the connection after sending the Response. 156 | 157 | If a 100-continue is in play, things are a bit more complicated. 158 | 159 | -} 160 | simpleTest :: IO () 161 | simpleTest = 162 | do r <- Pp.evalStateT (simpleOne stdoutResponse hello) (yield simpleRequest) 163 | case r of 164 | (Nothing, close) -> return () 165 | (Just e, _) -> error (show e) 166 | -} 167 | {- 168 | fromVerboseSocket :: (MonadIO m) => 169 | Socket 170 | -> Int 171 | -> Producer' ByteString m () 172 | fromVerboseSocket socket limit = 173 | fromSocket socket limit >-> 174 | (forever $ 175 | do bs <- await 176 | lift $ liftIO $ print bs 177 | yield bs 178 | yield " " 179 | ) 180 | 181 | simpleServe :: HostPreference 182 | -> ServiceName 183 | -> (Request -> Pp.Parser ByteString IO (Either Pa.ParsingError (Response IO))) 184 | -> IO () 185 | simpleServe hp port handler = 186 | runSafeT $ serve hp port $ \(csock, clientAddr) -> 187 | Pp.evalStateT (go (csock, clientAddr)) (fromSocket csock 4096) 188 | where 189 | go (csock, clientAddr) = 190 | do r <- simpleOne (socketResponse csock) handler 191 | case r of 192 | (Nothing, True) -> 193 | do liftIO $ close csock 194 | return () 195 | (Nothing, False) -> 196 | do go (csock, clientAddr) 197 | (Just e, _) -> 198 | do liftIO $ close csock 199 | error (show e) 200 | 201 | simpleServe2 :: forall m. (Functor m, Ps.MonadSafe m) => 202 | HostPreference 203 | -> ServiceName 204 | -> (Request -> Pp.Parser ByteString m (Either Pa.ParsingError (Response m))) 205 | -> m () 206 | simpleServe2 hp port handler = 207 | listen hp port $ \(lsock, hostAddr) -> 208 | forever $ (accept lsock $ 209 | \(csock, clientAddr) -> 210 | (Pp.evalStateT (go (csock, clientAddr)) (fromSocket csock 4096))) `Ps.catch` 211 | ((\e -> return ()) :: Ps.SomeException -> m ()) 212 | where 213 | -- go :: (MonadIO m) => (Socket, SockAddr) -> Pp.StateT (Producer ByteString (Ps.SafeT m) x) (Ps.SafeT m) () 214 | go (csock, clientAddr) = 215 | do r <- simpleOne (socketResponse csock) handler 216 | case r of 217 | (Nothing, True) -> 218 | do liftIO $ close csock 219 | return () 220 | (Nothing, False) -> 221 | do go (csock, clientAddr) 222 | (Just e, _) -> 223 | do liftIO $ close csock 224 | error (show e) 225 | 226 | data ServeState 227 | = Cont (Socket, SockAddr) 228 | | Close 229 | | Error Pa.ParsingError 230 | 231 | {- 232 | 233 | In this variant, we will limit the maxinum simulataneous connections. 234 | 235 | -} 236 | simpleServe3 :: HostPreference 237 | -> ServiceName 238 | -> (Request -> Pp.Parser ByteString IO (Either Pa.ParsingError (Response IO))) 239 | -> IO () 240 | simpleServe3 hp port handler = 241 | do connSem <- SSem.new 10 242 | runSafeT $ listen hp port $ \(lsock, hostAddr) -> 243 | liftIO $ forever $ 244 | (do SSem.wait connSem 245 | print =<< getValue connSem 246 | conn@(csock,_) <- N.accept lsock 247 | forkFinally 248 | (Pp.evalStateT (go (Cont conn)) (fromSocket csock 4096)) 249 | (\ea -> 250 | do NS.closeSock csock 251 | signal connSem 252 | either E.throwIO return ea 253 | ) 254 | 255 | return ()) 256 | 257 | 258 | {- 259 | listen hp port $ \(lsock, hostAddr) -> 260 | forever $ (accept lsock $ 261 | \(csock, clientAddr) -> 262 | (Pp.evalStateT (go (csock, clientAddr)) (fromSocket csock 4096))) `Ps.catch` 263 | ((\e -> return ()) :: Ps.SomeException -> m ()) 264 | -} 265 | where 266 | go :: ServeState -> Pp.Parser ByteString IO () 267 | go Close = return () 268 | go (Cont c) = go =<< step c 269 | go (Error e) = error (show e) 270 | step (csock, clientAddr) = 271 | do r <- simpleOne (socketResponse csock) handler 272 | case r of 273 | (Nothing, True) -> 274 | do return Close 275 | (Nothing, False) -> 276 | do return (Cont (csock, clientAddr)) 277 | (Just e, _) -> 278 | do return (Error e) 279 | -} 280 | {- 281 | {- 282 | 283 | This variant uses pipes-concurrency and work stealing to limit the 284 | number of requests being handled at once. In this version, we can 285 | handle a single request from a pipelined connection and push the 286 | remainder back into the work pool. 287 | 288 | This prevents someone from monopolizing all the worker threads by 289 | pipelining an unbounded number of requests. 290 | 291 | -- NOTE: this dies with out printing anything if Pc.Bounded is too 292 | -- small compared to the number of incoming connections. 293 | -} 294 | simpleServe4 :: HostPreference 295 | -> ServiceName 296 | -> (Request -> Pp.Parser ByteString IO (Either Pa.ParsingError (Response IO))) 297 | -> IO () 298 | simpleServe4 hp port handler = 299 | do -- create work queue 300 | (output, input) <- Pc.spawn (Pc.Bounded 1024) 301 | 302 | -- start worker threads 303 | as <- forM [1..16] $ \i -> 304 | async $ (runEffect $ Pc.fromInput input >-> worker output i) `E.finally` 305 | (putStrLn ("worker exited: " ++ show i) >> performGC) 306 | 307 | -- bind to socket 308 | x@(lsock, _) <- NS.bindSock hp port 309 | N.listen lsock 16 310 | 311 | -- accept connections and add work to the queue 312 | runEffect $ ((liftIO $ N.accept lsock) >>= \(csock, sockAddr) -> return (InOutClose (fromSocket csock 4096) (socketResponse csock) (NS.closeSock csock))) >~ 313 | (Pc.toOutput output) 314 | 315 | -- runEffect $ ((((liftIO $ N.accept lsock) `E.catch` (\e -> putStrLn "accept failed." >> E.throwIO (e :: Ps.SomeException))) >>= \(csock, sockAddr) -> return (InOutClose (fromSocket csock 4096) (socketResponse csock) (NS.closeSock csock))) `E.catch` (\e -> print (e :: Ps.SomeException) >> E.throwIO e) 316 | -- >~ Pc.toOutput output) `E.finally` (putStrLn "closing listening socket." >> N.close lsock) 317 | 318 | return () 319 | 320 | where 321 | worker :: Output (InOutClose Pa.ParsingError IO) -> Int -> Consumer' (InOutClose Pa.ParsingError IO) IO () 322 | worker output i = forever $ (do 323 | -- liftIO $ putStrLn $ show (i :: Int) ++ " waiting." 324 | triple <- await 325 | -- liftIO $ putStrLn $ show (i :: Int) ++ " processing." 326 | ((mErr, done), contP) <- lift $ Pp.runStateT (simpleOne (outResponse triple) handler) (inByteString triple) 327 | liftIO $ if done 328 | then do closeIt triple 329 | else do STM.atomically $ Pc.send output (triple { inByteString = contP }) 330 | threadDelay 10 -- this is just for testing to make it easier to see that the work is being handled by multiple workers for a single persistent connection. 331 | return ()) `Ps.catch` (\e -> lift $ print (e :: Ps.SomeException)) 332 | -} 333 | {- 334 | 335 | What if we want to re-use the worker stuff from simpleServe4, but we 336 | want to use it with SSL and then listening socket is being passed in? 337 | 338 | -- note: this doesn't seem to handle burst connections well 339 | -- probably because we don't do the right thing with the left overs from simpleOne or something? 340 | p 341 | -} 342 | simpleServe5' :: RequestParser Pa.ParsingError IO 343 | -> Effect IO (InOutClose Pa.ParsingError IO) 344 | -> (Request -> Pp.Parser ByteString IO (Either Pa.ParsingError (Response IO))) 345 | -> IO () 346 | simpleServe5' parseRequest acceptor handler = 347 | do -- create work queue 348 | (output, input) <- Pc.spawn (Pc.Bounded 4) 349 | 350 | -- start worker threads 351 | as <- forM [1..3] $ \i -> 352 | async $ (runEffect $ Pc.fromInput input >-> worker output i) 353 | `E.finally` 354 | (putStrLn ("worker exited: " ++ show i) >> performGC) 355 | 356 | 357 | -- accept connections and add work to the queue 358 | runEffect $ acceptor >~ (Pc.toOutput output) 359 | 360 | -- runEffect $ ((((liftIO $ N.accept lsock) `E.catch` (\e -> putStrLn "accept failed." >> E.throwIO (e :: Ps.SomeException))) >>= \(csock, sockAddr) -> return (InOutClose (fromSocket csock 4096) (socketResponse csock) (NS.closeSock csock))) `E.catch` (\e -> print (e :: Ps.SomeException) >> E.throwIO e) 361 | -- >~ Pc.toOutput output) `E.finally` (putStrLn "closing listening socket." >> N.close lsock) 362 | 363 | return () 364 | 365 | where 366 | worker :: Output (InOutClose Pa.ParsingError IO) -> Int -> Consumer' (InOutClose Pa.ParsingError IO) IO () 367 | worker output i = forever $ (do 368 | -- liftIO $ putStrLn $ show (i :: Int) ++ " waiting." 369 | triple <- await 370 | -- liftIO $ putStrLn $ show (i :: Int) ++ " processing." 371 | ((mErr, done), p) <- lift $ Pp.runStateT (simpleOne parseRequest (outResponse triple) handler) (inByteString triple) 372 | liftIO $ if done 373 | then do closeIt triple 374 | else do STM.atomically $ Pc.send output (triple { inByteString = p }) 375 | -- threadDelay 10 -- this is just for testing to make it easier to see that the work is being handled by multiple workers for a single persistent connection. 376 | return () 377 | return ()) `Ps.catch` (\e -> lift $ print (e :: Ps.SomeException)) 378 | 379 | simpleServe5 :: RequestParser Pa.ParsingError IO 380 | -> HostPreference 381 | -> ServiceName 382 | -> (Request -> Pp.Parser ByteString IO (Either Pa.ParsingError (Response IO))) 383 | -> IO () 384 | simpleServe5 parseRequest hp port handler = 385 | do -- bind to socket 386 | x@(lsock, _) <- NS.bindSock hp port 387 | N.listen lsock 16 388 | let acceptor = lift $ (liftIO $ N.accept lsock) >>= \(csock, sockAddr) -> return (InOutClose (fromSocket csock 4096) (socketResponse csock) (NS.closeSock csock)) 389 | simpleServe5' parseRequest acceptor handler 390 | return () 391 | 392 | {- 393 | can we use our pure 'simpleRequest' ? 394 | 395 | Note that due to the way >~ works, a copy of the triple will be passed 396 | to each worker - so even though we only appear yield once, we will 397 | actually yield as many times as we have workers 398 | ? 399 | -} 400 | {- 401 | simpleServe6 :: a 402 | -> b 403 | -> (Request -> Pp.Parser ByteString IO (Either Pa.ParsingError (Response IO))) 404 | -> IO () 405 | simpleServe6 _ _ handler = 406 | let triple = InOutClose { inByteString = yield simpleRequest 407 | , outResponse = stdoutResponse 408 | , closeIt = return () 409 | } 410 | in simpleServe5' (return triple) handler 411 | -} 412 | {- 413 | {- 414 | 415 | How can we add throttling? Limit to n reqs/second? 416 | p 417 | What does that even mean ? Do we accept up to n connections per second and then wait? Or accept a connection only every (second/n)? 418 | 419 | -} 420 | 421 | simpleServe7 :: a 422 | -> b 423 | -> (Request -> Pp.Parser ByteString IO (Either Pa.ParsingError (Response IO))) 424 | -> IO () 425 | simpleServe7 _ _ handler = 426 | let triple = InOutClose { inByteString = yield simpleRequest 427 | , outResponse = stdoutResponse 428 | , closeIt = return () 429 | } 430 | in simpleServe5' (return triple) handler 431 | 432 | 433 | -} 434 | 435 | serveTest :: IO () 436 | serveTest = simpleServe5 (Pa.parse requestParser) HostAny "8000" hello 437 | 438 | -------------------------------------------------------------------------------- /hyperdrive/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014, Jeremy Shaw 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Jeremy Shaw nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /hyperdrive/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Hyperdrive.Simple 4 | 5 | -- TODO: the reference parser should probably use a free monad with different interpreters instead of classes 6 | 7 | main = serveTest 8 | -------------------------------------------------------------------------------- /hyperdrive/Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /hyperdrive/hyperdrive.cabal: -------------------------------------------------------------------------------- 1 | Name: hyperdrive 2 | Version: 0.5.0.1 3 | Synopsis: a fast, trustworthy HTTP(s) server built 4 | Description: hyperdrive aims to provide an HTTP server which is not only 5 | extremely fast, but also provides a high-level of proof that 6 | its implementation is correct. 7 | . 8 | hyperdrive is still in alpha and not at all suitable for 9 | use. The current implementation is relatively fast, but does 10 | not yet use any of the techniques for proof-of-correctness. It 11 | also does not implement many essential features yet. 12 | License: BSD3 13 | License-file: LICENSE 14 | Author: Jeremy Shaw 15 | Maintainer: jeremy@n-heptane.com 16 | Copyright: 2012 Jeremy Shaw 17 | Category: Web 18 | Build-type: Simple 19 | Cabal-version: >=1.6 20 | 21 | source-repository head 22 | type: git 23 | location: https://github.com/stepcut/hyperdrive.git 24 | 25 | Library 26 | Exposed-modules: Hyperdrive.Serve 27 | Hyperdrive.Simple 28 | Build-depends: base > 4.6 && <5, 29 | async >= 2.0 && < 2.3, 30 | attoparsec >= 0.11 && < 0.14, 31 | bytestring >= 0.10 && < 0.11, 32 | case-insensitive >= 1.1 && < 1.3, 33 | exceptions >= 0.6 && < 0.11, 34 | http-types >= 0.8 && < 0.13, 35 | hyperdrive-core, 36 | hyperdrive-parser-abnf, 37 | lens-family-core >= 1.0 && < 1.3, 38 | mtl >= 2.1 && < 2.3, 39 | network >= 2.4 && < 2.9, 40 | network-simple >= 0.3 && < 0.5, 41 | pipes >= 4.0 && < 4.4, 42 | pipes-attoparsec >= 0.5 && < 0.6, 43 | pipes-bytestring >= 2.1 && < 2.2, 44 | pipes-concurrency >= 2.0 && < 2.1, 45 | pipes-parse >= 3.0 && < 3.1, 46 | pipes-network >= 0.6.2 && < 0.7, 47 | pipes-safe >= 2.2 && < 2.3, 48 | SafeSemaphore >= 0.10 && < 0.11, 49 | stm >= 2.4 && < 2.5, 50 | text >= 0.11 && < 1.3 51 | GHC-Options: -O2 52 | 53 | Executable pong 54 | Main-Is: Pong.hs 55 | GHC-Options: -threaded -O2 -rtsopts 56 | Buildable: False 57 | 58 | benchmark hyperdrive-benchmark 59 | type: exitcode-stdio-1.0 60 | Hs-source-dirs: bench . 61 | Main-is: Criterion.hs 62 | build-depends: criterion 63 | GHC-Options: -threaded -O2 64 | 65 | 66 | Test-Suite hyperdrive-test 67 | type: detailed-0.9 68 | test-module: Test.Hyperdrive 69 | build-depends: base, 70 | Cabal >= 1.9.2 71 | --------------------------------------------------------------------------------