gipeda 0.2.0.1 → 0.3
raw patch · 16 files changed
+528/−141 lines, 16 filesdep +concurrent-outputdep +file-embeddep +transformers
Dependencies added: concurrent-output, file-embed, transformers
Files
- README.md +1/−1
- gipeda.cabal +23/−18
- install-jslibs.sh +1/−0
- site/index.html +42/−47
- site/js/gipeda.js +30/−7
- src/BenchNames.hs +1/−1
- src/Development/Shake/Fancy.hs +182/−0
- src/Development/Shake/Gitlib.hs +22/−0
- src/EmbeddedFiles.hs +36/−0
- src/GraphReport.hs +1/−1
- src/JsonSettings.hs +1/−1
- src/Paths.hs +6/−1
- src/ReportTypes.hs +33/−2
- src/RevReport.hs +17/−2
- src/Shake.hs +129/−58
- src/gipeda.hs +3/−2
README.md view
@@ -45,7 +45,7 @@ cabal install --bindir=. - * Create a `settings.yaml`. You can look at the example file.+ * Create a `gipeda.yaml`. You can look at the example file. * Clone the repository of your project into `repository/`. A bare clone is sufficient, e.g.
gipeda.cabal view
@@ -1,5 +1,5 @@ name: gipeda-version: 0.2.0.1+version: 0.3 category: Development synopsis: Git Performance Dashboard description:@@ -60,29 +60,34 @@ Summary, GraphSummaries, WithLatestLogs,+ EmbeddedFiles, Development.Shake.Gitlib,+ Development.Shake.Fancy, Data.Text.Binary build-depends:- base >= 4.6 && <4.9,- bytestring >= 0.10 && <0.11,- containers >= 0.4 && <0.6,- directory >= 1.2 && <1.3,- filepath >= 1.3 && <1.5,- shake >= 0.13 && <0.16,- text >= 0.11 && <1.3,- unordered-containers >= 0.2 && <0.3,- split >= 0.2 && <0.3,- vector >= 0.10 && <0.12,- cassava >= 0.4 && <0.5,- yaml >= 0.8 && <0.9,- aeson >= 0.7 && <0.12,- scientific >= 0.3 && <0.4,- gitlib >= 3.1 && <3.2,+ base >= 4.6 && <4.9,+ bytestring >= 0.10 && <0.11,+ containers >= 0.4 && <0.6,+ directory >= 1.2 && <1.3,+ filepath >= 1.3 && <1.5,+ shake >= 0.13 && <0.16,+ text >= 0.11 && <1.3,+ unordered-containers >= 0.2 && <0.3,+ split >= 0.2 && <0.3,+ vector >= 0.10 && <0.12,+ cassava >= 0.4 && <0.5,+ yaml >= 0.8 && <0.9,+ aeson >= 0.7 && <0.12,+ scientific >= 0.3 && <0.4,+ gitlib >= 3.1 && <3.2, gitlib-libgit2,- tagged >= 0.7 && <0.9,- extra >= 1 && <1.5+ tagged >= 0.7 && <0.9,+ extra >= 1 && <1.5,+ file-embed >= 0.0.9 && < 0.0.11,+ concurrent-output >= 1.7 && < 1.8,+ transformers >= 0.4 && < 0.6 if flag(old-gitlib) build-depends:
install-jslibs.sh view
@@ -3,6 +3,7 @@ set -e set -x +mkdir -p site/js cd site/js test -e signals.min.js || wget -c https://raw.githubusercontent.com/millermedeiros/js-signals/master/dist/signals.min.js
site/index.html view
@@ -262,53 +262,48 @@ <script id="branches" type="text/x-handlebars-template"> <h2>Branches</h2> <table class="table branch-table">- {{#each_unnaturally branches}}- {{#with (lookup ../revisions this)}}- {{#with this.summary}}- <tr- class="- branch-row- {{#if stats.improvementCount}}branch-improvement{{/if}}- {{#if stats.regressionCount}}branch-regression{{/if}}- ">- <td class="col-md-2 text-right">- <abbrv class="timeago" title="{{ iso8601 this.gitDate }}">{{ humanDate this.gitDate}}</abbrv>- </td>- <td class="col-md-1">- <a href="{{revisionLink hash}}">- {{> rev-id hash=hash}}- </a>- </td>- <td class="col-md-2">- <strong>{{ @key }}</strong>- </td>- <td class="col-md-5">- {{ gitSubject }}- </td>- <td class="col-md-2 text-right">- {{> summary-icons stats}}- </td>- </tr>- {{/with}}- {{else}}- <tr- title="The tip of this branch has not been benchmarked yet"- class="branch-row">- <td class="col-md-2 text-right">- </td>- <td class="col-md-1">- {{> rev-id hash=this}}- </td>- <td class="col-md-2">- {{ @key }}- </td>- <td class="col-md-5">- </td>- <td class="col-md-2 text-right">- </td>- </tr>- {{/with}}- {{/each_unnaturally}}+ {{#each_branch branches}}+ <tr+ class="+ branch-row+ {{#if branchStats.improvementCount}}branch-improvement{{/if}}+ {{#if branchStats.regressionCount}}branch-regression{{/if}}+ ">+ <td class="col-md-2 text-right">+ {{#with (lookup ../revisions branchHash)}}+ <abbrv class="timeago" title="{{ iso8601 this.summary.gitDate }}">{{ humanDate this.summary.gitDate}}</abbrv>+ {{/with}}+ </td>+ <td class="col-md-2 text-right">+ {{# if @interesting }}+ <!--+ <a href="{{revisionLink mergeBaseHash}}" title="Merge base of this branch">+ {{> rev-id hash=mergeBaseHash}}+ </a>+ -->+ <a href="{{compareLink mergeBaseHash branchHash}}" title="Compare against merge base">+ {{ commitCount }} commits to+ </a>+ <a href="{{revisionLink branchHash}}" title="Show branch tip">+ {{> rev-id hash=branchHash}}+ </a>+ {{else}}+ (no results yet)+ {{/if}}+ </td>+ <td class="col-md-2">+ <strong>{{ @key }}</strong>+ </td>+ <td class="col-md-4">+ {{#with (lookup ../revisions branchHash)}}+ {{ summary.gitSubject }}+ {{/with}}+ </td>+ <td class="col-md-2 text-right">+ {{> summary-icons branchStats}}+ </td>+ </tr>+ {{/each_branch}} </table> </script>
site/js/gipeda.js view
@@ -226,7 +226,6 @@ Handlebars.registerHelper('each_naturally', function(context,options){ var output = ''; if (context) {- console.log(context); var keys = jQuery.map(context, function(v,k) {return k}); var sorted_keys = keys.sort(naturalSort); sorted_keys.map(function (k,i) {@@ -238,11 +237,8 @@ Handlebars.registerHelper('each_unnaturally', function(context,options){ var output = ''; if (context) {- console.log(context); var keys = jQuery.map(context, function(v,k) {return k});- // needs https://github.com/overset/javascript-natural-sort/issues/21 fixed- //var sorted_keys = keys.sort(naturalSort).reverse();- var sorted_keys = keys.sort().reverse();+ var sorted_keys = keys.sort(naturalSort).reverse(); sorted_keys.map(function (k,i) { output += options.fn(context[k], {data: {key: k, index: i}}); });@@ -250,6 +246,33 @@ return output; }); +// Sort by age, then by name+Handlebars.registerHelper('each_branch', function(context,options){+ var output = '';+ if (context) {+ jQuery.map(context, function (b,i) { return {branchData: b, branchName: i}; })+ .sort(function(a,b) {+ revA = data.revisions[a.branchData.branchHash];+ revB = data.revisions[b.branchData.branchHash];+ if (revA && revB) {+ return revB.summary.gitDate - revA.summary.gitDate;+ }+ if (revA) {+ return -1;+ }+ if (revB) {+ return 1;+ }+ return naturalSort(a.branchName, b.branchName);+ }).map(function (b,i) {+ var interesting = b.branchData.branchHash != b.branchData.mergeBaseHash;+ output += options.fn(b.branchData,+ {data: {key: b.branchName, index: i, interesting: interesting}});+ });+ }+ return output;+});+ // We cache everything var jsonSeen = {}; var jsonFetching = {};@@ -410,7 +433,7 @@ return rev.benchResults[bn] }).filter(function (br) {return br}); return {- groupName: group.groupName,+ groupName: group.groupName || "Benchmarks", benchResults: benchmarks, groupStats: groupStats(benchmarks), };@@ -438,7 +461,7 @@ return compareResults(r1,r2); }).filter(function (br) {return br}); return {- groupName: group.groupName,+ groupName: group.groupName || "Benchmarks", benchResults: benchmarks, groupStats: groupStats(benchmarks), };
src/BenchNames.hs view
@@ -16,7 +16,7 @@ benchNamesMain :: [S.BenchName] -> IO () benchNamesMain benchNames = do- settings <- S.readSettings "settings.yaml"+ settings <- S.readSettings "gipeda.yaml" let groups = map (uncurry BenchGroup) $
+ src/Development/Shake/Fancy.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds #-}+module Development.Shake.Fancy+ ( module Development.Shake++ , cmdWrap++ , shake+ , shakeArgs+ , Action+ , action+ , actionFinally+ , putNormal+ , (%>)+ , (~>)+ , writeFile'+ , writeFileChanged+ , need+ , orderOnly+ , readFileLines+ , liftAction+ , doesFileExist+ , addOracle+ , newCache+ , alwaysRerun+ , readFile'+ )+ where++import Development.Shake hiding+ ( Action+ , shake+ , shakeArgs+ , action+ , actionFinally+ , putNormal+ , (%>)+ , (~>)+ , writeFile'+ , writeFileChanged+ , need+ , orderOnly+ , readFileLines+ , doesFileExist+ , addOracle+ , newCache+ , alwaysRerun+ , readFile'+ )+import qualified Development.Shake as S+import qualified Development.Shake.Rule as S+import qualified Development.Shake.Classes as S+import qualified Development.Shake.Command as S+import System.Console.Concurrent+import System.Console.Regions+import Control.Monad.Trans.Reader+import Control.Monad.IO.Class+import Control.Monad+import Control.Applicative+import Data.List++-- | Wrapper around 'S.shake'+shake :: ShakeOptions -> Rules () -> IO ()+shake opts rules = displayConsoleRegions $ S.shake opts rules++-- | Wrapper around 'S.shakeArgs'+shakeArgs :: ShakeOptions -> Rules () -> IO ()+shakeArgs opts rules = displayConsoleRegions $ S.shakeArgs opts rules++data FancyEnv = FancyEnv+ { currentTarget :: String+ , currentRegion :: ConsoleRegion+ }++-- | Wrapper around 'S.Action'+newtype Action a = Action (ReaderT FancyEnv S.Action a)+ deriving (Monad, Applicative, Functor, MonadIO)++runAction :: Action a -> FancyEnv -> S.Action a+runAction (Action fa) = runReaderT fa++mkAction :: (FancyEnv -> S.Action a) -> Action a+mkAction act = Action (ReaderT act)++liftAction :: S.Action a -> Action a+liftAction act = mkAction (const act)+++finish :: FancyEnv -> IO ()+finish env = finishConsoleRegion (currentRegion env) $+ "✓ " ++ currentTarget env ++ " done"++wrapAction :: Action a -> String -> S.Action a+wrapAction act target = do+ region <- liftIO $ openConsoleRegion Linear+ let env = FancyEnv target region+ runAction act env `S.actionFinally` finish env++setDefaultMessage :: Action ()+setDefaultMessage = mkAction $ \env ->+ liftIO $ setConsoleRegion (currentRegion env) $+ " " ++ currentTarget env ++ " processing..."++setMessage :: Char -> String -> Action ()+setMessage c doing = mkAction $ \env ->+ liftIO $ setConsoleRegion (currentRegion env) $+ [c] ++ " " ++ currentTarget env ++ " " ++ doing+++describe :: S.Action a -> Char -> String -> Action a+describe act symb desc = do+ setMessage symb desc+ x <- liftAction act+ setDefaultMessage+ return x++-- | Wrapper around 'S.action'+action :: Action a -> Rules ()+action act = S.action $ wrapAction act "some action"++-- | Wrapper around 'S.actionFinally'+actionFinally :: Action a -> IO b -> Action a+actionFinally act io = mkAction $ \env -> runAction act env `S.actionFinally` io++-- | Wrapper around 'S.putNormal'+putNormal :: String -> Action ()+putNormal txt = mkAction $ \env -> do+ verb <- getVerbosity+ when (Normal >= verb) $ liftIO $ outputConcurrent $ currentTarget env ++ ": " ++ txt++-- | Wrapper around '%>'+(%>) :: FilePattern -> (FilePath -> Action ()) -> Rules () +pat %> act = pat S.%> (\out -> wrapAction (act out) out)++(~>) :: String -> Action () -> Rules ()+target ~> act = target S.~> wrapAction act target+++-- | Wrapper around 'writeFile''+writeFile' :: FilePath -> String -> Action ()+writeFile' filepath content =+ describe (S.writeFile' filepath content) '→' ("writing " ++ filepath)++-- | Wrapper around 'writeFile''+writeFileChanged :: FilePath -> String -> Action ()+writeFileChanged filepath content =+ describe (S.writeFileChanged filepath content) '→' ("writing " ++ filepath)++readFileLines :: FilePath -> Action [String]+readFileLines filepath =+ describe (S.readFileLines filepath) '←' ("reading " ++ filepath)++doesFileExist :: FilePath -> Action Bool+doesFileExist filepath = liftAction $ S.doesFileExist filepath++need :: [FilePath] -> Action ()+need filepaths =+ describe (S.need filepaths) '…' ("waiting for " ++ take 60 (intercalate ", " filepaths))++readFile' :: FilePath -> Action String+readFile' x = need [x] >> liftIO (readFile x)++orderOnly :: [FilePath] -> Action ()+orderOnly filepaths =+ describe (S.orderOnly filepaths) '…' ("waiting for " ++ take 60 (intercalate ", " filepaths))+++alwaysRerun :: Action ()+alwaysRerun = liftAction S.alwaysRerun++cmdWrap :: String -> S.Action a -> Action a+cmdWrap cmd act =+ describe (quietly act) '!' ("running " ++ cmd)++addOracle :: (S.ShakeValue q, S.ShakeValue a) => (q -> Action a) -> S.Rules (q -> Action a)+addOracle action = do+ query <- S.addOracle (\q -> wrapAction (action q) (show q))+ return $ liftAction . query++newCache :: (Eq k, S.Hashable k) => (k -> Action v) -> Rules (k -> Action v)+newCache cache = do+ query <- S.newCache (\k -> wrapAction (cache k) "cache")+ return $ liftAction . query
src/Development/Shake/Gitlib.hs view
@@ -6,6 +6,7 @@ , doesGitFileExist , readGitFile , isGitAncestor+ , getGitMergeBase ) where import System.IO@@ -41,6 +42,9 @@ newtype IsGitAncestorQ = IsGitAncestorQ (RepoPath, RefName, RefName) deriving (Typeable,Eq,Hashable,Binary,NFData,Show) +newtype GetGitMergeBase = GetGitMergeBase (RepoPath, RefName, RefName)+ deriving (Typeable,Eq,Hashable,Binary,NFData,Show)+ instance Rule GetGitReferenceQ GitSHA where storedValue _ (GetGitReferenceQ (repoPath, name)) = do Just . GitSHA <$> getGitReference' repoPath name@@ -54,6 +58,10 @@ storedValue _ (IsGitAncestorQ (repoPath, ancestor, child)) = do Just <$> isGitAncestor' repoPath ancestor child +instance Rule GetGitMergeBase GitSHA where+ storedValue _ (GetGitMergeBase (repoPath, baseBranchName, featureBranchName)) = do+ Just <$> getGitMergeBase' repoPath baseBranchName featureBranchName+ getGitReference :: RepoPath -> String -> Action String getGitReference repoPath refName = do GitSHA ref' <- apply1 $ GetGitReferenceQ (repoPath, T.pack refName)@@ -63,6 +71,12 @@ isGitAncestor repoPath ancName childName = do apply1 $ IsGitAncestorQ (repoPath, T.pack ancName, T.pack childName) +getGitMergeBase :: RepoPath -> String -> String -> Action String+getGitMergeBase repoPath baseBranchName featureBranchName = do+ GitSHA ref <- apply1 $ GetGitMergeBase (repoPath, T.pack baseBranchName, T.pack featureBranchName)+ return $ T.unpack ref++ getGitContents :: RepoPath -> Action [FilePath] getGitContents repoPath = do GitSHA ref' <- apply1 $ GetGitReferenceQ (repoPath, "HEAD")@@ -96,6 +110,12 @@ Exit c <- cmd ["git", "-C", repoPath, "merge-base", "--is-ancestor", T.unpack ancName, T.unpack childName] return (c == ExitSuccess) +getGitMergeBase' :: RepoPath -> RefName -> RefName -> IO GitSHA+-- Easier using git+getGitMergeBase' repoPath baseBranchName featureBranchName = do+ Stdout sha <- cmd ["git", "-C", repoPath, "merge-base", T.unpack baseBranchName, T.unpack featureBranchName]+ return (GitSHA (T.pack (head (words sha))))+ getGitFileRef' :: RepoPath -> T.Text -> FilePath -> IO (Maybe T.Text) getGitFileRef' repoPath ref' fn = do withRepository lgFactory repoPath $ do@@ -130,4 +150,6 @@ liftIO $ getGitFileRef' repoPath ref' fn rule $ \(IsGitAncestorQ (repoPath, ancName, childName)) -> Just $ liftIO $ isGitAncestor' repoPath ancName childName+ rule $ \(GetGitMergeBase (repoPath, baseBranchName, featureBranchName)) -> Just $ liftIO $+ getGitMergeBase' repoPath baseBranchName featureBranchName
+ src/EmbeddedFiles.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}+module EmbeddedFiles where++import Data.FileEmbed+import qualified Data.ByteString.Char8 as BS+import Data.Monoid+import System.Directory+import Data.Functor++marker :: BS.ByteString+marker = "Remove this line to prevent gipeda from overriding this file"++indexHtmlFile :: BS.ByteString+indexHtmlFile =+ $(embedFile "site/index.html") <>+ "\n<!-- " <> marker <> "-->\n"++gipedaJSFile :: BS.ByteString+gipedaJSFile = $(embedFile "site/js/gipeda.js") <>+ "\n// " <> marker <> "\n"+++installJSLibsScript :: BS.ByteString+installJSLibsScript = $(embedFile "install-jslibs.sh") <>+ "\n# " <> marker <> "\n"++isMarked :: BS.ByteString -> Bool+isMarked bs = marker `BS.isInfixOf` BS.drop n bs+ where n = BS.length bs - BS.length marker - 4++isMarkedFile :: FilePath -> IO Bool+isMarkedFile filepath = do+ ex <- doesFileExist filepath+ if ex then isMarked <$> BS.readFile filepath+ else return True+
src/GraphReport.hs view
@@ -17,7 +17,7 @@ graphReportMain :: [String] -> IO () graphReportMain (bench:revs) = do- settings <- S.readSettings "settings.yaml"+ settings <- S.readSettings "gipeda.yaml" g <- forM revs $ \rev -> do json <- BS.readFile (reportOf rev)
src/JsonSettings.hs view
@@ -9,6 +9,6 @@ jsonSettingsMain :: IO () jsonSettingsMain = do- s <- either (error.show) id <$> decodeFileEither "settings.yaml"+ s <- either (error.show) id <$> decodeFileEither "gipeda.yaml" let o = object [ "settings" .= (s :: Object) ] BS.putStr (Data.Aeson.encode o)
src/Paths.hs view
@@ -3,14 +3,19 @@ import System.FilePath type Hash = String+type BranchName = String out :: FilePath out = "site" </> "out" -resultsOf, reportOf, summaryOf, logsOf, graphFile :: Hash -> FilePath+resultsOf, reportOf, summaryOf, logsOf :: Hash -> FilePath+graphFile :: String -> FilePath+branchSummaryOf, branchMergebaseOf :: BranchName -> FilePath logsOf hash = "logs" </> hash <.> "log" resultsOf hash = out </> "results" </> hash <.> "csv" reportOf hash = out </> "reports" </> hash <.> "json" summaryOf hash = out </> "summaries" </> hash <.> "json" graphFile bench = out </> "graphs" </> bench <.> "json"+branchSummaryOf branch = out </> "branches" </> branch <.> "json"+branchMergebaseOf branch = out </> "branches" </> branch <.> "mergebase"
src/ReportTypes.hs view
@@ -27,6 +27,7 @@ , benchmarks :: Maybe (M.Map BenchName ()) , revisions :: Maybe (M.Map Hash RevReport) , benchGroups :: Maybe [BenchGroup]+ , branches :: Maybe (M.Map BranchName BranchReport) } instance ToJSON GlobalReport where@@ -34,14 +35,15 @@ ( "settings" .=? settings ) ++ ( "benchmarks" .=? benchmarks ) ++ ( "revisions" .=? revisions ) ++- ( "benchGroups" .=? benchGroups )+ ( "benchGroups" .=? benchGroups ) +++ ( "branches" .=? branches ) where k .=? Just v = [ k .= toJSON v ] _ .=? Nothing = [] emptyGlobalReport :: GlobalReport-emptyGlobalReport = GlobalReport Nothing Nothing Nothing Nothing+emptyGlobalReport = GlobalReport Nothing Nothing Nothing Nothing Nothing data SummaryStats = SummaryStats@@ -82,6 +84,17 @@ instance ToJSON RevReport instance FromJSON RevReport +data BranchReport = BranchReport+ { branchHash :: Hash+ , mergeBaseHash :: Hash+ , branchStats :: SummaryStats+ , commitCount :: Int+ }++ deriving (Generic)+instance ToJSON BranchReport+instance FromJSON BranchReport+ data ChangeType = Improvement | Boring | Regression deriving (Eq, Generic) instance ToJSON ChangeType@@ -240,6 +253,24 @@ } } -}++createBranchReport ::+ S.Settings -> Hash -> Hash ->+ ResultMap -> ResultMap ->+ Int ->+ BranchReport+createBranchReport settings this other thisM otherM commitCount = BranchReport+ { branchHash = this+ , mergeBaseHash = other+ , branchStats = toSummaryStats $ M.elems results+ , commitCount = commitCount+ }+ where+ results = M.fromList+ [ (name, toResult s name value (M.lookup name otherM))+ | (name, value) <- M.toAscList thisM+ , let s = S.benchSettings settings name+ ] createReport :: S.Settings -> Hash -> [Hash] ->
src/RevReport.hs view
@@ -17,7 +17,7 @@ revReportMain :: [String] -> IO () revReportMain (this:parents) = do- settings <- S.readSettings "settings.yaml"+ settings <- S.readSettings "gipeda.yaml" thisM <- readCSV this parentM <- case parents of@@ -38,4 +38,19 @@ let doc = emptyGlobalReport { revisions = Just (M.singleton this rep) } BS.putStr (encode doc)- ++branchReportMain :: [String]-> IO ()+branchReportMain [branchName, this, other] = do+ settings <- S.readSettings "gipeda.yaml"++ thisM <- readCSV this+ otherM <- readCSV other++ log <- fromStdout <$> git ["log", "--oneline", other ++ ".."++ this]+ let commits = length (lines log)++ let rep = createBranchReport settings this other thisM otherM commits+ let doc = emptyGlobalReport { branches = Just (M.singleton branchName rep) }+ BS.putStr (encode doc)++
src/Shake.hs view
@@ -1,19 +1,21 @@ {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving, NondecreasingIndentation #-} module Shake where -import Prelude hiding ((*>))--import Development.Shake hiding (withTempFile)+import Development.Shake.Fancy hiding (withTempFile)+import qualified Development.Shake.Fancy as S import Development.Shake.FilePath import Development.Shake.Classes import Control.Monad import qualified Data.Map as M import Data.Functor import Data.List+import Data.Maybe import System.IO.Extra (newTempFile) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified System.Directory+import System.Directory (getPermissions, setPermissions, setOwnerExecutable)+import System.Environment (getExecutablePath) import Data.Aeson import qualified Data.Text as T @@ -24,6 +26,8 @@ import BenchmarksInCSV import qualified BenchmarkSettings as S import JsonUtils+import EmbeddedFiles+import ReportTypes {- Global settings -} cGRAPH_HISTORY :: Integer@@ -31,16 +35,17 @@ git :: (CmdResult b) => String -> [String] -> Action b git gitcmd args = do- cmd (Traced $ "git " ++ gitcmd) (words "git -C repository" ++ gitcmd : args)+ cmdWrap ("git " ++ gitcmd) $ cmd (words "git -C repository" ++ gitcmd : args) self :: (CmdResult b) => String -> [String] -> Action b self name args = do -- orderOnly ["gipeda"]- cmd (Traced name) "./gipeda" name args+ gipeda <- liftIO getExecutablePath+ cmdWrap name $ cmd gipeda name args gitRange :: Action [String] gitRange = do- s <- liftIO $ S.readSettings "settings.yaml"+ s <- liftIO $ S.readSettings "gipeda.yaml" let first = S.start s heads <- readFileLines "site/out/heads.txt" Stdout range <- git "log" $ ["--format=%H","^"++first] ++ heads@@ -53,7 +58,7 @@ return existing doesLogExist :: LogSource -> Hash -> Action Bool-doesLogExist BareGit hash = doesGitFileExist "logs" (hash <.> "log")+doesLogExist BareGit hash = liftAction $ doesGitFileExist "logs" (hash <.> "log") doesLogExist FileSystem hash = doesFileExist (logsOf hash) doesLogExist NoLogs hash = doesFileExist (resultsOf hash) @@ -77,6 +82,13 @@ newtype LimitRecent = LimitRecent () deriving (Show,Typeable,Eq,Hashable,Binary,NFData) +newtype GetIndexHTMLFile = GetIndexHTMLFile ()+ deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+newtype GetGipedaJSFile = GetGipedaJSFile ()+ deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+newtype GetInstallJSLibsScript = GetInstallJSLibsScript ()+ deriving (Show,Typeable,Eq,Hashable,Binary,NFData)+ data LogSource = FileSystem | BareGit | NoLogs deriving Show determineLogSource :: IO LogSource@@ -106,8 +118,8 @@ -} getLimitRecent <- addOracle $ \(LimitRecent _) -> do- need ["settings.yaml"]- S.limitRecent <$> liftIO (S.readSettings "settings.yaml")+ need ["gipeda.yaml"]+ S.limitRecent <$> liftIO (S.readSettings "gipeda.yaml") "reports" ~> do hashes <- gitRange@@ -121,30 +133,62 @@ need $ map summaryOf withLogs want ["summaries"] - "site/out/head.txt" *> \ out -> do+ getIndexHTMLFile <- addOracle $ \(GetIndexHTMLFile _) -> do+ return indexHtmlFile+ "site/index.html" %> \out -> do+ content <- getIndexHTMLFile (GetIndexHTMLFile ())+ liftIO $ do+ marked <- isMarkedFile out+ when marked $ BS.writeFile out content+ want ["site/index.html"]++ getGipedaJSFile <- addOracle $ \(GetGipedaJSFile _) -> do+ return gipedaJSFile+ "site/js/gipeda.js" %> \out -> do+ content <- getGipedaJSFile (GetGipedaJSFile ())+ liftIO $ do+ marked <- isMarkedFile out+ when marked $ BS.writeFile out content+ want ["site/js/gipeda.js"]++ getInstallJSLibsScript <- addOracle $ \(GetInstallJSLibsScript _) -> do+ return installJSLibsScript+ "install-jslibs.sh" %> \out -> do+ content <- getInstallJSLibsScript (GetInstallJSLibsScript ())+ liftIO $ do+ marked <- isMarkedFile out+ when marked $ do+ BS.writeFile out content+ p <- getPermissions out+ setPermissions out (setOwnerExecutable True p)+ cmd "./install-jslibs.sh"+ want ["install-jslibs.sh"]+++ "site/out/head.txt" %> \ out -> do alwaysRerun Stdout stdout <- git "rev-parse" ["master"] writeFileChanged out stdout - "site/out/heads.txt" *> \ out -> do+ "site/out/heads.txt" %> \ out -> do tags <- readFileLines "site/out/tags.txt" tagHashes <- forM tags $ \t -> do- getGitReference "repository" ("refs/tags/" ++ t)+ liftAction $ getGitReference "repository" ("refs/tags/" ++ t) branches <- readFileLines "site/out/branches.txt" branchHashes <- forM branches $ \t -> do- getGitReference "repository" ("refs/heads/" ++ t)+ liftAction $ getGitReference "repository" ("refs/heads/" ++ t) - masterHash <- getGitReference "repository" "refs/heads/master"+ masterHash <- liftAction $ getGitReference "repository" "refs/heads/master" let heads = nub $ masterHash : tagHashes ++ branchHashes writeFileChanged out $ unlines $ heads - "site/out/history.csv" *> \out -> do+ "site/out/history.csv" %> \out -> do heads <- readFileLines "site/out/heads.txt" - s <- liftIO $ S.readSettings "settings.yaml"+ s <- liftIO $ S.readSettings "gipeda.yaml" let first = S.start s Stdout stdout <- git "log" $@@ -159,41 +203,41 @@ let pred h = do { hist <- history; findPred logSource hist h } let predOrSelf h = do { hist <- history; findPredOrSelf logSource hist h } let recent n h = do { hist <- history; findRecent logSource hist n h }+ let predOrSelf' h = do+ pred <- predOrSelf h+ case pred of Just pred -> return pred+ Nothing -> fail $ h ++ " has no parent with logs?" - "site/out/latest.txt" *> \ out -> do+ "site/out/latest.txt" %> \ out -> do [head] <- readFileLines "site/out/head.txt"- latestM <- predOrSelf head- case latestM of- Just latest ->- writeFileChanged out latest- Nothing ->- fail "Head has no parent with logs?"+ latest <- predOrSelf' head+ writeFileChanged out latest - "site/out/tags.txt" *> \ out -> do+ "site/out/tags.txt" %> \ out -> do alwaysRerun - need ["settings.yaml"]- s <- liftIO $ S.readSettings "settings.yaml"+ need ["gipeda.yaml"]+ s <- liftIO $ S.readSettings "gipeda.yaml" case S.interestingTags s of Nothing -> writeFileChanged out "" Just pattern -> do Stdout tags <- git "tag" ["-l", pattern]- tags' <- filterM (isGitAncestor "repository" (S.start s)) (lines tags)+ tags' <- filterM (liftAction . isGitAncestor "repository" (S.start s)) (lines tags) writeFileChanged out (unlines tags') - "site/out/branches.txt" *> \ out -> do+ "site/out/branches.txt" %> \ out -> do alwaysRerun - need ["settings.yaml"]- s <- liftIO $ S.readSettings "settings.yaml"+ need ["gipeda.yaml"]+ s <- liftIO $ S.readSettings "gipeda.yaml" case S.interestingBranches s of Nothing -> writeFileChanged out "" Just pattern -> do Stdout branches <- git "branch" ["--list", pattern]- branches <- filterM (isGitAncestor "repository" (S.start s)) (map (drop 2) $ lines branches)- branches <- filterM (\b -> not <$> isGitAncestor "repository" b "master") branches+ branches <- filterM (liftAction . isGitAncestor "repository" (S.start s)) (map (drop 2) $ lines branches)+ branches <- filterM (\b -> liftAction $ not <$> isGitAncestor "repository" b "master") branches writeFileChanged out (unlines branches) "graphs" ~> do@@ -205,22 +249,22 @@ case logSource of BareGit ->- "site/out/results/*.csv" *> \out -> do+ "site/out/results/*.csv" %> \out -> do let hash = takeBaseName out withTempFile $ \fn -> do- log <- readGitFile "logs" (hash <.> "log")+ log <- liftAction $ readGitFile "logs" (hash <.> "log") liftIO $ BS.writeFile fn log- Stdout csv <- cmd "./log2csv" fn+ Stdout csv <- cmdWrap "log2csv" $ cmd "./log2csv" fn writeFile' out csv FileSystem ->- "site/out/results/*.csv" *> \out -> do+ "site/out/results/*.csv" %> \out -> do let hash = takeBaseName out need [logsOf hash]- Stdout csv <- cmd "./log2csv" (logsOf hash)+ Stdout csv <- cmdWrap "log2csv" $ cmd "./log2csv" (logsOf hash) writeFile' out csv NoLogs -> return () - "site/out/graphs//*.json" *> \out -> do+ "site/out/graphs//*.json" %> \out -> do let bench = dropDirectory1 (dropDirectory1 (dropDirectory1 (dropExtension out))) [latest] <- readFileLines "site/out/latest.txt"@@ -231,7 +275,30 @@ Stdout json <- self "GraphReport" (bench : r) writeFile' out json - "site/out/reports/*.json" *> \out -> do+ "site/out/branches//*.mergebase" %> \out -> do+ let branch = dropDirectory1 (dropDirectory1 (dropDirectory1 (dropExtension out)))+ mb <- liftAction $ getGitMergeBase "repository" "refs/heads/master" ("refs/heads/"++branch)+ writeFile' out mb++ "site/out/branches//*.json" %> \out -> do+ let branch = dropDirectory1 (dropDirectory1 (dropDirectory1 (dropExtension out)))++ branchHead <- liftAction $ getGitReference "repository" ("refs/heads/" ++ branch)+ branchHeadM <- predOrSelf branchHead++ mergeBase <- readFile' $ branchMergebaseOf branch+ mergeBaseM <- predOrSelf mergeBase++ case (branchHeadM, mergeBaseM) of+ (Just branchHead, Just mergeBase) -> do+ need [resultsOf branchHead, resultsOf mergeBase]+ Stdout json <- self "BranchReport" [branch, branchHead, mergeBase]+ writeFile' out json+ _ -> do+ -- Write out nothing here, to ignore the branch+ liftIO $ LBS.writeFile out (encode emptyGlobalReport)++ "site/out/reports/*.json" %> \out -> do let hash = takeBaseName out need [resultsOf hash] @@ -241,33 +308,37 @@ Stdout json <- self "RevReport" (hash : [h | Just h <- return pred]) writeFile' out json - "site/out/summaries/*.json" *> \out -> do+ "site/out/summaries/*.json" %> \out -> do let hash = takeBaseName out need [reportOf hash] Stdout json <- self "Summary" [hash] writeFile' out json - "site/out/latest-summaries.json" *> \out -> do+ "site/out/latest-summaries.json" %> \out -> do [latest] <- readFileLines "site/out/latest.txt" recentCommits <- recent cGRAPH_HISTORY latest tags <- readFileLines "site/out/tags.txt"- tagsAndHashes <- forM tags $ \t -> do- h <- getGitReference "repository" ("refs/tags/" ++ t)- return $ (t, h)+ tagsHashes <- forM tags $ \t -> do+ liftAction $ getGitReference "repository" ("refs/tags/" ++ t) branches <- readFileLines "site/out/branches.txt"- branchesAndHashes <- forM branches $ \t -> do- h <- getGitReference "repository" ("refs/heads/" ++ t)- return $ (t, h)+ branchHashes <- forM branches $ \branch -> do+ liftAction $ getGitReference "repository" ("refs/heads/" ++ branch) + need $ map branchSummaryOf branches+ branchesData <- forM branches $ \branch -> do+ json <- liftIO $ LBS.readFile (branchSummaryOf branch)+ case eitherDecode json of+ Left e -> fail e+ Right rep -> return (rep :: Value)+ let o = object- [ T.pack "tags" .= object [ (T.pack t .= h) | (t,h) <- tagsAndHashes ]- , T.pack "branches" .= object [ (T.pack t .= h) | (t,h) <- branchesAndHashes ]+ [ T.pack "tags" .= object [ (T.pack t .= h) | (t,h) <- zip tags tagsHashes ] ] liftIO $ LBS.writeFile out (encode o)- extraCommits <- filterM (doesLogExist logSource) (map snd tagsAndHashes ++ map snd branchesAndHashes)+ extraCommits <- catMaybes <$> mapM predOrSelf (tagsHashes ++ branchHashes) let revs = nub $ recentCommits ++ extraCommits @@ -278,10 +349,11 @@ case eitherDecode json of Left e -> fail e Right rep -> return (rep :: Value)- liftIO $ LBS.writeFile out (encode (merges (o:g)))++ liftIO $ LBS.writeFile out (encode (merges (o : branchesData ++ g))) want ["site/out/latest-summaries.json"] - "site/out/graph-summaries.json" *> \out -> do+ "site/out/graph-summaries.json" %> \out -> do [latest] <- readFileLines "site/out/latest.txt" need [resultsOf latest] b <- liftIO $ benchmarksInCSVFile (resultsOf latest)@@ -291,19 +363,19 @@ writeFile' out json want ["site/out/graph-summaries.json"] - "site/out/benchNames.json" *> \out -> do+ "site/out/benchNames.json" %> \out -> do [latest] <- readFileLines "site/out/latest.txt" need [resultsOf latest] b <- liftIO $ benchmarksInCSVFile (resultsOf latest) - need ["settings.yaml"]+ need ["gipeda.yaml"] Stdout json <- self "BenchNames" (nub b) writeFile' out json want ["site/out/benchNames.json"] - "site/out/all-summaries.json" *> \out -> do+ "site/out/all-summaries.json" %> \out -> do hashes <- gitRange revs <- filterM (doesLogExist logSource) hashes need (map summaryOf revs)@@ -316,8 +388,8 @@ liftIO $ LBS.writeFile out (encode (merges g)) want ["site/out/all-summaries.json"] - "site/out/settings.json" *> \out -> do- need ["settings.yaml"]+ "site/out/settings.json" %> \out -> do+ need ["gipeda.yaml"] Stdout json <- self "JsonSettings" [] writeFile' out json@@ -325,7 +397,6 @@ phony "clean" $ do removeFilesAfter "site/out" ["//*"]- -- | Create a temporary file in the temporary directory. The file will be deleted -- after the action completes (provided the file is not still open).
src/gipeda.hs view
@@ -28,15 +28,16 @@ args <- getArgs - ex <- doesFileExist "settings.yaml"+ ex <- doesFileExist "gipeda.yaml" unless ex $ do- hPutStr stderr "Please run this from the same directory as the settings.yaml file.\n"+ hPutStr stderr "Please run this from the same directory as the gipeda.yaml file.\n" case args of "JsonSettings":_ -> jsonSettingsMain "Summary":opts -> summaryMain opts "RevReport":opts -> revReportMain opts+ "BranchReport":opts -> branchReportMain opts "GraphReport":opts -> graphReportMain opts "WithLatestLogs":opts -> withLatestLogsMain opts "BenchNames":opts -> benchNamesMain opts