Wai.hs

{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE TypeSynonymInstances #-}


-- | Backend of accessing a wai server:
module Servant.Subscriber.Backend.Wai where

import qualified Blaze.ByteString.Builder      as B
import           Control.Concurrent.STM        (STM, atomically, retry)
import           Control.Concurrent.STM.TVar
import           Control.Monad                 (void)
import           Data.Aeson
import qualified Data.ByteString               as BS
import qualified Data.CaseInsensitive          as Case
import           Data.IntMap                   (IntMap)
import qualified Data.IntMap                   as IntMap
import           Data.IORef
import           Data.Map                      (Map)
import           Data.Text                     (Text)
import qualified Data.Text.Encoding            as T
import           Data.Time
import           GHC.Generics
import qualified Network.HTTP.Types            as H
import qualified Network.Wai                   as Wai
import qualified Network.Wai.Internal          as Wai
import           Network.WebSockets.Connection as WS
import           Servant.Server

import           Servant.Subscriber.Backend
import           Servant.Subscriber.Request    as Req
import           Servant.Subscriber.Response   as Res
import           Servant.Subscriber.Types



instance Backend Wai.Application where
  requestResource app req sendResponse = do
      waiReq <- toWaiRequest req
      app waiReq (waiSendResponse sendResponse)
      return ResponseReceived

waiSendResponse :: (HttpResponse -> IO ResponseReceived) -> Wai.Response -> IO Wai.ResponseReceived
waiSendResponse sendResponse = fmap fixResponse . sendResponse . fromWaiResponse
  where fixResponse = const Wai.ResponseReceived

toWaiRequest :: HttpRequest -> IO Wai.Request
toWaiRequest r = do
  waiBody <- mkWaiRequestBody encodedBody
  return Wai.defaultRequest {
      Wai.requestMethod = T.encodeUtf8 . httpMethod $ r
    , Wai.pathInfo = toSegments . httpPath $ r
    , Wai.rawPathInfo = B.toByteString . H.encodePathSegments . toSegments . httpPath $ r
    , Wai.queryString = H.queryTextToQuery . httpQuery $ r
    , Wai.rawQueryString = B.toByteString . H.renderQueryText True . httpQuery $ r
    , Wai.requestHeaders = toHTTPHeaders . Req.httpHeaders $ r
    , Wai.requestBody = waiBody
    , Wai.requestBodyLength = Wai.KnownLength . fromIntegral . BS.length $ encodedBody
    }
  where
    encodedBody = B.toByteString . fromEncoding . toEncoding . Req.httpBody $ r

mkWaiRequestBody :: BS.ByteString -> IO (IO BS.ByteString)
mkWaiRequestBody b = do
  var <- newIORef b
  return $ do
    val <- readIORef var
    writeIORef var BS.empty
    return val


fromWaiResponse :: Wai.Response -> HttpResponse
fromWaiResponse (Wai.ResponseBuilder status headers builder)= HttpResponse {
      httpStatus      = fromHTTPStatus status
    , Res.httpHeaders = fromHTTPHeaders headers
    , Res.httpBody    = ResponseBody builder
    }
fromWaiResponse _ = error "I am sorry - this 'Response' type is not yet implemented in servant-subscriber!"