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