Skip to content

@snoyberg /yesod.hs
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Better Yesod benchmark
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.