Skip to content
This repository
Browse code

do MD5 calculation in test harness so tests are invariant on port

  • Loading branch information...
commit 9e3d648a1b4441224ce898e0a9741cf14a5aa218 1 parent 89fdd55
Ganesh Sittampalam authored May 08, 2012
1  HTTP.cabal
@@ -111,6 +111,7 @@ Test-Suite test
111 111
                      conduit >= 0.4 && < 0.5,
112 112
                      wai >= 1.2 && < 1.3,
113 113
                      warp >= 1.2 && < 1.3,
  114
+                     pureMD5 >= 2.1 && < 2.2,
114 115
                      base >= 2 && < 4.6,
115 116
                      network,
116 117
                      split >= 0.1 && < 0.2,
32  test/httpTests.hs
@@ -4,7 +4,9 @@ import Control.Concurrent
4 4
 import Control.Applicative ((<$))
5 5
 import Control.Concurrent (threadDelay)
6 6
 import Control.Exception (try)
  7
+import qualified Data.ByteString.Lazy.Char8 as BL (pack)
7 8
 import Data.Char (isSpace)
  9
+import qualified Data.Digest.Pure.MD5 as MD5 (md5)
8 10
 import Data.List.Split (splitOn)
9 11
 import Data.Maybe (fromJust)
10 12
 import System.IO.Error (userError)
@@ -385,6 +387,25 @@ haskellOrgText =
385 387
 \\t\t<meta http-equiv=\"Content-Type\" content=\"text/html; charset=UTF-8\" />\
386 388
 \\t\t\t\t<meta name=\"keywords\" content=\"Haskell,Applications and libraries,Books,Foreign Function Interface,Functional programming,Hac Boston,HakkuTaikai,HaskellImplementorsWorkshop/2011,Haskell Communities and Activities Report,Haskell in education,Haskell in industry\" />"
387 389
 
  390
+digestMatch
  391
+  username realm password
  392
+  nonce opaque
  393
+  method relativeURI makeAbsolute
  394
+  headers
  395
+  =
  396
+  common `isSubsetOf` headers && (relative `isSubsetOf` headers || absolute `isSubsetOf` headers)
  397
+ where
  398
+   common = [("username", show username), ("realm", show realm), ("nonce", show nonce),
  399
+             ("opaque", show opaque)]
  400
+   md5 = show . MD5.md5 . BL.pack
  401
+   ha1 = md5 (username++":"++realm++":"++password)
  402
+   ha2 uri = md5 (method++":"++uri)
  403
+   response uri = md5 (ha1 ++ ":" ++ nonce ++ ":" ++ ha2 uri)
  404
+   mkUncommon uri hash = [("uri", show uri), ("response", show hash)]
  405
+   relative = mkUncommon relativeURI (response relativeURI)
  406
+   absoluteURI = makeAbsolute relativeURI
  407
+   absolute = mkUncommon absoluteURI (response absoluteURI)
  408
+
388 409
 processRequest :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress)
389 410
                => Httpd.Request
390 411
                -> IO Httpd.Response
@@ -409,13 +430,10 @@ processRequest req = do
409 430
     ("GET", "/auth/digest") ->
410 431
       case lookup "Authorization" (Httpd.reqHeaders req) of
411 432
         Just (hasPrefix "Digest " -> Just (splitFields -> items))
412  
-          | [("username", show "test"), ("realm", show "Digest testing realm"), ("nonce", show "87e4"),
413  
-             ("uri", show (?testUrl "/auth/digest")), ("opaque", show "057d"),
414  
-             ("response", show "ace810a3cfb830489a3b48e90a02b2ae")] `isSubsetOf` items
415  
-          -> return $ Httpd.mkResponse 200 [] "Here's the digest secret"
416  
-          | [("username", show "test"), ("realm", show "Digest testing realm"), ("nonce", show "87e4"),
417  
-             ("uri", show "/auth/digest"), ("opaque", show "057d"),
418  
-             ("response", show "4845c3faf4dcb125b8dcc88b5c20bb89")] `isSubsetOf` items
  433
+          | digestMatch "test" "Digest testing realm" "digestpassword"
  434
+                        "87e4" "057d"
  435
+                        "GET" "/auth/digest" ?testUrl
  436
+                        items
419 437
           -> return $ Httpd.mkResponse 200 [] "Here's the digest secret"
420 438
         x -> return $ Httpd.mkResponse
421 439
                         401

0 notes on commit 9e3d648

Please sign in to comment.
Something went wrong with that request. Please try again.