diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/gipeda.cabal b/gipeda.cabal --- a/gipeda.cabal +++ b/gipeda.cabal @@ -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: diff --git a/install-jslibs.sh b/install-jslibs.sh --- a/install-jslibs.sh +++ b/install-jslibs.sh @@ -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 diff --git a/site/index.html b/site/index.html --- a/site/index.html +++ b/site/index.html @@ -262,53 +262,48 @@ diff --git a/site/js/gipeda.js b/site/js/gipeda.js --- a/site/js/gipeda.js +++ b/site/js/gipeda.js @@ -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), }; diff --git a/src/BenchNames.hs b/src/BenchNames.hs --- a/src/BenchNames.hs +++ b/src/BenchNames.hs @@ -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) $ diff --git a/src/Development/Shake/Fancy.hs b/src/Development/Shake/Fancy.hs new file mode 100644 --- /dev/null +++ b/src/Development/Shake/Fancy.hs @@ -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 diff --git a/src/Development/Shake/Gitlib.hs b/src/Development/Shake/Gitlib.hs --- a/src/Development/Shake/Gitlib.hs +++ b/src/Development/Shake/Gitlib.hs @@ -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 diff --git a/src/EmbeddedFiles.hs b/src/EmbeddedFiles.hs new file mode 100644 --- /dev/null +++ b/src/EmbeddedFiles.hs @@ -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\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 + diff --git a/src/GraphReport.hs b/src/GraphReport.hs --- a/src/GraphReport.hs +++ b/src/GraphReport.hs @@ -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) diff --git a/src/JsonSettings.hs b/src/JsonSettings.hs --- a/src/JsonSettings.hs +++ b/src/JsonSettings.hs @@ -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) diff --git a/src/Paths.hs b/src/Paths.hs --- a/src/Paths.hs +++ b/src/Paths.hs @@ -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" diff --git a/src/ReportTypes.hs b/src/ReportTypes.hs --- a/src/ReportTypes.hs +++ b/src/ReportTypes.hs @@ -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] -> diff --git a/src/RevReport.hs b/src/RevReport.hs --- a/src/RevReport.hs +++ b/src/RevReport.hs @@ -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) + + diff --git a/src/Shake.hs b/src/Shake.hs --- a/src/Shake.hs +++ b/src/Shake.hs @@ -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). diff --git a/src/gipeda.hs b/src/gipeda.hs --- a/src/gipeda.hs +++ b/src/gipeda.hs @@ -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