Merge pull request #1440 from TechEmpower/snap-yesod-valid

Fixed validation warnings for Yesod and Snap

frameworks/Haskell/snap/bench/src/Main.hs

@@ -65,6 +65,7 @@ site :: Pool Connection -> Snap ()
 site pool = route
     [ ("json",      jsonHandler)
     , ("db",        dbHandler pool)
+    , ("dbs",       dbsHandler pool)
     , ("plaintext", writeBS "Hello, World!")
     ]
 
@@ -75,16 +76,21 @@ jsonHandler = do
 
 dbHandler :: Pool Connection -> Snap ()
 dbHandler pool = do
+    modifyResponse (setContentType "application/json")
+    r <- liftIO $ randomRIO (1, 10000)
+    qry <- liftIO $ withResource pool (flip runOne r)
+    writeLBS $ encode qry
+
+dbsHandler :: Pool Connection -> Snap ()
+dbsHandler pool = do
     modifyResponse (setContentType "application/json")
     qs <- getQueryParam "queries"
     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
+runAll pool i | i < 1 = runAll pool 1
+              | i > 500 = runAll pool 500
+              | otherwise = do
     !rs <- take i . randomRs (1, 10000) <$> liftIO newStdGen
     qry <- liftIO $ withResource pool (forM rs . runOne)
     writeLBS $ encode qry

frameworks/Haskell/snap/benchmark_config

@@ -5,7 +5,7 @@
       "setup_file": "setup",
       "json_url": "/json",
       "db_url": "/db",
-      "query_url": "/db?queries=",
+      "query_url": "/dbs?queries=",
       "plaintext_url": "/plaintext",
       "port": 8000,
       "approach": "Realistic",

frameworks/Haskell/yesod/bench/src/yesod.hs

@@ -62,9 +62,11 @@ mkYesod "App" [parseRoutes|
 
 /db                 DbR       GET
 /dbs/#Int           DbsR      GET
+!/dbs/#Text         DbsRdefault  GET
 
 /mongo/raw/db       MongoRawDbR  GET
 /mongo/raw/dbs/#Int MongoRawDbsR GET
+!/mongo/raw/dbs/#Text MongoRawDbsRdefault GET
 |]
 
 fakeInternalState :: InternalState
@@ -105,11 +107,24 @@ getMongoRawDbR = getDb rawMongoIntQuery
 getDbsR :: Int -> Handler Value
 getDbsR cnt = do
     App {..} <- getYesod
-    multiRandomHandler (intQuery runMySQL My.toSqlKey) cnt
+    multiRandomHandler (intQuery runMySQL My.toSqlKey) cnt'
+  where
+    cnt' | cnt < 1 = 1
+         | cnt > 500 = 500
+         | otherwise = cnt
+
+getDbsRdefault :: Text -> Handler Value
+getDbsRdefault _ = getDbsR 1
 
 getMongoRawDbsR :: Int -> Handler Value
-getMongoRawDbsR cnt = multiRandomHandler rawMongoIntQuery cnt
+getMongoRawDbsR cnt = multiRandomHandler rawMongoIntQuery cnt'
+  where
+    cnt' | cnt < 1 = 1
+         | cnt > 500 = 500
+         | otherwise = cnt
 
+getMongoRawDbsRdefault :: Text -> Handler Value
+getMongoRawDbsRdefault _ = getMongoRawDbsR 1
 
 randomNumber :: R.Gen (PrimState IO) -> IO Int64
 randomNumber appGen = R.uniformR (1, 10000) appGen