Browse Source

verify Fixed snap's json/db tests

Mike Smith 11 years ago
parent
commit
3ee01d1b1e
2 changed files with 8 additions and 2 deletions
  1. 2 1
      snap/bench/snap-bench.cabal
  2. 6 1
      snap/bench/src/Main.hs

+ 2 - 1
snap/bench/snap-bench.cabal

@@ -27,7 +27,8 @@ Executable snap-bench
     mysql-simple              >= 0.2.2.4  && < 0.3,
     text                      >= 0.11.0.0 && < 0.12,
     transformers              >= 0.3      && < 0.4,
-    random                    >= 1        && < 2
+    random                    >= 1        && < 2,
+    unordered-containers      >= 0.2.3.1  && < 0.3
 
   if impl(ghc >= 6.12.0)
     ghc-options: -threaded -Wall -fwarn-tabs -funbox-strict-fields -O2

+ 6 - 1
snap/bench/src/Main.hs

@@ -18,6 +18,7 @@ import Snap.Core
 import Snap.Http.Server
 import System.Random
 
+import qualified Data.HashMap as HM
 import qualified Data.ByteString.Char8 as B
 
 data RandQuery = RQ !Int !Int
@@ -70,7 +71,7 @@ site pool = route
 jsonHandler :: Snap ()
 jsonHandler = do
     modifyResponse (setContentType "application/json")
-    writeLBS $ encode [ "message" .= ("Hello, World!" :: Text) ]
+    writeLBS $ encode ( Object $ HM.singleton "message" (String "Hello, World!") )
 
 dbHandler :: Pool Connection -> Snap ()
 dbHandler pool = do
@@ -79,6 +80,10 @@ dbHandler pool = do
     runAll pool $ maybe 1 fst (qs >>= B.readInt)
 
 runAll :: Pool Connection -> Int -> Snap ()
+runAll pool 1 = do
+    !rs <- take 1 . randomRs (1, 10000) <$> liftIO newStdGen
+    qry <- liftIO $ withResource pool (forM rs . runOne)
+    writeLBS $ encode $ head qry
 runAll pool i = do
     !rs <- take i . randomRs (1, 10000) <$> liftIO newStdGen
     qry <- liftIO $ withResource pool (forM rs . runOne)