erikd
commented
12 years ago {-# LANGUAGE OverloadedStrings #-}
import Blaze.ByteString.Builder
import Control.Concurrent (forkIO, killThread)
import Control.Monad (unless)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Resource
import Data.ByteString (ByteString)
import Data.Conduit (($$))
import Data.String
import Network.HTTP.Types
import Network.TLS
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Handler.WarpTLS
import System.Environment
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit as DC
import qualified Data.Conduit.Binary as CB
import qualified Network.HTTP.Conduit as HC
import qualified Network.HTTP.Types as HT
main :: IO ()
main = do
opts <- getArgs
case opts of
["tls"] -> runTest True
_ -> runTest False
runTest :: Bool -> IO ()
runTest tls = runResourceT $ do
let (proto, testFunc) = if tls
then ("https", runTestServerTLS)
else ("http", runTestServer)
let testServerPort = 3030
_ <- allocate (forkIO $ testFunc testServerPort) killThread
let url = proto ++ "://localhost:" ++ show testServerPort ++ "/"
request <- lift $ HC.parseUrl url
direct@(Result _ _ hdrs _) <- httpRun request
let isWarp =
case lookup "server" hdrs of
Just s -> BS.isPrefixOf "Warp" s
Nothing -> False
unless isWarp $ error "No 'Server: Warp' header."
liftIO $ printResult direct
--------------------------------------------------------------------------------
runTestServer :: Int -> IO ()
runTestServer port = do
let settings = defaultSettings { settingsPort = port, settingsHost = "*6" }
putStrLn "runTestServer"
runSettings settings serverApp
runTestServerTLS :: Int -> IO ()
runTestServerTLS port = do
let settings = defaultSettings { settingsPort = port, settingsHost = "*6" }
tlsSettings = TLSSettings "test/certificate.pem" "test/key.pem"
putStrLn "runTestServerTLS"
runTLS tlsSettings settings serverApp
serverApp :: Request -> ResourceT IO Response
serverApp req= do
liftIO $ putStrLn "serverApp"
let text = BS.concat
[ " Method : " , requestMethod req , "\n"
, " HTTP Version : " , fromString (show (httpVersion req)) , "\n"
, " Path Info : " , rawPathInfo req , "\n"
, " Query String : " , rawQueryString req , "\n"
, " Server Name : " , serverName req , "\n"
, " Server Port : " , fromString (show (serverPort req)), "\n"
, " Secure (SSL) : " , fromString (show (isSecure req)), "\n"
, " Request Headers :\n\n"
, headerShow (requestHeaders req)
, "\n"
]
let respHeaders =
[ (hContentType, "text/plain")
, (hContentLength, fromString $ show $ BS.length text)
]
let responseBS s h = ResponseBuilder s h . fromByteString
return $ responseBS status200 respHeaders text
headerShow :: [HT.Header] -> ByteString
headerShow headers =
BS.concat $ map hdrShow headers
where
hdrShow (f, v) = BS.concat [ " ", CI.original f , ": " , v, "\n" ]
-- | Use HC.http to fullfil a HC.Request. We need to wrap it because the
-- Response contains a Source which we need to read to generate our result.
httpRun :: HC.Request (ResourceT IO) -> ResourceT IO Result
httpRun req = liftIO $ withManagerSettings settings $ \mgr -> do
liftIO $ dumpHttpConduitRequest req
HC.Response st hver hdrs bdyRes <- HC.http req mgr
(bdy, finalizer) <- DC.unwrapResumable bdyRes
bodyText <- bdy $$ CB.take 8192
finalizer
return $ Result (HT.statusCode st) hver hdrs $ BS.concat $ LBS.toChunks bodyText
where
settings = HC.def { HC.managerCheckCerts = \ _ _ -> return CertificateUsageAccept }
data Result = Result Int HT.HttpVersion [HT.Header] ByteString
printResult :: Result -> IO ()
printResult (Result status _ headers body) = do
putStrLn $ "Status : " ++ show status
putStrLn "Headers :"
BS.putStr $ headerShow headers
putStrLn "Body :"
BS.putStrLn body
dumpHttpConduitRequest :: HC.Request m -> IO ()
dumpHttpConduitRequest req =
let text = BS.concat
[ "------- HttpConduit Request ------------------------------------------------------\n"
, "Method : " , HC.method req , "\n"
, "Secure (SSL) : " , fromString (show (HC.secure req)), "\n"
, "Host Name : " , HC.host req , "\n"
, "Host Port : " , fromString (show (HC.port req)), "\n"
, "Path : " , HC.path req , "\n"
, "Query String : " , HT.urlDecode False (HC.queryString req), "\n"
, "Request Headers :\n"
, headerShow (HC.requestHeaders req), "\n"
]
in BS.putStr text
withManagerSettings :: HC.ManagerSettings -> (HC.Manager -> ResourceT IO a) -> IO a
withManagerSettings settings f = runResourceT $ do
(_, manager) <- allocate (HC.newManager settings) HC.closeManager
f manager
snoyberg
iquiw
quetz
malthe
I was having some troubles with warp-tls giving me a "data: end of file" failure.
I tried debugging this myself, but wasn't able to make much progress. However, during my debugging I came up with a (relatively) simple test program that shows the problem (I'll add it as an attachment, warp-tls-test.hs).
When the test program is run as:
it sets up a warp server with a simple WAI Application and uses http-conduit read from the server. This works as expected.
However, when the test program is run as:
it sets up a warp-tls server instead of a warp server and uses http-conduit to access the server using HTTPS instead of HTTP. This fails.
My debugging suggests that the failure occurs when warp-tls is parsing the HTTP request, but I'm not making much progress debugging this further.