feed-gipeda 0.1.0.4 → 0.2.0.0
raw patch · 28 files changed
+2866/−2495 lines, 28 filesdep +SafeSemaphoredep +freedep ~loggingsetup-changed
Dependencies added: SafeSemaphore, free
Dependency ranges changed: logging
Files
- LICENSE +29/−29
- README.md +96/−96
- Setup.hs +2/−2
- app/Main.hs +122/−122
- feed-gipeda.cabal +137/−125
- src/FeedGipeda.hs +103/−107
- src/FeedGipeda/Assets.hs +22/−22
- src/FeedGipeda/Config.hs +77/−77
- src/FeedGipeda/Gipeda.hs +225/−210
- src/FeedGipeda/GitShell.hs +99/−99
- src/FeedGipeda/Master.hs +254/−254
- src/FeedGipeda/Master/CommitQueue.hs +150/−0
- src/FeedGipeda/Master/File.hs +89/−113
- src/FeedGipeda/Master/Finalize.hs +194/−193
- src/FeedGipeda/Master/RepoDiff.hs +29/−29
- src/FeedGipeda/Prelude.hs +38/−0
- src/FeedGipeda/Repo.hs +96/−96
- src/FeedGipeda/Slave.hs +119/−115
- src/FeedGipeda/THGenerated.hs +38/−38
- src/FeedGipeda/TaskQueue.hs +0/−227
- src/FeedGipeda/TaskScheduler.hs +238/−0
- src/FeedGipeda/Types.hs +87/−87
- tests/Acceptance.hs +264/−261
- tests/Acceptance/Driver.hs +125/−125
- tests/Acceptance/Files.hs +60/−60
- tests/Unit.hs +13/−0
- tests/Unit/CommitQueue.hs +151/−0
- tests/test.hs +9/−8
LICENSE view
@@ -1,30 +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 +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
@@ -1,96 +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` +# 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
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
app/Main.hs view
@@ -1,122 +1,122 @@-{-| 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.") - <*> option - (fromIntegral <$> auto) - (long "timeout" - <> metavar "SECONDS" - <> value (fromIntegral (30*60)) - <> help "Timeout for a benchmark run. A slave is canceled if it needs more than SECONDS seconds. Defaults to 30 minutes.") - - -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 +{-| 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.")+ <*> option+ (fromIntegral <$> auto)+ (long "timeout"+ <> metavar "SECONDS"+ <> value (fromIntegral (30*60))+ <> help "Timeout for a benchmark run. A slave is canceled if it needs more than SECONDS seconds. Defaults to 30 minutes.")+++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
feed-gipeda.cabal view
@@ -1,125 +1,137 @@-name: feed-gipeda -version: 0.1.0.4 -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: 2016 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 - , conduit - , conduit-extra >= 1.1.2 && < 1.2 - -- Concurrently - , async >= 2.0.1 && < 2.2 - -executable feed-gipeda - hs-source-dirs: app - main-is: Main.hs - default-language: Haskell2010 - ghc-options: -threaded - 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 +name: feed-gipeda+version: 0.2.0.0+synopsis: CI service around gipeda+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: 2016 Sebastian Graf+category: Benchmarking+build-type: Simple+cabal-version: >=1.10+tested-with: GHC == 7.8.4+ , GHC == 7.10.2+ , GHC == 7.10.3+extra-source-files: assets/default_index.html+ , README.md++library+ hs-source-dirs: src+ exposed-modules: FeedGipeda+ , FeedGipeda.GitShell+ , FeedGipeda.Assets+ , FeedGipeda.Repo+ , FeedGipeda.Master+ , FeedGipeda.Slave+ , FeedGipeda.Gipeda+ , FeedGipeda.Config+ , FeedGipeda.THGenerated+ , FeedGipeda.TaskScheduler+ , FeedGipeda.Types+ , FeedGipeda.Master.Finalize+ , FeedGipeda.Master.File+ , FeedGipeda.Master.RepoDiff+ , FeedGipeda.Master.CommitQueue+ , FeedGipeda.Prelude+ default-language: Haskell2010+ build-depends: base >= 4.6 && < 5+ , containers >= 0.5 && < 0.6+ , fsnotify >= 0.2 && < 0.3+ -- 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+ , conduit+ , conduit-extra >= 1.1.2 && < 1.2+ -- Concurrently+ , async >= 2.0.1 && < 2.2+ -- Any version with MSemN should do+ , SafeSemaphore++executable feed-gipeda+ hs-source-dirs: app+ main-is: Main.hs+ default-language: Haskell2010+ ghc-options: -threaded+ 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+ , Unit+ , Unit.CommitQueue+ build-depends: base >= 4.6 && < 5+ , tasty+ , tasty-quickcheck+ , tasty-smallcheck+ , tasty-hunit+ , tasty-hspec+ , HUnit+ , feed-gipeda+ , 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+ , free+ , logging++source-repository head+ type: git+ location: https://github.com/sgraf812/feed-gipeda.git
src/FeedGipeda.hs view
@@ -1,107 +1,103 @@-{-| 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 (fromMaybe, - 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 timeout -> 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 timeout) - liftIO (finalize result) - - let - onNewCommit :: (String -> IO ()) -> String -> Repo -> SHA -> IO () - onNewCommit finalize benchmarkScript repo commit = - writeChan tasks (finalize . fromMaybe "", benchmarkScript, repo, commit) - - liftIO (Master.checkForNewCommits paths deployment mode onNewCommit) +{-| 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 (fromMaybe,+ isJust)+import Data.Set (Set)+import Data.Time (NominalDiffTime)+import qualified FeedGipeda.Config as Config+import qualified FeedGipeda.Gipeda as Gipeda+import FeedGipeda.GitShell (SHA)+import qualified FeedGipeda.Master as Master+import qualified FeedGipeda.Master.CommitQueue as CommitQueue+import qualified FeedGipeda.Master.File as Master.File+import FeedGipeda.Prelude+import FeedGipeda.Repo (Repo)+import qualified FeedGipeda.TaskScheduler as TaskScheduler+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 timeout -> 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+ TaskScheduler.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+ queue <- CommitQueue.new+ runProcess node $ do+ let+ toTask :: (Repo, SHA) -> IO (TaskScheduler.Task String)+ toTask (repo, commit) = do+ script <- Gipeda.determineBenchmarkScript repo+ return (THGenerated.stringDict, THGenerated.benchmarkClosure script repo commit timeout, Master.File.writeBenchmarkCSV repo commit . fromMaybe "")++ TaskScheduler.start backend (CommitQueue.dequeue queue >>= toTask)+ liftIO (Master.checkForNewCommits paths deployment mode queue)
src/FeedGipeda/Assets.hs view
@@ -1,22 +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) +{-# 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
@@ -1,77 +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) +{-# 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
@@ -1,210 +1,225 @@-{-# 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" - <|> GitShell.showHead clone ".gipeda.yml" - <|> GitShell.showHead clone "gipeda.yaml" - <|> GitShell.showHead clone "gipeda.yml" - 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! +{-# 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 qualified Control.Logging as Logging+import Control.Monad (liftM2, when)+import Data.Aeson (withArray, withObject)+import Data.Either (either)+import Data.Functor+import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing)+import Data.String (fromString)+import qualified Data.Text as Text+import Data.Yaml (FromJSON (..), ToJSON (..), (.:), (.=))+import qualified Data.Yaml as Yaml+import FeedGipeda.GitShell (SHA)+import qualified FeedGipeda.GitShell as GitShell+import FeedGipeda.Prelude+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 :: Maybe 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.ya?ml@ file at the+ repository's @HEAD@ (if present) or from the project directory and fills+ in missing settings with defaults.+-}+settingsForRepo :: Repo -> IO GipedaSettings+settingsForRepo repo = do+ let a <?> b = liftM2 (<|>) a b+ clone <- Repo.cloneDir repo+ firstCommit <- GitShell.firstCommit clone+ gipedaYaml <-+ GitShell.showHead clone ".gipeda.yaml"+ <?> GitShell.showHead clone ".gipeda.yml"+ <?> GitShell.showHead clone "gipeda.yaml"+ <?> GitShell.showHead clone "gipeda.yml"+ <?> (Repo.settingsFile repo >>= readFileMaybe)++ let+ parsedValue :: Either String Yaml.Value+ parsedValue = do+ contents <- maybe (Left "Could not find a gipeda.yaml.") Right gipedaYaml+ either (Left . ("Could not parse the supplied gipeda.yaml:\n" ++)) Right $+ Yaml.decodeEither (fromString contents)++ 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+ <*> ((Just <$> obj .: "start") <|> pure firstCommit)+ <*> "interestingTags" ?? "*"+ <*> "interestingBranches" ?? "*"+ <*> "benchmarkScript" ?? "cloben"+ <*> "benchmarks" ?? []+ where key ?? def = obj .: key <|> pure def+ settings _ = settings (Yaml.object []) -- This should fill in some defaults nonetheless++ case parsedValue of+ Left err -> do+ logWarn err+ Yaml.parseMonad settings (Yaml.object [])+ Right value ->+ Yaml.parseMonad settings value
src/FeedGipeda/GitShell.hs view
@@ -1,99 +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)) +{-| 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
@@ -1,254 +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 +{-| 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+ ( checkForNewCommits+ ) where+++import Control.Applicative+import Control.Arrow (second)+import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.Async (mapConcurrently)+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 (foldM, forM_, forever, unless,+ 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, UTCTime)+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 FeedGipeda.Master.CommitQueue (CommitQueue)+import qualified FeedGipeda.Master.CommitQueue as CommitQueue+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.Prelude+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+++finalizeRepos+ :: Event+ -> Lock+ -> Paths+ -> Deployment+ -> Set Repo+ -> (UTCTime, Set Repo)+ -> Map Repo UTCTime+ -> IO (Map Repo UTCTime)+finalizeRepos notFinalizing lock paths deployment activeRepos (timestamp, repos) lastGenerated =+ foldM finalizeRepo lastGenerated (Set.toList repos)+ where+ finalizeRepo lastGenerated repo = Lock.with lock $+ case Map.lookup repo lastGenerated of+ Just lg | lg > timestamp -> return lastGenerated+ _ -> do+ Event.clear notFinalizing+ newLG <- Time.getCurrentTime+ -- TODO: parallelize the gipeda step+ Finalize.regenerateAndDeploy (gipeda paths) deployment activeRepos repo+ Event.set notFinalizing+ return (Map.insert repo newLG lastGenerated)+++readConfigFileRepos :: FS.Event -> IO (Maybe (Set Repo))+readConfigFileRepos (FS.Removed _ _) = return (Just Set.empty)+readConfigFileRepos evt =+ Config.decodeFile (FS.eventPath evt) >>= either+ (\err -> logWarn 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)+++updateCommitQueue :: Event -> CommitQueue -> Repo -> IO ()+updateCommitQueue notBenchmarking queue repo = do+ Event.clear notBenchmarking+ backlog <- File.readBacklog repo+ empty <- CommitQueue.updateRepoBacklog queue repo backlog+ when empty (Event.set notBenchmarking)+++fetchRepos :: Set Repo -> IO (UTCTime, Set Repo)+fetchRepos repos = do+ mapConcurrently fetch (Set.toList repos)+ timestamp <- Time.getCurrentTime -- 'last modified'+ return (timestamp, repos)+ where+ fetch repo = do+ logInfo ("Syncing " ++ Repo.shortName repo)+ GitShell.sync repo+++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 (UTCTime, Repo))+repoOfFileEvent cwd activeRepos fileEvents =+ Banana.filterJust <$> Banana.mapEventIO id timestampedRepos+ where+ timestampedRepos =+ reverseRoute <$> activeRepos <@> fileEvents+ reverseRoute repos evt =+ ((,) (FS.eventTime evt) <$>) <$> File.repoOfPath cwd repos (FS.eventPath evt)+++accumEM+ :: (Monad m, Banana.MonadMoment mom)+ => a+ -> Banana.Event (a -> m a)+ -> mom (Banana.Event (m a))+accumEM acc fs = Banana.accumE (return acc) ((=<<) <$> fs)+++{-| 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+ -> CommitQueue+ -> IO ()+checkForNewCommits paths deployment mode commitQueue = FS.withManager $ \mgr -> do+ cwd <- getCurrentDirectory+ notBenchmarking <- Event.new+ notFinalizing <- 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+ logDebug ("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+ logDebug ("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+ fetchedRepos <- Banana.mapEventIO fetchRepos (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 unite (t1, r1) (t2, r2) = (min t1 t2, Set.union r1 r2)+ let reposToFinish = Banana.unionWith unite fetchedRepos (second Set.singleton <$> benchmarkedRepos)+ finalizeLock <- liftIO Lock.new+ ios <- accumEM Map.empty (finalizeRepos notFinalizing finalizeLock paths deployment <$> activeReposB <@> reposToFinish)+ Banana.reactimate (void <$> ios)++ -- Source: Backlog changes+ backlogs <- watchTree cwd (File.isBacklog cwd)+ backlogRepos <- repoOfFileEvent cwd activeReposB backlogs++ -- Sink: Backlog changes are propagated to the commit queue, which should+ -- know how to handle them. Also we exit when the queue is empty,+ -- provided we are in --one-shot mode.+ Banana.reactimate (updateCommitQueue notBenchmarking commitQueue . snd <$> backlogRepos)++ network <- Banana.compile networkDescription+ Banana.actuate network+ Event.set start+ let detectIdle = do+ Event.wait notBenchmarking+ threadDelay (100*1000) -- wait 100 ms, sample again+ -- The next line might contain a race, but it's close enough+ exit <- (&&) <$> Event.isSet notBenchmarking <*> Event.isSet notFinalizing+ unless exit detectIdle+ case mode of+ Once -> detectIdle+ WatchForChanges _ -> Event.new >>= Event.wait -- block indefinitely
+ src/FeedGipeda/Master/CommitQueue.hs view
@@ -0,0 +1,150 @@+module FeedGipeda.Master.CommitQueue+ ( CommitQueue+ , new+ , dequeue+ , updateRepoBacklog+ ) where+++import Control.Applicative+import Control.Concurrent.Event (Event)+import qualified Control.Concurrent.Event as Event+import Control.Concurrent.MVar+import qualified Control.Logging as Logging+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.Text as Text+import qualified FeedGipeda.Gipeda as Gipeda+import FeedGipeda.GitShell (SHA)+import qualified FeedGipeda.Master.File as File+import FeedGipeda.Prelude+import FeedGipeda.Repo (Repo)+import qualified FeedGipeda.Repo as Repo+++data CommitQueue+ = CommitQueue (MVar State) Event+++data Backlog+ = Backlog+ { queue :: [SHA]+ , set :: Set SHA+ , blacklist :: Set SHA+ }+++data State+ = State+ { backlogs :: Map Repo Backlog+ , lastRepo :: Maybe Repo+ }+++new :: IO CommitQueue+new = do+ state <- newMVar (State Map.empty Nothing)+ stateChangedEvt <- Event.new+ return (CommitQueue state stateChangedEvt)+++{-| Selects the next (Repo, Commit) pair approx. based on round-robin.+ Skips blacklisted commits, e.g. those which already have been selected+ previously, but still appear in backlogs.+-}+nextCommitView :: State -> Maybe ((Repo, SHA), State)+nextCommitView s = go traversal+ where+ -- We traverse the backlogs map starting from lastRepo+ -- and wrapping around after that. This seems to be the most+ -- elegant way to do that.+ traversal :: [Map Repo Backlog]+ traversal =+ maybe [backlogs s] (\repo -> toList (swap (splitLE repo (backlogs s)))) (lastRepo s)++ splitLE :: Ord k => k -> Map k v -> (Map k v, Map k v)+ splitLE k = readd . Map.splitLookup k+ where+ readd (le, Nothing, gr) = (le, gr)+ readd (le, Just eq, gr) = (Map.insert k eq le, gr)++ toList :: (a, a) -> [a]+ toList (a, b) = [a, b]++ swap :: (a, b) -> (b, a)+ swap (a, b) = (b, a)++ go :: [Map Repo Backlog] -> Maybe ((Repo, SHA), State)+ go [] = Nothing+ go (m : ms) =+ case Map.minViewWithKey m of+ Nothing -> go ms+ Just ((repo, Backlog queue set blacklist), m') ->+ case filter (not . flip Set.member blacklist) queue of+ [] -> go (m' : ms)+ commit : _ -> Just ((repo, commit), newState)+ where+ newState = State+ { lastRepo = Just repo+ , backlogs = Map.insert repo newBacklog (backlogs s)+ }+ newBacklog = Backlog queue set (Set.insert commit blacklist)+++dequeue :: CommitQueue -> IO (Repo, SHA)+dequeue cq@(CommitQueue stateVar stateChanged) = do+ Event.wait stateChanged+ maybePair <- modifyMVar stateVar $ \state ->+ case nextCommitView state of+ Nothing -> Event.clear stateChanged >> return (state, Nothing)+ Just (pair, newState) -> return (newState, Just (pair, newState))+ case maybePair of+ Nothing -> dequeue cq+ Just ((repo, commit), newState) -> do+ logInfo (unlines ["Dequeue (" ++ Repo.shortName repo ++ ", " ++ take 7 commit ++ "). New state: ", showState newState])+ return (repo, commit)+++updateRepoBacklog :: CommitQueue -> Repo -> [SHA] -> IO Bool+updateRepoBacklog (CommitQueue stateVar stateChanged) repo backlog = do+ let backlogSet = Set.fromList backlog+ s <- backlogSet `seq` modifyMVar stateVar $ \s -> do+ let alterBacklog bl =+ if null backlog+ then Nothing+ else Just Backlog+ { queue = backlog+ , set = backlogSet+ , blacklist = Set.intersection backlogSet (maybe Set.empty blacklist bl)+ }+ newState = s { backlogs = Map.alter alterBacklog repo (backlogs s) }+ Event.set stateChanged+ return (newState, newState)+ logInfo (unlines ["Updated the commit queue. New state:", showState s])+ return (Map.null (backlogs s))+++showState :: State -> String+showState (State backlogs lastRepo) =+ unlines $+ [ "lastRepo: " ++ show (Repo.shortName <$> lastRepo)+ , "backlogs: "+ ] ++ if Map.null backlogs+ then ["empty!"]+ else Map.foldrWithKey mkEntry [] backlogs+ where+ mkEntry repo (Backlog queue set bl) rest =+ (" "+ ++ Repo.shortName repo ++ " -- "+ ++ "next: " ++ (show . safeHead . map (take 7) . filter (not . (`Set.member` bl))) queue+ ++ queueMsg queue ++ (show . map (take 7) . take 3) queue) : rest++ queueMsg queue =+ if length queue < 3+ then ", queue: "+ else ", first 3 in queue (" ++ show (length queue - 3) ++ " more): "++ safeHead [] = Nothing+ safeHead (x:xs) = Just x
src/FeedGipeda/Master/File.hs view
@@ -1,113 +1,89 @@--- | 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) +-- | Functions for file handling in the master node.++module FeedGipeda.Master.File+ ( writeBenchmarkCSV+ , isBenchmarkCSV+ , 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.Prelude+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,+ (<.>), (</>))+++readBacklog :: Repo -> IO [SHA]+readBacklog repo = do+ backlog <- Repo.backlogFile repo+ maybe [] lines <$> readFileMaybe backlog+++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 ["site", "out"] cwd path+ ]+++writeBenchmarkCSV :: Repo -> SHA -> String -> IO ()+writeBenchmarkCSV repo commit result = do+ cwd <- getCurrentDirectory+ resultsDir <- Repo.resultsDir repo+ createDirectoryIfMissing True resultsDir+ writeFile (resultsDir </> 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
@@ -1,193 +1,194 @@-{-| 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 () +{-| 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.Prelude+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 } ""+ logDebug (takeBaseName executable ++ ": " ++ show exitCode)+ case exitCode of+ ExitFailure _ -> logDebug stderr >> logDebug stdout+ _ -> return ()+ -- That's too much even for debug+ --logDebug "stdout:"+ --logDebug stdout+ --logDebug "stderr:"+ --logDebug 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+ logInfo ("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", "--keep-going", "--always-make"]+ rsyncSite repos repo deployment+ return ()+ else+ logInfo "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+ logInfo "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
@@ -1,29 +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) +-- | 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/Prelude.hs view
@@ -0,0 +1,38 @@+module FeedGipeda.Prelude+ ( logInfo+ , logDebug+ , logWarn+ , logError+ , readFileMaybe+ ) where+++import Control.Applicative+import qualified Control.Logging as Logging+import Control.Monad.IO.Class+import qualified Data.Text as Text+import System.Directory (doesFileExist)+++logInfo :: MonadIO io => String -> io ()+logInfo = liftIO . Logging.log . Text.pack+++logDebug :: MonadIO io => String -> io ()+logDebug = liftIO . Logging.debug . Text.pack+++logWarn :: MonadIO io => String -> io ()+logWarn = liftIO . Logging.warn . Text.pack+++logError :: String -> a+logError = Logging.errorL . Text.pack+++readFileMaybe :: MonadIO io => FilePath -> io (Maybe String)+readFileMaybe file = liftIO $ do+ exists <- doesFileExist file+ if exists+ then Just <$> readFile file+ else return Nothing
src/FeedGipeda/Repo.hs view
@@ -1,96 +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) +{-# 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 (</> "site" </> "out" </> "backlog.txt") (projectDir repo)
src/FeedGipeda/Slave.hs view
@@ -1,115 +1,119 @@-{-| @benchmark@ contains the logic to be executed on slave nodes. --} - - -module FeedGipeda.Slave - ( benchmark - ) where - - -import Control.Applicative -import Control.Concurrent.Async (Concurrently (..)) -import Control.Exception (bracket) -import Control.Logging as Logging -import Data.Conduit (($$)) -import qualified Data.Conduit.List as CL -import Data.Conduit.Process (ClosedStream (..), - CreateProcess (..), - interruptProcessGroupOf, proc, - readCreateProcessWithExitCode, shell, - showCommandForUser, streamingProcess, - streamingProcessHandleRaw, - waitForStreamingProcess) -import Data.Monoid -import qualified Data.Text as Text -import qualified Data.Text.Encoding as Text -import FeedGipeda.GitShell (SHA) -import FeedGipeda.Repo (Repo) -import qualified FeedGipeda.Repo as Repo -import FeedGipeda.Types (Timeout) -import System.Exit (ExitCode (..)) -import System.IO.Temp (withSystemTempDirectory) -import qualified System.Timeout - - --- We have to roll our own, because the provided functions use @terminateProcess@ --- instead of @interruptProcessGroupOf@, so that in case of shelling out we only --- kill the shell process but not its children. -readCreateProcessGroupWithExitCode :: CreateProcess -> IO (ExitCode, String, String) -readCreateProcessGroupWithExitCode cp = - bracket - (streamingProcess cp { create_group = True }) - cleanup - captureStreams - where - cleanup (_, _, _, sph) = - interruptProcessGroupOf (streamingProcessHandleRaw sph) - - captureStreams (ClosedStream, out, err, sph) = - runConcurrently $ (,,) - <$> Concurrently (waitForStreamingProcess sph) - <*> Concurrently (out $$ stringSink) - <*> Concurrently (err $$ stringSink) - - stringSink = - Text.unpack . Text.decodeUtf8 <$> CL.fold (<>) mempty - - -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) <- - readCreateProcessGroupWithExitCode (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 -> Timeout -> IO String -benchmark benchmarkScript repo commit timeout = do - clone <- Repo.cloneDir repo - Logging.log (Text.pack ("Benchmarking " ++ Repo.uri repo ++ "@" ++ commit)) - withSystemTempDirectory "feed-gipeda" $ \cloneDir -> do - cloneRecursiveAndCheckout repo commit cloneDir - res <- System.Timeout.timeout (ceiling (timeout * 10^6)) $ - shellReportingError repo commit (Just cloneDir) benchmarkScript - case res of - Just res -> return res - Nothing -> do - Logging.warn . Text.pack . unlines $ - [ "Benchmark script timed out (--timeout is " ++ show timeout ++ ")" - , "At commit " ++ Repo.uri repo ++ "@" ++ commit - ] - return "build/timeout;1.0" +{-| @benchmark@ contains the logic to be executed on slave nodes.+-}+++module FeedGipeda.Slave+ ( benchmark+ ) where+++import Control.Applicative+import Control.Concurrent.Async (Concurrently (..))+import Control.Exception (bracket)+import Control.Logging as Logging+import Data.Conduit (($$))+import qualified Data.Conduit.List as CL+import Data.Conduit.Process (ClosedStream (..),+ CreateProcess (..),+ interruptProcessGroupOf, proc,+ readCreateProcessWithExitCode, shell,+ showCommandForUser, streamingProcess,+ streamingProcessHandleRaw,+ waitForStreamingProcess)+import Data.Monoid+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import FeedGipeda.GitShell (SHA)+import FeedGipeda.Prelude+import FeedGipeda.Repo (Repo)+import qualified FeedGipeda.Repo as Repo+import FeedGipeda.Types (Timeout)+import System.Exit (ExitCode (..))+import System.IO.Temp (withSystemTempDirectory)+import qualified System.Timeout+++-- We have to roll our own, because the provided functions use @terminateProcess@+-- instead of @interruptProcessGroupOf@, so that in case of shelling out we only+-- kill the shell process but not its children.+readCreateProcessGroupWithExitCode :: CreateProcess -> IO (ExitCode, String, String)+readCreateProcessGroupWithExitCode cp =+ bracket+ (streamingProcess cp { create_group = True })+ cleanup+ captureStreams+ where+ cleanup (_, _, _, sph) =+ interruptProcessGroupOf (streamingProcessHandleRaw sph)++ captureStreams (ClosedStream, out, err, sph) =+ runConcurrently $ (,,)+ <$> Concurrently (waitForStreamingProcess sph)+ <*> Concurrently (out $$ stringSink)+ <*> Concurrently (err $$ stringSink)++ stringSink =+ Text.unpack . Text.decodeUtf8 <$> CL.fold (<>) mempty+++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) <-+ readCreateProcessGroupWithExitCode (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 ->+ logWarn . 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 -> Timeout -> IO String+benchmark benchmarkScript repo commit timeout = do+ clone <- Repo.cloneDir repo+ logInfo ("Benchmarking " ++ Repo.uri repo ++ "@" ++ commit)+ withSystemTempDirectory "feed-gipeda" $ \cloneDir -> do+ cloneRecursiveAndCheckout repo commit cloneDir+ res <- System.Timeout.timeout (ceiling (timeout * 10^6)) $+ shellReportingError repo commit (Just cloneDir) benchmarkScript+ case res of+ Just res -> do+ logInfo "Finished. Output:"+ mapM_ logInfo (lines res)+ return res+ Nothing -> do+ logWarn . unlines $+ [ "Benchmark script timed out (--timeout is " ++ show timeout ++ ")"+ , "At commit " ++ Repo.uri repo ++ "@" ++ commit+ ]+ return "build/timeout;1.0"
src/FeedGipeda/THGenerated.hs view
@@ -1,38 +1,38 @@-{-# 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 -import FeedGipeda.Types (Timeout) - - -benchmarkProcess :: (String, Repo, SHA, Rational) -> Process String -benchmarkProcess (benchmarkScript, repo, sha, timeout) = - liftIO (Slave.benchmark benchmarkScript repo sha (fromRational timeout)) -remotable ['benchmarkProcess] - - -benchmarkClosure :: String -> Repo -> SHA -> Timeout -> Closure (Process String) -benchmarkClosure benchmarkScript repo commit timeout = - $(mkClosure 'benchmarkProcess) (benchmarkScript, repo, commit, toRational timeout) - - -stringDict :: Static (SerializableDict String) -stringDict = - $(functionTDict 'benchmarkProcess) +{-# 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+import FeedGipeda.Types (Timeout)+++benchmarkProcess :: (String, Repo, SHA, Rational) -> Process String+benchmarkProcess (benchmarkScript, repo, sha, timeout) =+ liftIO (Slave.benchmark benchmarkScript repo sha (fromRational timeout))+remotable ['benchmarkProcess]+++benchmarkClosure :: String -> Repo -> SHA -> Timeout -> Closure (Process String)+benchmarkClosure benchmarkScript repo commit timeout =+ $(mkClosure 'benchmarkProcess) (benchmarkScript, repo, commit, toRational timeout)+++stringDict :: Static (SerializableDict String)+stringDict =+ $(functionTDict 'benchmarkProcess)
− src/FeedGipeda/TaskQueue.hs
@@ -1,227 +0,0 @@-{-# 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 (Maybe a), Task a) - , onHold :: Seq (CallRef (Maybe 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. - Tasks which don't finish within `timeout` return `Nothing`. --} -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 (Maybe 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 (Maybe 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 - 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 (Maybe a) - -> Task a - -> Process (ProcessReply (Maybe 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 (Just 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/TaskScheduler.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-| A task scheduler 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.TaskScheduler+ ( Task+ , start+ , work+ ) where+++import Control.Concurrent (threadDelay)+import Control.Concurrent.MSemN (MSemN)+import qualified Control.Concurrent.MSemN as MSemN+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.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)+++{-| A @Task@ contains all information to execute a process on a remote+ node and finalize the result with a continuation. It consists of:++ * A static pointer for the slave to find the entry point of task to execute++ * The state in which to execute the task++ * A continuation to call with the result of the (possibly timed out) task+-}+type Task a+ = (Static (SerializableDict a), Closure (Process a), Maybe a -> IO ())+++type RemoteCall 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 SchedulerState a+ = SchedulerState+ { slaves :: Map NodeId (Maybe MonitorRef)+ , active :: Map MonitorRef (NodeId, Async a, CallRef (Maybe a), RemoteCall a)+ , onHold :: Seq (CallRef (Maybe a), RemoteCall a)+ }+++initialSchedulerState :: SchedulerState a+initialSchedulerState =+ SchedulerState Map.empty Map.empty Seq.empty+++{-| Spawn the task queue on the local node and start to discover slave nodes.+ Tasks which don't finish within `timeout` return `Nothing`.++ The consumer tries to keep the task list short and `await`s new task items+ only when there are idle slaves. This way, upstream can react more timely+ to changes in task items priority (e.g. when a newer commit comes in or+ to interleave commits of a new repository).+-}+start+ :: forall a r . Serializable a+ => Backend+ -> IO (Task a)+ -> Process ()+start backend awaitTask = do+ idleSlaves <- liftIO (MSemN.new 0)+ q <- spawnLocal (queue idleSlaves)+ spawnLocal (slaveDiscovery backend q)+ spawnLocal (dispatch idleSlaves q)+ return ()+ where+ dispatch+ :: MSemN Int+ -> ProcessId+ -> Process ()+ dispatch idleSlaves queue = forever $ do+ liftIO (MSemN.wait idleSlaves 1)+ (dict, closure, cont) <- liftIO awaitTask+ spawnLocal $ do+ ret <- call queue (dict, closure)+ liftIO (cont ret)++ queue :: MSemN Int -> Process ()+ queue idleSlaves =+ serve () init (process idleSlaves)++ init :: InitHandler () (SchedulerState a)+ init () =+ return (InitOk initialSchedulerState Infinity)++ process :: MSemN Int -> ProcessDefinition (SchedulerState a)+ process idleSlaves = defaultProcess+ { apiHandlers =+ [ handleCast (onSlaveListChanged idleSlaves)+ , handleCallFrom onNewTask+ ]+ , infoHandlers =+ [ handleInfo (onTaskCompleted idleSlaves)+ ]+ , unhandledMessagePolicy = Log+ }++ assignTasks :: SchedulerState a -> Process (SchedulerState a)+ assignTasks qs@(SchedulerState slaves active onHold) =+ let+ idle :: Set NodeId+ idle =+ Map.keysSet (Map.filter isNothing slaves)++ assignment :: Maybe (NodeId, CallRef (Maybe a), RemoteCall a)+ assignment = do+ node <- fst <$> Set.minView idle+ (ref, task) <- case Seq.viewl onHold of+ EmptyL -> Nothing+ head :< _ -> Just head+ return (node, ref, task)+ in+ case assignment of+ Nothing -> return qs+ Just (node, callRef, (dict, closure)) -> do+ 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+ :: SchedulerState a+ -> CallRef (Maybe a)+ -> RemoteCall a+ -> Process (ProcessReply (Maybe a) (SchedulerState a))+ onNewTask qs ref call =+ assignTasks (qs { onHold = onHold qs |> (ref, call) }) >>= noReply_++ onTaskCompleted+ :: MSemN Int+ -> SchedulerState a+ -> ProcessMonitorNotification+ -> Process (ProcessAction (SchedulerState a))+ onTaskCompleted idleSlaves qs (ProcessMonitorNotification monitorRef _ _) =+ let+ withoutRef =+ Map.delete monitorRef (active qs)+ reenqueue callRef call =+ (callRef, call) <| onHold qs+ in+ case Map.lookup monitorRef (active qs) of+ Nothing -> continue qs { active = withoutRef }+ Just (node, handle, callRef, call) -> 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 (Just ret)+ liftIO (MSemN.signal idleSlaves 1)+ continue qs'+ AsyncPending -> fail "Waited for an async task, but still pending"+ _ -> do+ say (show node ++ " failed. Reassigning task.")+ -- (temporarily) blacklist the failing node+ liftIO (MSemN.signal idleSlaves (-1))+ qs' <- assignTasks qs+ { slaves = Map.delete node (slaves qs)+ , active = withoutRef+ , onHold = reenqueue callRef call+ }+ continue qs'++ onSlaveListChanged+ :: MSemN Int+ -> SchedulerState a+ -> SlaveListChanged+ -> Process (ProcessAction (SchedulerState a))+ onSlaveListChanged idleSlaves qs (SlaveListChanged slaveSet) = do+ liftIO (MSemN.signal idleSlaves delta)+ assignTasks (qs { slaves = slaves qs `Map.union` newSlaves `Map.intersection` newSlaves }) >>= continue+ where+ delta =+ Set.size slaveSet - Map.size (slaves qs)+ newSlaves =+ Map.fromSet (const Nothing) slaveSet++ slaveDiscovery :: Backend -> ProcessId -> 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
@@ -1,87 +1,87 @@-{-| 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) - - -type Timeout - = NominalDiffTime - - --- | feed-gipeda can either check config file syntax or build the sites. -data Command - = Check - | Build BuildMode Timeout - 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) +{-| 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)+++type Timeout+ = NominalDiffTime+++-- | feed-gipeda can either check config file syntax or build the sites.+data Command+ = Check+ | Build BuildMode Timeout+ 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
@@ -1,261 +1,264 @@-{-# 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 +{-# 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+++waitSeconds :: Int+waitSeconds = 40+++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 </> "feed-gipeda-test-11018374512395291872" </> "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" </> "feed-gipeda-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/feed-gipeda-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 waitSeconds 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 waitSeconds 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 waitSeconds 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" </> "stub")+ 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
@@ -1,125 +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) +{-# 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
@@ -1,60 +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 () +{-# 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/Unit.hs view
@@ -0,0 +1,13 @@+module Unit+ ( tests+ ) where+++import Test.Tasty+import qualified Unit.CommitQueue+++tests :: TestTree+tests = testGroup "Unit tests"+ [ Unit.CommitQueue.tests+ ]
+ tests/Unit/CommitQueue.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}++module Unit.CommitQueue+ ( tests+ ) where+++import Control.Concurrent (forkIO, threadDelay)+import qualified Control.Logging as Logging+import Control.Monad.Free+import Control.Monad.IO.Class+import FeedGipeda.GitShell (SHA)+import FeedGipeda.Master.CommitQueue (CommitQueue)+import qualified FeedGipeda.Master.CommitQueue as CommitQueue+import FeedGipeda.Repo (Repo (..))+import qualified FeedGipeda.Repo as Repo+import System.Timeout (timeout)+import Test.Tasty+import Test.Tasty.HUnit+++data QueueF a+ = Update Repo [SHA] (Bool -> a)+ | TryDequeue (Maybe (Repo, SHA) -> a)+ | forall r. EmbedIO (IO r) (r -> a)+++instance Functor QueueF where+ fmap f (Update repo commits g) = Update repo commits (f . g)+ fmap f (TryDequeue g) = TryDequeue (f . g)+ fmap f (EmbedIO action g) = EmbedIO action (f . g)+++type Queue+ = Free QueueF+++instance MonadIO (Free QueueF) where+ liftIO action = liftF (EmbedIO action id)+++update :: Repo -> [SHA] -> Queue Bool+update repo commits = liftF (Update repo commits id)+++tryDequeue :: Queue (Maybe (Repo, SHA))+tryDequeue = liftF (TryDequeue id)+++timeoutDelay :: Int+timeoutDelay = 1000 -- 1 ms+++runQueue :: CommitQueue -> Queue r -> IO r+runQueue queue = iterM run+ where+ run (Update repo commits k) = CommitQueue.updateRepoBacklog queue repo commits >>= k+ run (TryDequeue k) = timeout timeoutDelay (CommitQueue.dequeue queue) >>= k+ run (EmbedIO action k) = action >>= k+++runEmptyQueue :: (CommitQueue -> Queue r) -> IO r+runEmptyQueue st = Logging.withStdoutLogging $ do+ Logging.setLogLevel Logging.LevelError+ q <- CommitQueue.new+ runQueue q (st q)+++pipes, conduit, servant :: Repo+pipes = Repo.unsafeFromString "https://github.com/Gabriel439/Haskell-Pipes-Library"+conduit = Repo.unsafeFromString "https://github.com/snoyberg/conduit"+servant = Repo.unsafeFromString "https://github.com/haskell-servant/servant"+++assertJust :: String -> Maybe a -> IO a+assertJust _ (Just a) = return a+assertJust msg _ = assertFailure msg >> error "Should never hit this"+++assertNothing :: String -> Maybe a -> IO ()+assertNothing _ Nothing = return ()+assertNothing msg _ = assertFailure msg+++assertDequeuedCommitFromRepo :: Repo -> SHA -> Queue ()+assertDequeuedCommitFromRepo repo commit = do+ (actualRepo, actualCommit) <- tryDequeue >>= liftIO . assertJust "dequeue should not time out"+ liftIO $ assertEqual "dequeued from wrong repo" repo actualRepo+ liftIO $ assertEqual "dequeued wrong commit" commit actualCommit+++updateNonEmpty :: Repo -> [SHA] -> Queue ()+updateNonEmpty repo commits =+ update repo commits >>= liftIO . assertBool "queue was empty" . not+++updateEmpty :: Repo -> Queue ()+updateEmpty repo =+ update repo [] >>= liftIO . assertBool "queue was not empty"+++tests :: TestTree+tests = testGroup "CommitQueue"+ [ testGroup "single repo"+ [ testCase "update then dequeue and empty queue" $ runEmptyQueue $ \_ -> do+ updateNonEmpty pipes ["1", "3", "2"]+ assertDequeuedCommitFromRepo pipes "1"+ assertDequeuedCommitFromRepo pipes "3"+ assertDequeuedCommitFromRepo pipes "2"+ tryDequeue >>= liftIO . assertNothing "empty queue should lead to blocking"+ -- Even if we there aren't any more items to dequeue, the queue might not+ -- not be empty, since items are just blacklisted, meaning they are executing+ -- right now. We have to clear all items for that repo to effectively have+ -- an empty CommitQueue.+ updateEmpty pipes+ , testCase "concurrent update leads to unblocking of the dequeuer" $ runEmptyQueue $ \q -> do+ liftIO . forkIO . runQueue q $ updateNonEmpty pipes ["1"]+ assertDequeuedCommitFromRepo pipes "1"+ ]+ , testGroup "multiple repos"+ [ testCase "fairness" $ runEmptyQueue $ \_ -> do+ updateNonEmpty pipes ["1", "2"]+ assertDequeuedCommitFromRepo pipes "1"+ updateNonEmpty conduit ["4", "3"]+ -- we point now to what comes after pipes entry, so we wrap around+ assertDequeuedCommitFromRepo conduit "4"+ updateNonEmpty servant ["7", "5", "6"]+ -- lastRepo was conduit, so we continue with pipes+ assertDequeuedCommitFromRepo pipes "2"+ updateNonEmpty pipes ["8", "9"]+ -- pipes -> servant+ assertDequeuedCommitFromRepo servant "7"+ -- servant -> conduit+ assertDequeuedCommitFromRepo conduit "3"+ -- conduit -> pipes+ assertDequeuedCommitFromRepo pipes "8"+ -- pipes -> servant+ assertDequeuedCommitFromRepo servant "5"+ -- servant -> conduit, which is depleted, so -> pipes+ assertDequeuedCommitFromRepo pipes "9"+ -- pipes -> servant+ assertDequeuedCommitFromRepo servant "6"+ -- that should be all, see if dequeue blocks+ tryDequeue >>= liftIO . assertNothing "empty queue should lead to blocking"+ -- now tear down the queue+ updateNonEmpty conduit []+ updateNonEmpty pipes []+ updateEmpty servant+ ]+ ]
tests/test.hs view
@@ -1,8 +1,9 @@-import qualified Acceptance -import Test.Tasty - - -main = defaultMain tests - -tests :: TestTree -tests = testGroup "Tests" [Acceptance.tests] +import qualified Acceptance+import Test.Tasty+import qualified Unit+++main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [Acceptance.tests, Unit.tests]