public
Created

Better Yesod benchmark

  • Download Gist
yesod.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, MultiParamTypeClasses, OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE EmptyDataDecls #-}
import Yesod
import System.Environment (getArgs)
import qualified Network.Wai.Handler.Warp as Warp
import Data.Text (Text)
import Data.Conduit.Pool (Pool)
import Database.Persist.Store (get, PersistValue (PersistInt64))
import Database.Persist.MySQL
import qualified System.Random.MWC as R
import Control.Monad.Primitive (PrimState)
import Control.Monad (replicateM)
import Data.Conduit.Network (bindPort)
import System.Posix.Process (forkProcess)
import Control.Monad (replicateM_)
 
mkPersist sqlSettings [persist|
World sql=World
randomNumber Int sql=randomNumber
|]
 
data App = App
{ appConnPool :: Pool Connection
, appGen :: R.Gen (PrimState IO)
}
 
mkYesod "App" [parseRoutes|
/json JsonR GET
/db DbR GET
/dbs/#Int DbsR GET
|]
 
instance Yesod App where
makeSessionBackend _ = return Nothing
shouldLog _ _ _ = False
yesodMiddleware = id
 
getJsonR :: Handler RepJson
getJsonR = jsonToRepJson $ object ["message" .= ("Hello, World!" :: Text)]
 
getDbR :: Handler RepJson
getDbR = do
App {..} <- getYesod
i <- liftIO $ R.uniformR (1, 10000) appGen
Just x <- flip runSqlPool appConnPool $ get (Key $ PersistInt64 i :: WorldId)
jsonToRepJson $ object ["id" .= i, "randomNumber" .= worldRandomNumber x]
 
getDbsR :: Int -> Handler RepJson
getDbsR cnt = do
App {..} <- getYesod
objs <- replicateM cnt $ do
i <- liftIO $ R.uniformR (1, 10000) appGen
Just x <- flip runSqlPool appConnPool $ get (Key $ PersistInt64 i :: WorldId)
return $ object ["id" .= i, "randomNumber" .= worldRandomNumber x]
jsonToRepJson $ array objs
 
main :: IO ()
main = R.withSystemRandom $ \gen -> do
socket <- bindPort 8080 "*"
[cores, host] <- getArgs
pool <- createMySQLPool defaultConnectInfo
{ connectUser = "benchmarkdbuser"
, connectPassword = "benchmarkdbpass"
, connectDatabase = "hello_world"
, connectHost = host
} 1000
app <- toWaiAppPlain App
{ appConnPool = pool
, appGen = gen
}
let run = Warp.runSettingsSocket Warp.defaultSettings
{ Warp.settingsPort = 8080
, Warp.settingsHost = "*"
, Warp.settingsOnException = const $ return ()
} socket app
replicateM_ (read cores - 1) $ forkProcess run
run

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.