1{-# LANGUAGE CPP #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4import Test.Hspec
5import qualified Data.ByteString as S
6import qualified Data.ByteString.Char8 as S8
7import qualified Data.ByteString.Lazy.Char8 as L8
8import Test.HUnit
9import Network.Wai hiding (requestBody)
10import Network.Wai.Conduit (responseSource, sourceRequestBody)
11import Network.HTTP.Client (streamFile)
12import System.IO.Temp (withSystemTempFile)
13import qualified Network.Wai as Wai
14import Network.Wai.Handler.Warp (runSettings, defaultSettings, setPort, setBeforeMainLoop, Settings, setTimeout)
15import Network.HTTP.Conduit hiding (port)
16import qualified Network.HTTP.Conduit as NHC
17import Network.HTTP.Client.MultipartFormData
18import Control.Concurrent (forkIO, killThread, putMVar, takeMVar, newEmptyMVar, threadDelay)
19import Network.HTTP.Types
20import UnliftIO.Exception (try, SomeException, bracket, onException, IOException)
21import qualified Data.IORef as I
22import qualified Control.Exception as E (catch)
23import qualified Network.Socket as NS
24import CookieTest (cookieTest)
25#if MIN_VERSION_conduit(1,1,0)
26import Data.Conduit.Network (runTCPServer, serverSettings, appSink, appSource, ServerSettings)
27import Data.Streaming.Network (bindPortTCP, setAfterBind)
28#define bindPort bindPortTCP
29#else
30import Data.Conduit.Network (runTCPServer, serverSettings, HostPreference (..), appSink, appSource, bindPort, serverAfterBind, ServerSettings)
31#endif
32import qualified Data.Conduit.Network
33import System.IO.Unsafe (unsafePerformIO)
34import Data.Conduit ((.|), yield, Flush (Chunk, Flush), await, runConduit)
35import Control.Monad (void, forever)
36import Control.Monad.IO.Class (liftIO)
37import Data.ByteString.UTF8 (fromString)
38import Data.Conduit.List (sourceList)
39import Data.CaseInsensitive (mk)
40import Data.List (partition)
41import qualified Data.Conduit.List as CL
42import qualified Data.Text as T
43import qualified Data.Text.Encoding as TE
44import qualified Data.ByteString.Lazy as L
45import Blaze.ByteString.Builder (fromByteString)
46import System.IO
47import Data.Time.Clock
48import Data.Time.Calendar
49import qualified Network.Wai.Handler.WarpTLS as WT
50import Network.Connection (settingDisableCertificateValidation)
51import Data.Default.Class (def)
52#ifdef VERSION_aeson
53import qualified Data.Aeson as A
54#endif
55import qualified Network.HTTP.Simple as Simple
56import Data.Monoid (mempty)
57import Control.Monad.Trans.Resource (runResourceT)
58
59past :: UTCTime
60past = UTCTime (ModifiedJulianDay 56200) (secondsToDiffTime 0)
61
62future :: UTCTime
63future = UTCTime (ModifiedJulianDay 562000) (secondsToDiffTime 0)
64
65cookie :: Cookie
66cookie = Cookie { cookie_name = "key"
67                , cookie_value = "value"
68                , cookie_expiry_time = future
69                , cookie_domain = "127.0.0.1"
70                , cookie_path = "/dump_cookies"
71                , cookie_creation_time = past
72                , cookie_last_access_time = past
73                , cookie_persistent = False
74                , cookie_host_only = False
75                , cookie_secure_only = False
76                , cookie_http_only = False
77                }
78
79cookie_jar :: CookieJar
80cookie_jar = createCookieJar [cookie]
81
82app :: Wai.Request -> IO Wai.Response
83app req =
84    case pathInfo req of
85        [] ->
86            if maybe False ("example.com:" `S.isPrefixOf`) $ lookup "host" $ Wai.requestHeaders req
87                then return $ responseLBS status200 [] "homepage for example.com"
88                else return $ responseLBS status200 [] "homepage"
89        ["cookies"] -> return $ responseLBS status200 [tastyCookie] "cookies"
90        ["cookie_redir1"] -> return $ responseLBS status303 [tastyCookie, (hLocation, "/checkcookie")] ""
91        ["checkcookie"] -> return $ case lookup hCookie $ Wai.requestHeaders req of
92                                Just "flavor=chocolate-chip" -> responseLBS status200 [] "nom-nom-nom"
93                                _ -> responseLBS status412 [] "Baaaw where's my chocolate?"
94        ["infredir", i'] ->
95            let i = read $ T.unpack i' :: Int
96            in return $ responseLBS status303
97                    [(hLocation, S.append "/infredir/" $ S8.pack $ show $ i+1)]
98                    (L8.pack $ show i)
99        ["dump_cookies"] -> return $ responseLBS status200 [] $ L.fromChunks $ return $ maybe "" id $ lookup hCookie $ Wai.requestHeaders req
100        ["delayed"] -> return $ responseSource status200 [("foo", "bar")] $ do
101            yield Flush
102            liftIO $ threadDelay 30000000
103            yield $ Chunk $ fromByteString "Hello World!"
104        _ -> return $ responseLBS status404 [] "not found"
105
106    where tastyCookie = (mk (fromString "Set-Cookie"), fromString "flavor=chocolate-chip;")
107
108nextPort :: I.IORef Int
109nextPort = unsafePerformIO $ I.newIORef 15452
110{-# NOINLINE nextPort #-}
111
112getPort :: IO Int
113getPort = do
114    port <- I.atomicModifyIORef nextPort $ \p -> (p + 1, p + 1)
115    esocket <- try $ bindPort port "*4"
116    case esocket of
117        Left (_ :: IOException) -> getPort
118        Right socket -> do
119            NS.close socket
120            return port
121
122withApp :: (Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO ()
123withApp app' f = withApp' (const app') f
124
125withApp' :: (Int -> Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO ()
126withApp' = withAppSettings id
127
128withAppSettings :: (Settings -> Settings)
129                -> (Int -> Wai.Request -> IO Wai.Response)
130                -> (Int -> IO ())
131                -> IO ()
132withAppSettings modSettings app' f = do
133    port <- getPort
134    baton <- newEmptyMVar
135    bracket
136        (forkIO $ runSettings (modSettings $
137            setPort port
138            $ setBeforeMainLoop (putMVar baton ())
139              defaultSettings) (app'' port) `onException` putMVar baton ())
140        killThread
141        (const $ takeMVar baton >> f port)
142  where
143    app'' port req sendResponse = do
144        res <- app' port req
145        sendResponse res
146
147withAppTls :: (Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO ()
148withAppTls app' f = withAppTls' (const app') f
149
150withAppTls' :: (Int -> Wai.Request -> IO Wai.Response) -> (Int -> IO ()) -> IO ()
151withAppTls' app' f = do
152    port <- getPort
153    baton <- newEmptyMVar
154    bracket
155        (forkIO $ WT.runTLS WT.defaultTlsSettings (
156            setPort port
157            $ setBeforeMainLoop (putMVar baton ())
158              defaultSettings)
159            (app'' port) `onException` putMVar baton ())
160        killThread
161        (const $ takeMVar baton >> f port)
162  where
163    app'' port req sendResponse = do
164        res <- app' port req
165        sendResponse res
166
167main :: IO ()
168main = do
169  mapM_ (`hSetBuffering` LineBuffering) [stdout, stderr]
170  hspec $ do
171    cookieTest
172    describe "simpleHttp" $ do
173        it "gets homepage" $ withApp app $ \port -> do
174            lbs <- simpleHttp $ "http://127.0.0.1:" ++ show port
175            lbs @?= "homepage"
176        it "throws exception on 404" $ withApp app $ \port -> do
177            elbs <- try $ simpleHttp $ concat ["http://127.0.0.1:", show port, "/404"]
178            case elbs of
179                Left (HttpExceptionRequest _ StatusCodeException {}) -> return ()
180                _ -> error "Expected an exception"
181    describe "httpLbs" $ do
182        it "preserves 'set-cookie' headers" $ withApp app $ \port -> do
183            request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"]
184            manager <- newManager tlsManagerSettings
185            response <- httpLbs request manager
186            let setCookie = mk (fromString "Set-Cookie")
187                (setCookieHeaders, _) = partition ((== setCookie) . fst) (NHC.responseHeaders response)
188            assertBool "response contains a 'set-cookie' header" $ length setCookieHeaders > 0
189        it "redirects set cookies" $ withApp app $ \port -> do
190            request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookie_redir1"]
191            manager <- newManager tlsManagerSettings
192            response <- httpLbs request manager
193            (responseBody response) @?= "nom-nom-nom"
194        it "user-defined cookie jar works" $ withApp app $ \port -> do
195            request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]
196            manager <- newManager tlsManagerSettings
197            response <- httpLbs (request {redirectCount = 1, cookieJar = Just cookie_jar}) manager
198            (responseBody response) @?= "key=value"
199        it "user-defined cookie jar is not ignored when redirection is disabled" $ withApp app $ \port -> do
200            request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]
201            manager <- newManager tlsManagerSettings
202            response <- httpLbs (request {redirectCount = 0, cookieJar = Just cookie_jar}) manager
203            (responseBody response) @?= "key=value"
204        it "cookie jar is available in response" $ withApp app $ \port -> do
205            request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"]
206            manager <- newManager tlsManagerSettings
207            response <- httpLbs (request {cookieJar = Just Data.Monoid.mempty}) manager
208            (length $ destroyCookieJar $ responseCookieJar response) @?= 1
209        it "Cookie header isn't touched when no cookie jar supplied" $ withApp app $ \port -> do
210            request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/dump_cookies"]
211            manager <- newManager tlsManagerSettings
212            let request_headers = (mk "Cookie", "key2=value2") : filter ((/= mk "Cookie") . fst) (NHC.requestHeaders request)
213            response <- httpLbs (request {NHC.requestHeaders = request_headers, cookieJar = Nothing}) manager
214            (responseBody response) @?= "key2=value2"
215        it "Response cookie jar is nothing when request cookie jar is nothing" $ withApp app $ \port -> do
216            request <- parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/cookies"]
217            manager <- newManager tlsManagerSettings
218            response <- httpLbs (request {cookieJar = Nothing}) manager
219            (responseCookieJar response) @?= mempty
220        it "TLS" $ withAppTls app $ \port -> do
221            request <- parseUrlThrow $ "https://127.0.0.1:" ++ show port
222            let set = mkManagerSettings
223                    def
224                        { settingDisableCertificateValidation = True
225                        }
226                    Nothing
227            manager <- newManager set
228            response <- httpLbs request manager
229            responseBody response @?= "homepage"
230    describe "manager" $ do
231        it "closes all connections" $ withApp app $ \port1 -> withApp app $ \port2 -> do
232            --FIXME clearSocketsList
233            manager <- newManager tlsManagerSettings
234            let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port1
235            let Just req2 = parseUrlThrow $ "http://127.0.0.1:" ++ show port2
236            runResourceT $ do
237                _res1a <- http req1 manager
238                _res1b <- http req1 manager
239                _res2 <- http req2 manager
240                return ()
241            --FIXME requireAllSocketsClosed
242    describe "http" $ do
243        it "response body" $ withApp app $ \port -> do
244            manager <- newManager tlsManagerSettings
245            req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port
246            runResourceT $ do
247                res1 <- http req manager
248                bss <- runConduit $ responseBody res1 .| CL.consume
249                res2 <- httpLbs req manager
250                liftIO $ L.fromChunks bss `shouldBe` responseBody res2
251    describe "DOS protection" $ do
252        it "overlong headers" $ overLongHeaders $ \port -> do
253            manager <- newManager tlsManagerSettings
254            let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port
255            res1 <- try $ runResourceT $ http req1 manager
256            case res1 of
257              Left e -> show (e :: SomeException) @?= show (HttpExceptionRequest req1 OverlongHeaders)
258              _ -> error "Shouldn't have worked"
259        it "not overlong headers" $ notOverLongHeaders $ \port -> do
260            manager <- newManager tlsManagerSettings
261            let Just req1 = parseUrlThrow $ "http://127.0.0.1:" ++ show port
262            _ <- httpLbs req1 manager
263            return ()
264    describe "redirects" $ do
265        it "doesn't double escape" $ redir $ \port -> do
266            manager <- newManager tlsManagerSettings
267            let go (encoded, final) = do
268                    let Just req1 = parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/redir/", encoded]
269                    res <- httpLbs req1 manager
270                    liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200
271                    liftIO $ responseBody res @?= L.fromChunks [TE.encodeUtf8 final]
272            mapM_ go
273                [ ("hello world%2F", "hello world/")
274                , ("%D7%A9%D7%9C%D7%95%D7%9D", "שלום")
275                , ("simple", "simple")
276                , ("hello%20world", "hello world")
277                , ("hello%20world%3f%23", "hello world?#")
278                ]
279        it "TooManyRedirects: redirect request body is preserved" $ withApp app $ \port -> do
280            let Just req = parseUrlThrow $ concat ["http://127.0.0.1:", show port, "/infredir/0"]
281            let go (res, i) = liftIO $ responseBody res @?= (L8.pack $ show i)
282            manager <- newManager tlsManagerSettings
283            E.catch (void $ runResourceT $ http req{redirectCount=5} manager)
284              $ \e ->
285                    case e of
286                        HttpExceptionRequest _ (TooManyRedirects redirs) ->
287                            mapM_ go (zip redirs [5,4..0 :: Int])
288                        _ -> error $ show e
289    describe "chunked request body" $ do
290        it "works" $ echo $ \port -> do
291            manager <- newManager tlsManagerSettings
292            let go bss = do
293                    let Just req1 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port
294                        src = sourceList bss
295                        lbs = L.fromChunks bss
296                    res <- httpLbs req1
297                        { requestBody = requestBodySourceChunked src
298                        } manager
299                    liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200
300                    let ts = S.concat . L.toChunks
301                    liftIO $ ts (responseBody res) @?= ts lbs
302            mapM_ go
303                [ ["hello", "world"]
304                , replicate 500 "foo\003\n\r"
305                ]
306    describe "no status message" $ do
307        it "works" $ noStatusMessage $ \port -> do
308            req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port
309            manager <- newManager tlsManagerSettings
310            res <- httpLbs req manager
311            liftIO $ do
312                Network.HTTP.Conduit.responseStatus res `shouldBe` status200
313                responseBody res `shouldBe` "foo"
314
315    describe "response body too short" $ do
316        it "throws an exception" $ wrongLength $ \port -> do
317            req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port
318            manager <- newManager tlsManagerSettings
319            eres <- try $ httpLbs req manager
320            liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres
321             `shouldBe` Left (show $ HttpExceptionRequest req $ ResponseBodyTooShort 50 18)
322
323    describe "chunked response body" $ do
324        it "no chunk terminator" $ wrongLengthChunk1 $ \port -> do
325            req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port
326            manager <- newManager tlsManagerSettings
327            eres <- try $ httpLbs req manager
328            liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres
329             `shouldBe` Left (show (HttpExceptionRequest req IncompleteHeaders))
330        it "incomplete chunk" $ wrongLengthChunk2 $ \port -> do
331            req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port
332            manager <- newManager tlsManagerSettings
333            eres <- try $ httpLbs req manager
334            liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres
335             `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders))
336        it "invalid chunk" $ invalidChunk $ \port -> do
337            req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port
338            manager <- newManager tlsManagerSettings
339            eres <- try $ httpLbs req manager
340            liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres
341             `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders))
342
343        it "missing header" $ rawApp
344          "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\n\r\n\r\n"
345          $ \port -> do
346            req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port
347            manager <- newManager tlsManagerSettings
348            eres <- try $ httpLbs req manager
349            liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres
350             `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders))
351
352        it "junk header" $ rawApp
353          "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\njunk\r\n\r\n"
354          $ \port -> do
355            req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port
356            manager <- newManager tlsManagerSettings
357            eres <- try $ httpLbs req manager
358            liftIO $ either (Left . (show :: HttpException -> String)) (Right . id) eres
359             `shouldBe` Left (show (HttpExceptionRequest req InvalidChunkHeaders))
360
361    describe "redirect" $ do
362        it "ignores large response bodies" $ do
363            let app' port req =
364                    case pathInfo req of
365                        ["foo"] -> return $ responseLBS status200 [] "Hello World!"
366                        _ -> return $ responseSource status301 [("location", S8.pack $ "http://127.0.0.1:" ++ show port ++ "/foo")] $ forever $ yield $ Chunk $ fromByteString "hello\n"
367            manager <- newManager tlsManagerSettings
368            withApp' app' $ \port -> do
369                req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port
370                res <- httpLbs req manager
371                liftIO $ do
372                    Network.HTTP.Conduit.responseStatus res `shouldBe` status200
373                    responseBody res `shouldBe` "Hello World!"
374    describe "multipart/form-data" $ do
375        it "formats correctly" $ do
376            let bd = "---------------------------190723902820679116301912680260"
377            (RequestBodyStream _ givesPopper) <- renderParts bd
378                [partBS "email" ""
379                ,partBS "parent_id" "70488"
380                ,partBS "captcha" ""
381                ,partBS "homeboard" "0chan.hk"
382                ,partBS "text" $ TE.encodeUtf8 ">>72127\r\nМы работаем над этим."
383                ,partFileSource "upload" "nyan.gif"
384                ]
385            ires <- I.newIORef S.empty
386            let loop front popper = do
387                    bs <- popper
388                    if S.null bs
389                        then I.writeIORef ires $ S.concat $ front []
390                        else loop (front . (bs:)) popper
391            givesPopper $ loop id
392            mfd <- I.readIORef ires
393            exam <- S.readFile "multipart-example.bin"
394            mfd @?= exam
395
396    describe "HTTP/1.0" $ do
397        it "BaseHTTP" $ do
398            let baseHTTP app' = do
399                    _ <- runConduit $ appSource app' .| await
400                    runConduit $ yield "HTTP/1.0 200 OK\r\n\r\nThis is it!" .| appSink app'
401            manager <- newManager tlsManagerSettings
402            withCApp baseHTTP $ \port -> do
403                req <- liftIO $ parseUrlThrow $ "http://127.0.0.1:" ++ show port
404                res1 <- httpLbs req manager
405                res2 <- httpLbs req manager
406                liftIO $ res1 @?= res2
407
408    describe "hostAddress" $ do
409        it "overrides host" $ withApp app $ \port -> do
410            req' <- parseUrlThrow $ "http://example.com:" ++ show port
411            let req = req' { hostAddress = Just $ NS.tupleToHostAddress (127, 0, 0, 1) }
412            manager <- newManager tlsManagerSettings
413            res <- httpLbs req manager
414            responseBody res @?= "homepage for example.com"
415
416    describe "managerResponseTimeout" $ do
417        it "works" $ withApp app $ \port -> do
418            req1 <- parseUrlThrow $ "http://localhost:" ++ show port
419            let req2 = req1 { responseTimeout = responseTimeoutMicro 5000000 }
420            man <- newManager tlsManagerSettings { managerResponseTimeout = responseTimeoutMicro 1 }
421            eres1 <- try $ httpLbs req1 { NHC.path = "/delayed" } man
422            case eres1 of
423                Left (HttpExceptionRequest _ ConnectionTimeout{}) -> return ()
424                _ -> error "Did not time out"
425            _ <- httpLbs req2 man
426            return ()
427
428    describe "delayed body" $ do
429        it "works" $ withApp app $ \port -> do
430            req <- parseUrlThrow $ "http://localhost:" ++ show port ++ "/delayed"
431            man <- newManager tlsManagerSettings
432            _ <- runResourceT $ http req man
433            return ()
434
435    it "reuse/connection close tries again" $ do
436        withAppSettings (setTimeout 1) (const app) $ \port -> do
437            req <- parseUrlThrow $ "http://localhost:" ++ show port
438            man <- newManager tlsManagerSettings
439            res1 <- httpLbs req man
440            threadDelay 3000000
441            res2 <- httpLbs req man
442            let f res = res
443                    { NHC.responseHeaders = filter (not . isDate) (NHC.responseHeaders res)
444                    }
445                isDate ("date", _) = True
446                isDate _ = False
447            f res2 `shouldBe` f res1
448
449    it "setQueryString" $ do
450        ref <- I.newIORef undefined
451        let app' req = do
452                I.writeIORef ref $ Wai.queryString req
453                return $ responseLBS status200 [] ""
454        withApp app' $ \port -> do
455            let qs =
456                    [ ("foo", Just "bar")
457                    , (TE.encodeUtf8 "שלום", Just "hola")
458                    , ("noval", Nothing)
459                    ]
460            man <- newManager tlsManagerSettings
461            req <- parseUrlThrow $ "http://localhost:" ++ show port
462            _ <- httpLbs (setQueryString qs req) man
463            res <- I.readIORef ref
464            res `shouldBe` qs
465
466#ifdef VERSION_aeson
467    describe "Simple.JSON" $ do
468        it "normal" $ jsonApp $ \port -> do
469            req <- parseUrlThrow $ "http://localhost:" ++ show port
470            value <- Simple.httpJSON req
471            responseBody value `shouldBe` jsonValue
472        it "trailing whitespace" $ jsonApp $ \port -> do
473            req <- parseUrlThrow $ "http://localhost:" ++ show port ++ "/trailing"
474            value <- Simple.httpJSON req
475            responseBody value `shouldBe` jsonValue
476#endif
477
478    it "RequestBodyIO" $ echo $ \port -> do
479        manager <- newManager tlsManagerSettings
480        let go bss = withSystemTempFile "request-body-io" $ \tmpfp tmph -> do
481                liftIO $ do
482                    mapM_ (S.hPutStr tmph) bss
483                    hClose tmph
484
485                let Just req1 = parseUrlThrow $ "POST http://127.0.0.1:" ++ show port
486                    lbs = L.fromChunks bss
487                res <- httpLbs req1
488                    { requestBody = RequestBodyIO (streamFile tmpfp)
489                    } manager
490                liftIO $ Network.HTTP.Conduit.responseStatus res @?= status200
491                let ts = S.concat . L.toChunks
492                liftIO $ ts (responseBody res) @?= ts lbs
493        mapM_ go
494            [ ["hello", "world"]
495            , replicate 500 "foo\003\n\r"
496            ]
497
498withCApp :: (Data.Conduit.Network.AppData -> IO ()) -> (Int -> IO ()) -> IO ()
499withCApp app' f = do
500    port <- getPort
501    baton <- newEmptyMVar
502    let start = putMVar baton ()
503#if MIN_VERSION_conduit(1,1,0)
504        settings :: ServerSettings
505        settings = setAfterBind (const start) (serverSettings port "*")
506#else
507        settings :: ServerSettings IO
508        settings = (serverSettings port "*" :: ServerSettings IO) { serverAfterBind = const start }
509#endif
510    bracket
511        (forkIO $ runTCPServer settings app' `onException` start)
512        killThread
513        (const $ takeMVar baton >> f port)
514
515overLongHeaders :: (Int -> IO ()) -> IO ()
516overLongHeaders =
517    withCApp $ \app' -> runConduit $ src .| appSink app'
518  where
519    src = sourceList $ "HTTP/1.0 200 OK\r\nfoo: " : repeat "bar"
520
521notOverLongHeaders :: (Int -> IO ()) -> IO ()
522notOverLongHeaders = withCApp $ \app' -> do
523    runConduit $ appSource app' .| CL.drop 1
524    runConduit $ src .| appSink app'
525  where
526    src = sourceList $ [S.concat $ "HTTP/1.0 200 OK\r\nContent-Type: text/plain\r\nContent-Length: 16384\r\n\r\n" : ( take 16384 $ repeat "x")]
527
528redir :: (Int -> IO ()) -> IO ()
529redir =
530    withApp' redirApp
531  where
532    redirApp port req =
533        case pathInfo req of
534            ["redir", foo] -> return $ responseLBS status301
535                [ ("Location", S8.pack (concat ["http://127.0.0.1:", show port, "/content/"]) `S.append` escape foo)
536                ]
537                ""
538            ["content", foo] -> return $ responseLBS status200 [] $ L.fromChunks [TE.encodeUtf8 foo]
539            _ -> return $ responseLBS status404 [] ""
540    escape = S8.concatMap (S8.pack . encodeUrlChar) . TE.encodeUtf8
541
542    encodeUrlChar :: Char -> String
543    encodeUrlChar c
544        -- List of unreserved characters per RFC 3986
545        -- Gleaned from http://en.wikipedia.org/wiki/Percent-encoding
546        | 'A' <= c && c <= 'Z' = [c]
547        | 'a' <= c && c <= 'z' = [c]
548        | '0' <= c && c <= '9' = [c]
549    encodeUrlChar c@'-' = [c]
550    encodeUrlChar c@'_' = [c]
551    encodeUrlChar c@'.' = [c]
552    encodeUrlChar c@'~' = [c]
553    encodeUrlChar y =
554        let (a, c) = fromEnum y `divMod` 16
555            b = a `mod` 16
556            showHex' x
557                | x < 10 = toEnum $ x + (fromEnum '0')
558                | x < 16 = toEnum $ x - 10 + (fromEnum 'A')
559                | otherwise = error $ "Invalid argument to showHex: " ++ show x
560         in ['%', showHex' b, showHex' c]
561
562echo :: (Int -> IO ()) -> IO ()
563echo = withApp $ \req -> do
564    bss <- runConduit $ sourceRequestBody req .| CL.consume
565    return $ responseLBS status200 [] $ L.fromChunks bss
566
567noStatusMessage :: (Int -> IO ()) -> IO ()
568noStatusMessage =
569    withCApp $ \app' -> runConduit $ src .| appSink app'
570  where
571    src = yield "HTTP/1.0 200\r\nContent-Length: 3\r\n\r\nfoo: barbazbin"
572
573wrongLength :: (Int -> IO ()) -> IO ()
574wrongLength =
575    withCApp $ \app' -> do
576        _ <- runConduit $ appSource app' .| await
577        runConduit $ src .| appSink app'
578  where
579    src = do
580        yield "HTTP/1.0 200 OK\r\nContent-Length: 50\r\n\r\n"
581        yield "Not quite 50 bytes"
582
583wrongLengthChunk1 :: (Int -> IO ()) -> IO ()
584wrongLengthChunk1 =
585    withCApp $ \app' -> do
586        _ <- runConduit $ appSource app' .| await
587        runConduit $ src .| appSink app'
588  where
589    src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nWiki\r\n"
590
591wrongLengthChunk2 :: (Int -> IO ()) -> IO ()
592wrongLengthChunk2 =
593    withCApp $ \app' -> do
594        _ <- runConduit $ appSource app' .| await
595        runConduit $ src .| appSink app'
596  where
597    src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nWiki\r\n5\r\npedia\r\nE\r\nin\r\n\r\nch\r\n"
598
599invalidChunk :: (Int -> IO ()) -> IO ()
600invalidChunk =
601    withCApp $ \app' -> do
602        _ <- runConduit $ appSource app' .| await
603        runConduit $ src .| appSink app'
604  where
605    src = yield "HTTP/1.1 200 OK\r\nTransfer-Encoding: chunked\r\n\r\n4\r\nabcd\r\ngarbage\r\nef\r\n0\r\n\r\n"
606
607rawApp :: S8.ByteString -> (Int -> IO ()) -> IO ()
608rawApp bs =
609    withCApp $ \app' -> do
610        _ <- runConduit $ appSource app' .| await
611        runConduit $ src .| appSink app'
612  where
613    src = yield bs
614
615#ifdef VERSION_aeson
616jsonApp :: (Int -> IO ()) -> IO ()
617jsonApp = withApp $ \req -> return $ responseLBS
618    status200
619    [ ("Content-Type", "application/json")
620    ] $
621    case pathInfo req of
622      [] -> A.encode jsonValue
623      ["trailing"] -> L.append (A.encode jsonValue) "   \n\r\n\t  "
624      x -> error $ "unsupported: " ++ show x
625
626jsonValue :: A.Value
627jsonValue = A.object
628    [ "name" A..= ("Alice" :: String)
629    , "age" A..= (35 :: Int)
630    ]
631#endif
632