diff --git a/Controller.hs b/Controller.hs --- a/Controller.hs +++ b/Controller.hs @@ -10,7 +10,7 @@ import Network.Wai (Application) import Settings import TKYProf -import Yesod.Helpers.Static +import Yesod.Static -- Import all relevant handler modules here. import Handler.Home import Handler.Reports @@ -35,11 +35,10 @@ withTKYProf :: (Application -> IO a) -> IO a withTKYProf f = do rs <- atomically $ emptyReports + s <- static Settings.staticdir let h = TKYProf { getStatic = s , getReports = rs } toWaiApp h >>= f - where - s = static Settings.staticdir withDevelApp :: Dynamic withDevelApp = toDyn (withTKYProf :: (Application -> IO ()) -> IO ()) diff --git a/Handler/Home.hs b/Handler/Home.hs --- a/Handler/Home.hs +++ b/Handler/Home.hs @@ -21,4 +21,4 @@ addScript $ StaticR js_jquery_ui_widget_js addScript $ StaticR js_jquery_iframe_transport_js addScript $ StaticR js_jquery_fileupload_js - addWidget $(widgetFile "home") + $(widgetFile "home") diff --git a/Handler/Reports.hs b/Handler/Reports.hs --- a/Handler/Reports.hs +++ b/Handler/Reports.hs @@ -11,20 +11,20 @@ import Data.Text (Text) import Handler.Reports.Helpers (getAllReports, getProfilingReport, postProfilingReport) import ProfilingReport -import TKYProf -import Yesod.Request +import TKYProf hiding (lift) +import Yesod.Core (lift) import qualified Data.Aeson as A (encode) -import qualified Data.Attoparsec as A -import qualified Data.ByteString as S -import qualified Data.ByteString.Lazy as L import qualified Data.Text.Lazy.Encoding as T (decodeUtf8) +import Network.HTTP.Types.Status (seeOther303) +import Data.Conduit (($$)) +import Text.Julius getReportsR :: Handler RepHtml getReportsR = do reports <- getAllReports defaultLayout $ do setTitle "TKYProf Reports" - addWidget $(widgetFile "reports") + $(widgetFile "reports") postReportsR :: Handler () postReportsR = do @@ -36,7 +36,7 @@ sendResponseCreated ReportsR getReportsIdR :: ReportID -> Handler RepHtml -getReportsIdR reportId = redirect RedirectSeeOther (ReportsIdTimeR reportId []) +getReportsIdR reportId = redirectWith seeOther303 (ReportsIdTimeR reportId []) getReportsIdTimeR :: ReportID -> [a] -> Handler RepHtml getReportsIdTimeR reportId _ = getReportsIdCommon reportId "time" @@ -53,23 +53,17 @@ found -> return found postFileInfo :: FileInfo -> Handler ReportID -postFileInfo FileInfo {fileContent} = do - prof <- parseFileContent fileContent +postFileInfo info = do + prof <- lift $ fileSource info $$ profilingReportI postProfilingReport prof -parseFileContent :: L.ByteString -> Handler ProfilingReport -parseFileContent content = - case A.parseOnly profilingReport (S.concat $ L.toChunks content) of - Left err -> invalidArgs ["Invalid format", toMessage err] - Right tree -> return tree - getReportsIdCommon :: ReportID -> Text -> Handler RepHtml getReportsIdCommon reportId profilingType = do report@ProfilingReport {..} <- getProfilingReport reportId - let json = T.decodeUtf8 $ A.encode reportCostCentres + let json = rawJS $ T.decodeUtf8 $ A.encode reportCostCentres defaultLayout $ do setTitle $ "TKYProf Reports" addScript $ StaticR js_tkyprof_js addScript $ StaticR js_d3_min_js addScript $ StaticR js_d3_layout_min_js - addWidget $(widgetFile "reports-id") + $(widgetFile "reports-id") diff --git a/ProfilingReport.hs b/ProfilingReport.hs --- a/ProfilingReport.hs +++ b/ProfilingReport.hs @@ -27,16 +27,16 @@ import Control.Applicative hiding (many) import Data.Aeson import Data.Attoparsec.Char8 as A8 -import Data.Attoparsec.Enumerator (iterParser) +import Data.Conduit.Attoparsec (sinkParser) import Data.ByteString (ByteString) -import Data.Enumerator (Iteratee) +import Data.Conduit import Data.Foldable (foldl') import Data.Time (UTCTime(..), TimeOfDay(..), timeOfDayToTime, fromGregorian) import Data.Tree (Tree(..), Forest) import Data.Tree.Zipper (TreePos, Full) import Prelude hiding (takeWhile) import qualified Data.Attoparsec as A -import qualified Data.Map as M +import qualified Data.HashMap.Strict as M import qualified Data.Tree.Zipper as Z import qualified Data.Vector as V import Data.Text (Text) @@ -59,6 +59,7 @@ { totalSecs :: Double , totalTicks :: Integer , resolution :: Integer + , processors :: Integer } deriving Show newtype TotalAlloc = TotalAlloc @@ -83,8 +84,8 @@ , inheritedAlloc :: Double } deriving Show -profilingReportI :: Monad m => Iteratee ByteString m ProfilingReport -profilingReportI = iterParser profilingReport +profilingReportI :: MonadThrow m => GLSink ByteString m ProfilingReport +profilingReportI = sinkParser profilingReport profilingReport :: Parser ProfilingReport profilingReport = spaces >> @@ -128,12 +129,15 @@ string "total time ="; spaces secs <- double string " secs"; spaces - (ticks, res) <- parens $ - (,) <$> decimal <* string " ticks @ " - <*> decimal <* string " ms" + (ticks, res, procs) <- parens $ + (,,) <$> decimal <* string " ticks @ " + <*> time + <*> ( string ", " *> decimal <* string " processor" <|> pure 1 ) return TotalTime { totalSecs = secs , totalTicks = ticks - , resolution = res } + , resolution = res + , processors = procs } + where time = (decimal <* string " us") <|> (pure (*1000) <*> decimal <* string " ms") totalAlloc :: Parser TotalAlloc totalAlloc = do @@ -205,7 +209,7 @@ where howMany' !n = (p >> howMany' (succ n)) <|> return n spaces :: Parser () -spaces = () <$ many space +spaces = () <$ skipMany space line :: Parser ByteString line = A.takeWhile (not . isEndOfLine) <* spaces diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -26,3 +26,6 @@ ------------------------ This tool is written and maintained by Mitsutoshi Aoe, . +And thanks to the following contributors: + +* Ben Gamari (@bgamari) diff --git a/TKYProf.hs b/TKYProf.hs --- a/TKYProf.hs +++ b/TKYProf.hs @@ -1,7 +1,7 @@ {-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} module TKYProf ( TKYProf (..) - , TKYProfRoute (..) + , Route (..) , resourcesTKYProf , Handler , Widget @@ -10,7 +10,7 @@ , module StaticFiles , module Model , module Control.Monad.STM - , StaticRoute (..) + , StaticRoute , lift , liftIO ) where @@ -24,8 +24,8 @@ import StaticFiles import System.Directory import System.FilePath (()) -import Yesod.Core -import Yesod.Helpers.Static +import Yesod.Core hiding (lift) +import Yesod.Static import qualified Data.ByteString.Lazy as L import qualified Data.Text as T import qualified Settings @@ -39,14 +39,6 @@ , getReports :: Reports } --- | A useful synonym; most of the handler functions in your application --- will need to be of this type. -type Handler = GHandler TKYProf TKYProf - --- | A useful synonym; most of the widgets functions in your application --- will need to be of this type. -type Widget = GWidget TKYProf TKYProf - -- This is where we define all of the routes in our application. For a full -- explanation of the syntax, please see: -- http://docs.yesodweb.com/book/web-routes-quasi/ @@ -71,22 +63,16 @@ -- Please see the documentation for the Yesod typeclass. There are a number -- of settings which can be configured by overriding methods here. instance Yesod TKYProf where - approot _ = Settings.approot + approot = ApprootRelative defaultLayout widget = do mmsg <- getMessage (title, bcs) <- breadcrumbs pc <- widgetToPageContent $ do - addWidget $(Settings.widgetFile "header") + $(Settings.widgetFile "header") widget - addLucius $(Settings.luciusFile "default-layout") - hamletToRepHtml $(Settings.hamletFile "default-layout") - - -- This is done to provide an optimization for serving static files from - -- a separate domain. Please see the staticroot setting in Settings.hs - urlRenderOverride a (StaticR s) = - Just $ uncurry (joinPath a Settings.staticroot) $ renderRoute s - urlRenderOverride _ _ = Nothing + toWidget $(Settings.luciusFile "templates/default-layout.lucius") + hamletToRepHtml $(Settings.hamletFile "templates/default-layout.hamlet") -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows @@ -100,6 +86,8 @@ exists <- liftIO $ doesFileExist fn' unless exists $ liftIO $ L.writeFile fn' content return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], []) + + maximumContentLength _ _ = 20*1024*1024 instance YesodBreadcrumbs TKYProf where breadcrumb HomeR = return ("Home", Nothing) diff --git a/config/Settings.hs b/config/Settings.hs --- a/config/Settings.hs +++ b/config/Settings.hs @@ -7,12 +7,10 @@ -- by overriding methods in the Yesod typeclass. That instance is -- declared in the tkyprof.hs file. module Settings - ( hamletFile - , juliusFile - , luciusFile + ( H.hamletFile + , H.juliusFile + , H.luciusFile , widgetFile - , approot - , staticroot , staticdir ) where @@ -20,46 +18,14 @@ import qualified Text.Julius as H import qualified Text.Lucius as H import Language.Haskell.TH.Syntax -import Yesod.Widget (addWidget, addJulius, addLucius) -import Data.Monoid (mempty, mappend) -import System.Directory (doesFileExist) -import Data.Text (Text) - --- | The base URL for your application. This will usually be different for --- development and production. Yesod automatically constructs URLs for you, --- so this value must be accurate to create valid links. -approot :: Text -#ifdef PRODUCTION --- You probably want to change this. If your domain name was "yesod.com", --- you would probably want it to be: --- > approot = "http://www.yesod.com" --- Please note that there is no trailing slash. -approot = "http://localhost:3000" -#else -approot = "http://localhost:3000" -#endif +import Yesod.Default.Util +import Data.Default (def) -- | The location of static files on your system. This is a file system -- path. The default value works properly with your scaffolded site. staticdir :: FilePath staticdir = "static" --- | The base URL for your static files. As you can see by the default --- value, this can simply be "static" appended to your application root. --- A powerful optimization can be serving static files from a separate --- domain name. This allows you to use a web server optimized for static --- files, more easily set expires and cache values, and avoid possibly --- costly transference of cookies on static files. For more information, --- please see: --- http://code.google.com/speed/page-speed/docs/request.html#ServeFromCookielessDomain --- --- If you change the resource pattern for StaticR in tkyprof.hs, you will --- have to make a corresponding change here. --- --- To see how this value is used, see urlRenderOverride in tkyprof.hs -staticroot :: Text -staticroot = approot `mappend` "/static" - -- The rest of this file contains settings which rarely need changing by a -- user. @@ -76,35 +42,5 @@ -- used; to get the same auto-loading effect, it is recommended that you -- use the devel server. -toHamletFile, toJuliusFile, toLuciusFile :: String -> FilePath -toHamletFile x = "hamlet/" ++ x ++ ".hamlet" -toJuliusFile x = "julius/" ++ x ++ ".julius" -toLuciusFile x = "lucius/" ++ x ++ ".lucius" - -hamletFile :: FilePath -> Q Exp -hamletFile = H.hamletFile . toHamletFile - -luciusFile :: FilePath -> Q Exp -#ifdef PRODUCTION -luciusFile = H.luciusFile . toLuciusFile -#else -luciusFile = H.luciusFileDebug . toLuciusFile -#endif - -juliusFile :: FilePath -> Q Exp -#ifdef PRODUCTION -juliusFile = H.juliusFile . toJuliusFile -#else -juliusFile = H.juliusFileDebug . toJuliusFile -#endif - widgetFile :: FilePath -> Q Exp -widgetFile x = do - let h = unlessExists toHamletFile hamletFile - let j = unlessExists toJuliusFile juliusFile - let l = unlessExists toLuciusFile luciusFile - [|addWidget $h >> addJulius $j >> addLucius $l|] - where - unlessExists tofn f = do - e <- qRunIO $ doesFileExist $ tofn x - if e then f x else [|mempty|] +widgetFile = widgetFileNoReload def diff --git a/config/StaticFiles.hs b/config/StaticFiles.hs --- a/config/StaticFiles.hs +++ b/config/StaticFiles.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} module StaticFiles where -import Yesod.Helpers.Static +import Yesod.Static -- | This generates easy references to files in the static directory at compile time. -- The upside to this is that you have compile-time verification that referenced files diff --git a/hamlet/default-layout.hamlet b/hamlet/default-layout.hamlet deleted file mode 100644 --- a/hamlet/default-layout.hamlet +++ /dev/null @@ -1,15 +0,0 @@ -!!! - - - - - -