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.HTTP.Types as HTTP
import qualified Network.Wai as Wai
import Network.Wai.Internal (Response(ResponseBuilder)
, ResponseReceived(ResponseReceived))
import Pipes (next)
import Pipes.ByteString (fromLazy)
import Network.HTTP.Pony.Serve.Wai.Helper (())
import Network.HTTP.Pony.Serve.Wai.Parser (parseRequestURITokens)
import Network.HTTP.Pony.Serve.Wai.Type (Request, Response, App)
import Prelude hiding (())
parseRequest :: Request -> IO Wai.Request
parseRequest (((method, uri, version), headers), body) = do
bodyRef <- newIORef (Just body)
let (rawPathInfo, rawQueryString) = parseRequestURITokens uri
(pathInfo, queryString) = HTTP.decodePath uri
pure Wai.defaultRequest
{
Wai.requestMethod = method
, Wai.httpVersion = version
, Wai.rawPathInfo = rawPathInfo
, Wai.rawQueryString = rawQueryString
, Wai.requestHeaders = headers
, Wai.pathInfo = pathInfo
, Wai.queryString = queryString
, Wai.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
}
fromWAI :: ( Wai.Request
-> (Wai.Response -> IO ResponseReceived)
-> IO ResponseReceived
) -> App
fromWAI app r = do
waiRequest <- parseRequest r
let waiC :: (Wai.Response -> IO ResponseReceived) -> IO ResponseReceived
waiC = app waiRequest
responseRef <- newIORef Nothing
let version = Wai.httpVersion waiRequest
let callback :: Wai.Response -> IO ResponseReceived
callback waiResponse = do
let status = Wai.responseStatus waiResponse
headers = Wai.responseHeaders waiResponse
responseLine = (version, status)
case waiResponse of
ResponseBuilder _ _ builder -> do
let p = fromLazy (toLazyByteString builder)
writeIORef responseRef (Just ((responseLine, headers), p))
pure ResponseReceived
_ -> do
pure ResponseReceived
waiC callback
maybeResponse <- readIORef responseRef
case maybeResponse of
Just response -> do
pure response
_ -> do
pure (((version, HTTP.status500), mempty), mempty)