HTTP 4000.2.13 → 4000.2.14
raw patch · 3 files changed
+115/−2 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- HTTP.cabal +4/−1
- Network/Browser.hs +1/−1
- test/Httpd.hs +110/−0
HTTP.cabal view
@@ -1,5 +1,5 @@ Name: HTTP-Version: 4000.2.13+Version: 4000.2.14 Cabal-Version: >= 1.8 Build-type: Simple License: BSD3@@ -54,6 +54,7 @@ Flag warn-as-error default: False description: Build with warnings-as-errors+ manual: True Flag network23 description: Use version 2.3.x or below of the network package@@ -108,6 +109,8 @@ hs-source-dirs: test main-is: httpTests.hs++ other-modules: Httpd -- note: version constraints are inherited from HTTP library stanza build-depends: HTTP,
Network/Browser.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP #-}+{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP, FlexibleContexts #-} {- | Module : Network.Browser
+ test/Httpd.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE CPP #-}++module Httpd+ ( Request, Response, Server+ , mkResponse+ , reqMethod, reqURI, reqHeaders, reqBody+ , shed, warp+ )+ where++import Control.Applicative+import Control.Arrow ( (***) )+import Control.DeepSeq+import Control.Monad+import Control.Monad.Trans ( lift )+import Data.ByteString as B ( empty, concat, length, ByteString )+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,+ reqURI :: URI,+ reqHeaders :: [(String, String)],+ reqBody :: String+ }++data Response = Response+ {+ respStatus :: Int,+ respHeaders :: [(String, String)],+ respBody :: String+ }++mkResponse :: Int -> [(String, String)] -> String -> Response+mkResponse = Response++type Server = Int -> (Request -> IO Response) -> IO ()++shed :: Server+shed port handler =+ () <$ Shed.initServer+ port+ (liftM responseToShed . handler . requestFromShed)+ where+ responseToShed (Response status hdrs body) =+ Shed.Response status hdrs body+ chomp = reverse . strip '\r' . reverse+ strip c (c':str) | c == c' = str+ strip c str = str+ requestFromShed request =+ Request+ {+ reqMethod = Shed.reqMethod request,+ reqURI = Shed.reqURI request,+ reqHeaders = map (id *** chomp) $ Shed.reqHeaders request,+ reqBody = Shed.reqBody request+ }++#if !MIN_VERSION_bytestring(0,10,0)+instance NFData B.ByteString where+ rnf = rnf . B.length+#endif++warp :: Server+warp port handler =+ Warp.run port $ \warpRequest -> do+ request <- requestFromWarp warpRequest+ response <- 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)+ body `deepseq` return ()+ 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)+ }