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