From f06b3eacadaae0325a6a7fd4873bb64d477bdc45 Mon Sep 17 00:00:00 2001
From: Ganesh Sittampalam <ganesh@earth.li>
Date: Tue, 1 May 2012 20:00:04 +0100
Subject: [PATCH] Add warp server to test harness

---
 HTTP.cabal    |  7 +++++++
 test/Httpd.hs | 47 +++++++++++++++++++++++++++++++++++++++++++++--
 2 files changed, 52 insertions(+), 2 deletions(-)

diff --git a/HTTP.cabal b/HTTP.cabal
index 4d71fa4..682ac66 100644
--- a/HTTP.cabal
+++ b/HTTP.cabal
@@ -103,6 +103,13 @@ Test-Suite test
   build-depends:     HTTP,
                      HUnit,
                      httpd-shed,
+                     mtl >= 2.0 && < 2.2,
+                     bytestring >= 0.9 && < 0.10,
+                     case-insensitive >= 0.4 && < 0.5,
+                     http-types >= 0.6 && < 0.7,
+                     conduit >= 0.4 && < 0.5,
+                     wai >= 1.2 && < 1.3,
+                     warp >= 1.2 && < 1.3,
                      base >= 2 && < 4.6,
                      network,
                      split >= 0.1 && < 0.2,
diff --git a/test/Httpd.hs b/test/Httpd.hs
index 2ffae20..b70ff9d 100644
--- a/test/Httpd.hs
+++ b/test/Httpd.hs
@@ -2,19 +2,35 @@ module Httpd
     ( Request, Response, Server
     , mkResponse
     , reqMethod, reqURI, reqHeaders, reqBody
-    , shed
+    , shed, warp
     )
     where
 
 import Control.Applicative
 import Control.Monad
-import Network.URI ( URI )
+import Control.Monad.Trans ( lift )
+import Data.ByteString as B ( empty, concat )
+import Data.ByteString.Char8 as BC ( pack, unpack )
+import Data.ByteString.Lazy.Char8 as BLC ( pack )
+import qualified Data.CaseInsensitive as CI ( mk, original )
+import Data.Maybe ( fromJust )
+import Network.URI ( URI, parseRelativeReference )
 
 import qualified Network.Shed.Httpd as Shed
     ( Request, Response(Response), initServer
     , reqMethod, reqURI, reqHeaders, reqBody
     )
 
+import qualified Data.Conduit.Lazy as Warp
+    ( lazyConsume )
+import qualified Network.HTTP.Types as Warp
+    ( Status(..) )
+import qualified Network.Wai as Warp
+    ( Request(requestMethod, requestHeaders, rawPathInfo, requestBody)
+    , responseLBS )
+import qualified Network.Wai.Handler.Warp as Warp
+    ( run )
+
 data Request = Request
     {
      reqMethod :: String,
@@ -52,3 +68,30 @@ shed port handler =
           reqBody = Shed.reqBody request
          }
 
+warp :: Server
+warp port handler =
+    Warp.run port $ \warpRequest -> do
+       request <- requestFromWarp warpRequest
+       response <- lift $ handler request
+       return (responseToWarp response)
+  where
+     responseToWarp (Response status hdrs body) =
+         Warp.responseLBS
+                 (Warp.Status status B.empty)
+                 (map headerToWarp hdrs)
+                 (BLC.pack body)
+     headerToWarp (name, value) = (CI.mk (BC.pack name), BC.pack value)
+     headerFromWarp (name, value) =
+         (BC.unpack (CI.original name), BC.unpack value)
+     requestFromWarp request = do
+         body <- Warp.lazyConsume (Warp.requestBody request)
+         return $
+                Request
+                {
+                 reqMethod = BC.unpack (Warp.requestMethod request),
+                 reqURI = fromJust . parseRelativeReference .
+                          BC.unpack . Warp.rawPathInfo $
+                          request,
+                 reqHeaders = map headerFromWarp (Warp.requestHeaders request),
+                 reqBody = BC.unpack (B.concat body)
+                }
\ No newline at end of file