diff --git a/Controller.hs b/Controller.hs new file mode 100644 --- /dev/null +++ b/Controller.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Controller + ( withTKYProf + , withDevelApp + ) where + +import TKYProf +import Settings +import Yesod.Helpers.Static +import Data.ByteString (ByteString) +import Network.Wai (Application) +import Data.Dynamic (Dynamic, toDyn) + +-- Import all relevant handler modules here. +import Handler.Home +import Handler.Reports + +-- This line actually creates our YesodSite instance. It is the second half +-- of the call to mkYesodData which occurs in TKYProf.hs. Please see +-- the comments there for more details. +mkYesodDispatch "TKYProf" resourcesTKYProf + +-- Some default handlers that ship with the Yesod site template. You will +-- very rarely need to modify this. +getFaviconR :: Handler () +getFaviconR = sendFile "image/x-icon" "config/favicon.ico" + +getRobotsR :: Handler RepPlain +getRobotsR = return $ RepPlain $ toContent ("User-agent: *" :: ByteString) + +-- This function allocates resources (such as a database connection pool), +-- performs initialization and creates a WAI application. This is also the +-- place to put your migrate statements to have automatic database +-- migrations handled by Yesod. +withTKYProf :: (Application -> IO a) -> IO a +withTKYProf f = do + rs <- atomically $ emptyReports + 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 new file mode 100644 --- /dev/null +++ b/Handler/Home.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +module Handler.Home where +import TKYProf +import Yesod.Form (Enctype(Multipart)) + +-- This is a handler function for the GET request method on the RootR +-- resource pattern. All of your resource patterns are defined in +-- TKYProf.hs; look for the line beginning with mkYesodData. +-- +-- The majority of the code you will write in Yesod lives in these handler +-- functions. You can spread them across multiple files if you are so +-- inclined, or create a single monolithic file. +getHomeR :: Handler RepHtml +getHomeR = do + defaultLayout $ do + setTitle "Devel.TKYProf Home" + addScript $ StaticR js_jquery_ui_widgets_min_js + addScript $ StaticR js_jquery_iframe_transport_js + addScript $ StaticR js_jquery_fileupload_js + addWidget $(widgetFile "home") diff --git a/Handler/Reports.hs b/Handler/Reports.hs new file mode 100644 --- /dev/null +++ b/Handler/Reports.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE RecordWildCards, NamedFieldPuns, TemplateHaskell, QuasiQuotes, OverloadedStrings #-} +module Handler.Reports + ( getReportsR + , postReportsR + , getReportsIdR + ) where + +import TKYProf +import ProfilingReport +import Control.Applicative +import Yesod.Request +import qualified Data.Attoparsec as A +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.Aeson as A (encode) +import qualified Data.Text.Lazy.Encoding as T (decodeUtf8) + +getReportsR :: Handler RepHtml +getReportsR = do + reports <- getAllReports + defaultLayout $ do + setTitle "Devel.TKYProf Report" + addWidget $(widgetFile "reports") + +postReportsR :: Handler () +postReportsR = do + FileInfo {fileContent} <- getPostedReport + prof <- parseFileContent fileContent + postProfilingReport prof + +getReportsIdR :: ReportID -> Handler RepHtml +getReportsIdR reportId = do + report@ProfilingReport {..} <- getProfilingReport reportId + let json = T.decodeUtf8 $ A.encode reportCostCentres + defaultLayout $ do + setTitle "Devel.TKYProf Report" + addScript $ StaticR js_d3_js + addScript $ StaticR js_d3_layout_js + addWidget $(widgetFile "reports-id") + +-- Helper functions +runReports :: STM a -> Handler a +runReports = liftIO . atomically + +getReports' :: Handler Reports +getReports' = getReports <$> getYesod + +getAllReports :: Handler [(ReportID, ProfilingReport)] +getAllReports = do + rs <- getReports' + runReports $ allReports rs + +getAllProfilingReports :: Handler [ProfilingReport] +getAllProfilingReports = map snd <$> getAllReports + +getProfilingReport :: ReportID -> Handler ProfilingReport +getProfilingReport reportId = do + rs <- getReports' + mreport <- runReports $ lookupReport reportId rs + case mreport of + Just r -> return r + Nothing -> notFound + +postProfilingReport :: ProfilingReport -> Handler () +postProfilingReport prof = do + rs <- getReports' + reportId <- runReports $ insertReport prof rs + sendResponseCreated (ReportsIdR reportId) + +getPostedReport :: Handler FileInfo +getPostedReport = do + (_, files) <- runRequestBody + case lookup "reports" files of + Nothing -> invalidArgs ["Missing files"] + Just file -> return file + +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2011, Mitsutoshi Aoe. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Model.hs b/Model.hs new file mode 100644 --- /dev/null +++ b/Model.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE RecordWildCards #-} +module Model where +import ProfilingReport +import Data.Map (Map) +import qualified Data.Map as M +import Control.Applicative +import Control.Concurrent.STM + +type ReportID = Integer + +data Reports = Reports + { newReportId :: TVar ReportID + , reports :: TVar (Map ReportID ProfilingReport) + } + +emptyReports :: STM Reports +emptyReports = do + uid <- newTVar 0 + rs <- newTVar M.empty + return $ Reports { newReportId = uid + , reports = rs } + +insertReport :: ProfilingReport -> Reports -> STM ReportID +insertReport r Reports{..} = do + uid <- readTVar newReportId + rs <- readTVar reports + writeTVar newReportId (succ uid) + writeTVar reports (M.insert uid r rs) + return uid + +deleteReport :: ReportID -> Reports -> STM () +deleteReport i Reports{..} = do + rs <- readTVar reports + writeTVar reports (M.delete i rs) + +lookupReport :: ReportID -> Reports -> STM (Maybe ProfilingReport) +lookupReport i Reports{..} = do + rs <- readTVar reports + return $ M.lookup i rs + +memberReport :: ReportID -> Reports -> STM Bool +memberReport i Reports{..} = do + rs <- readTVar reports + return $ M.member i rs + +allReports :: Reports -> STM [(ReportID, ProfilingReport)] +allReports (Reports _ rs) = M.toList <$> readTVar rs + +allProfilingReports :: Reports -> STM [ProfilingReport] +allProfilingReports r = map snd <$> allReports r diff --git a/ProfilingReport.hs b/ProfilingReport.hs new file mode 100644 --- /dev/null +++ b/ProfilingReport.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE FlexibleInstances, RecordWildCards, OverloadedStrings, BangPatterns #-} +module ProfilingReport + ( -- * Parsers for profiling reports + profilingReport + , profilingReportI + -- * Parsers for sub-parts of the report + , timestamp + , title + , commandLine + , totalTime + , totalAlloc + , hotCostCentres + , costCentres + -- * Data types + , ProfilingReport(..) + , Timestamp + , CommandLine + , TotalTime(..) + , TotalAlloc(..) + , BriefCostCentre(..) + , CostCentre(..) + -- * Re-exported modules + , module Data.Tree + ) where + +import Control.Applicative hiding (many) +import Data.Aeson +import Data.Attoparsec.Char8 as A8 +import Data.Attoparsec.Enumerator (iterParser) +import Data.ByteString (ByteString) +import Data.Enumerator (Iteratee) +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.Tree.Zipper as Z +import qualified Data.Vector as V +import Data.Text (Text) +import qualified Data.Text.Encoding as T + +data ProfilingReport = ProfilingReport + { reportTimestamp :: Timestamp + , reportCommandLine :: CommandLine + , reportTotalTime :: TotalTime + , reportTotalAlloc :: TotalAlloc + , reportHotCostCentres :: [BriefCostCentre] + , reportCostCentres :: Tree CostCentre + } deriving Show + +type Timestamp = UTCTime + +type CommandLine = Text + +data TotalTime = TotalTime + { totalSecs :: Double + , totalTicks :: Integer + , resolution :: Integer + } deriving Show + +newtype TotalAlloc = TotalAlloc + { totalAllocBytes :: Integer + } deriving Show + +data BriefCostCentre = BriefCostCentre + { briefCostCentreName :: Text + , briefCostCentreModule :: Text + , briefCostCentreTime :: Double + , briefCostCentreAlloc :: Double + } deriving Show + +data CostCentre = CostCentre + { costCentreName :: ByteString + , costCentreModule :: ByteString + , costCentreNo :: Integer + , costCentreEntries :: Integer + , individualTime :: Double + , individualAlloc :: Double + , inheritedTime :: Double + , inheritedAlloc :: Double + } deriving Show + +profilingReportI :: Monad m => Iteratee ByteString m ProfilingReport +profilingReportI = iterParser profilingReport + +profilingReport :: Parser ProfilingReport +profilingReport = spaces >> + ProfilingReport <$> timestamp + <* title <* spaces + <*> commandLine <* spaces + <*> totalTime <* spaces + <*> totalAlloc <* spaces + <*> hotCostCentres <* spaces + <*> costCentres + +timestamp :: Parser Timestamp +timestamp = do + dayOfTheWeek <* spaces + m <- month <* spaces + d <- day <* spaces + tod <- timeOfDay <* spaces + y <- year <* spaces + return UTCTime { utctDay = fromGregorian y m d + , utctDayTime = timeOfDayToTime tod } + where + year = decimal + month = toNum <$> A8.take 3 + where toNum m = case m of + "Jan" -> 1; "Feb" -> 2; "Mar" -> 3; "Apr" -> 4; + "May" -> 5; "Jun" -> 6; "Jul" -> 7; "Aug" -> 8; + "Sep" -> 9; "Oct" -> 10; "Nov" -> 11; "Dec" -> 12 + _ -> error "timestamp.toNum: impossible" + day = decimal + timeOfDay = TimeOfDay <$> decimal <* string ":" <*> decimal <*> pure 0 + dayOfTheWeek = takeTill isSpace + +title :: Parser ByteString +title = string "Time and Allocation Profiling Report (Final)" + +commandLine :: Parser CommandLine +commandLine = T.decodeUtf8 <$> line + +totalTime :: Parser TotalTime +totalTime = do + string "total time ="; spaces + secs <- double + string " secs"; spaces + (ticks, res) <- parens $ + (,) <$> decimal <* string " ticks @ " + <*> decimal <* string " ms" + return TotalTime { totalSecs = secs + , totalTicks = ticks + , resolution = res } + +totalAlloc :: Parser TotalAlloc +totalAlloc = do + string "total alloc ="; spaces + n <- groupedDecimal + string " bytes" <* spaces <* parens (string "excludes profiling overheads") + return TotalAlloc { totalAllocBytes = n } + +groupedDecimal :: Parser Integer +groupedDecimal = foldl' go 0 <$> decimal `sepBy` char8 ',' + where go z n = z*1000 + n + +hotCostCentres :: Parser [BriefCostCentre] +hotCostCentres = header *> spaces *> many1 briefCostCentre + where header :: Parser ByteString + header = line + +briefCostCentre :: Parser BriefCostCentre +briefCostCentre = + BriefCostCentre <$> symbolText <* spaces + <*> symbolText <* spaces + <*> double <* spaces + <*> double <* spaces + +costCentres :: Parser (Tree CostCentre) +costCentres = header *> spaces *> costCentreTree + where header = count 2 line + +-- Internal functions +costCentreTree :: Parser (Tree CostCentre) +costCentreTree = buildTree <$> costCentreMap >>= maybe empty pure + where + costCentreMap = nestedCostCentre `sepBy1` endOfLine + nestedCostCentre = (,) <$> nestLevel <*> costCentre + +nestLevel :: Parser Int +nestLevel = howMany space + +costCentre :: Parser CostCentre +costCentre = CostCentre <$> takeWhile (not . isSpace) <* spaces + <*> takeWhile (not . isSpace) <* spaces + <*> decimal <* spaces + <*> decimal <* spaces + <*> double <* spaces + <*> double <* spaces + <*> double <* spaces + <*> double + +type Zipper = TreePos Full +type Level = Int + +buildTree :: [(Level, a)] -> Maybe (Tree a) +buildTree [] = Nothing +buildTree ((lvl, t):xs) = Z.toTree <$> snd (foldl' go (lvl, Just z) xs) + where + z = Z.fromTree $ Node t [] + go :: (Level, Maybe (Zipper a)) -> (Level, a) -> (Level, Maybe (Zipper a)) + go (curLvl, mzipper) a@(lvl', x) + | curLvl > lvl' = go (curLvl-1, mzipper >>= Z.parent) a + | curLvl < lvl' = case mzipper >>= Z.lastChild of + Nothing -> (lvl', Z.insert (Node x []) . Z.children <$> mzipper) + mzipper' -> go (curLvl+1, mzipper') a + | otherwise = (lvl', Z.insert (Node x []) . Z.nextSpace <$> mzipper) + + +-- Small utilities +howMany :: Parser a -> Parser Int +howMany p = howMany' 0 + where howMany' !n = (p >> howMany' (succ n)) <|> return n + +spaces :: Parser () +spaces = () <$ many space + +line :: Parser ByteString +line = A.takeWhile (not . isEndOfLine) <* spaces + +parens :: Parser a -> Parser a +parens p = string "(" *> p <* string ")" + +symbol :: Parser ByteString +symbol = takeWhile (not . isSpace) + +symbolText :: Parser Text +symbolText = T.decodeUtf8 <$> symbol + +-- Aeson +instance ToJSON ProfilingReport where + toJSON ProfilingReport {..} = + object [ "timestamp" .= reportTimestamp + , "commandLine" .= reportCommandLine + , "totalTime" .= reportTotalTime + , "totalAlloc" .= reportTotalAlloc + , "hotCostCentres" .= reportHotCostCentres + , "costCentres" .= reportCostCentres + ] + +instance ToJSON TotalTime where + toJSON TotalTime {..} = + object [ "secs" .= totalSecs + , "ticks" .= totalTicks + , "resolution" .= resolution + ] + +instance ToJSON TotalAlloc where + toJSON TotalAlloc {..} = + object [ "bytes" .= totalAllocBytes ] + +instance ToJSON BriefCostCentre where + toJSON BriefCostCentre {..} = + object [ "name" .= briefCostCentreName + , "module" .= briefCostCentreModule + , "time" .= briefCostCentreTime + , "alloc" .= briefCostCentreAlloc + ] + +instance ToJSON (Tree CostCentre) where + toJSON (Node cc@(CostCentre {..}) subForest) + | null subForest = cc' + | otherwise = branch + where + branch = Object $ M.insert "subForest" subForestWithParent unwrappedCC + parent = Object $ M.insert "isParent" (toJSON True) unwrappedCC + subForestWithParent = Array $ V.fromList $ parent:map toJSON subForest + cc'@(Object unwrappedCC) = toJSON cc + +instance ToJSON CostCentre where + toJSON CostCentre {..} = + object [ "name" .= costCentreName + , "module" .= costCentreModule + , "no" .= costCentreNo + , "entries" .= costCentreEntries + , "individualTime" .= individualTime + , "individualAlloc" .= individualAlloc + , "inheritedTime" .= inheritedTime + , "inheritedAlloc" .= inheritedAlloc ] diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/TKYProf.hs b/TKYProf.hs new file mode 100644 --- /dev/null +++ b/TKYProf.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings #-} +module TKYProf + ( TKYProf (..) + , TKYProfRoute (..) + , resourcesTKYProf + , Handler + , Widget + , module Yesod.Core + , module Settings + , module StaticFiles + , module Model + , module Control.Monad.STM + , StaticRoute (..) + , lift + , liftIO + ) where + +import Control.Monad (unless) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.STM (STM, atomically) +import Control.Monad.Trans.Class (lift) +import Model +import Settings (hamletFile, luciusFile, juliusFile, widgetFile) +import StaticFiles +import System.Directory +import Yesod.Core +import Yesod.Helpers.Static +import qualified Data.ByteString.Lazy as L +import qualified Data.Text as T +import qualified Settings + +-- | The site argument for your application. This can be a good place to +-- keep settings and values requiring initialization before your application +-- starts running, such as database connections. Every handler will have +-- access to the data present here. +data TKYProf = TKYProf + { getStatic :: Static -- ^ Settings for static file serving. + , 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/ +-- +-- This function does three things: +-- +-- * Creates the route datatype TKYProfRoute. Every valid URL in your +-- application can be represented as a value of this type. +-- * Creates the associated type: +-- type instance Route TKYProf = TKYProfRoute +-- * Creates the value resourcesTKYProf which contains information on the +-- resources declared below. This is used in Controller.hs by the call to +-- mkYesodDispatch +-- +-- What this function does *not* do is create a YesodSite instance for +-- TKYProf. Creating that instance requires all of the handler functions +-- for our application to be in scope. However, the handler functions +-- usually require access to the TKYProfRoute datatype. Therefore, we +-- split these actions into two functions and place them in separate files. +mkYesodData "TKYProf" $(parseRoutesFile "config/routes") + +-- 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 + + defaultLayout widget = do + mmsg <- getMessage + (title, bcs) <- breadcrumbs + pc <- widgetToPageContent $ do + 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 + + -- This function creates static content files in the static folder + -- and names them based on a hash of their content. This allows + -- expiration dates to be set far in the future without worry of + -- users receiving stale content. + addStaticContent ext' _ content = do + let fn = base64md5 content ++ '.' : T.unpack ext' + let statictmp = Settings.staticdir ++ "/tmp/" + liftIO $ createDirectoryIfMissing True statictmp + let fn' = statictmp ++ fn + exists <- liftIO $ doesFileExist fn' + unless exists $ liftIO $ L.writeFile fn' content + return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], []) + +instance YesodBreadcrumbs TKYProf where + breadcrumb HomeR = return ("Home", Nothing) + breadcrumb ReportsR = return ("Reports", Just HomeR) + breadcrumb (ReportsIdR rid) = return ("Report #" `T.append` T.pack (show rid), Just ReportsR) + breadcrumb _ = return ("Not found", Just HomeR) + diff --git a/bin/prof2json.hs b/bin/prof2json.hs new file mode 100644 --- /dev/null +++ b/bin/prof2json.hs @@ -0,0 +1,29 @@ +module Main where +import Blaze.ByteString.Builder (toByteStringIO) +import Control.Applicative +import Control.Exception (bracket) +import Control.Monad.Trans (liftIO) +import Data.Aeson (toJSON) +import Data.Aeson.Encode (fromValue) +import Data.Enumerator (Iteratee, ($$), run_) +import ProfilingReport (ProfilingReport(..), profilingReportI) +import System.Environment (getArgs) +import System.FilePath (dropExtension) +import System.IO (IOMode(WriteMode), openFile, hClose) +import qualified Data.ByteString as S +import qualified Data.Enumerator.Binary as E + +main :: IO () +main = getArgs >>= mapM_ (run_ . job) + +job :: FilePath -> Iteratee S.ByteString IO () +job f = E.enumFile f $$ iterJob json + where + json = dropExtension f ++ ".json" + +iterJob :: FilePath -> Iteratee S.ByteString IO () +iterJob fpath = do + builder <- fromValue . toJSON . reportCostCentres <$> profilingReportI + liftIO $ bracket (openFile fpath WriteMode) + hClose + (\h -> toByteStringIO (S.hPut h) builder) diff --git a/bin/tkyprof.hs b/bin/tkyprof.hs new file mode 100644 --- /dev/null +++ b/bin/tkyprof.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE CPP #-} +import Controller (withTKYProf) +#if PRODUCTION +import Network.Wai.Handler.Webkit (run) + +main :: IO () +main = withTKYProf $ run "Devel.TKYProf" +#elif WEB +import Network.Wai.Handler.Warp (run) + +main :: IO () +main = withTKYProf $ run 3000 +#else +import System.IO (hPutStrLn, stderr) +import Network.Wai.Middleware.Debug (debug) +import Network.Wai.Handler.Warp (run) + +main :: IO () +main = do + let port = 3000 + hPutStrLn stderr $ "Application launched, listening on port " ++ show port + withTKYProf $ run port . debug +#endif diff --git a/config/Settings.hs b/config/Settings.hs new file mode 100644 --- /dev/null +++ b/config/Settings.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Settings are centralized, as much as possible, into this file. This +-- includes database connection settings, static file locations, etc. +-- In addition, you can configure a number of different aspects of Yesod +-- by overriding methods in the Yesod typeclass. That instance is +-- declared in the tkyprof.hs file. +module Settings + ( hamletFile + , juliusFile + , luciusFile + , widgetFile + , approot + , staticroot + , staticdir + ) where + +import qualified Text.Hamlet as H +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 + +-- | 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. + +-- The following three functions are used for calling HTML, CSS and +-- Javascript templates from your Haskell code. During development, +-- the "Debug" versions of these functions are used so that changes to +-- the templates are immediately reflected in an already running +-- application. When making a production compile, the non-debug version +-- is used for increased performance. +-- +-- You can see an example of how to call these functions in Handler/Root.hs +-- +-- Note: due to polymorphic Hamlet templates, hamletFileDebug is no longer +-- 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|] diff --git a/config/StaticFiles.hs b/config/StaticFiles.hs new file mode 100644 --- /dev/null +++ b/config/StaticFiles.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies #-} +module StaticFiles where + +import Yesod.Helpers.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 +-- exist. However, any files added to your static directory during run-time can't be +-- accessed this way. You'll have to use their FilePath or URL to access them. +staticFiles "static" diff --git a/tkyprof.cabal b/tkyprof.cabal new file mode 100644 --- /dev/null +++ b/tkyprof.cabal @@ -0,0 +1,97 @@ +name: tkyprof +version: 0.0.1 +license: BSD3 +license-file: LICENSE +author: Mitsutoshi Aoe +maintainer: Mitsutoshi Aoe +synopsis: A visualizer for GHC Profiling Reports +description: A visualizer for GHC Profiling Reports +category: Devel +stability: Experimental +cabal-version: >= 1.6 +build-type: Simple +homepage: https://github.com/maoe/tkyprof + +flag production + description: Build the production executable. + default: False + +flag web + description: Build the production executable. + default: True + +flag devel + description: Build for use with "yesod devel" + default: False + +executable tkyprof + if flag(devel) + buildable: False + + if flag(production) + if flag(web) + ghc-options: -Wall -threaded -O2 -fno-warn-unused-do-bind + cpp-options: -DWEB + else + cpp-options: -DPRODUCTION + ghc-options: -Wall -fno-warn-unused-do-bind -pgmc g++ -pgml g++ + pkgconfig-depends: QtWebKit + build-depends: wai-handler-webkit + else + ghc-options: -Wall -threaded + + main-is: bin/tkyprof.hs + hs-source-dirs: ., config, bin + + build-depends: base >= 4 && < 5 + , aeson >= 0.3 && < 0.4 + , attoparsec >= 0.9 && < 0.10 + , attoparsec-enumerator >= 0.2 && < 0.3 + , bytestring >= 0.9 && < 0.10 + , containers < 0.5 + , directory < 2 + , enumerator >= 0.4 && < 0.5 + , hamlet >= 0.8 && < 0.10 + , rosezipper >= 0.2 && < 0.3 + , stm < 3 + , template-haskell < 3 + , text >= 0.11 && < 0.12 + , time >= 1.2 && < 1.3 + , transformers >= 0.2 && < 0.3 + , wai >= 0.4 && < 0.5 + , wai-extra >= 0.4 && < 0.5 + , warp >= 0.4 && < 0.5 + , web-routes >= 0.23 && < 0.26 + , yesod-core >= 0.8 && < 0.9 + , yesod-form >= 0.1 && < 0.2 + , yesod-json >= 0.1 && < 0.2 + , yesod-static >= 0.1 && < 0.2 + ghc-options: -Wall -threaded + +library + if flag(devel) + buildable: True + else + buildable: False + exposed-modules: Controller + hs-source-dirs: ., config, bin + other-modules: TKYProf + Handler.Home + Handler.Reports + Model + ProfilingReport + Settings + StaticFiles + +executable prof2json + buildable: False + hs-source-dirs: ., bin + main-is: prof2json.hs + build-depends: filepath + , mtl + , blaze-builder + , vector + +source-repository head + type: git + location: git@github.com:maoe/tkyprof.git