TechEmpower.FrameworkBenchmarks/yesod/bench/Application.hs

{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Application
    ( makeApplication
    , makeFoundation
    ) where

import Import
import Control.Monad
import Control.DeepSeq (force)
import System.Random

import qualified Database.Persist.Store
import Database.Persist.Store (PersistValue (..))
import Network.HTTP.Conduit (newManager, def)
import Yesod.Default.Config


import Settings

getJsonR :: Handler RepJson
getJsonR = jsonToRepJson $ object [("message", "Hello, World!" :: Text)]

getDBR :: Handler RepJson
getDBR = do
    !i <- liftIO $ randomRIO (1, 10000)
    Just o <- runDB $ get $ Key $ PersistInt64 i
    jsonToRepJson $ object ["id" .= i, "randomNumber" .= worldRandomNumber o]

getDB2R :: Int -> Handler RepJson
getDB2R n = do
    !is <- force . take n . randomRs (1, 10000) <$> liftIO newStdGen

    ns <- runDB $
        forM is $ \i -> do
            Just o <- get $ Key $ PersistInt64 i
            return (i, worldRandomNumber o)

    jsonToRepJson $ array
        [ object ["id" .= i, "randomNumber" .= rn] | (i, rn) <- ns ]

mkYesodDispatch "App" resourcesApp

makeApplication :: AppConfig DefaultEnv Extra -> IO Application
makeApplication conf = makeFoundation conf >>= toWaiAppPlain

makeFoundation :: AppConfig DefaultEnv Extra -> IO App
makeFoundation conf = do
    manager <- newManager def
    dbconf <- withYamlEnvironment "config/mysql.yml" (appEnv conf)
              Database.Persist.Store.loadConfig >>=
              Database.Persist.Store.applyEnv
    p <- Database.Persist.Store.createPoolConfig (dbconf :: Settings.PersistConfig)
    let foundation = App conf p manager dbconf

    return foundation