Remove a painful slowdown from randomIV

.gitignore

@@ -1,4 +1,5 @@
 *.o
+*.o_p
 *.hi
 dist
 *.swp

yesod-core/Yesod/Internal/Core.hs

@@ -343,12 +343,12 @@ defaultYesodRunner _ m toMaster _ murl _ req
             [] -> Nothing
             (x, _):_ -> Just x
 defaultYesodRunner s master toMasterRoute mkey murl handler req = do
-    now <- liftIO getCurrentTime
-    let getExpires m = fromIntegral (m * 60) `addUTCTime` now
-    let exp' = getExpires $ clientSessionDuration master
-    let rh = takeWhile (/= ':') $ show $ W.remoteHost req
+    now <- {-# SCC "getCurrentTime" #-} liftIO getCurrentTime
+    let getExpires m = {-# SCC "getExpires" #-} fromIntegral (m * 60) `addUTCTime` now
+    let exp' = {-# SCC "exp'" #-} getExpires $ clientSessionDuration master
+    let rh = {-# SCC "rh" #-} takeWhile (/= ':') $ show $ W.remoteHost req
     let host = if sessionIpAddress master then S8.pack rh else ""
-    let session' =
+    let session' = {-# SCC "session'" #-}
             case mkey of
                 Nothing -> []
                 Just key -> fromMaybe [] $ do
@@ -356,7 +356,7 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
                     val <- lookup sessionName $ parseCookies raw
                     decodeSession key now host val
     rr <- liftIO $ parseWaiRequest req session' mkey
-    let h = do
+    let h = {-# SCC "h" #-} do
           case murl of
             Nothing -> handler
             Just url -> do
@@ -377,7 +377,8 @@ defaultYesodRunner s master toMasterRoute mkey murl handler req = do
                    $ filter (\(x, _) -> x /= nonceKey) session'
     yar <- handlerToYAR master s toMasterRoute (yesodRender master) errorHandler rr murl sessionMap h
     let mnonce = reqNonce rr
-    iv <- liftIO CS.randomIV
+    -- FIXME should we be caching this IV value and reusing it for efficiency?
+    iv <- {-# SCC "iv" #-} maybe (return $ error "Should not be used") (const $ liftIO CS.randomIV) mkey
     return $ yarToResponse (hr iv mnonce getExpires host exp') yar
   where
     hr iv mnonce getExpires host exp' hs ct sm =

yesod-core/bench.sh

@@ -0,0 +1,8 @@
+#!/bin/bash -ex
+
+ghc --make bench/pong.hs
+ghc --make bench/pong.hs -prof -osuf o_p -caf-all -auto-all -rtsopts
+./bench/pong +RTS -p &
+sleep 2
+ab -n 1000 -c 5 http://localhost:3000/ 2>&1 | grep 'Time taken'
+curl http://localhost:3000/kill

yesod-core/bench/pong.hs

@@ -0,0 +1,32 @@
+{-# LANGUAGE OverloadedStrings, QuasiQuotes, TypeFamilies, TemplateHaskell, MultiParamTypeClasses #-}
+import Yesod.Dispatch
+import Yesod.Content
+import Yesod.Internal.Core
+import Data.ByteString (ByteString)
+import Network.Wai.Handler.Warp (run)
+import Control.Concurrent.MVar
+import Control.Concurrent
+import Network.Wai
+import Control.Monad.IO.Class
+
+data Pong = Pong
+mkYesod "Pong" [$parseRoutes|
+/ PongR GET
+|]
+
+instance Yesod Pong where
+    approot _ = ""
+    encryptKey _ = return Nothing
+
+getPongR = return $ RepPlain $ toContent ("PONG" :: ByteString)
+
+main = do
+    app <- toWaiAppPlain Pong
+    flag <- newEmptyMVar
+    forkIO $ run 3000 $ \req ->
+        if pathInfo req == ["kill"]
+            then do
+                liftIO $ putMVar flag ()
+                error "done"
+            else app req
+    takeMVar flag