~ubuntu-branches/ubuntu/utopic/haskell-wai-extra/utopic : revision 21

3

4

import Test.Hspec

5

import Test.HUnit hiding (Test)

6

import Data.Monoid (mappend, mempty)

6

7

8

import Network.Wai

8

9

import Network.Wai.Test

9

10

import Network.Wai.Parse

11

import Network.Wai.UrlMap

10

12

import qualified Data.ByteString as S

11

13

import qualified Data.ByteString.Char8 as S8

12

14

import qualified Data.ByteString.Lazy.Char8 as L8

15

17

import qualified Data.Text as TS

16

18

import qualified Data.Text.Encoding as TE

17

19

import Control.Arrow

20

import Control.Applicative

21

import Control.Monad.Trans.Resource (withInternalState, runResourceT)

18

22

19

23

import Network.Wai.Middleware.Jsonp

20

24

import Network.Wai.Middleware.Gzip

28

32

29

33

import qualified Data.Conduit as C

30

34

import qualified Data.Conduit.List as CL

31

import Data.Conduit.Binary (sourceFile)

35

import Data.Conduit.Binary (sourceHandle)

32

36

import Control.Monad.IO.Class (liftIO)

33

37

import Data.Maybe (fromMaybe)

34

38

import Network.HTTP.Types (parseSimpleQuery, status200)

35

39

import System.Log.FastLogger

40

import System.IO (withFile, IOMode (ReadMode))

36

41

37

42

import qualified Data.IORef as I

38

43

39

44

specs :: Spec

40

45

specs = do

46

describe "Network.Wai.UrlMap" $ do

47

mapM_ (uncurry it) casesUrlMap

48

41

49

describe "Network.Wai.Parse" $ do

42

50

describe "parseContentType" $ do

43

51

let go (x, y, z) = it (TS.unpack $ TE.decodeUtf8 x) $ parseContentType x `shouldBe` (y, z)

63

71

it "jsonp" caseJsonp

64

72

it "gzip" caseGzip

65

73

it "gzip not for MSIE" caseGzipMSIE

74

it "gzip bypass when precompressed" caseGzipBypassPre

66

75

it "defaultCheckMime" caseDefaultCheckMime

67

76

it "vhost" caseVhost

68

77

it "autohead" caseAutohead

113

122

expected = ["text/html;charset=utf-8", "text/x-c", "text/x-dvi", "text/*", "text/plain"]

114

123

expected @=? parseHttpAccept input

115

124

116

parseRequestBody' :: BackEnd L.ByteString

125

parseRequestBody' :: BackEnd file

117

126

-> SRequest

118

-> C.ResourceT IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo L.ByteString)])

127

-> IO ([(S.ByteString, S.ByteString)], [(S.ByteString, FileInfo file)])

119

128

parseRequestBody' sink (SRequest req bod) =

120

129

case getRequestBodyType req of

121

130

Nothing -> return ([], [])

123

132

124

133

caseParseRequestBody :: Assertion

125

134

caseParseRequestBody =

126

C.runResourceT t

135

t

127

136

where

128

137

content2 = S8.pack $

129

138

"--AaB03x\n" ++

187

196

188

197

caseMultipartPlus :: Assertion

189

198

caseMultipartPlus = do

190

result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content

199

result <- parseRequestBody' lbsBackEnd $ toRequest ctype content

191

200

liftIO $ result @?= ([("email", "has+plus")], [])

192

201

where

193

202

content = S8.pack $

200

209

201

210

caseMultipartAttrs :: Assertion

202

211

caseMultipartAttrs = do

203

result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content

212

result <- parseRequestBody' lbsBackEnd $ toRequest ctype content

204

213

liftIO $ result @?= ([("email", "has+plus")], [])

205

214

where

206

215

content = S8.pack $

213

222

214

223

caseUrlEncPlus :: Assertion

215

224

caseUrlEncPlus = do

216

result <- C.runResourceT $ parseRequestBody' lbsBackEnd $ toRequest ctype content

225

result <- runResourceT $ withInternalState $ \state ->

226

parseRequestBody' (tempFileBackEnd state) $ toRequest ctype content

217

227

liftIO $ result @?= ([("email", "has+plus")], [])

218

228

where

219

229

content = S8.pack $ "email=has%2Bplus"

318

328

[("Content-Type", "text/plain")]

319

329

"test"

320

330

331

-- Lie a little and don't compress the body. This way we test

332

-- that the compression is skipped based on the presence of

333

-- the Content-Encoding header.

334

gzipPrecompressedApp :: Application

335

gzipPrecompressedApp = gzip def $ const $ return $ responseLBS status200

336

[("Content-Type", "text/plain"), ("Content-Encoding", "gzip")]

337

"test"

338

321

339

caseGzip :: Assertion

322

340

caseGzip = flip runSession gzipApp $ do

323

341

sres1 <- request defaultRequest

353

371

assertNoHeader "Content-Encoding" sres1

354

372

liftIO $ simpleBody sres1 @?= "test"

355

373

374

caseGzipBypassPre :: Assertion

375

caseGzipBypassPre = flip runSession gzipPrecompressedApp $ do

376

sres1 <- request defaultRequest

377

{ requestHeaders = [("Accept-Encoding", "gzip")]

378

}

379

assertHeader "Content-Encoding" "gzip" sres1

380

assertBody "test" sres1 -- the body is not actually compressed

381

356

382

vhostApp1, vhostApp2, vhostApp :: Application

357

383

vhostApp1 = const $ return $ responseLBS status200 [] "app1"

358

384

vhostApp2 = const $ return $ responseLBS status200 [] "app2"

359

385

vhostApp = vhost

360

[ ((== "foo.com") . serverName, vhostApp1)

386

[ ((== Just "foo.com") . lookup "host" . requestHeaders, vhostApp1)

361

387

]

362

388

vhostApp2

363

389

364

390

caseVhost :: Assertion

365

391

caseVhost = flip runSession vhostApp $ do

366

392

sres1 <- request defaultRequest

367

{ serverName = "foo.com"

393

{ requestHeaders = [("Host", "foo.com")]

368

394

}

369

395

assertBody "app1" sres1

370

396

371

397

sres2 <- request defaultRequest

372

{ serverName = "bar.com"

398

{ requestHeaders = [("Host", "bar.com")]

373

399

}

374

400

assertBody "app2" sres2

375

401

493

519

(params, files) <-

494

520

case getRequestBodyType request' of

495

521

Nothing -> return ([], [])

496

Just rbt -> C.runResourceT $ sourceFile "test/requests/dalvik-request"

497

C.$$ sinkRequestBody lbsBackEnd rbt

522

Just rbt -> withFile "test/requests/dalvik-request" ReadMode $ \h ->

523

sourceHandle h C.$$ sinkRequestBody lbsBackEnd rbt

498

524

lookup "scannedTime" params @?= Just "1.298590056748E9"

499

525

lookup "geoLong" params @?= Just "0"

500

526

lookup "geoLat" params @?= Just "0"

519

545

where

520

546

params = [("foo", "bar"), ("baz", "bin")]

521

547

-- FIXME change back once we include post parameter output in logging postOutput = T.pack $ "POST \nAccept: \nPOST " ++ (show params)

522

postOutput = T.pack $ "POST /\nAccept: \nStatus: 200 OK. /\n"

523

getOutput params' = T.pack $ "GET /location\nAccept: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n"

548

postOutput = T.pack $ "POST / :: \nStatus: 200 OK. /\n"

549

getOutput params' = T.pack $ "GET /location :: \nGET " ++ show params' ++ "\nStatus: 200 OK. /location\n"

524

550

525

551

debugApp output' req = do

526

iactual <- liftIO $ I.newIORef []

552

iactual <- liftIO $ I.newIORef mempty

527

553

middleware <- liftIO $ mkRequestLogger def

528

{ destination = Callback $ \strs -> I.modifyIORef iactual $ (++ strs)

554

{ destination = Callback $ \strs -> I.modifyIORef iactual $ (`mappend` strs)

529

555

, outputFormat = Detailed False

530

556

}

531

557

res <- middleware (\_req -> return $ responseLBS status200 [ ] "") req

532

558

actual <- liftIO $ I.readIORef iactual

533

liftIO $ assertEqual "debug" output $ logsToBs actual

559

liftIO $ assertEqual "debug" output $ logToBs actual

534

560

return res

535

561

where

536

562

output = TE.encodeUtf8 $ T.toStrict output'

537

logsToBs = S.concat . map logToBs

538

563

539

logToBs (LB bs) = bs

540

logToBs (LS s) = S8.pack s

564

logToBs = fromLogStr

541

565

542

566

{-debugApp = debug $ \req -> do-}

543

567

{-return $ responseLBS status200 [ ] ""-}

568

569

urlMapTestApp :: Application

570

urlMapTestApp = mapUrls $

571

mount "bugs" bugsApp

572

<|> mount "helpdesk" helpdeskApp

573

<|> mount "api"

574

( mount "v1" apiV1

575

<|> mount "v2" apiV2

576

)

577

<|> mountRoot mainApp

578

579

where

580

trivialApp :: S.ByteString -> Application

581

trivialApp name req =

582

return $

583

responseLBS

584

status200

585

[ ("content-type", "text/plain")

586

, ("X-pathInfo", S8.pack . show . pathInfo $ req)

587

, ("X-rawPathInfo", rawPathInfo req)

588

, ("X-appName", name)

589

]

590

""

591

592

bugsApp = trivialApp "bugs"

593

helpdeskApp = trivialApp "helpdesk"

594

apiV1 = trivialApp "apiv1"

595

apiV2 = trivialApp "apiv2"

596

mainApp = trivialApp "main"

597

598

casesUrlMap :: [(String, Assertion)]

599

casesUrlMap = [pair1, pair2, pair3, pair4]

600

where

601

makePair name session = (name, runSession session urlMapTestApp)

602

get reqPath = request $ setPath defaultRequest reqPath

603

s = S8.pack . show :: [TS.Text] -> S.ByteString

604

605

pair1 = makePair "should mount root" $ do

606

res1 <- get "/"

607

assertStatus 200 res1

608

assertHeader "X-rawPathInfo" "/" res1

609

assertHeader "X-pathInfo" (s []) res1

610

assertHeader "X-appName" "main" res1

611

612

pair2 = makePair "should mount apps" $ do

613

res2 <- get "/bugs"

614

assertStatus 200 res2

615

assertHeader "X-rawPathInfo" "/" res2

616

assertHeader "X-pathInfo" (s []) res2

617

assertHeader "X-appName" "bugs" res2

618

619

pair3 = makePair "should preserve extra path info" $ do

620

res3 <- get "/helpdesk/issues/11"

621

assertStatus 200 res3

622

assertHeader "X-rawPathInfo" "/issues/11" res3

623

assertHeader "X-pathInfo" (s ["issues", "11"]) res3

624

625

pair4 = makePair "should 404 if none match" $ do

626

res4 <- get "/api/v3"

627

assertStatus 404 res4