Permalink
Browse files

Moving towards being an adapter

  • Loading branch information...
1 parent 6093fb4 commit dae81f3b848b42997f75f5581f1ea8ffbfc555a4 @hsenag hsenag committed Apr 30, 2012
Showing with 29 additions and 7 deletions.
  1. +24 −2 test/Httpd.hs
  2. +5 −5 test/httpTests.hs
View
@@ -5,9 +5,31 @@ module Httpd
)
where
-import Network.Shed.Httpd
+import Control.Applicative
+import Network.URI ( URI )
+
+import qualified Network.Shed.Httpd as Shed
( Request, Response(Response), initServer
, reqMethod, reqURI, reqHeaders, reqBody
)
-mkResponse = Response
+type Request = Shed.Request
+type Response = Shed.Response
+
+mkResponse :: Int -> [(String, String)] -> String -> Response
+mkResponse = Shed.Response
+
+initServer :: Int -> (Request -> IO Response) -> IO ()
+initServer port handler = () <$ Shed.initServer port handler
+
+reqMethod :: Request -> String
+reqMethod = Shed.reqMethod
+
+reqURI :: Request -> URI
+reqURI = Shed.reqURI
+
+reqHeaders :: Request -> [(String, String)]
+reqHeaders = Shed.reqHeaders
+
+reqBody :: Request -> String
+reqBody = Shed.reqBody
View
@@ -560,17 +560,17 @@ main = do
case args of
["server"] -> do -- run only the harness servers for diagnostic/debug purposes
-- halt on any keypress
- _ <- forkIO (() <$ Httpd.initServer portNum processRequest)
- _ <- forkIO (() <$ Httpd.initServer altPortNum altProcessRequest)
+ _ <- forkIO $ Httpd.initServer portNum processRequest
+ _ <- forkIO $ Httpd.initServer altPortNum altProcessRequest
_ <- getChar
return ()
("--withport80":args) -> do
- _ <- forkIO (() <$ Httpd.initServer portNum processRequest)
- _ <- forkIO (() <$ Httpd.initServer altPortNum altProcessRequest)
+ _ <- forkIO $ Httpd.initServer portNum processRequest
+ _ <- forkIO $ Httpd.initServer altPortNum altProcessRequest
_ <- threadDelay 1000000 -- Give the server time to start :-(
defaultMainWithArgs (tests True) args
args -> do -- run the test harness as normal
- _ <- forkIO (() <$ Httpd.initServer portNum processRequest)
+ _ <- forkIO $ Httpd.initServer portNum processRequest
_ <- threadDelay 1000000 -- Give the server time to start :-(
defaultMainWithArgs (tests False) args

0 comments on commit dae81f3

Please sign in to comment.