http-pony-serve-wai (empty) → 0.1.0.0
raw patch · 8 files changed
+260/−0 lines, 8 filesdep +attoparsecdep +basedep +blaze-buildersetup-changed
Dependencies added: attoparsec, base, blaze-builder, bytestring, case-insensitive, http-types, network, pipes, pipes-bytestring, transformers, wai
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- http-pony-serve-wai.cabal +38/−0
- src/Network/HTTP/Pony/Serve/Wai.hs +105/−0
- src/Network/HTTP/Pony/Serve/Wai/Helper.hs +7/−0
- src/Network/HTTP/Pony/Serve/Wai/Parser.hs +54/−0
- src/Network/HTTP/Pony/Serve/Wai/Type.hs +19/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for http-pony-serve-wai++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Jinjing Wang++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jinjing Wang nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ http-pony-serve-wai.cabal view
@@ -0,0 +1,38 @@+-- Initial http-pony.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: http-pony-serve-wai+version: 0.1.0.0+synopsis: Serve a WAI application with http-pony+-- description: +license: BSD3+license-file: LICENSE+author: Jinjing Wang+maintainer: nfjinjing@gmail.com+-- copyright: +category: Network+build-type: Simple+extra-source-files: ChangeLog.md+cabal-version: >=1.10++library+ exposed-modules: Network.HTTP.Pony.Serve.Wai+ , Network.HTTP.Pony.Serve.Wai.Parser+ , Network.HTTP.Pony.Serve.Wai.Helper+ , Network.HTTP.Pony.Serve.Wai.Type+ -- other-modules: + -- other-extensions: OverloadedStrings+ build-depends: base >=4.9 && <4.10+ , attoparsec >=0.13+ , blaze-builder+ , bytestring >=0.10 && <0.11+ , case-insensitive+ , http-types+ , network+ , pipes >=4.1+ , pipes-bytestring+ , transformers >=0.5+ , wai++ hs-source-dirs: src+ default-language: Haskell2010
+ src/Network/HTTP/Pony/Serve/Wai.hs view
@@ -0,0 +1,105 @@+-- | Wai++{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Pony.Serve.Wai where++import Blaze.ByteString.Builder (toLazyByteString)+import Data.Attoparsec.ByteString (parse, eitherResult)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Semigroup+import qualified Network.Wai as Wai+import Network.Wai.Internal hiding (Request, Response)+import Pipes (yield, for, next)+import Pipes.ByteString (fromLazy)+import qualified Network.HTTP.Types as HTTP++import Network.HTTP.Pony.Serve.Wai.Helper ((-))+import Network.HTTP.Pony.Serve.Wai.Parser+import Network.HTTP.Pony.Serve.Wai.Type+import Prelude hiding ((-))++parseRequest :: Request ByteString IO a -> IO (Either String Wai.Request)+parseRequest (requestLine, headers, body) = do+ bodyRef <- newIORef (Just body)++ let eitherRequest =+ do+ (method, uri, version) <- eitherResult (parse requestLineTokens requestLine)+ (pathInfo, queryString) <- parseRequestURITokens uri++ pure - Wai.defaultRequest+ {+ requestMethod = method+ , httpVersion = version+ , rawPathInfo = pathInfo+ , requestHeaders = headers+ , rawQueryString = queryString+ , requestBody = do+ bodyC <- readIORef bodyRef+ case bodyC of+ Just _body -> do+ r <- next _body+ case r of+ Right (x, bodyC) -> do+ writeIORef bodyRef (Just bodyC)+ pure x++ _ -> do+ writeIORef bodyRef Nothing+ pure mempty++ _ -> pure mempty+ }++ pure (eitherRequest :: Either String Wai.Request)+++++fromWAI :: ( Wai.Request+ -> (Wai.Response -> IO ResponseReceived)+ -> IO ResponseReceived+ ) -> App+fromWAI app r = do+ eitherWaiRequest <- parseRequest r+ case eitherWaiRequest of+ Right waiRequest -> do+ let waiC :: (Wai.Response -> IO ResponseReceived) -> IO ResponseReceived+ waiC = app waiRequest++ responseRef <- newIORef Nothing++ let callback :: HTTP.HttpVersion -> Wai.Response -> IO ResponseReceived+ callback version waiResponse = do+ let (HTTP.Status code message) = Wai.responseStatus waiResponse+ headers = Wai.responseHeaders waiResponse+ responseLine =+ B.pack (show version)+ <> " "+ <> B.pack (show code)+ <> " "+ <> message++ case waiResponse of+ ResponseBuilder _ _ builder -> do++ let p = fromLazy (toLazyByteString builder)+ writeIORef responseRef (Just (responseLine, headers, p))+ pure ResponseReceived+ _ -> do+ pure ResponseReceived++ waiC - callback (httpVersion waiRequest)++ maybeResponse <- readIORef responseRef++ case maybeResponse of+ Just response -> do+ pure response+ _ -> do+ pure mempty+ Left err -> do+ pure mempty
+ src/Network/HTTP/Pony/Serve/Wai/Helper.hs view
@@ -0,0 +1,7 @@+-- | Helper++module Network.HTTP.Pony.Serve.Wai.Helper where++infixr 0 -+f - x = f x+
+ src/Network/HTTP/Pony/Serve/Wai/Parser.hs view
@@ -0,0 +1,54 @@+-- | Parser++{-# LANGUAGE OverloadedStrings #-}++module Network.HTTP.Pony.Serve.Wai.Parser where++import Data.Attoparsec.ByteString (Parser)+import qualified Data.Attoparsec.ByteString.Char8 as Char+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as B+import qualified Data.CaseInsensitive as CI+import Data.Char (ord)+import qualified Network.HTTP.Types as HTTP+import Pipes (Producer)++type RequestURI = ByteString++requestLineTokens :: Parser (HTTP.Method, RequestURI, HTTP.HttpVersion)+requestLineTokens = do+ method <- Char.takeTill (== ' ')+ Char.char ' '+ requestURI <- Char.takeTill (== ' ')+ Char.char ' '+ Char.string "HTTP/"++ let minusZero = (+) (- ord '0')+ charToInt = minusZero . ord+ digit = fmap charToInt Char.digit++ httpVersionMajor<- digit+ Char.char '.'+ httpVersionMinor <- digit++ pure (method, requestURI, HTTP.HttpVersion httpVersionMajor httpVersionMinor)++-- requestURITokens :: Parser (ByteString, ByteString)+-- requestURITokens = do+-- ( (,) <$> Char.takeTill (== '?')+-- <*> (Char.char '?' >> takeByteString)+-- )++-- <|>++-- ( (,) <$> takeByteString+-- <*> pure mempty+-- )++parseRequestURITokens :: ByteString -> Either String (ByteString, ByteString)+parseRequestURITokens x = pure $+ let pathInfo = B.takeWhile (/= '?') x+ queryString = B.dropWhile (== '?') . B.dropWhile (/= '?') $ x+ in++ (pathInfo, queryString)
+ src/Network/HTTP/Pony/Serve/Wai/Type.hs view
@@ -0,0 +1,19 @@+module Network.HTTP.Pony.Serve.Wai.Type where+++import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI)+import Network.Socket (Socket)+import Pipes (Producer)++type StartLine = ByteString+type Header = (CI ByteString, ByteString)++type Message a m r = (StartLine, [Header], Producer a m r)++type Request a m r = Message a m r+type Response a m r = Message a m r++-- App shouldn't block!+type Application m a b c d = Request a m c -> m (Response b m d)+type App = Application IO ByteString ByteString () ()