From d05160f458262f0e9cc9f7cafb970e534f54c1e2 Mon Sep 17 00:00:00 2001 From: patrick brisbin Date: Thu, 24 Nov 2011 13:28:06 -0500 Subject: [PATCH 1/2] fix deprecated pragma and follow it ourselves --- yesod-form/Yesod/Form/Functions.hs | 34 +++++++++++++++--------------- yesod-form/Yesod/Form/MassInput.hs | 6 +++--- yesod-form/Yesod/Form/Types.hs | 2 +- 3 files changed, 21 insertions(+), 21 deletions(-) diff --git a/yesod-form/Yesod/Form/Functions.hs b/yesod-form/Yesod/Form/Functions.hs index f762b621..1c42ba02 100644 --- a/yesod-form/Yesod/Form/Functions.hs +++ b/yesod-form/Yesod/Form/Functions.hs @@ -62,7 +62,7 @@ import qualified Data.ByteString.Lazy as L #endif -- | Get a unique identifier. -newFormIdent :: Form sub master Text +newFormIdent :: MForm sub master Text newFormIdent = do i <- get let i' = incrInts i @@ -72,12 +72,12 @@ newFormIdent = do incrInts (IntSingle i) = IntSingle $ i + 1 incrInts (IntCons i is) = (i + 1) `IntCons` is -formToAForm :: Form sub master (FormResult a, FieldView sub master) -> AForm sub master a +formToAForm :: MForm sub master (FormResult a, FieldView sub master) -> AForm sub master a formToAForm form = AForm $ \(master, langs) env ints -> do ((a, xml), ints', enc) <- runRWST form (env, master, langs) ints return (a, (:) xml, ints', enc) -aFormToForm :: AForm sub master a -> Form sub master (FormResult a, [FieldView sub master] -> [FieldView sub master]) +aFormToForm :: AForm sub master a -> MForm sub master (FormResult a, [FieldView sub master] -> [FieldView sub master]) aFormToForm (AForm aform) = do ints <- get (env, master, langs) <- ask @@ -86,24 +86,24 @@ aFormToForm (AForm aform) = do tell enc return (a, xml) -askParams :: Form sub master (Maybe Env) +askParams :: MForm sub master (Maybe Env) askParams = do (x, _, _) <- ask return $ liftM fst x -askFiles :: Form sub master (Maybe FileEnv) +askFiles :: MForm sub master (Maybe FileEnv) askFiles = do (x, _, _) <- ask return $ liftM snd x mreq :: (RenderMessage master msg, RenderMessage master FormMessage) => Field sub master a -> FieldSettings msg -> Maybe a - -> Form sub master (FormResult a, FieldView sub master) + -> MForm sub master (FormResult a, FieldView sub master) mreq field fs mdef = mhelper field fs mdef (\m l -> FormFailure [renderMessage m l MsgValueRequired]) FormSuccess True mopt :: RenderMessage master msg => Field sub master a -> FieldSettings msg -> Maybe (Maybe a) - -> Form sub master (FormResult (Maybe a), FieldView sub master) + -> MForm sub master (FormResult (Maybe a), FieldView sub master) mopt field fs mdef = mhelper field fs (join mdef) (const $ const $ FormSuccess Nothing) (FormSuccess . Just) False mhelper :: RenderMessage master msg @@ -113,7 +113,7 @@ mhelper :: RenderMessage master msg -> (master -> [Text] -> FormResult b) -- ^ on missing -> (a -> FormResult b) -- ^ on success -> Bool -- ^ is it required? - -> Form sub master (FormResult b, FieldView sub master) + -> MForm sub master (FormResult b, FieldView sub master) mhelper Field {..} FieldSettings {..} mdef onMissing onFound isReq = do mp <- askParams @@ -157,7 +157,7 @@ aopt :: RenderMessage master msg -> AForm sub master (Maybe a) aopt a b = formToAForm . mopt a b -runFormGeneric :: MonadIO m => Form sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GGHandler sub master m (a, Enctype) +runFormGeneric :: MonadIO m => MForm sub master a -> master -> [Text] -> Maybe (Env, FileEnv) -> GGHandler sub master m (a, Enctype) runFormGeneric form master langs env = liftIOHandler $ evalRWST form (env, master, langs) (IntSingle 1) -- | This function is used to both initially render a form and to later extract @@ -170,14 +170,14 @@ runFormGeneric form master langs env = liftIOHandler $ evalRWST form (env, maste -- the form submit to a POST page. In such a case, both the GET and POST -- handlers should use 'runFormPost'. runFormPost :: RenderMessage master FormMessage - => (Html -> Form sub master (FormResult a, xml)) + => (Html -> MForm sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype) runFormPost form = do env <- postEnv postHelper form env postHelper :: RenderMessage master FormMessage - => (Html -> Form sub master (FormResult a, xml)) + => (Html -> MForm sub master (FormResult a, xml)) -> Maybe (Env, FileEnv) -> GHandler sub master ((FormResult a, xml), Enctype) postHelper form env = do @@ -204,7 +204,7 @@ postHelper form env = do -- general usage, you can stick with @runFormPost@. generateFormPost :: RenderMessage master FormMessage - => (Html -> Form sub master (FormResult a, xml)) + => (Html -> MForm sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype) generateFormPost form = postHelper form Nothing @@ -220,14 +220,14 @@ postEnv = do where notEmpty = not . L.null . fileContent -runFormPostNoNonce :: (Html -> Form sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype) +runFormPostNoNonce :: (Html -> MForm sub master (FormResult a, xml)) -> GHandler sub master ((FormResult a, xml), Enctype) runFormPostNoNonce form = do langs <- languages m <- getYesod env <- postEnv runFormGeneric (form mempty) m langs env -runFormGet :: (Html -> Form sub master a) -> GHandler sub master (a, Enctype) +runFormGet :: (Html -> MForm sub master a) -> GHandler sub master (a, Enctype) runFormGet form = do gets <- liftM reqGetParams getRequest let env = @@ -236,13 +236,13 @@ runFormGet form = do Just _ -> Just (Map.unionsWith (++) $ map (\(x, y) -> Map.singleton x [y]) gets, Map.empty) getHelper form env -generateFormGet :: (Html -> Form sub master a) -> GHandler sub master (a, Enctype) +generateFormGet :: (Html -> MForm sub master a) -> GHandler sub master (a, Enctype) generateFormGet form = getHelper form Nothing getKey :: Text getKey = "_hasdata" -getHelper :: (Html -> Form sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype) +getHelper :: (Html -> MForm sub master a) -> Maybe (Env, FileEnv) -> GHandler sub master (a, Enctype) getHelper form env = do let fragment = [HTML||] langs <- languages @@ -252,7 +252,7 @@ getHelper form env = do type FormRender sub master a = AForm sub master a -> Html - -> Form sub master (FormResult a, GWidget sub master ()) + -> MForm sub master (FormResult a, GWidget sub master ()) renderTable, renderDivs :: FormRender sub master a renderTable aform fragment = do diff --git a/yesod-form/Yesod/Form/MassInput.hs b/yesod-form/Yesod/Form/MassInput.hs index 3a3eae40..a07fd7fe 100644 --- a/yesod-form/Yesod/Form/MassInput.hs +++ b/yesod-form/Yesod/Form/MassInput.hs @@ -35,7 +35,7 @@ import Data.Maybe (listToMaybe) #define WHAMLET $whamlet #endif -down :: Int -> Form sub master () +down :: Int -> MForm sub master () down 0 = return () down i | i < 0 = error "called down with a negative number" down i = do @@ -43,7 +43,7 @@ down i = do put $ IntCons 0 is down $ i - 1 -up :: Int -> Form sub master () +up :: Int -> MForm sub master () up 0 = return () up i | i < 0 = error "called down with a negative number" up i = do @@ -98,7 +98,7 @@ inputList label fixXml single mdef = formToAForm $ do withDelete :: (xml ~ GWidget sub master (), RenderMessage master FormMessage) => AForm sub master a - -> Form sub master (Either xml (FormResult a, [FieldView sub master])) + -> MForm sub master (Either xml (FormResult a, [FieldView sub master])) withDelete af = do down 1 deleteName <- newFormIdent diff --git a/yesod-form/Yesod/Form/Types.hs b/yesod-form/Yesod/Form/Types.hs index cf3a6e7c..ddd1cd48 100644 --- a/yesod-form/Yesod/Form/Types.hs +++ b/yesod-form/Yesod/Form/Types.hs @@ -76,7 +76,7 @@ type FileEnv = Map.Map Text FileInfo type Lang = Text type Form sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GGHandler sub master IO) a -{-# DEPRECATE Form "Use MForm instead" #-} +{-# DEPRECATED Form "Use MForm instead" #-} type MForm sub master a = RWST (Maybe (Env, FileEnv), master, [Lang]) Enctype Ints (GGHandler sub master IO) a newtype AForm sub master a = AForm From 4d2f4a3b4f7dee015c0c50dcac28918b0860cb32 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Fri, 25 Nov 2011 15:11:15 +0200 Subject: [PATCH 2/2] Remove a painful slowdown from randomIV --- .gitignore | 1 + yesod-core/Yesod/Internal/Core.hs | 15 ++++++++------- yesod-core/bench.sh | 8 ++++++++ yesod-core/bench/pong.hs | 32 +++++++++++++++++++++++++++++++ 4 files changed, 49 insertions(+), 7 deletions(-) create mode 100755 yesod-core/bench.sh create mode 100644 yesod-core/bench/pong.hs diff --git a/.gitignore b/.gitignore index d18abfaa..0b1195cd 100644 --- a/.gitignore +++ b/.gitignore @@ -1,4 +1,5 @@ *.o +*.o_p *.hi dist *.swp diff --git a/yesod-core/Yesod/Internal/Core.hs b/yesod-core/Yesod/Internal/Core.hs index 638e03fc..150cc46c 100644 --- a/yesod-core/Yesod/Internal/Core.hs +++ b/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 = diff --git a/yesod-core/bench.sh b/yesod-core/bench.sh new file mode 100755 index 00000000..40331201 --- /dev/null +++ b/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 diff --git a/yesod-core/bench/pong.hs b/yesod-core/bench/pong.hs new file mode 100644 index 00000000..2c69a6d3 --- /dev/null +++ b/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