feed-gipeda (empty) → 0.1.0.0
raw patch · 24 files changed
+2497/−0 lines, 24 filesdep +HUnitdep +aesondep +asyncsetup-changed
Dependencies added: HUnit, aeson, async, base, binary, bytestring, concurrent-extra, conduit, conduit-extra, containers, data-hash, directory, distributed-process, distributed-process-async, distributed-process-client-server, distributed-process-extras, distributed-process-simplelocalnet, exceptions, feed-gipeda, file-embed, filepath, fsnotify, logging, managed, network-uri, optparse-applicative, process, reactive-banana, tasty, tasty-hspec, tasty-hunit, tasty-quickcheck, tasty-smallcheck, temporary, text, time, transformers, yaml
Files
- LICENSE +30/−0
- README.md +96/−0
- Setup.hs +2/−0
- app/Main.hs +116/−0
- assets/default_index.html +69/−0
- feed-gipeda.cabal +120/−0
- src/FeedGipeda.hs +106/−0
- src/FeedGipeda/Assets.hs +22/−0
- src/FeedGipeda/Config.hs +77/−0
- src/FeedGipeda/Gipeda.hs +206/−0
- src/FeedGipeda/GitShell.hs +99/−0
- src/FeedGipeda/Master.hs +254/−0
- src/FeedGipeda/Master/File.hs +113/−0
- src/FeedGipeda/Master/Finalize.hs +193/−0
- src/FeedGipeda/Master/RepoDiff.hs +29/−0
- src/FeedGipeda/Repo.hs +96/−0
- src/FeedGipeda/Slave.hs +69/−0
- src/FeedGipeda/THGenerated.hs +37/−0
- src/FeedGipeda/TaskQueue.hs +226/−0
- src/FeedGipeda/Types.hs +83/−0
- tests/Acceptance.hs +261/−0
- tests/Acceptance/Driver.hs +125/−0
- tests/Acceptance/Files.hs +60/−0
- tests/test.hs +8/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Sebastian Graf (c) 2016 + +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. + + * Neither the name of Sebastian Graf nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"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 +OWNER OR CONTRIBUTORS 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.
+ README.md view
@@ -0,0 +1,96 @@+# feed-gipeda [](https://travis-ci.org/sgraf812/feed-gipeda) [](https://hackage.haskell.org/package/feed-gipeda) + +A kitchen-sink tool to run [gipeda](https://hackage.haskell.org/package/gipeda) on a list of repositories after having run a benchmark script on each (repo, commit) pair that is yet to be benchmarked. + +This will take all the necessary steps to update and deploy a `gipeda`-based site. Think Travis CI for benchmarks. + +Use this when you host a variety of repositories and want to display performance data about them. Although the defaults are biased towards Haskell projects using `cabal`/`stack`, the script to run on each new commit can be configured. + +## I think I could use this but I haven't understood a word + +This is a high-level example setup of how to use it: + + + +Below there is a detailed visualization of the FRP layer (of the master node): + + + +Without any special flags, `feed-gipeda` will enter the build once mode (and then exit). + +`feed-gipeda` extracts repositories to watch from a \*.yaml file (c.f. Config file). For each remote repository, a unique but human-readable directory (`<base-name>-<hash-of-URI>`) is created, under which a mirror repository resides in the `repository/` folder. + +Every commit for which `gipeda` requests a benchmark (e.g. because there is no \*.csv result file in `site/out/results`) causes a benchmark script to be run. The concrete example above uses [`cloben`](https://github.com/sgraf812/cloben) for that (it's also the default), but any other benchmark script which expects to be executed in the project folder and which writes its CSV output to `stdout` should do. + +Either after a benchmark finishes or a repository was fetched, `gipeda` is executed for both new commits to benchmark and for producing the website to be deployed via `rsync` to a remote location (`--deploy-to` flag). + +## `--watch` mode + +When `gipeda` requests no more benchmarks, `feed-gipeda` exits. + +This can be changed +via the `--watch=SECONDS` option. If specified, `feed-gipeda` will enter a daemon mode +and not exit if there is temporary nothing to benchmark. Instead, it will watch for +changes to the config file (handle updates to the watched repository list) and refetch +all currently watched repositories every `SECONDS` seconds. + +## `--check` mode + +With the `--check` flag supplied, `feed-gipeda` will check the config file +(c.f. Config file, `--config`) for syntax errors and report them as an error. +It will successfully exit when it can find none. + +## How to get it to run + +The following steps should get you all Haskell dependencies (using `cabal` in a similar way): + +``` +$ stack install cloben gipeda feed-gipeda +``` + +You will also need to install the [system dependencies for gipeda](https://github.com/nomeata/gipeda#setting-it-up) (sorry, fellow Windows users!), as well as there must be `rsync` and `ssh` available on the path, if +you choose to `--deploy-to` some location. + +Using `cloben` is of course optional, but the simplest option for benchmarking (if you want to benchmark `cabal`-conformant Haskell repositories). + +By now, `$ feed-gipeda --help` should spit out maybe more up-to-date documentation than this README and you can read about supplying custom paths to various files such as the configuration file. For the sake of the example, we will use the default location, which is at `~/.feed-gipeda/feed-gipeda.yaml`. Put this into that file: + +``` +repositories: +- https://github.com/sgraf812/benchmark-test +``` + +In `--watch` mode, that file would be watched for changes, so you can make it part of a git repository (like I did [here](https://github.com/sgraf812/.feed-gipeda)) and fetch updates as part of a `cron` job. + +Alternatively, you can run `feed-gipeda` in the default mode (build once) any time you need updates. + +Now find yourself a quiet little tmp folder and run +``` +$ feed-gipeda --help +... +$ feed-gipeda --deploy-to=some/local/path/if/you/want +``` + +For some more usage examples, see the Cookbook section. + +## Config file + +Contains the list of repositories to watch encoded in a YAML file. Is supplied via the `--config` option, which defaults to `~/.feed-gipeda/feed-gipeda.yaml` (resp. `%APPDATA%/Roaming/.feed-gipeda/feed-gipeda.yaml` on Windows). + +For an example, see <https://github.com/sgraf812/.feed-gipeda> or the example 2 line file above. +The file must contain a top-level `repositories` mapping to a list of repository URIs. + +## Cookbook + +- `feed-gipeda` +Enter default mode (Exit when done). Read config from the default location (system-specific, see `--config` option under `--help`), act as both a master and a slave node. +- `feed-gipeda --watch=5` +Enter watch mode. Watch for changes to config and re-fetch repositories every 5 seconds. Read config from the default location, act as both master and slave node +- `feed-gipeda --check --config=~/.feed-gipeda/feed-gipeda.yaml` +Enter check mode. Check the specified config file for syntax errors. Useful in a CI setting. +- `feed-gipeda --master=localhost:12345` +Enter default mode. Dispatch benchmark requests on registered slave nodes, don't work on them in this process +- `feed-gipeda --slave=localhost:12346` +Enter slave-only mode. Listen via multicast for master nodes which request you to do benchmarks. +- `feed-gipeda --deploy-to=deploymentDir/` +Enter default mode. Deploy changes via `rsync` to the local `deploymentDir`
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,116 @@+{-| Defines the entry point of the @feed-gipeda@ executable and the command line + parsing associated with that. +-} + +import Control.Applicative +import Control.Logging as Logging +import Control.Monad (join) +import Data.Functor +import Data.List (elemIndex) +import FeedGipeda +import Options.Applicative +import System.Directory (getAppUserDataDirectory) +import System.FilePath ((</>)) +import Text.Read (readMaybe) + + +endpoint :: ReadM Endpoint +endpoint = do + s <- str + case elemIndex ':' s of + Nothing -> readerError "Expected a colon separator" + Just idx -> do + let (host, port') = splitAt idx s + case readMaybe (drop 1 port') of + Just port -> return (Endpoint host port) + Nothing -> readerError "Port was not integral" + + +paths :: FilePath -> Parser Paths +paths defaultConfig = + Paths + <$> option str + (long "config" + <> value defaultConfig + <> metavar "FILEPATH" + <> help ("Path to the YAML file containing a list of watched repositories. Will be watched for changes. Defaults to " ++ defaultConfig ++ ".")) + <*> option str + (long "gipeda" + <> value "gipeda" + <> metavar "FILEPATH" + <> help "Custom path to the gipeda executable") + + +cmd :: Parser Command +cmd = + flag' + Check + (long "check" + <> help "Verify that the given config file is well-formed and exit") + <|> + Build + <$> option + (WatchForChanges . fromIntegral <$> auto) + (long "watch" + <> metavar "SECONDS" + <> value Once + <> help "Don't quit when done, watch the config file for changes and refetch watched repositories every SECONDS seconds and benchmark new commits.") + + +deployment :: Parser Deployment +deployment = + option + (Deploy <$> str) + (long "deploy-to" + <> metavar "SSH_PATH" + <> value NoDeployment + <> help "ssh or local path under which to deploy site/ folders with rsync") + + +processRole :: Parser ProcessRole +processRole = + impl + <$> optional (option endpoint + (long "master" + <> metavar "ENDPOINT" + <> help "Start in master mode, distributing work items. Identified via the given TCP endpoint (ipadress:portnumber).")) + <*> optional (option endpoint + (long "slave" + <> metavar "ENDPOINT" + <> help "Start in slave mode, requesting work items from a master node. Identified via the given TCP endpoint (ipadress:portnumber).")) + where + impl Nothing Nothing = Both (Endpoint "localhost" 1337) (Endpoint "localhost" 1338) + impl (Just ep) Nothing = Master ep + impl Nothing (Just ep) = Slave ep + impl (Just mep) (Just sep) = Both mep sep + + +verbosity :: Parser Verbosity +verbosity = + flag + NotVerbose + Verbose + (long "verbose" + <> short 'v' + <> help "Show log messages intended for debugging") + + +parser :: IO (Parser (IO ())) +parser = do + defaultConfig <- getAppUserDataDirectory ("feed-gipeda" </> "feed-gipeda.yaml") + return $ + FeedGipeda.feedGipeda + <$> paths defaultConfig + <*> cmd + <*> deployment + <*> processRole + <*> verbosity + + +main :: IO () +main = Logging.withStdoutLogging $ do + p <- parser + join $ execParser $ info (helper <*> p) $ + fullDesc + <> header "feed-gipeda - watch git repositories and feed benchmark results to gipeda" + -- <> progDesc "" -- TODO
+ assets/default_index.html view
@@ -0,0 +1,69 @@+<!DOCTYPE html> +<html lang="en"> + <head> + <meta charset="utf-8"> + <meta http-equiv="X-UA-Compatible" content="IE=edge"> + <meta name="viewport" content="width=device-width, initial-scale=1"> + <title>Gipeda - Overview</title> + + <link href="https://cdnjs.cloudflare.com/ajax/libs/twitter-bootstrap/3.3.5/css/bootstrap.min.css" rel="stylesheet"> + + <!-- HTML5 shim and Respond.js for IE8 support of HTML5 elements and media queries --> + <!-- WARNING: Respond.js doesn't work if you view the page via file:// --> + <!--[if lt IE 9]> + <script src="https://oss.maxcdn.com/html5shiv/3.7.2/html5shiv.min.js"></script> + <script src="https://oss.maxcdn.com/respond/1.4.2/respond.min.js"></script> + <![endif]--> + </head> + <body> + <div class="container"> + <div class="page-header"> + <h1>Git performance dashboard <small>Overview</small></h1> + </div> + <div id="links" class="row"> + <div class="col-sm-4"> + <div class="panel panel-default">+ <a class="dashboard panel-heading btn-block" href="#"> + <h4 class="name panel-title"></h4> + </a> + <div class="panel-body"> + <p class="description"></p> + <a class="repo">Repository link</a> + </div> + </div> + </div> + </div> + </div> + + <script src="https://cdnjs.cloudflare.com/ajax/libs/jquery/1.11.3/jquery.min.js"></script> + <script src="https://cdnjs.cloudflare.com/ajax/libs/twitter-bootstrap/3.3.5/js/bootstrap.min.js"></script> + <script src="https://cdnjs.cloudflare.com/ajax/libs/transparency/0.9.9/transparency.min.js"></script> + + <script> + $.getJSON("sites.json", function(json) { + model = []; + for (var name in json) { + var gitRepo = json[name]; + model.push({ + name: name, + gitRepo: gitRepo, + description: '', // TODO?! + dashboardLink: name + }); + } + + directives = { + repo: { + href: function() { return this.gitRepo; } + }, + dashboard: { + href: function() { return this.dashboardLink; } + } + }; + + $('#links').render(model, directives); + }); + </script> + + </body> +</html>
+ feed-gipeda.cabal view
@@ -0,0 +1,120 @@+name: feed-gipeda +version: 0.1.0.0 +synopsis: Simple project template from stack +description: + A service for easy handling of multiple repositories with <https://hackage.haskell.org/package/gipeda gipeda>. + . + See @--help@ for usage. Example invocation for benchmarking the whole of the @Pipes@ library: + . + @ + $ cat > feed-gipeda.yaml + repositories: + - https://github.com/Gabriel439/Haskell-Pipes-Library + ^D + $ feed-gipeda --config=./feed-gipeda.yaml --deploy-to=./website + @ +homepage: http://github.com/sgraf812/feed-gipeda#readme +license: BSD3 +license-file: LICENSE +author: Sebastian Graf +maintainer: sgraf1337@gmail.com +copyright: 2015 Sebastian Graf +category: Benchmarking +build-type: Simple +cabal-version: >=1.10 +extra-source-files: assets/default_index.html + , README.md + +library + hs-source-dirs: src + exposed-modules: FeedGipeda + other-modules: FeedGipeda.GitShell + , FeedGipeda.Assets + , FeedGipeda.Repo + , FeedGipeda.Master + , FeedGipeda.Slave + , FeedGipeda.Gipeda + , FeedGipeda.Config + , FeedGipeda.THGenerated + , FeedGipeda.TaskQueue + , FeedGipeda.Types + , FeedGipeda.Master.Finalize + , FeedGipeda.Master.File + , FeedGipeda.Master.RepoDiff + default-language: Haskell2010 + build-depends: base >= 4.6 && < 5 + , fsnotify >= 0.2 && < 0.3 + , containers >= 0.5 && < 0.6 + -- prettyPrintParseException + , yaml >= 0.8.11 && < 0.9 + -- We only use (.=), encode and object from aeson, so we should be fine with any version + , aeson + , text < 1.3 + -- readCreateProcessWithExitCode since 1.2.3 + , process >= 1.2.3 && < 1.5 + , directory < 1.3 + , filepath < 1.5 + , network-uri < 2.7 + , data-hash < 0.3 + , transformers >= 0.2 + , time >= 1.5 && < 2 + , bytestring < 0.11 + , binary < 0.9 + , distributed-process >= 0.5 && < 0.7 + , distributed-process-extras >= 0.1 && < 0.3 + , distributed-process-client-server >= 0.1 && < 0.3 + , distributed-process-async >= 0.1 && < 0.3 + , distributed-process-simplelocalnet >= 0.2 && < 0.3 + -- we need makeRelativeToProject for CI builds + , file-embed >= 0.0.10 + , reactive-banana >= 1 && < 1.2 + , logging >= 3.0.4 && < 3.1 + , temporary >= 1.1 && < 1.3 + , concurrent-extra < 0.8 + +executable feed-gipeda + hs-source-dirs: app + main-is: Main.hs + default-language: Haskell2010 + build-depends: base >= 4.6 && < 5 + , feed-gipeda + , directory >= 1.2.0.0 && < 1.3.0.0 + , filepath >= 1.4.0.0 && < 1.5.0.0 + , optparse-applicative >= 0.11 + , logging >= 3.0.4 + +test-suite test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: test.hs + ghc-options: -threaded + other-modules: Acceptance + , Acceptance.Files + , Acceptance.Driver + build-depends: base >= 4.6 && < 5 + , tasty + , tasty-quickcheck + , tasty-smallcheck + , tasty-hunit + , tasty-hspec + , HUnit + , temporary >= 1.1 + , file-embed >= 0.0.10 + , exceptions + , process >= 1.2.3 && < 1.5 + , directory < 1.3 + , filepath < 1.5 + , managed + , bytestring >= 0.10.0.0 + , transformers >= 0.2.0.0 + , fsnotify >= 0.2 && < 0.3 + , network-uri < 2.7 + , conduit + , conduit-extra >= 1.1.2 + , text + , async + +source-repository head + type: git + location: https://github.com/sgraf812/feed-gipeda.git
+ src/FeedGipeda.hs view
@@ -0,0 +1,106 @@+{-| The API part of @feed-gipeda@. The console client is just a thin wrapper + around this. +-} + +module FeedGipeda + ( Endpoint (..) + , feedGipeda + , module FeedGipeda.Types + ) where + + +import Control.Arrow (second) +import Control.Concurrent (forkIO) +import Control.Concurrent.Chan (Chan, + newChan, + readChan, + writeChan) +import Control.Distributed.Process (Process, + RemoteTable, + liftIO, + say, + spawnLocal) +import qualified Control.Distributed.Process.Backend.SimpleLocalnet as SLN +import Control.Distributed.Process.Node (initRemoteTable, + runProcess) +import Control.Logging as Logging +import Control.Monad (forever, + void, when) +import Data.List (elemIndex) +import Data.Maybe (isJust) +import Data.Set (Set) +import Data.Time (NominalDiffTime) +import qualified FeedGipeda.Config as Config +import FeedGipeda.GitShell (SHA) +import qualified FeedGipeda.Master as Master +import FeedGipeda.Repo (Repo) +import qualified FeedGipeda.TaskQueue as TaskQueue +import qualified FeedGipeda.THGenerated as THGenerated +import FeedGipeda.Types +import Network.URI (parseURI) +import System.Directory (getAppUserDataDirectory) +import System.Exit (exitSuccess) +import System.FilePath ((</>)) + + +remoteTable :: RemoteTable +remoteTable = + THGenerated.__remoteTable initRemoteTable + + +{-| The parameters correspond exactly to the command line parameters, to + you should read the @--help@ message for more thorough documentation. + + @feedGipeda@ determines the appropriate mode of operation (e.g. watching or one-shot). + It also works as master or slave node, depending on which endpoints are given. + Lastly, @verbose@ will lead to more debug output. +-} +feedGipeda + :: Paths + -> Command + -> Deployment + -> ProcessRole + -> Verbosity + -> IO () +feedGipeda paths cmd deployment role_ verbosity = do + case verbosity of + Verbose -> Logging.setLogLevel Logging.LevelDebug + NotVerbose -> Logging.setLogLevel Logging.LevelWarn + + case cmd of + Check -> + -- Just perform a syntax check on the given configFile + Config.checkFile (configFile paths) >>= maybe exitSuccess error + Build mode -> do + case slaveEndpoint role_ of + Just (Endpoint host port) -> do + let + run = if isBoth role_ then void . forkIO else id + run $ do + backend <- SLN.initializeBackend host (show port) remoteTable + TaskQueue.work backend + _ -> return () + + case masterEndpoint role_ of + Nothing -> return () + Just (Endpoint host port) -> do + backend <- SLN.initializeBackend host (show port) remoteTable + node <- SLN.newLocalNode backend + tasks <- newChan + runProcess node $ do + taskQueue <- TaskQueue.start backend + + spawnLocal $ forever $ do + (finalize, benchmarkScript, repo, commit) <- liftIO (readChan tasks) + spawnLocal $ do + result <- TaskQueue.execute taskQueue + THGenerated.stringDict + (THGenerated.benchmarkClosure benchmarkScript repo commit) + liftIO (finalize result) + + let + onNewCommit :: (String -> IO ()) -> String -> Repo -> SHA -> IO () + onNewCommit finalize benchmarkScript repo commit = + writeChan tasks (finalize, benchmarkScript, repo, commit) + + liftIO (Master.checkForNewCommits paths deployment mode onNewCommit)
+ src/FeedGipeda/Assets.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE TemplateHaskell #-} + +{-| Contains @ByteString@ assets embedded via + @<https://hackage.haskell.org/package/file-embed file-embed>@. +-} + +module FeedGipeda.Assets + ( defaultIndexHtml + ) where + + +import Data.ByteString (ByteString) +import Data.FileEmbed (embedFile, makeRelativeToProject) + + +{-| A default @index.html@ to use as the top-level index site, as long as + the user doesn't paste its own to the appropriate location + (e.g. @`pwd`/default_index.html@). +-} +defaultIndexHtml :: ByteString +defaultIndexHtml = + $(makeRelativeToProject "assets/default_index.html" >>= embedFile)
+ src/FeedGipeda/Config.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE OverloadedStrings #-} + +{-| @feed-gipeda.yaml@ related stuff like decoding and syntax checking. +-} + + +module FeedGipeda.Config + ( Config + , empty + , repos + , decodeFile + , checkFile + ) where + + +import Control.Arrow (left) +import Control.Monad (forever) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Yaml (FromJSON (..), Value (Object), (.:)) +import qualified Data.Yaml as Yaml +import FeedGipeda.Repo (Repo (..)) +import qualified FeedGipeda.Repo as Repo +import Network.URI (parseURI) +import System.FilePath (dropFileName, equalFilePath) + + +{-| Represents a decoded config file. Has the appropriate @FromJSON@ config to + be deserializable from YAML. +-} +data Config + = Config + { repos :: Set Repo + } deriving (Eq, Show) + + +-- | A config with no repositories to watch. +empty :: Config +empty = + Config Set.empty + + +instance FromJSON Repo where + parseJSON v = do + s <- parseJSON v + uri <- maybe (fail "Could not parse URI") return (parseURI s) + return (Repo uri) + + +instance FromJSON Config where + parseJSON (Object v) = + fmap (Config . Set.fromList) (v .: "repositories") + parseJSON _ = + fail "Object" + + +{-| @decodeFile file@ @Either@ decodes a @Config@ from a YAML @file@ + (such as @feed-gipeda.yaml@) or returns a parse error message. +-} +decodeFile :: FilePath -> IO (Either String Config) +decodeFile file = fmap (left errorToString) (Yaml.decodeFileEither file) + where + errorToString :: Yaml.ParseException -> String + errorToString e = + unlines + [ "Could not decode the config file:" + , Yaml.prettyPrintParseException e + ] + + +{-| Checks for syntax errors while reading a @Config@ from the supplied YAML + file. +-} +checkFile :: FilePath -> IO (Maybe String) +checkFile file = + fmap (either Just (const Nothing)) (decodeFile file)
+ src/FeedGipeda/Gipeda.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE OverloadedStrings #-} + +{-| This module is just for parsing and generating gipeda.yaml files. + It should probably replaced by a reference to gipeda, but it works for now. + The raison d'être is @settingsForRepo@. +-} + +module FeedGipeda.Gipeda + ( GipedaSettings (..) + , BenchmarkSettings (..) + , settingsForRepo + , determineBenchmarkScript + ) where + + +import Control.Applicative +import Data.Aeson (withArray, withObject) +import Data.Functor +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (fromString) +import Data.Yaml (FromJSON (..), ToJSON (..), (.:), (.=)) +import qualified Data.Yaml as Yaml +import FeedGipeda.GitShell (SHA) +import qualified FeedGipeda.GitShell as GitShell +import FeedGipeda.Repo (Repo) +import qualified FeedGipeda.Repo as Repo +import System.Directory (doesFileExist) +import Text.Printf (printf) + + +{-| Models the possible settings in a @gipeda.yaml@ file, as expected to be + present by @gipeda@. +-} +data GipedaSettings = GipedaSettings + { title :: String + -- ^ Sets the repo-specific <title> text. + , revisionInfo :: String + {-^ Arbitrary HTML code that will displayed on a single commit's page. + @{{rev}}@ is replaced by the full SHA hash of the commit. + -} + , diffLink :: String + {-^ A link that displays the difference between two commits of the repository. + The strings @{{rev}}@ and @{{base}}@ are replaced by the full SHA hashes of + the two commits to compare. + -} + , limitRecent :: Int + -- ^ Number of commits shown on the start page. + , start :: SHA + {-^ Commit hash of the first commit to take into account. Useful to limit + the scope of gipeda in projects with a large history. + -} + , interestingTags :: String -- wildcard based, i.e. "*" + {-^ A glob (as understood by git tag -l) specifying which tags should be + shown on the main page. By default, no tags are shown; use * to show all. + -} + , interestingBranches :: String + -- ^ A glob such as @interestingTags@, but for selecting branches. + , benchmarkScript :: String + {-^ A shell command to execute in the directory for benchmarking. + Should produce CSV data in the format expected by gipeda. + -} + , benchmarks :: [BenchmarkSettings] + -- ^ Matchers for benchmark groups within the CSV files. + } deriving (Show) + + +{-| Matches benchmark groups from the names in the produced benchmark CSV files. +-} +data BenchmarkSettings = BenchmarkSettings + { match :: String + {-^ A file glob that determines to what benchmarks these settings apply. + @match: "*"@ will apply these settings to all benchmarks, + @match: "regression/*"*@ only to those whose title starts with + @regression/@. + -} + , smallerIsBetter :: Maybe Bool + {-^ By default (or if this is @False@), gipeda assumes that greater number + indicate improvement, and smaller number indicate regressions + (e.g. requests per second). This inverts this logic (e.g. runtime). + -} + , unit :: Maybe String + -- ^ Arbitrary unit, to be printed in the tables and on the graph axes. Defaults to @""@. + , type_ :: Maybe String + {-^ @"float", @"integral"@ (default) or @"small integral". For the first two, + differences are expressed in percentages (+10%), while for the latter, + differences are expressed in differences (+2). This is more suitable for + numbers like test suite failures, which should usually be zero or very + small. + -} + , group :: Maybe String + {-^ The benchmarks are displayed in groups; all benchmarks that have the same + string here are grouped under this title. Defaults to @""@. + -} + , threshold :: Maybe Double + {-^ Any change by a percentage greater than this number is flagged as a + regression resp. improvement; anything below this number is considered to + be a boring result, and not highlighted separately. + -} + , important :: Maybe Bool + {-^ @True@ by default. If @False@, a regression in this benchmark will not be + included in the summary for the whole commit. Use this if you have very + volatile tests that would produce too much noise on the main page. + -} + } deriving (Show) + + +benchmark :: String -> BenchmarkSettings +benchmark match = BenchmarkSettings + { match = match + , smallerIsBetter = Nothing + , unit = Nothing + , type_ = Nothing + , group = Nothing + , threshold = Nothing + , important = Nothing + } + + +instance ToJSON BenchmarkSettings where + toJSON s = (Yaml.object . catMaybes) + [ "match" .=? Just (match s) + , "smallerIsBetter" .=? smallerIsBetter s + , "unit" .=? unit s + , "type" .=? type_ s + , "group" .=? group s + , "threshold" .=? threshold s + , "important" .=? important s + ] where key .=? value = fmap (key .=) value + + +instance FromJSON BenchmarkSettings where + parseJSON (Yaml.Object o) = BenchmarkSettings + <$> o .: "match" + <*> o .? "smallerIsBetter" + <*> o .? "unit" + <*> o .? "type" + <*> o .? "group" + <*> o .? "threshold" + <*> o .? "important" + where o .? key = optional (o .: key) + + +instance ToJSON GipedaSettings where + toJSON s = Yaml.object + [ "title" .= title s + , "revisionInfo" .= revisionInfo s + , "diffLink" .= diffLink s + , "limitRecent" .= limitRecent s + , "start" .= start s + , "interestingTags" .= interestingTags s + , "interestingBranches" .= interestingBranches s + , "benchmarkScript" .= benchmarkScript s + , "benchmarks" .= benchmarks s + ] + + +{-| Determines the benchmark script for the given repo by looking into the + @gipeda.yaml@ file in the project-specific directory under the working + directory. The settings file was previously generated by @settingsForRepo@, + which also tries to merge project-specific settings to the default. +-} +determineBenchmarkScript :: Repo -> IO String +determineBenchmarkScript repo = do + settingsFile <- Repo.settingsFile repo + exists <- doesFileExist settingsFile + maybeSettings <- if exists then Yaml.decodeFile settingsFile else return Nothing + return $ fromMaybe "cloben" $ do + (Yaml.Object settings) <- maybeSettings + Yaml.parseMaybe (\_ -> settings .: "benchmarkScript") () + + +{-| Generates a @gipeda.yaml@ file for the given repository. It thereby takes + project-specific settings from a top-level @gipeda.yaml@ file at the + repository's @HEAD@ (if present) and fills in missing settings with + defaults. +-} +settingsForRepo :: Repo -> IO GipedaSettings +settingsForRepo repo = do + clone <- Repo.cloneDir repo + firstCommit <- GitShell.firstCommit clone + gipedaYaml <- GitShell.showHead clone "gipeda.yaml" + let + yaml :: Yaml.Value + yaml = + fromMaybe (Yaml.object []) (gipedaYaml >>= Yaml.decode . fromString) + + revisionInfo :: String + revisionInfo = + printf "<a href=\"%s/commit/{{rev}}>View Diff</a>" (Repo.uri repo) + + settings :: Yaml.Value -> Yaml.Parser GipedaSettings + settings (Yaml.Object obj) = + GipedaSettings + <$> "title" ?? Repo.shortName repo + <*> "revisionInfo" ?? printf "<a href=\"%s/commit/{{rev}}\">View Diff</a>" (Repo.uri repo) + <*> "diffLink" ?? printf "%s/compare/{{base}}...{{rev}}" (Repo.uri repo) + <*> "limitRecent" ?? 20 + <*> "start" ?? fromMaybe "HEAD" firstCommit -- "HEAD" doesn't really work, but better than crashing?! We shouldn't execute gipeda on an empty repository after all + <*> "interestingTags" ?? "*" + <*> "interestingBranches" ?? "*" + <*> "benchmarkScript" ?? "cloben" + <*> "benchmarks" ?? [] + where key ?? def = obj .: key <|> pure def + settings _ = settings (Yaml.object []) -- This should fill in some defaults nonetheless + + Yaml.parseMonad settings yaml -- This should never fail. Never!
+ src/FeedGipeda/GitShell.hs view
@@ -0,0 +1,99 @@+{-| Functions for shelling out to @git@ to work with git repositories. +-} + + +module FeedGipeda.GitShell + ( isRepositoryRoot + , fetch + , allCommits + , firstCommit + , remoteRepo + , showHead + , sync + , SHA + ) where + + +import Data.Char (isSpace) +import Data.Functor +import Data.Maybe (listToMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import FeedGipeda.Repo (Repo) +import qualified FeedGipeda.Repo as Repo +import System.Directory (createDirectoryIfMissing) +import System.Exit (ExitCode (..)) +import System.Process (callProcess, readProcessWithExitCode) + + +type SHA + = String + + +isRepositoryRoot :: FilePath -> IO Bool +isRepositoryRoot path = do + (_, stdout, _) <- readProcessWithExitCode + "git" ["-C", path, "rev-parse", "--git-dir"] "" + -- testing for ".git" and "." (bare repo) should be good enough. + (return . maybe False (`elem` [".git", "."]) . listToMaybe . lines) stdout + + +mirror :: Repo -> FilePath -> IO () +mirror repo path = do + (_, _, _) <- readProcessWithExitCode + "git" ["clone", "--mirror", "--quiet", Repo.uri repo, path] "" + return () + + +remoteRepo :: FilePath -> IO Repo +remoteRepo path = do + (_, stdout, _) <- readProcessWithExitCode + "git" ["-C", path, "ls-remote", "--get-url", "origin"] "" + return (Repo.unsafeFromString (init stdout)) -- strip the \n with init + + +fetch :: FilePath -> IO () +fetch path = + callProcess "git" ["-C", path, "fetch", "--quiet"] + + +{-| @sync repo@ tries to fetch updates from the remote @repo@ or creates a + mirror of @repo@ if there isn't already a local clone present. +-} +sync :: Repo -> IO () +sync repo = do + path <- Repo.cloneDir repo + hasClone <- isRepositoryRoot path + if hasClone + then fetch path + else do + createDirectoryIfMissing True path + mirror repo path + + +allCommits :: FilePath -> IO (Set SHA) +allCommits path = + Set.fromList <$> gitLogImpl path [] + + +firstCommit :: FilePath -> IO (Maybe SHA) +firstCommit path = + listToMaybe <$> gitLogImpl path ["--reverse"] + + +showHead :: FilePath -> FilePath -> IO (Maybe String) +showHead path file = do + let + allArgs = ["-C", path, "show", "HEAD:" ++ file] + (exitCode, stdout, stderr) <- readProcessWithExitCode "git" allArgs "" + case exitCode of + ExitSuccess -> return (Just stdout) + ExitFailure _ -> return Nothing + + +gitLogImpl :: FilePath -> [String] -> IO [SHA] +gitLogImpl path additionalArgs = do + let + allArgs = ["-C", path, "log", "--format=format:%H"] ++ additionalArgs + (_, stdout, _) <- readProcessWithExitCode "git" allArgs "" + return (filter (not . null) (lines stdout))
+ src/FeedGipeda/Master.hs view
@@ -0,0 +1,254 @@+{-| The master node works as follows: + + 1. Maintain updated local clones of a number of configured repositories + 2. Ask @gipeda@ which of those repositories have commits that need to be benchmarked + 3. Notify the caller for each (Repo, SHA) pair (to delegate work to slaves) + 4. Call @gipeda@ when either the repository or some benchmark result file changed + + If in @Watch@ mode (as opposed to @OneShot@ mode), the configuration file is + watched for updates to the actively watched repositories, as well as + fetches all currently watched repositories at a fixed interval. Existing + clones are detected and reused, so that restarting the daemon will not do + unnecessary work. +-} + +module FeedGipeda.Master + ( NewCommitAction + , checkForNewCommits + ) where + + +import Control.Concurrent (forkIO, threadDelay) +import Control.Concurrent.Event (Event) +import qualified Control.Concurrent.Event as Event +import Control.Concurrent.Lock (Lock) +import qualified Control.Concurrent.Lock as Lock +import Control.Logging as Logging +import Control.Monad (forM_, forever, when) +import Control.Monad.IO.Class (liftIO) +import Data.Functor +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as Text +import Data.Time (NominalDiffTime) +import qualified Data.Time as Time +import Debug.Trace (traceShowId) +import qualified FeedGipeda.Config as Config +import qualified FeedGipeda.Gipeda as Gipeda +import FeedGipeda.GitShell (SHA) +import qualified FeedGipeda.GitShell as GitShell +import qualified FeedGipeda.Master.File as File +import qualified FeedGipeda.Master.Finalize as Finalize +import FeedGipeda.Master.RepoDiff (RepoDiff) +import qualified FeedGipeda.Master.RepoDiff as RepoDiff +import FeedGipeda.Repo (Repo) +import qualified FeedGipeda.Repo as Repo +import FeedGipeda.Types +import Reactive.Banana ((<@), (<@>)) +import qualified Reactive.Banana as Banana +import qualified Reactive.Banana.Frameworks as Banana +import System.Directory (canonicalizePath, + getCurrentDirectory) +import System.FilePath (equalFilePath, takeDirectory) +import qualified System.FSNotify as FS + + +-- | Handler which will be called for commits @gipeda@ requests to benchmark. +type NewCommitAction + = (String -> IO ()) + -- ^ Continuation to call with the benchmark results + -> String + -- ^ The @benchmarkScript@ as determined when assembling the @gipeda.yaml@ + -> Repo + -- ^ The repository of the commit to benchmark + -> SHA + -- ^ The commit to benchmark + -> IO () + + +notifyOnNewCommitsInBacklog :: NewCommitAction -> (Repo, Set SHA) -> IO () +notifyOnNewCommitsInBacklog onNewCommit (repo, backlog) = do + benchmarkScript <- Gipeda.determineBenchmarkScript repo + forM_ (Set.toList backlog) $ \commit -> + onNewCommit (File.writeBenchmarkCSV repo commit) benchmarkScript repo commit + + +finalizeRepos :: Lock -> Paths -> Deployment -> Set Repo -> Set Repo -> IO () +finalizeRepos lock paths deployment activeRepos repos = + forM_ (Set.toList repos) $ \repo -> Lock.with lock $ do + backlog <- File.generateBacklog repo + Finalize.regenerateAndDeploy (gipeda paths) deployment activeRepos repo + File.writeBacklog repo backlog + + +readConfigFileRepos :: FS.Event -> IO (Maybe (Set Repo)) +readConfigFileRepos evt = + case evt of + FS.Removed _ _ -> return (Just Set.empty) + _ -> + Config.decodeFile (FS.eventPath evt) >>= either + (\err -> Logging.warn (Text.pack err) >> return Nothing) + (return . Just . Config.repos) + + +accumDiff + :: Banana.Event (Set Repo) + -> Banana.MomentIO (Banana.Event RepoDiff) +accumDiff repos = + fst <$> Banana.mapAccum Set.empty ((\new old -> (RepoDiff.compute old new, new)) <$> repos) + + +dedupCommitsAndNotifyWhenEmpty + :: IO () + -> Banana.Event (Repo, Set SHA) + -> Banana.MomentIO (Banana.Event (Repo, Set SHA)) +dedupCommitsAndNotifyWhenEmpty notify commits = do + (events, maps) <- Banana.mapAccum Map.empty (filterDuplicates <$> commits) + Banana.mapEventIO id events + where + filterDuplicates + :: (Repo, Set SHA) + -> Map Repo (Set SHA) + -> (IO (Repo, Set SHA), Map Repo (Set SHA)) + filterDuplicates (repo, commits) inProgress = + let + nonDuplicates = + Set.difference commits (fromMaybe Set.empty (Map.lookup repo inProgress)) + + newMap = + if Set.null commits + then Map.delete repo inProgress + else Map.insert repo commits inProgress + + eventAction = do + when (Map.null newMap) notify + Logging.log (Text.pack ("Backlog for " ++ Repo.uri repo + ++ " contained " ++ show (Set.size commits) ++ " commits, " + ++ show (Set.size nonDuplicates) ++ " unhandled.")) + return (repo, nonDuplicates) + in + (eventAction, newMap) + + +periodically :: NominalDiffTime -> Banana.MomentIO (Banana.Event ()) +periodically dt = do + (event, fire) <- Banana.newEvent + liftIO $ forkIO $ forever $ do + begin <- Time.getCurrentTime + fire () + end <- Time.getCurrentTime + let elapsed = Time.diffUTCTime end begin + threadDelay (ceiling ((dt - elapsed) * 1000000)) + return event + + +singleShot :: Event -> Banana.MomentIO (Banana.Event ()) +singleShot evt = do + (event, fire) <- Banana.newEvent + liftIO $ forkIO $ Event.wait evt >>= fire + return event + + +repoOfFileEvent + :: FilePath + -> Banana.Behavior (Set Repo) + -> Banana.Event FS.Event + -> Banana.MomentIO (Banana.Event Repo) +repoOfFileEvent cwd activeRepos fileEvents = + Banana.filterJust <$> Banana.mapEventIO + id + (File.repoOfPath cwd <$> activeRepos <@> (FS.eventPath <$> fileEvents)) + + +{-| See the module docs. This function builds up the FRP network with primitives + from @reactive-banana@. No other module should be 'tainted' by that. +-} +checkForNewCommits + :: Paths + -> Deployment + -> BuildMode + -> NewCommitAction + -> IO () +checkForNewCommits paths deployment mode onNewCommit = FS.withManager $ \mgr -> do + cwd <- getCurrentDirectory + exit <- Event.new + start <- Event.new + + let + watchFile :: FilePath -> Banana.MomentIO (Banana.Event FS.Event) + watchFile path' = do + (event, fire) <- Banana.newEvent + path <- liftIO (canonicalizePath path') + liftIO $ FS.watchDir mgr (takeDirectory path) (equalFilePath path . FS.eventPath) $ \evt -> do + Logging.debug (Text.pack ("File changed: " ++ show evt)) + fire evt + return event + + watchTree :: FilePath -> (FilePath -> Bool) -> Banana.MomentIO (Banana.Event FS.Event) + watchTree path predicate = do + (event, fire) <- Banana.newEvent + liftIO $ FS.watchTree mgr path (predicate . FS.eventPath) $ \evt -> do + Logging.debug (Text.pack ("File changed: " ++ show evt)) + fire evt + return event + + networkDescription :: Banana.MomentIO () + networkDescription = do + -- Source: Initial tick to read in the file + initialConfig <- (FS.Added (configFile paths) undefined <$) <$> singleShot start + + -- Source: Events resulting from watching the config file + configFileChanges <- + case mode of + Once -> return initialConfig + WatchForChanges _ -> Banana.unionWith const initialConfig <$> watchFile (configFile paths) + + activeRepos <- Banana.filterJust <$> Banana.mapEventIO readConfigFileRepos configFileChanges + activeReposB <- Banana.stepper Set.empty activeRepos + diffsWithoutRefresh <- accumDiff activeRepos + + -- Source: When in PeriodicRefresh mode, occasionally mark all repos dirty + diffs <- + case mode of + Once -> return diffsWithoutRefresh + WatchForChanges dt -> do + ticks <- periodically dt + return (Banana.unionWith const (RepoDiff.compute Set.empty <$> activeReposB <@ ticks) diffsWithoutRefresh) + + -- Fetch every added ('dirty') repository, delay until fetch is complete + -- TODO: parallelize and/or get rid of forM_ somehow + fetchedRepos <- + Banana.mapEventIO + (\added -> do + forM_ (Set.toList added) $ \repo -> do + Logging.log (Text.pack ("Syncing " ++ Repo.shortName repo)) + GitShell.sync repo + return added) + (RepoDiff.added <$> diffs) + + -- Source: Changed benchmark CSV files + benchmarks <- watchTree cwd (File.isBenchmarkCSV cwd) + benchmarkedRepos <- repoOfFileEvent cwd activeReposB benchmarks + + -- Sink: produce the appropriate backlog and deploy + let reposToFinish = Banana.unionWith Set.union fetchedRepos (Set.singleton <$> benchmarkedRepos) + finalizeLock <- liftIO Lock.new + Banana.reactimate (finalizeRepos finalizeLock paths deployment <$> activeReposB <@> reposToFinish) + + -- Source: Backlog changes + backlogs <- watchTree cwd (File.isBacklog cwd) + backlogRepos <- repoOfFileEvent cwd activeReposB backlogs + + -- Sink: Backlog changes kick off workers, resp. the new commit action + backlogCommits <- Banana.mapEventIO (\repo -> (,) repo <$> File.readBacklog repo) backlogRepos + let doExit = when (mode == Once) (Event.set exit) + dedupedCommits <- dedupCommitsAndNotifyWhenEmpty doExit backlogCommits + Banana.reactimate (notifyOnNewCommitsInBacklog onNewCommit <$> dedupedCommits) + + network <- Banana.compile networkDescription + Banana.actuate network + Event.set start + Event.wait exit
+ src/FeedGipeda/Master/File.hs view
@@ -0,0 +1,113 @@+-- | Functions for file handling in the master node. + +module FeedGipeda.Master.File + ( writeBenchmarkCSV + , isBenchmarkCSV + , generateBacklog + , writeBacklog + , readBacklog + , isBacklog + , repoOfPath + ) where + + +import Data.Char (toLower) +import Data.Functor +import Data.List (isSuffixOf) +import Data.Maybe (listToMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import FeedGipeda.GitShell (SHA) +import qualified FeedGipeda.GitShell as GitShell +import FeedGipeda.Repo (Repo) +import qualified FeedGipeda.Repo as Repo +import System.Directory (createDirectoryIfMissing, doesFileExist, + getCurrentDirectory, getDirectoryContents) +import System.FilePath (dropFileName, makeRelative, normalise, + splitDirectories, takeBaseName, + takeBaseName, takeExtension, takeFileName, + (<.>), (</>)) + + +-- Until this is done by gipeda, we have to also produce the backlog on our own. +generateBacklog :: Repo -> IO (Set SHA) +generateBacklog repo = do + projectDir <- Repo.projectDir repo + path <- Repo.cloneDir repo + hasClone <- GitShell.isRepositoryRoot path + if not hasClone -- This should never be true, actually + then return Set.empty + else do + allCommits <- GitShell.allCommits path + resultsDir <- Repo.resultsDir repo + createDirectoryIfMissing True resultsDir + alreadyHandledCommits <- Set.fromList . map takeBaseName <$> getDirectoryContents resultsDir + return (Set.difference allCommits alreadyHandledCommits) + + +writeBacklog :: Repo -> Set SHA -> IO () +writeBacklog repo backlog = do + backlogFile <- Repo.backlogFile repo + writeFile backlogFile (unlines (Set.toList backlog)) + + +readBacklog :: Repo -> IO (Set SHA) +readBacklog repo = do + backlog <- Repo.backlogFile repo + exists <- doesFileExist backlog + if exists + then Set.fromList . lines <$> readFile backlog + else return Set.empty + + +matchProjectRelativeDirectory :: [String] -> FilePath -> FilePath -> Bool +matchProjectRelativeDirectory subDirs cwd path = + let + splitNormalisedDirs :: [String] + splitNormalisedDirs = + splitDirectories (makeRelative cwd (normalise (dropFileName path))) + in + length splitNormalisedDirs == length subDirs + 1 + && subDirs `isSuffixOf` splitNormalisedDirs + + +isBacklog :: FilePath -> FilePath -> Bool +isBacklog cwd path = + and + [ map toLower (takeBaseName path) == "backlog" + , map toLower (takeExtension path) == ".txt" + , matchProjectRelativeDirectory [] cwd path + ] + + +writeBenchmarkCSV :: Repo -> SHA -> String -> IO () +writeBenchmarkCSV repo commit result = do + cwd <- getCurrentDirectory + writeFile (cwd </> Repo.uniqueName repo </> "site" </> "out" </> "results" </> commit <.> "csv") result + + +isBenchmarkCSV :: FilePath -> FilePath -> Bool +isBenchmarkCSV cwd path = + map toLower (takeExtension path) == ".csv" + && matchProjectRelativeDirectory ["site", "out", "results"] cwd path + + +repoOfPath :: FilePath -> Set Repo -> FilePath -> IO (Maybe Repo) +repoOfPath cwd activeRepos path = + let + uniqueName :: FilePath -> Maybe String + uniqueName = + listToMaybe . splitDirectories . makeRelative cwd + in + case uniqueName path of + Nothing -> return Nothing + Just name -> do + let path = cwd </> name </> "repository" + hasClone <- GitShell.isRepositoryRoot path + if not hasClone + then return Nothing + else do + repo <- GitShell.remoteRepo path + if not (Set.member repo activeRepos) + then return Nothing + else return (Just repo)
+ src/FeedGipeda/Master/Finalize.hs view
@@ -0,0 +1,193 @@+{-| The meat of the master node: Calls @gipeda@ and optionally deploys the + website via @rsync@. + + Upon deployment, repositories are mapped to URLs via specific policies + verified in @sshSubPathTestFailures@. +-} + +module FeedGipeda.Master.Finalize + ( regenerateAndDeploy + ) where + + +import Control.Logging as Logging +import Control.Monad (unless, void, when) +import Data.Aeson ((.=)) +import qualified Data.Aeson as Json +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Foldable (find) +import Data.List (elemIndex, stripPrefix) +import Data.Maybe (fromMaybe, isJust, isNothing) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Yaml as Yaml +import qualified FeedGipeda.Assets as Assets +import qualified FeedGipeda.Gipeda as Gipeda +import FeedGipeda.GitShell (SHA) +import qualified FeedGipeda.GitShell as GitShell +import FeedGipeda.Repo (Repo) +import qualified FeedGipeda.Repo as Repo +import FeedGipeda.Types (Deployment (..)) +import Network.URI (URI, uriAuthority, uriPath, uriRegName, + uriToString) +import System.Directory (copyFile, createDirectoryIfMissing, + doesFileExist) +import System.Exit (ExitCode (..)) +import System.FilePath (addTrailingPathSeparator, dropExtension, + dropFileName, takeBaseName, (</>)) +import System.Process (cwd, proc, readCreateProcessWithExitCode) + + +executeIn :: Maybe FilePath -> FilePath -> [String] -> IO String +executeIn cwd executable args = do + (exitCode, stdout, stderr) <- + readCreateProcessWithExitCode (proc executable args) { cwd = cwd } "" + Logging.debug (Text.pack (takeBaseName executable ++ ": " ++ show exitCode)) + case exitCode of + ExitFailure _ -> Logging.debug (Text.pack stderr) >> Logging.debug (Text.pack stdout) + _ -> return () + -- That's too much even for debug + --Logging.debug (Text.pack "stdout:") + --Logging.debug (Text.pack stdout) + --Logging.debug (Text.pack "stderr:") + --Logging.debug (Text.pack stderr) + return stdout + + +{-| @regenerateAndDeploy gipeda rsyncPath repos repo@ updates the @site/@ sub + folder by calling @gipeda@ in @repo@s @projectDir@. That also updates + the @backlog.txt@, which will possibly kick off other benchmarks. + + After the site has been regenerated, the changes are deployed via @rsync@ + to @remoteDir@, if present. The sub directory to which the site is synced + follow a mapping which should satisfy the tests in @sshSubPathTestFailures@. +-} +regenerateAndDeploy :: FilePath -> Deployment -> Set Repo -> Repo -> IO () +regenerateAndDeploy gipeda deployment repos repo = do + project <- Repo.projectDir repo + Logging.log (Text.pack ("Regenerating " ++ Repo.uri repo ++ " (" ++ Repo.uniqueName repo ++ ")")) + clone <- Repo.cloneDir repo + first <- GitShell.firstCommit clone + if isJust first + then do + saveSettings repo + executeIn (Just project) gipeda ["-j"] + rsyncSite repos repo deployment + return () + else + Logging.log (Text.pack "There were no commits") + + +saveSettings :: Repo -> IO () +saveSettings repo = do + settingsFile <- Repo.settingsFile repo + settings <- Gipeda.settingsForRepo repo + Yaml.encodeFile settingsFile settings + + +type SSHSubPathPolicy + = (Repo -> Bool, Repo -> FilePath) + + +sshSubPath :: Repo -> FilePath +sshSubPath repo = + maybe Repo.uniqueName snd (find (\(matches, _) -> matches repo) policies) repo + where + policies :: [SSHSubPathPolicy] + policies = + [ gitHubPolicy + , perfHaskellPolicy + ] + + stripWWW :: String -> String + stripWWW s = + fromMaybe s (stripPrefix "www." s) + + matchRegName :: String -> Repo -> Bool + matchRegName regName = + maybe False ((== regName) . stripWWW . uriRegName) . uriAuthority . Repo.unRepo + + gitHubPolicy :: SSHSubPathPolicy + gitHubPolicy = + -- tail because the path will start a slash + (matchRegName "github.com", dropExtension . tail . uriPath . Repo.unRepo) + + perfHaskellPolicy :: SSHSubPathPolicy + perfHaskellPolicy = + (matchRegName "git.haskell.org", takeBaseName . uriPath . Repo.unRepo) + + +sshSubPathTestFailures :: [(Repo, String, String)] +sshSubPathTestFailures = + (map (\(r, e) -> (r, e, sshSubPath r)) . filter isFailure) + [ (Repo.unsafeFromString "https://github.com/sgraf812/benchmark-test", "sgraf812/benchmark-test") + , (Repo.unsafeFromString "https://www.github.com/sgraf812/benchmark-test", "sgraf812/benchmark-test") + , (Repo.unsafeFromString "https://git.haskell.org/sgraf812/benchmark-test", "benchmark-test") + , (Repo.unsafeFromString "https://bitbucket.org/sgraf812/benchmark-test", "benchmark-test-2921196486978765793") + ] + where + isFailure (repo, expected) = + sshSubPath repo /= expected + + +generateMapping :: FilePath -> Set Repo -> IO () +generateMapping file = + LBS.writeFile file . Json.encode . Json.object . map sshMapping . Set.toList + where + sshMapping repo = + Text.pack (sshSubPath repo) .= Repo.uri repo + + +parseSSHUri :: String -> (Maybe String, FilePath) +parseSSHUri sshUri = + case elemIndex ':' (reverse sshUri) of + Nothing -> (Nothing, sshUri) -- Assume it's a local file path + Just n -> + let + n' = length sshUri - n + in + (Just (take (n' - 1) sshUri), drop n' sshUri) + + +rsyncSite :: Set Repo -> Repo -> Deployment -> IO () +rsyncSite repos repo NoDeployment = return () +rsyncSite repos repo (Deploy remoteDir) = do + projectDir <- Repo.projectDir repo + -- we need the trailing path separator, otherwise it will add a site + -- sub directory. + -- The rsync-path parameter is used for a little hack that ensures the + -- remote directory acutally exists on the remote machine. + -- Otherwise, we couldn't cope with nested sshSubPaths. + -- -a: archive mode (many different flags), -v verbose, -z compress + Logging.log (Text.pack "rsyncing") + let (sshPart, filePart) = parseSSHUri remoteDir + + case sshPart of + Nothing -> createDirectoryIfMissing True (filePart </> sshSubPath repo) + Just uri -> + void $ executeIn Nothing "ssh" [uri, "mkdir -p " ++ filePart </> sshSubPath repo] + + executeIn Nothing "rsync" + [ "-avz" + , addTrailingPathSeparator (projectDir </> "site") + , remoteDir </> sshSubPath repo + ] + + generateMapping "sites.json" repos + executeIn Nothing "rsync" + [ "-avz" + , "sites.json" + , remoteDir </> "sites.json" + ] + + BS.writeFile "default_index.html" Assets.defaultIndexHtml + executeIn Nothing "rsync" + [ "-avz" + , "--ignore-existing" -- so that users can provide their own index.html + , "default_index.html" + , remoteDir </> "index.html" + ] + + return ()
+ src/FeedGipeda/Master/RepoDiff.hs view
@@ -0,0 +1,29 @@+-- | Provides means to diff sets of repositories. + +module FeedGipeda.Master.RepoDiff + ( RepoDiff (..) + , compute + , apply + ) where + + +import Data.Set (Set) +import qualified Data.Set as Set +import FeedGipeda.Repo (Repo) + + +data RepoDiff + = RepoDiff + { added :: Set Repo + , removed :: Set Repo + } deriving (Eq, Show) + + +compute :: Set Repo -> Set Repo -> RepoDiff +compute old new = + RepoDiff (Set.difference new old) (Set.difference old new) + + +apply :: RepoDiff -> Set Repo -> Set Repo +apply diff = + flip Set.difference (removed diff) . Set.union (added diff)
+ src/FeedGipeda/Repo.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| Provides domain functions around remote git repositories. + It also exposes @projectDir@ related functions, e.g. mapping conceptual file + paths to concrete file paths. +-} + +module FeedGipeda.Repo + ( Repo (..) + , unsafeFromString + , uri + , uniqueName + , shortName + , projectDir + , cloneDir + , resultsDir + , settingsFile + , backlogFile + ) where + + +import Data.Binary (Binary (..)) +import Data.Functor +import qualified Data.Hash as Hash +import Data.Maybe (fromJust) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Typeable (Typeable) +import Data.Word (Word64) +import Network.URI (URI, parseURI, uriPath, uriToString) +import System.Directory (getCurrentDirectory) +import System.FilePath (takeFileName, (</>)) + + +newtype Repo = Repo + { unRepo :: URI + } deriving (Eq, Ord, Show, Typeable) + + +instance Binary Repo where + get = unsafeFromString <$> get + put = put . uri + + +unsafeFromString :: String -> Repo +unsafeFromString uri = + Repo (fromJust (parseURI uri)) + + +uri :: Repo -> String +uri (Repo u) = + uriToString id u "" + + +hash :: Repo -> Word64 +hash = + Hash.asWord64 . Hash.hash . show . uri + + +{-| Used in @projectDir@ to disambiguate file paths. -} +uniqueName :: Repo -> String +uniqueName repo = + shortName repo ++ "-" ++ (show . hash) repo + + +shortName :: Repo -> String +shortName repo = + takeFileName (uriPath (unRepo repo)) + + +{-| Assigns each repository a unique local working directory. -} +projectDir :: Repo -> IO FilePath +projectDir repo = do + cwd <- getCurrentDirectory + return (cwd </> uniqueName repo) + + +cloneDir :: Repo -> IO FilePath +cloneDir repo = + fmap (</> "repository") (projectDir repo) + + +resultsDir :: Repo -> IO FilePath +resultsDir repo = + fmap (</> "site" </> "out" </> "results") (projectDir repo) + + +settingsFile :: Repo -> IO FilePath +settingsFile repo = + fmap (</> "gipeda.yaml") (projectDir repo) + + +backlogFile :: Repo -> IO FilePath +backlogFile repo = + fmap (</> "backlog.txt") (projectDir repo)
+ src/FeedGipeda/Slave.hs view
@@ -0,0 +1,69 @@+{-| @benchmark@ contains the logic to be executed on slave nodes. +-} + + +module FeedGipeda.Slave + ( benchmark + ) where + + +import Control.Logging as Logging +import qualified Data.Text as Text +import FeedGipeda.GitShell (SHA) +import FeedGipeda.Repo (Repo) +import qualified FeedGipeda.Repo as Repo +import System.Exit (ExitCode (..)) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (cwd, proc, readCreateProcessWithExitCode, + shell, showCommandForUser) + + +procReportingError :: Repo -> SHA -> Maybe FilePath -> FilePath -> [String] -> IO String +procReportingError repo commit cwd cmd args = do + (exitCode, stdout, stderr) <- + readCreateProcessWithExitCode (proc cmd args) { cwd = cwd } "" + reportError repo commit (showCommandForUser cmd args) exitCode stderr + return stdout + + +shellReportingError :: Repo -> SHA -> Maybe FilePath -> FilePath -> IO String +shellReportingError repo commit cwd cmd = do + (exitCode, stdout, stderr) <- + readCreateProcessWithExitCode (shell cmd) { cwd = cwd } "" + reportError repo commit cmd exitCode stderr + return stdout + + +reportError :: Repo -> SHA -> String -> ExitCode -> String -> IO () +reportError repo commit cmd code stderr = + case code of + ExitSuccess -> return () + ExitFailure c -> + Logging.warn . Text.pack . unlines $ + [ "Benchmark script error" + , "At commit " ++ Repo.uri repo ++ "@" ++ commit ++ ":" + , cmd ++ ": exit code " ++ show c + , stderr + ] + + +cloneRecursiveAndCheckout :: Repo -> SHA -> FilePath -> IO () +cloneRecursiveAndCheckout repo commit cloneDir = do + procReportingError repo commit Nothing "git" ["clone", "--quiet", Repo.uri repo, cloneDir] + procReportingError repo commit (Just cloneDir) "git" ["reset", "--hard", commit] + shellReportingError repo commit (Just cloneDir) "git submodule update --init --recursive --quiet" + return () + + +{-| Clones the given @repo@ at a specific @commit@ into a temporary directory. + Then calls the @benchmarkScript@ within that directory and returns its output. + + Will be executed on slave nodes. +-} +benchmark :: String -> Repo -> SHA -> IO String +benchmark benchmarkScript repo commit = do + clone <- Repo.cloneDir repo + Logging.log (Text.pack ("Benchmarking " ++ Repo.uri repo ++ "@" ++ commit)) + withSystemTempDirectory "feed-gipeda" $ \cloneDir -> do + cloneRecursiveAndCheckout repo commit cloneDir + shellReportingError repo commit (Just cloneDir) benchmarkScript
+ src/FeedGipeda/THGenerated.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE TemplateHaskell #-} + +{-| Contains TemplateHaskell stuff I don't want to recompile every time I make + changes to other files, a pre-compiled header, so to say. Don't know if that + even works. +-} + +module FeedGipeda.THGenerated + ( benchmarkClosure + , stringDict + , __remoteTable + ) where + +import Control.Distributed.Process (Closure, Process, Static, + liftIO) +import Control.Distributed.Process.Closure (SerializableDict, + functionTDict, mkClosure, + remotable) +import FeedGipeda.GitShell (SHA) +import FeedGipeda.Repo (Repo) +import qualified FeedGipeda.Slave as Slave + + +benchmarkProcess :: (String, Repo, SHA) -> Process String +benchmarkProcess (benchmarkScript, repo, sha) = + liftIO (Slave.benchmark benchmarkScript repo sha) +remotable ['benchmarkProcess] + + +benchmarkClosure :: String -> Repo -> SHA -> Closure (Process String) +benchmarkClosure benchmarkScript repo commit = + $(mkClosure 'benchmarkProcess) (benchmarkScript, repo, commit) + + +stringDict :: Static (SerializableDict String) +stringDict = + $(functionTDict 'benchmarkProcess)
+ src/FeedGipeda/TaskQueue.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-| A task queue implementation based on + <http://haskell-distributed.github.io/tutorials/4ch.html#building-a-task-queue>. + It is however flexible in the number of active slaves, which are discovered + via the SimpleLocalnet backend of cloud haskell. + Also, failures are automatically retried. +-} + +module FeedGipeda.TaskQueue + ( TaskQueue + , start + , execute + , work + ) where + + +import Control.Concurrent (threadDelay) +import Control.Distributed.Process hiding + (call) +import Control.Distributed.Process.Async +import Control.Distributed.Process.Backend.SimpleLocalnet (Backend (..), + findSlaves, + startSlave) +import Control.Distributed.Process.Extras hiding + (call, + send) +import Control.Distributed.Process.Extras.Time +import Control.Distributed.Process.ManagedProcess +import Control.Distributed.Process.Serializable +import Control.Monad (forever) +import Data.Binary (Binary) +import Data.Functor +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (isNothing) +import Data.Proxy +import Data.Sequence (Seq, + ViewL (..), + (<|), (|>)) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Typeable (Typeable) +import GHC.Generics (Generic) + + +{-| Abstract process representing the task queue. Notably has an instance of + @Resolvable@. +-} +newtype TaskQueue a + = TaskQueue ProcessId + + +instance Resolvable (TaskQueue a) where + resolve (TaskQueue pid) = return (Just pid) + + +type Task a + = (Static (SerializableDict a), Closure (Process a)) + + +newtype Result a + = Result a + deriving (Eq, Ord, Show, Generic, Typeable) +instance Binary a => Binary (Result a) + + +newtype SlaveListChanged + = SlaveListChanged (Set NodeId) + deriving (Ord, Eq, Show, Generic, Typeable) +instance Binary SlaveListChanged + + +data QueueState a + = QueueState + { slaves :: Map NodeId (Maybe MonitorRef) + , active :: Map MonitorRef (NodeId, Async a, CallRef a, Task a) + , onHold :: Seq (CallRef a, Task a) + } + + +initialQueueState :: QueueState a +initialQueueState = + QueueState Map.empty Map.empty Seq.empty + + +-- | Spawn the task queue on the local node and start to discover slave nodes. +start + :: forall a . Serializable a + => Backend + -> Process (TaskQueue a) +start backend = do + queue <- TaskQueue <$> spawnLocal (queue (Proxy :: Proxy a)) + spawnLocal (slaveDiscovery backend queue) + return queue + + +-- ^ Execute task on a slave node. +execute + :: Serializable a + => TaskQueue a + -- ^ The task queue which will dispatch the task to a previously discovered slave + -> Static (SerializableDict a) + -- ^ A static pointer for the slave to find the entry point of the task to execute + -> Closure (Process a) + -- ^ The state in which to execute the task + -> Process a +execute queue dict closure = + call queue (dict, closure) + + +queue + :: forall a . Serializable a + => Proxy a + -> Process () +queue _ = serve () init process + where + init :: InitHandler () (QueueState a) + init () = + return (InitOk initialQueueState Infinity) + + process :: ProcessDefinition (QueueState a) + process = defaultProcess + { apiHandlers = + [ handleCast onSlaveListChanged + , handleCallFrom onNewTask + ] + , infoHandlers = + [ handleInfo onTaskCompleted + ] + , unhandledMessagePolicy = Log + } + + assignTasks :: QueueState a -> Process (QueueState a) + assignTasks qs@(QueueState slaves active onHold) = do + let + idle :: Set NodeId + idle = + Map.keysSet (Map.filter isNothing slaves) + + assignment :: Maybe (NodeId, CallRef a, Task a) + assignment = do + node <- fst <$> Set.minView idle + (ref, task) <- case Seq.viewl onHold of + EmptyL -> Nothing + head :< _ -> Just head + return (node, ref, task) + + case assignment of + Nothing -> return qs + Just (node, callRef, (dict, closure)) -> do + --say $ "Assigning node " ++ show node ++ " to a task" + handle <- async (remoteTask dict node closure) + monitorRef <- monitorAsync handle + return qs + { slaves = Map.insert node (Just monitorRef) slaves + , onHold = Seq.drop 1 onHold + , active = Map.insert monitorRef (node, handle, callRef, (dict, closure)) active + } + + onNewTask + :: QueueState a + -> CallRef a + -> Task a + -> Process (ProcessReply a (QueueState a)) + onNewTask qs ref task = + assignTasks (qs { onHold = onHold qs |> (ref, task) }) >>= noReply_ + + onTaskCompleted + :: QueueState a + -> ProcessMonitorNotification + -> Process (ProcessAction (QueueState a)) + onTaskCompleted qs (ProcessMonitorNotification monitorRef _ _) = + let + withoutRef = + Map.delete monitorRef (active qs) + reenqueue callRef task = + (callRef, task) <| onHold qs + in + case Map.lookup monitorRef (active qs) of + Nothing -> continue qs { active = withoutRef } + Just (node, handle, callRef, task) -> do + result <- wait handle + case result of + AsyncDone ret -> do + qs' <- assignTasks qs + { slaves = Map.adjust (const Nothing) node (slaves qs) + , active = withoutRef + } + replyTo callRef ret + continue qs' + AsyncPending -> fail "Waited for an async task, but still pending" + _ -> do + say (show node ++ " failed. Reassigning task.") + qs' <- assignTasks qs + { slaves = Map.delete node (slaves qs) -- temporarily blacklist the failing node + , active = withoutRef + , onHold = reenqueue callRef task + } + continue qs' + + onSlaveListChanged + :: QueueState a + -> SlaveListChanged + -> Process (ProcessAction (QueueState a)) + onSlaveListChanged qs (SlaveListChanged slaveSet) = + assignTasks (qs { slaves = slaves qs `Map.union` newSlaves `Map.intersection` newSlaves }) >>= continue + where + newSlaves = + Map.fromSet (const Nothing) slaveSet + + +slaveDiscovery :: Backend -> TaskQueue a -> Process () +slaveDiscovery backend queue = forever $ do + self <- getSelfNode + slaves <- Set.fromList . map processNodeId <$> findSlaves backend + --say $ show slaves + cast queue (SlaveListChanged (Set.delete self slaves)) + + +-- | Register as a slave node and request tasks from the master node. Blocks. +work :: Backend -> IO () +work = startSlave
+ src/FeedGipeda/Types.hs view
@@ -0,0 +1,83 @@+{-| The types for configuring @feedGipeda@. Correspond to the different modes + of operation that are possible, but in a type-safe way. +-} + +module FeedGipeda.Types where + + +import Data.Time (NominalDiffTime) + + +-- | Important file paths for the master node. +data Paths + = Paths + { configFile :: FilePath + -- ^ Lists the repositories to clone in YAML markup. See <https://github.com/sgraf812/feed-gipeda#config-file the README>. + , gipeda :: FilePath + -- ^ Path to the gipeda executable if not in @$PATH@. + } deriving (Show, Eq) + + +-- | An IP endpoint, or rather some string and some integer delimited by a colon. +data Endpoint + = Endpoint + { host :: String + , port :: Int + } deriving (Show, Eq) + + +-- | feed-gipeda can either check config file syntax or build the sites. +data Command + = Check + | Build BuildMode + deriving (Show, Eq) + + +-- | Whether feed-gipeda should exit when done regenerating +data BuildMode + = Once + {-^ Don't watch the config file or repositories for updates, exit immediately + when there are no more commits to benchmark. + -} + | WatchForChanges NominalDiffTime + -- ^ Don't exit; watch config file and repositories for updates. + deriving (Show, Eq) + + +-- | Signifies deployment to a location accessible via SSH. +data Deployment + = NoDeployment + | Deploy String + -- ^ A SSH/local directory where to @rsync@ website changes to. + deriving (Show, Eq) + + +-- | Whether the current feed-gipeda process is a master node, slave node, or both. +data ProcessRole + = Master Endpoint + | Slave Endpoint + | Both Endpoint Endpoint + deriving (Show, Eq) + + +masterEndpoint :: ProcessRole -> Maybe Endpoint +masterEndpoint (Master ep) = Just ep +masterEndpoint (Both ep _) = Just ep +masterEndpoint _ = Nothing + + +slaveEndpoint :: ProcessRole -> Maybe Endpoint +slaveEndpoint (Slave ep) = Just ep +slaveEndpoint (Both _ ep) = Just ep +slaveEndpoint _ = Nothing + + +isBoth :: ProcessRole -> Bool +isBoth (Both _ _) = True +isBoth _ = False + + +data Verbosity + = Verbose + | NotVerbose + deriving (Show, Eq)
+ tests/Acceptance.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE OverloadedStrings #-} + +module Acceptance + ( tests + ) where + + +import qualified Acceptance.Driver as Driver +import qualified Acceptance.Files as Files +import Control.Concurrent (ThreadId, forkIO, killThread, + myThreadId, threadDelay) +import Control.Concurrent.Async (link, race_, withAsync) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Exception (AsyncException, SomeException, + bracket, catch, handle, throwTo) +import Control.Monad (filterM, mfilter, unless, when, + (<=<)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Managed (Managed, managed, runManaged) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Conduit (Source, await, ($$), ($=), (=$)) +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CLc +import Data.Conduit.Process (StreamingProcessHandle, + waitForStreamingProcess) +import Data.Functor +import Data.List (isInfixOf, isSuffixOf) +import Data.Maybe (fromJust, fromMaybe, isJust) +import Data.Monoid (Any (..)) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Network.URI (parseURI) +import System.Directory (doesFileExist, findExecutable, + getDirectoryContents, makeAbsolute) +import System.Exit (ExitCode (..)) +import System.FilePath (takeDirectory, takeExtension, (</>)) +import qualified System.FSNotify as FS +import System.IO (hClose, hPutStrLn) +import System.IO.Temp (withSystemTempDirectory, + withSystemTempFile) +import Test.Tasty +import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, + assertFailure, testCase) + + +debugTests :: Bool +debugTests = True -- cringe + + +tests :: TestTree +tests = testGroup "Acceptance tests" + [ testCase "has feed-gipeda in $PATH" $ do + path <- findExecutable "feed-gipeda" + assertBool "feed-gipeda should exist" (isJust path) + , check + , oneShot + , daemon + , parallelization + ] + + +check :: TestTree +check = testGroup "check" + [ testCase "malformed file exits with error" $ runManaged $ do + (_, _, stderr, handle) <- + Files.withMalformedConfig >>= Driver.withCheckInTmpDir + exitCode <- waitForStreamingProcess handle + liftIO $ assertNotEqual "exited successfully" ExitSuccess exitCode + liftIO $ stderr $= CB.lines $$ do + line <- await + maybe (return ()) (liftIO . assertBool "no YAML error" . not . BS.isInfixOf "YAML") line + , testCase "well-formed file exits successfully" $ runManaged $ do + (_, stdout, stderr, handle) <- + Files.withWellFormedConfig >>= Driver.withCheckInTmpDir + assertNormalExit handle stdout stderr + ] + + +oneShot :: TestTree +oneShot = testGroup "one-shot mode" + [ testCase "watching a single repo produces site/ files" $ runManaged $ do + (path, stdout, stderr, handle) <- + Files.withWellFormedConfig >>= Driver.withOneShotInTmpDir Nothing + assertNormalExit handle stdout stderr + assertSiteFolderComplete (path </> "benchmark-test-6085726404018277061" </> "site") + , testCase "watching a single repo with deployment" $ runManaged $ do + deploymentDir <- managed (withSystemTempDirectory "feed-gipeda") + (path, stdout, stderr, handle) <- + Files.withWellFormedConfig >>= Driver.withOneShotInTmpDir (Just deploymentDir) + assertNormalExit handle stdout stderr + assertSiteFolderComplete (deploymentDir </> "sgraf812" </> "benchmark-test") + -- Test with multiple repos in config? There shouldn't be any new code paths. + ] + + +daemon :: TestTree +daemon = testGroup "daemon mode" + [ testCase "adding a repo to the config causes that repo to be added" $ runManaged $ do + (config, handle) <- managed (withSystemTempFile "feed-gipeda.yaml" . curry) + liftIO (hClose handle) + deploymentDir <- managed (withSystemTempDirectory "feed-gipeda") + (path, stdout, stderr, handle) <- + Driver.withDaemonInTmpDir (Just deploymentDir) 3600 config + assertReactsToChange handle stdout stderr deploymentDir + (BS.writeFile config Files.wellFormedConfig) + , testCase "adding commits to a repo under watch should trigger benchmarks" $ runManaged $ do + liftIO (threadDelay 10000000) -- terminateProcess doesn't release the TCP ports, so we have to wait for the OS to catch up + repo <- Files.withInitGitRepo + (config, h) <- managed (withSystemTempFile "feed-gipeda.yaml" . curry) + liftIO (hPutStrLn h "repositories:") + liftIO (hPutStrLn h ("- file://" ++ repo)) + liftIO (hClose h) + deploymentDir <- managed (withSystemTempDirectory "feed-gipeda") + (path, stdout, stderr, handle) <- + Driver.withDaemonInTmpDir (Just deploymentDir) 5 config + assertReactsToChange handle stdout stderr deploymentDir + (Files.makeCloneOf repo (fromJust $ parseURI "https://github.com/sgraf812/benchmark-test")) + ] + + +parallelization :: TestTree +parallelization = testGroup "parallelization" + [ testCase "does not benchmark in master mode" $ runManaged $ do + (path, stdout, stderr, handle) <- + Files.withWellFormedConfig >>= Driver.withMasterInTmpDir 12345 + withAssertNotExit handle + assertCsvFilesDontChangeWithin 100 path + , testCase "can distribute work on slave nodes" $ runManaged $ do + (path, stdout, stderr, handle) <- + Files.withWellFormedConfig >>= Driver.withMasterInTmpDir 12345 + withAssertNotExit handle + spawnSlave 12346 + spawnSlave 12347 + spawnSlave 12348 + spawnSlave 12349 + assertCsvFilesChangeWithin 100 path + ] + where + spawnSlave port = do + (_, _, h) <- Driver.withSlave port + withAssertNotExit h + + +assertReactsToChange + :: MonadIO io + => StreamingProcessHandle + -> Source IO ByteString + -> Source IO ByteString + -> String + -> IO () + -> io () +assertReactsToChange handle stdout stderr deploymentDir changeAction = liftIO $ runManaged $ do + withAssertNotExit handle + withAssertNoOutput stderr "stderr" + liftIO (threadDelay 5000000) -- ouch + liftIO changeAction + assertCsvFilesChangeWithin 100 deploymentDir + + +catchAsyncException :: IO () -> IO () +catchAsyncException = + handle handler + where + handler :: AsyncException -> IO () + handler e = return () + + +withAssertNotExit :: StreamingProcessHandle -> Managed () +withAssertNotExit handle = do + asy <- managed $ withAsync $ catchAsyncException $ do + waitForStreamingProcess handle + threadDelay 50 -- So that failures due to stdout/stderr have precedence + threadDelay 50 + assertFailure "must not exit" + liftIO $ link asy + + +withAssertNoOutput :: Source IO ByteString -> String -> Managed () +withAssertNoOutput content name = do + asy <- managed $ withAsync $ catchAsyncException $ content $= CB.lines $$ do + line <- await + case mfilter (not . BS.null) line of + Nothing -> return () + Just sth -> + liftIO $ assertFailure $ + "should not write any output to " ++ name ++ ". Got: " ++ Text.unpack (Text.decodeUtf8 sth) + liftIO $ link asy + + +assertNormalExit + :: StreamingProcessHandle + -> Source IO ByteString + -> Source IO ByteString + -> Managed () +assertNormalExit handle stdout stderr = do + withAssertNoOutput stdout "stdout" + withAssertNoOutput stderr "stderr" + liftIO $ do + exitCode <- waitForStreamingProcess handle + threadDelay 50 -- So that failures due to stdout/stderr have precedence + threadDelay 50 + assertEqual "should exit successfully" ExitSuccess exitCode + + +assertCsvFilesWithin :: MonadIO io => (Bool -> Bool) -> Int -> FilePath -> io () +assertCsvFilesWithin isOk seconds treeRoot = liftIO $ runManaged $ do + mgr <- managed FS.withManager + liftIO $ do + var <- newEmptyMVar + let matches fp = takeExtension fp == ".csv" && "results" `isSuffixOf` takeDirectory fp + FS.watchTree mgr treeRoot (matches . FS.eventPath) $ \path -> + putMVar var True + forkIO $ do + threadDelay (seconds * 1000000) + putMVar var False + result <- takeMVar var + unless (isOk result) (assertFailure ((if result then "" else "No ") ++ "CSV change within timeout")) + + +assertCsvFilesDontChangeWithin :: MonadIO io => Int -> FilePath -> io () +assertCsvFilesDontChangeWithin = + assertCsvFilesWithin not + + +assertCsvFilesChangeWithin :: MonadIO io => Int -> FilePath -> io () +assertCsvFilesChangeWithin = + assertCsvFilesWithin id + + +assertSiteFolderComplete :: MonadIO io => FilePath -> io () +assertSiteFolderComplete site = do + -- Benchmark results + csvs <- liftIO $ filesInDirWithExt ".csv" (site </> "out" </> "results") + assertNotEqual "should produce some result files" [] csvs + nonEmptyCsvs <- liftIO $ filterM (fmap (not . null) . readFile) csvs + assertNotEqual "should produce some non-empty result files" [] nonEmptyCsvs + + -- Gipeda files + jsons <- liftIO $ filesInDirWithExt ".json" (site </> "out" </> "graphs" </> "benchmarks" </> "fib") + assertNotEqual "should produce some json data through gipeda" [] (filter ((== ".json") . takeExtension) jsons) + + +filesInDirWithExt :: String -> FilePath -> IO [FilePath] +filesInDirWithExt ext dir = + map (dir </>) . filter ((== ext) . takeExtension) <$> getDirectoryContents dir + + + +assertNotEqual + :: (Eq a, Show a, MonadIO io) + => String -- ^ The message prefix + -> a -- ^ The expected value + -> a -- ^ The actual value + -> io () +assertNotEqual preface expected actual = + unless (actual /= expected) (liftIO (assertFailure msg)) + where + msg = + (if null preface then "" else preface ++ "\n") + ++ "expected not to get: " ++ show expected ++ "\n but got: " ++ show actual
+ tests/Acceptance/Driver.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE RecordWildCards #-} + +module Acceptance.Driver + ( Args (..) + , withCheckInTmpDir + , withOneShotInTmpDir + , withDaemonInTmpDir + , withMasterInTmpDir + , withSlave + ) where + + +import Control.Exception (bracket) +import Control.Monad (when) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Managed (Managed, managed) +import Control.Monad.Trans.Writer (Writer, execWriter, tell) +import Data.ByteString (ByteString) +import Data.Conduit (Source, ($=), (=$=)) +import qualified Data.Conduit.List as CL +import Data.Conduit.Process (ClosedStream (..), CreateProcess, + InputSource, OutputSink, + StreamingProcessHandle, + readCreateProcessWithExitCode, + streamingProcess, + streamingProcessHandleRaw, + terminateProcess, + waitForStreamingProcess) +import Data.Text (unpack) +import System.Exit (ExitCode) +import System.IO.Temp (withSystemTempDirectory) +import System.Process (cwd, proc, showCommandForUser) + + +data Args + = Args + { check :: Bool + , config :: FilePath + , deploymentDir :: Maybe FilePath + , watch :: Maybe Int + , masterPort :: Maybe Int + } deriving (Show, Eq) + + +defaultConfig :: FilePath -> Args +defaultConfig config = + Args False config Nothing Nothing Nothing + + +withCheckInTmpDir + :: FilePath + -> Managed (FilePath, Source IO ByteString, Source IO ByteString, StreamingProcessHandle) +withCheckInTmpDir config = + withExecuteInTmpDir (defaultConfig config) { check = True } + + +withOneShotInTmpDir + :: Maybe FilePath + -> FilePath + -> Managed (FilePath, Source IO ByteString, Source IO ByteString, StreamingProcessHandle) +withOneShotInTmpDir deploymentDir config = + withExecuteInTmpDir (defaultConfig config) + { deploymentDir = deploymentDir + } + + +withDaemonInTmpDir + :: Maybe FilePath + -> Int + -> FilePath + -> Managed (FilePath, Source IO ByteString, Source IO ByteString, StreamingProcessHandle) +withDaemonInTmpDir deploymentDir dt config = + withExecuteInTmpDir (defaultConfig config) + { deploymentDir = deploymentDir + , watch = Just dt + } + + +withMasterInTmpDir + :: Int + -> FilePath + -> Managed (FilePath, Source IO ByteString, Source IO ByteString, StreamingProcessHandle) +withMasterInTmpDir port config = + withExecuteInTmpDir (defaultConfig config) + { masterPort = Just port + } + + +withSlave :: Int -> Managed (Source IO ByteString, Source IO ByteString, StreamingProcessHandle) +withSlave port = + withProcess (proc "feed-gipeda" ["--slave", "localhost:" ++ show port]) + + +withProcess :: CreateProcess -> Managed (Source IO ByteString, Source IO ByteString, StreamingProcessHandle) +withProcess cp = do + (ClosedStream, stdout, stderr, handle) <- managed (bracket acquire release) + return (stdout, stderr, handle) + where + acquire = + streamingProcess cp + release (_, _, _, h) = + terminateProcess (streamingProcessHandleRaw h) + + +withExecuteInTmpDir + :: Args + -> Managed (FilePath, Source IO ByteString, Source IO ByteString, StreamingProcessHandle) +withExecuteInTmpDir Args{..} = do + let + whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () + whenJust val action = + maybe (return ()) action val + + args :: [String] + args = execWriter $ do + tell ["--config", config] + when check (tell ["--check"]) + whenJust deploymentDir $ \r -> tell ["--deploy-to", r] + whenJust watch $ \dt -> tell ["--watch", show dt] + whenJust masterPort $ \p -> tell ["--master", "localhost:" ++ show p] + return () + + path <- managed (withSystemTempDirectory "feed-gipeda") + (stdout, stderr, handle) <- withProcess (proc "feed-gipeda" args) { cwd = Just path } + return (path, stdout, stderr, handle)
+ tests/Acceptance/Files.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE TemplateHaskell #-} + +module Acceptance.Files + ( withWellFormedConfig + , withMalformedConfig + , wellFormedConfig + , withInitGitRepo + , makeCloneOf + ) where + + +import Control.Monad.Managed (Managed, liftIO, managed) +import Data.ByteString (ByteString, hPutStr) +import Data.FileEmbed (embedFile) +import Network.URI (URI, uriToString) +import System.IO (hClose) +import System.IO.Temp (withSystemTempDirectory, + withSystemTempFile) +import System.Process (proc, readCreateProcessWithExitCode) + +wellFormedConfig :: ByteString +wellFormedConfig = + $(embedFile "tests/Acceptance/Files/feed-gipeda.yaml") + + +malformedConfig :: ByteString +malformedConfig = + $(embedFile "tests/Acceptance/Files/malformed-feed-gipeda.yaml") + + +withTempFileFromByteString :: ByteString -> Managed FilePath +withTempFileFromByteString bytes = do + (path, handle) <- managed (withSystemTempFile "feed-gipeda.yaml" . curry) + liftIO (hPutStr handle bytes) + liftIO (hClose handle) + return path + + +withWellFormedConfig :: Managed FilePath +withWellFormedConfig = + withTempFileFromByteString wellFormedConfig + + +withMalformedConfig :: Managed FilePath +withMalformedConfig = + withTempFileFromByteString malformedConfig + + +withInitGitRepo :: Managed FilePath +withInitGitRepo = do + path <- managed (withSystemTempDirectory "feed-gipeda") + liftIO $ readCreateProcessWithExitCode (proc "git" ["-C", path, "init"]) "" + return path + + +makeCloneOf :: FilePath -> URI -> IO () +makeCloneOf path remote = do + readCreateProcessWithExitCode (proc "git" ["-C", path, "remote", "add", "origin", uriToString id remote ""]) "" + readCreateProcessWithExitCode (proc "git" ["-C", path, "pull", "origin", "master"]) "" + return ()
+ tests/test.hs view
@@ -0,0 +1,8 @@+import qualified Acceptance +import Test.Tasty + + +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [Acceptance.tests]