Wai.hs

-- | 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.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
                                                    , requestLineTokens)
import           Network.HTTP.Pony.Serve.Wai.Type (Request, Response, App)
import           Prelude hiding ((-))



parseRequest :: Request -> 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
                  {
                    Wai.requestMethod = method
                  , Wai.httpVersion = version
                  , Wai.rawPathInfo = pathInfo
                  , Wai.requestHeaders = headers
                  , Wai.rawQueryString = 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
                  }

  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 (Wai.httpVersion waiRequest)

      maybeResponse <- readIORef responseRef

      case maybeResponse of
        Just response -> do
          pure response
        _ -> do
          pure mempty
    Left err -> do
      pure mempty