├── .ghci ├── .gitignore ├── .hlint.yaml ├── .travis.yml ├── CHANGES.txt ├── LICENSE ├── README.md ├── Setup.hs ├── bake.cabal ├── docs ├── Algebra.md └── Notes.md ├── html └── favicon.ico ├── screenshot-part.png ├── screenshot.png ├── shell.nix ├── src ├── Development │ ├── Bake.hs │ └── Bake │ │ ├── Build.hs │ │ ├── Core │ │ ├── Args.hs │ │ ├── Client.hs │ │ ├── GC.hs │ │ ├── Message.hs │ │ ├── Run.hs │ │ ├── Send.hs │ │ └── Type.hs │ │ ├── Email.hs │ │ ├── Git.hs │ │ ├── Pretty.hs │ │ ├── Server │ │ ├── Brain.hs │ │ ├── Database.hs │ │ ├── Memory.hs │ │ ├── Property.hs │ │ ├── Start.hs │ │ ├── Stats.hs │ │ ├── Store.hs │ │ └── Web.hs │ │ ├── StepGit.hs │ │ └── Test │ │ └── Simulate.hs ├── Example.hs ├── General │ ├── BigString.hs │ ├── Database.hs │ ├── Equal.hs │ ├── Extra.hs │ ├── HTML.hs │ ├── Index.hs │ ├── Lens.hs │ ├── MRU.hs │ └── Web.hs ├── Paths.hs └── Test.hs ├── stack.yaml ├── test ├── Bake │ └── Test │ │ └── GCSpec.hs ├── bake-test.hs └── test-gc │ ├── bake-extra-467723236138728164 │ └── .bake.name │ ├── bake-extra-7086488451789726956 │ └── .bake.name │ ├── bake-extra-8242524289800929962 │ └── .bake.name │ ├── bake-git-5401199084002705030 │ └── .bake.name │ ├── bake-incremental.txt │ ├── bake-init │ └── .bake.name │ ├── bake-store │ └── .bake.name │ ├── bake-test-467723236138728164 │ └── .bake.name │ ├── bake-test-657771599651844319.gc │ └── .bake.name │ ├── bake-test-657771599651844319 │ └── .bake.name │ ├── bake-test-7086488451789726956 │ └── .bake.name │ └── bake-update-467723236138728164 │ └── .bake.name └── travis.hs /.ghci: -------------------------------------------------------------------------------- 1 | :set -W -fno-warn-unused-matches 2 | :set -isrc 3 | :load Test src/Paths 4 | 5 | :def docs_ const $ return $ unlines [":!cabal haddock"] 6 | :def docs const $ return $ unlines [":docs_",":!start dist\\doc\\html\\bake\\Development-Bake.html"] 7 | 8 | :{ 9 | :def test \s -> return $ unlines 10 | [":!ghc --make -o .test/bake-test -outputdir .test -isrc Test src/Paths -main-is Test.main -threaded -with-rtsopts=-T" 11 | ,":!.test\\bake-test " ++ s 12 | ] 13 | :} 14 | 15 | :{ 16 | :def prof \_ -> return $ unlines 17 | [":!ghc --make -o .test/prof/bake-test -outputdir .test/prof -isrc Test src/Paths -main-is Test.main -prof -auto-all -caf-all -rtsopts -DPROFILE" 18 | ,":!.test\\prof\\bake-test +RTS -p" 19 | ] 20 | :} 21 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | /.test/ 3 | /.bake-test/ 4 | *.prof 5 | /.stack-work/ 6 | *~ 7 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | ########################## 4 | 5 | # This file contains a template configuration file, which is typically 6 | # placed as .hlint.yaml in the root of your project 7 | 8 | 9 | # Warnings currently triggered by your code 10 | - ignore: {name: "Use module export list"} 11 | - ignore: {name: "Missing NOINLINE pragma"} 12 | - ignore: {name: "Use unless"} 13 | - ignore: {name: "Redundant $"} 14 | - ignore: {name: "Reduce duplication"} 15 | - ignore: {name: "Redundant do"} 16 | - ignore: {name: "Unused LANGUAGE pragma"} 17 | - ignore: {name: "Use <$>"} 18 | - ignore: {name: "Use map once"} 19 | - ignore: {name: "Evaluate"} 20 | - ignore: {name: "Use isNothing"} 21 | - ignore: {name: "Use const"} 22 | - ignore: {name: "Use null"} 23 | - ignore: {name: "Avoid lambda"} 24 | - ignore: {name: "Eta reduce"} 25 | - ignore: {name: "Use fmap"} 26 | - ignore: {name: "Redundant bracket"} 27 | - ignore: {name: "Use isAsciiUpper"} 28 | - ignore: {name: "Use isAsciiLower"} 29 | - ignore: {name: "Use isDigit"} 30 | - ignore: {name: "Use newtype instead of data"} 31 | 32 | 33 | # Specify additional command line arguments 34 | # 35 | # - arguments: [--color, --cpp-simple, -XQuasiQuotes] 36 | 37 | 38 | # Control which extensions/flags/modules/functions can be used 39 | # 40 | # - extensions: 41 | # - default: false # all extension are banned by default 42 | # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used 43 | # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module 44 | # 45 | # - flags: 46 | # - {name: -w, within: []} # -w is allowed nowhere 47 | # 48 | # - modules: 49 | # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' 50 | # - {name: Control.Arrow, within: []} # Certain modules are banned entirely 51 | # 52 | # - functions: 53 | # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules 54 | 55 | 56 | # Add custom hints for this project 57 | # 58 | # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" 59 | # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} 60 | 61 | 62 | # Turn on hints that are off by default 63 | # 64 | # Ban "module X(module X) where", to require a real export list 65 | # - warn: {name: Use explicit module export list} 66 | # 67 | # Replace a $ b $ c with a . b $ c 68 | # - group: {name: dollar, enabled: true} 69 | # 70 | # Generalise map to fmap, ++ to <> 71 | # - group: {name: generalise, enabled: true} 72 | 73 | 74 | # Ignore some builtin hints 75 | # - ignore: {name: Use let} 76 | # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules 77 | 78 | 79 | # Define some custom infix operators 80 | # - fixity: infixr 3 ~^#^~ 81 | 82 | 83 | # To generate a suitable file for HLint do: 84 | # $ hlint --default > .hlint.yaml 85 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | sudo: required 2 | env: 3 | - GHCVER=7.6.3 4 | - GHCVER=7.8.4 5 | - GHCVER=7.10.3 6 | - GHCVER=8.0.2 7 | - GHCVER=head 8 | 9 | script: 10 | - curl -sL https://raw.github.com/ndmitchell/neil/master/travis.sh | sh 11 | -------------------------------------------------------------------------------- /CHANGES.txt: -------------------------------------------------------------------------------- 1 | Changelog for Bake 2 | 3 | 0.5 4 | Allow extra-1.5.1 5 | #19, support much bigger files 6 | 0.4 7 | Remove the --author parameter from many operations 8 | Rewrite notifications 9 | 0.3 10 | Add persistence to an SQLite db 11 | Add ping expiration 12 | Start testing as soon as you are launched 13 | 0.2 14 | Require extra-0.3 15 | Lots of work on lots of things 16 | #1, add incremental building 17 | #1, mirror the Git repo 18 | Require a name for the client 19 | Sort out which directory things are run from 20 | Change to a separate --host and --port flag 21 | 0.1 22 | Works to some level 23 | 0.0 24 | Initial version, not ready for public use 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Neil Mitchell 2014-2017. 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Neil Mitchell nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | 32 | The icon in resources/ is the "Microwave" icon by "FatCow" 33 | http://www.softicons.com/toolbar-icons/fatcow-hosting-extra-icons-2-by-fatcow/microwave-icon 34 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # WARNING: UNMAINTAINED PROJECT 2 | 3 | **This project is not actively developed - you are likely to be better of using something more complete (if you do want to use it, consider forking it and taking it over). See [the blog post](https://neilmitchell.blogspot.co.uk/2018/05/the-end-of-bake.html) giving notes on why it is now unmaintained.** 4 | 5 | Bake is a continuous integration server, designed for large, productive, semi-trusted teams. In particular it primarily targets: 6 | 7 | * _Large teams_ where there are at least several contributors working full-time on a single code base. 8 | * _Productive teams_ which are regularly pushing code, many times a day. 9 | * _Semi-trusted teams_ where code does not go through manual code review, but code does need to pass a test suite and perhaps some static analysis. People are assumed to be fallible. 10 | 11 | To give a flavour, the web GUI looks of a running Bake system looks like: 12 | 13 | ![](https://raw.githubusercontent.com/ndmitchell/bake/master/screenshot-part.png) 14 | 15 | _Acknowledgements:_ The name "Bake" is thanks to Andy Adams-Moran. 16 | 17 | 18 | ## The Design 19 | 20 | Bake is a Haskell library that can be used to put together a continuous integration server. To run Bake you start a single server for your project, which coordinates tasks, provides an HTTP API for submitting new patches, and a web-based GUI for viewing the progress of your patches. You also run some Bake clients which run the tests on behalf of the server. While Bake is written in Haskell, most of the tests are expected to just call some system command. 21 | 22 | There are a few aspects that make Bake different from most alternatives: 23 | 24 | * Patches are submitted to Bake, but are not applied to the main repo until they have passed all their tests. There is no way for someone to "break the build" - at all points the repo will build on all platforms and all tests will pass. 25 | * Bake scales up so that even if you have 5 hours of testing and 50 commits a day it will not require 250 hours of computation per day. In order for Bake to prove that a set of patches pass a test, it does not have to test each patch individually. 26 | * Bake allows multiple clients to run tests, even if some tests are only able to be run on some clients, allowing both parallelisation and specialisation (testing both Windows and Linux, for example). 27 | * Bake can detect that tests are no longer valid, for example because they access a server that is no longer running, and report the issue without blaming the submitted patches. 28 | 29 | ## The Workflow 30 | 31 | Bake is highly parametrisable, and can be reconfigured to support several different styles of use, but here I give one plausible workflow. Imagine a number of developers, somewhere between 5 and 50. Each developer has 1 or 2 active branches they are working on. You have a master branch, which developers merge from once a day. When a developer has completed something they push their branch to the Git repo and register the SHA1 with Bake. Bake then tests the patch on all tests (in conjunction with all other patches that got promoted) and if it passes merges it into the master branch. Once a day (say 7pm) you pause the incoming patches, ensure the queue has emptied, then resume. 32 | 33 | 34 | ## An Example 35 | 36 | The test suite provides both [an example configuration](https://github.com/ndmitchell/bake/blob/master/src/Example.hs) and [commands to drive it](https://github.com/ndmitchell/bake/blob/master/src/Test.hs). Here we annotate a slightly simplified version of the example, for lists of imports see the original code. 37 | 38 | First we define an enumeration for where we want tests to run. Our server is going to require tests on both Windows and Linux before a `patch` is accepted. 39 | ```haskell 40 | data Platform = Linux | Windows deriving (Show,Read) 41 | platforms = [Linux,Windows] 42 | ``` 43 | Next we define the `test` type. A `test` is something that must pass before a `patch` is accepted. 44 | ```haskell 45 | data Action = Compile | Run Int deriving (Show,Read) 46 | ``` 47 | Our type is named `Action`. We have two distinct types of tests, compiling the code, and running the result with a particular argument. Now we need to supply some information about the tests: 48 | ```haskell 49 | allTests = [(p,t) | p <- platforms, t <- Compile : map Run [1,10,0]] 50 | 51 | execute :: (Platform,Action) -> TestInfo (Platform,Action) 52 | execute (p,Compile) = matchOS p $ run $ do 53 | cmd "ghc --make Main.hs" 54 | execute (p,Run i) = require [(p,Compile)] $ matchOS p $ run $ do 55 | cmd ("." "Main") (show i) 56 | ``` 57 | We have to declare `allTests`, then list of all tests that must pass, and `execute`, which gives information about a test. Note that the `test` type is `(Platform,Action)`, so a test is a platform (where to run the test) and an `Action` (what to run). The `run` function gives an `IO` action to run, and `require` specifies dependencies. We use an auxiliary `matchOS` to detect whether a test is running on the right platform: 58 | ```haskell 59 | #if WINDOWS 60 | myPlatform = Windows 61 | #else 62 | myPlatform = Linux 63 | #endif 64 | 65 | matchOS :: Platform -> TestInfo t -> TestInfo t 66 | matchOS p = suitable (return . (==) myPlatform) 67 | ``` 68 | We use the `suitable` function to declare whether a test can run on a particular client. Finally, we define the `main` function: 69 | ```haskell 70 | main :: IO () 71 | main = bake $ 72 | ovenGit "http://example.com/myrepo.git" "master" $ 73 | ovenTest readShowStringy (return allTests) execute 74 | defaultOven{ovenServer=("127.0.0.1",5000)} 75 | ``` 76 | We define `main = bake`, then fill in some configuration. We first declare we are working with Git, and give a repo name and branch name. Next we declare what the tests are, passing the information about the tests. Finally we give a host/port for the server, which we can visit in a web browser or access via the HTTP API. 77 | 78 | 79 | ## Using the Example 80 | 81 | Now we have defined the example, we need to start up some servers and clients using the command line for our tool. Assuming we compiled as `bake`, we can write `bake server` and `bake client` (we'll need to launch at least one client per OS). We can view the state by visiting `http://127.0.0.1:5000` in a web browser. 82 | 83 | To add a patch we can run `bake addpatch --name=d088cc3c677a867185f083aca200cb421c27b984`, using the SHA1 of the commit, which will try and integrate that patch into the `master` branch, after all the tests have passed. Alternatively, we can run `bake addpatch --name=$(git rev-parse HEAD)` to try and integrate our working tree into `master`. 84 | 85 | When viewing the server, there are a few additional URL's that may be of use: 86 | 87 | * `?stats=` will show stats about which tests take longest, how long a test run takes, which test fails most often. 88 | * `?raw=` will give internal details of the implementation. 89 | * `/dump` will download an SQLite database containing all of the persistent state. 90 | * `?admin=` will give you an admin control panel on any page, letting you retry/delete patches and skip tests. If you want to restrict access to this panel, run `bake admin myPassword` which says that running `bake server --admin=3A18885C` will then require `?admin=myPassword`. 91 | 92 | ## More Examples 93 | 94 | You can find more examples at: 95 | 96 | * [Haskell Bake and Kubernetes](http://brian.uncannyworks.com/posts/2016-12-09-haskell-bake-and-kubernetes.html). 97 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bake.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: >= 1.18 2 | build-type: Simple 3 | name: bake 4 | version: 0.5 5 | license: BSD3 6 | license-file: LICENSE 7 | category: Development 8 | author: Neil Mitchell 9 | maintainer: Neil Mitchell 10 | copyright: Neil Mitchell 2014-2017 11 | synopsis: Continuous integration system 12 | description: 13 | Bake is a continuous integration server, designed for large, productive, semi-trusted teams. 14 | . 15 | * /Large teams/ where there are at least several contributors working full-time on a single code base. 16 | . 17 | * /Productive teams/ which are regularly pushing code, many times a day. 18 | . 19 | * /Semi-trusted teams/ where code does not go through manual code review, but code does need to pass a test suite and perhaps some static analysis. People are assumed not to be malicious, but are fallible. 20 | homepage: https://github.com/ndmitchell/bake#readme 21 | bug-reports: https://github.com/ndmitchell/bake/issues 22 | tested-with: GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 23 | 24 | extra-doc-files: 25 | CHANGES.txt 26 | README.md 27 | 28 | data-files: 29 | html/favicon.ico 30 | 31 | source-repository head 32 | type: git 33 | location: https://github.com/ndmitchell/bake.git 34 | 35 | library 36 | default-language: Haskell2010 37 | hs-source-dirs: src 38 | build-depends: 39 | base == 4.*, 40 | cmdargs >= 0.10, 41 | shake >= 0.15, 42 | directory, 43 | bytestring, 44 | containers, 45 | text, 46 | time, 47 | random, 48 | hashable, 49 | transformers >= 0.4, 50 | HTTP, 51 | safe, 52 | old-locale, 53 | http-conduit, 54 | http-client, 55 | http-types, 56 | wai-extra, 57 | deepseq, 58 | filepath, 59 | aeson, 60 | sqlite-simple, 61 | direct-sqlite, 62 | disk-free-space, 63 | unordered-containers, 64 | smtp-mail, 65 | extra >= 1.5.1, 66 | wai >= 3.0.1, 67 | warp >= 3.0 68 | 69 | exposed-modules: 70 | Development.Bake 71 | 72 | other-modules: 73 | Development.Bake.Build 74 | Development.Bake.Core.Args 75 | Development.Bake.Core.Client 76 | Development.Bake.Core.GC 77 | Development.Bake.Core.Message 78 | Development.Bake.Core.Run 79 | Development.Bake.Core.Send 80 | Development.Bake.Core.Type 81 | Development.Bake.Email 82 | Development.Bake.Git 83 | Development.Bake.StepGit 84 | Development.Bake.Pretty 85 | Development.Bake.Server.Brain 86 | Development.Bake.Server.Database 87 | Development.Bake.Server.Memory 88 | Development.Bake.Server.Property 89 | Development.Bake.Server.Start 90 | Development.Bake.Server.Stats 91 | Development.Bake.Server.Store 92 | Development.Bake.Server.Web 93 | General.BigString 94 | General.Database 95 | General.Extra 96 | General.HTML 97 | General.Web 98 | Paths_bake 99 | 100 | -- don't use 'cabal test' since that loses the child stdout 101 | executable bake-test 102 | default-language: Haskell2010 103 | hs-source-dirs: src 104 | main-is: Test.hs 105 | other-modules: 106 | Example 107 | Development.Bake.Test.Simulate 108 | ghc-options: -threaded -main-is Test.main 109 | build-depends: 110 | base == 4.*, 111 | cmdargs >= 0.10, 112 | shake >= 0.15, 113 | directory, 114 | bytestring, 115 | containers, 116 | text, 117 | old-locale, 118 | time, 119 | random, 120 | hashable, 121 | HTTP, 122 | safe, 123 | http-client, 124 | http-conduit, 125 | http-types, 126 | wai-extra, 127 | transformers, 128 | deepseq, 129 | aeson, 130 | smtp-mail, 131 | disk-free-space, 132 | unordered-containers, 133 | sqlite-simple, 134 | direct-sqlite, 135 | extra >= 0.2, 136 | wai >= 3.0.1, 137 | warp >= 3.0, 138 | process, 139 | filepath 140 | 141 | test-suite test 142 | default-language: 143 | Haskell2010 144 | type: 145 | exitcode-stdio-1.0 146 | hs-source-dirs: 147 | test 148 | main-is: 149 | bake-test.hs 150 | build-depends: 151 | base >= 4 && < 5 152 | , tasty >= 0.7 153 | , tasty-hspec 154 | , bake 155 | , extra 156 | , filepath 157 | , directory 158 | , containers 159 | -------------------------------------------------------------------------------- /docs/Algebra.md: -------------------------------------------------------------------------------- 1 | # Algebra of Bake 2 | 3 | This document outlines the algebra behind Bake, and it means for a patch to be accepted, and how to pick what should be done next. 4 | 5 | ## Types 6 | ```haskell 7 | data Patch 8 | type State = [Patch] 9 | ``` 10 | The fundamental types in Bake are the `Patch` (think of a diff) and a `State` (the state of the repo). A `State` is just a sequence of `Patch` values, in order. As might be expected, we use `p` and `s` to denote values drawn from the sensible domains for each type. 11 | ```haskell 12 | data Test 13 | tests :: Set Test 14 | ``` 15 | We define a `Test` (a single test case), and a set of `tests` which must pass. We assume values named `t` are drawn from `tests`. For the moment, we ignore the fact that different `State`s may induce different `Test`s, and that there may be dependencies between `Test`s. 16 | ```haskell 17 | type History = Set (State, Test, Bool) 18 | ``` 19 | After running `Test`s, we accumulate a set of `State` (the state of the repo), `Test` (the test we ran) and `Bool` for the result of the `Test`. We assume `history` is a function that takes a triple and performs membership of a (changing) `History` value. 20 | 21 | ## Predicates 22 | 23 | * A `State` is **blessed** if: _forall t, history (s, t, True)_ 24 | * A `Patch` is **blessed** if: _exists s, p in s && blessed s_ 25 | * A `Patch` is **plausible** if: _forall t, exists s, p in s && history (s, t, True)_ 26 | * A `Patch` is **faulty** if: _exists t, exists s, history (s, t, True) && history (s ++ [p], t, False)_. In addition, a passing test of `t` (on a different state) must be run after the failing test. 27 | 28 | ## Approach 29 | 30 | * We maintain a `target` being a blessed state and a sequence of patches, no prefix of which forms a blessed state (if that occurs, we update the state). 31 | * A failure is a state based on the target, plus a prefix of the target state, which leads to a test failure. 32 | * If there are no failures, we work towards blessing the target, aiming to make targets plausible as fast as we can. 33 | * If they are non-empty we need to find an inconsistent test, or a faulty patch, and exclude it and resume. 34 | 35 | ## Approach 36 | 37 | We maintain a current `s` (assumed to be blessed), and a sequence of `ps` values. We want to prove every `Patch` to be either faulty or blessed. 38 | 39 | If any state of `s` plus a prefix of `ps` becomes blessed, we roll that in as the new `State` and reduce `ps` to be only the non-included suffix. 40 | 41 | We search for failures, that is a test that fails with state `s` plus a prefix of `ps`. We are keen to find failures that either make a patch blessed or plausible. Usually the focus will be on plausible, but at certain times of day (say during a 7pm freeze) the focus will become blessed until a blessed state has been reached. 42 | 43 | Once we find a failure, we search for blame. The blame must lie either with a faulty patch, or an inconsistent test. 44 | 45 | **Lemma:** In the absence of failures, we end up with everything blessed. Every failure results in a blame that excludes either a test or a patch. (I think the definition of faulty means this isn't quite true, but not sure exactly how.) 46 | 47 | -------------------------------------------------------------------------------- /docs/Notes.md: -------------------------------------------------------------------------------- 1 | # Notes 2 | 3 | General development notes I might one day forget. 4 | 5 | ## Should Step declare it uses N threads to compile 6 | 7 | No. The reason is that the first prepare (which basically runs on its own, or only while other things are winding down) does take N threads. Any subsequent prepares (e.g. for the bisection) only require 1 thread. You would mostly end up delaying bisections for a time that doesn't really happen. 8 | 9 | ## Should you be able to discover more tests while running 10 | 11 | Yes, theoretically that seems reasonable. In practice, it's not necessary, especially with something like Step. If you were to do it, you'd keep a set of tests that are required and let each additional test add to it. You'd still do dependencies as now. 12 | -------------------------------------------------------------------------------- /html/favicon.ico: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/bake/967de648990e06fa1eb9a8fd629fcf155be5891f/html/favicon.ico -------------------------------------------------------------------------------- /screenshot-part.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/bake/967de648990e06fa1eb9a8fd629fcf155be5891f/screenshot-part.png -------------------------------------------------------------------------------- /screenshot.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/bake/967de648990e06fa1eb9a8fd629fcf155be5891f/screenshot.png -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | { nixpkgs ? import {}, compiler ? "default" }: 2 | 3 | let 4 | 5 | inherit (nixpkgs) pkgs; 6 | 7 | f = { mkDerivation, aeson, base, bytestring, cmdargs, containers 8 | , deepseq, direct-sqlite, directory, disk-free-space, extra 9 | , filepath, hashable, HTTP, http-client, http-conduit, http-types 10 | , old-locale, process, random, safe, shake, smtp-mail 11 | , sqlite-simple, stdenv, text, time, transformers 12 | , unordered-containers, wai, wai-extra, warp 13 | }: 14 | mkDerivation { 15 | pname = "bake"; 16 | version = "0.5"; 17 | src = ./.; 18 | isLibrary = true; 19 | isExecutable = true; 20 | libraryHaskellDepends = [ 21 | aeson base bytestring cmdargs containers deepseq direct-sqlite 22 | directory disk-free-space extra filepath hashable HTTP http-client 23 | http-conduit http-types old-locale random safe shake smtp-mail 24 | sqlite-simple text time transformers unordered-containers wai 25 | wai-extra warp 26 | ]; 27 | executableHaskellDepends = [ 28 | aeson base bytestring cmdargs containers deepseq direct-sqlite 29 | directory disk-free-space extra filepath hashable HTTP http-client 30 | http-conduit http-types old-locale process random safe shake 31 | smtp-mail sqlite-simple text time transformers unordered-containers 32 | wai wai-extra warp 33 | ]; 34 | homepage = "https://github.com/ndmitchell/bake#readme"; 35 | description = "Continuous integration system"; 36 | license = stdenv.lib.licenses.bsd3; 37 | }; 38 | 39 | haskellPackages = if compiler == "default" 40 | then pkgs.haskellPackages 41 | else pkgs.haskell.packages.${compiler}; 42 | 43 | drv = haskellPackages.callPackage f {}; 44 | 45 | in 46 | 47 | if pkgs.lib.inNixShell then drv.env else drv 48 | -------------------------------------------------------------------------------- /src/Development/Bake.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | A continuous integration system. For an example of how to get started 3 | -- see . 4 | module Development.Bake( 5 | -- * Execute 6 | bake, 7 | -- * Central types 8 | Oven(..), defaultOven, 9 | Stringy(..), 10 | -- ** Oven modifiers 11 | ovenTest, 12 | SHA1, ovenGit, ovenStepGit, 13 | ovenNotifyAdd, ovenNotifyStdout, ovenNotifyEmail, 14 | ovenPretty, ovenPrettyMerge, 15 | ovenIncremental, incrementalStart, incrementalDone, 16 | -- ** TestInfo members 17 | TestInfo, run, threads, threadsAll, depend, require, priority, 18 | -- * Operations 19 | startServer, startClient, garbageCollect, 20 | module Development.Bake.Core.Send, 21 | -- * Utility types 22 | Host, Port, Author 23 | ) where 24 | 25 | import Development.Bake.Core.Type 26 | import Development.Bake.Server.Start 27 | import Development.Bake.Core.Client 28 | import Development.Bake.Core.Args 29 | import Development.Bake.Core.GC 30 | import Development.Bake.Core.Send 31 | import Development.Bake.Build 32 | import Development.Bake.Git 33 | import Development.Bake.StepGit 34 | import Development.Bake.Pretty 35 | import Development.Bake.Email 36 | -------------------------------------------------------------------------------- /src/Development/Bake/Build.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, ViewPatterns #-} 2 | 3 | module Development.Bake.Build( 4 | ovenIncremental, incrementalDone, incrementalStart 5 | ) where 6 | 7 | import Development.Bake.Core.Type 8 | import Development.Shake.Command 9 | import Control.Monad.Extra 10 | import Control.Applicative 11 | import System.FilePath 12 | import Control.Exception.Extra 13 | import System.Directory 14 | import General.Extra 15 | import Prelude 16 | 17 | 18 | -- Files involved: 19 | -- ../bake-incremental.txt, stores the directory name of the most recent successful increment 20 | -- .bake.incremental exists if you have done an increment yourself, or copied from someone who has 21 | -- we always use the most recent increment to build onwards from 22 | 23 | -- | This requires a version of @cp@. On Windows, you can get that here: 24 | -- 25 | ovenIncremental :: Oven state patch test -> Oven state patch test 26 | ovenIncremental oven@Oven{..} = oven{ovenPrepare = \s ps -> do incPrepare s ps; ovenPrepare s ps} 27 | where 28 | incPrepare s ps = ignore $ do 29 | -- if i have already been incremental'd (via copy, or via completion) don't do anything 30 | unlessM (doesFileExist ".bake.incremental") $ do 31 | src <- takeWhile (/= '\n') <$> readFile "../bake-incremental.txt" 32 | whenM (doesFileExist $ ".." src ".bake.incremental") $ do 33 | putStrLn $ "Preparing by copying from " ++ src 34 | timed "copying for ovenIncremental" $ 35 | cmd "cp --preserve=timestamps --recursive --no-target-directory" ("../" ++ src) "." 36 | 37 | incrementalStart :: IO () 38 | incrementalStart = 39 | writeFile ".bake.incremental" "" 40 | 41 | incrementalDone :: IO () 42 | incrementalDone = do 43 | incrementalStart 44 | x <- getCurrentDirectory 45 | writeFile "../bake-incremental.txt" $ unlines [takeFileName x] 46 | -------------------------------------------------------------------------------- /src/Development/Bake/Core/Args.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, DeriveDataTypeable, ScopedTypeVariables #-} 2 | {-# OPTIONS_GHC -fno-warn-missing-fields #-} 3 | 4 | -- | Define a continuous integration system. 5 | module Development.Bake.Core.Args( 6 | bake 7 | ) where 8 | 9 | import System.Console.CmdArgs 10 | import Development.Bake.Core.Type hiding (Client) 11 | import Development.Bake.Core.Client 12 | import Development.Bake.Core.GC 13 | import Development.Bake.Server.Start 14 | import Development.Bake.Core.Send 15 | import Control.Exception.Extra 16 | import General.Extra 17 | import Control.DeepSeq 18 | import System.FilePath 19 | import System.IO.Extra 20 | import System.Directory.Extra 21 | import Control.Monad.Extra 22 | import Control.Applicative 23 | import Data.Either.Extra 24 | import Data.Maybe 25 | import Data.List.Extra 26 | import Data.Tuple.Extra 27 | import Paths_bake 28 | import Prelude 29 | 30 | 31 | data Bake 32 | = Server {port :: Port, author :: [Author], timeout :: Double, admin :: String} 33 | | Client {host :: Host, port :: Port, author :: [Author], name :: String, threads :: Int, provide :: [String], ping :: Double} 34 | | AddPatch {host :: Host, port :: Port, author :: [Author], name :: String} 35 | | DelPatch {host :: Host, port :: Port, name :: String} 36 | | Requeue {host :: Host, port :: Port} 37 | | SetState {host :: Host, port :: Port, author :: [Author], state :: String} 38 | | Pause {host :: Host, port :: Port} 39 | | Unpause {host :: Host, port :: Port} 40 | | GC {bytes :: Integer, ratio :: Double, days :: Double, dirs :: [FilePath]} 41 | | Admin {password :: [String]} 42 | | View {port :: Port, file :: FilePath} 43 | -- actions sent through from Bake itself 44 | | RunInit 45 | | RunUpdate {state :: String, patch :: [String]} 46 | | RunTest {test :: Maybe String, state :: String, patch :: [String]} 47 | | RunExtra {state :: String, patch :: [String]} 48 | deriving (Typeable,Data) 49 | 50 | 51 | bakeMode = cmdArgsMode $ modes 52 | [Server{port = 0, author = [], timeout = 10*60, admin = ""} 53 | ,Client{host = "", threads = 1, name = "", ping = 60, provide = []} 54 | ,AddPatch{} 55 | ,DelPatch{} 56 | ,Requeue{} 57 | ,SetState{state = ""} 58 | ,Pause{} 59 | ,Unpause{} 60 | ,GC 0 0 7 ([] &= args) 61 | ,Admin ([] &= args) 62 | ,View{file = "" &= args} 63 | ,RunTest def def def 64 | ,RunInit{} 65 | ,RunExtra{} 66 | ,RunUpdate{} 67 | ] &= verbosity 68 | 69 | -- | The entry point to the system. Usually you will define: 70 | -- 71 | -- > main = bake myOven 72 | -- 73 | -- Where @myOven@ defines details about the server. The program 74 | -- deals with command line arguments, run @--help@ for details. 75 | bake :: (Stringy state, Stringy patch, Stringy test) => Oven state patch test -> IO () 76 | bake = bake_ -- so the forall's don't show up in Haddock 77 | 78 | bake_ :: forall state patch test . (Stringy state, Stringy patch, Stringy test) => Oven state patch test -> IO () 79 | bake_ oven = do 80 | registerMaster 81 | timeInit 82 | getDataDir -- ensure it gets forced in case you change directory 83 | x <- cmdArgsRun bakeMode 84 | let author1 = head $ author x ++ ["unknown"] 85 | case x of 86 | Server{..} -> startServer (getPort port) author timeout admin False oven 87 | View{..} -> do 88 | when (file == "") $ error "You must pass a file" 89 | file <- canonicalizePath file 90 | withTempDir $ \dir -> withCurrentDirectory dir $ do 91 | createDirectoryIfMissing True $ dir "bake-store" 92 | copyFile file $ dir "bake-store" "bake.sqlite" 93 | -- the concrete ensures nothing ever results in a parse error 94 | startServer (getPort port) [] 100 "" True $ snd $ concrete oven 95 | Client{..} -> do 96 | name <- if name /= "" then return name else pick defaultNames 97 | startClient (getHostPort host port) author1 name threads provide ping oven 98 | AddPatch{..} -> sendAddPatch (getHostPort host port) author1 =<< check "patch" (undefined :: patch) name 99 | DelPatch{..} -> sendDelPatch (getHostPort host port) =<< check "patch" (undefined :: patch) name 100 | Requeue{..} -> sendRequeue (getHostPort host port) 101 | SetState{..} -> sendSetState (getHostPort host port) author1 state 102 | Pause{..} -> sendPause (getHostPort host port) 103 | Unpause{..} -> sendUnpause (getHostPort host port) 104 | GC{..} -> garbageCollect bytes ratio (days * 24*60*60) (if null dirs then ["."] else dirs) 105 | Admin{..} -> do 106 | when (null password) $ putStrLn "Pass passwords on the command line to be suitable for 'server --admin=XXX'" 107 | forM_ password $ \x -> putStrLn $ "Password " ++ x ++ " requires --admin=" ++ encryptish x 108 | RunInit -> do 109 | s <- ovenInit oven 110 | writeFile ".bake.result" $ stringyTo s 111 | RunUpdate{..} -> do 112 | s <- ovenUpdate oven (stringyFrom state) $ map stringyFrom patch 113 | writeFile ".bake.result" $ stringyTo s 114 | RunTest{..} -> do 115 | case test of 116 | Nothing -> do 117 | res <- nubOn stringyTo <$> ovenPrepare oven 118 | (stringyFrom state) 119 | (map stringyFrom patch) 120 | 121 | case validTests (ovenTestInfo oven) res of 122 | Left err -> fail err 123 | Right () -> return () 124 | 125 | writeFile ".bake.result" $ show $ map stringyTo res 126 | Just test -> do 127 | testAction $ ovenTestInfo oven $ stringyFrom test 128 | RunExtra{..} -> do 129 | res <- ovenPatchExtra oven 130 | (stringyFrom state) 131 | (fmap stringyFrom $ listToMaybe patch) 132 | writeFile ".bake.result" $ show res 133 | where 134 | getPort p = if p == 0 then snd $ ovenServer oven else p 135 | getHostPort h p = (if h == "" then fst $ ovenServer oven else h, getPort p) 136 | 137 | 138 | check :: Stringy s => String -> s -> String -> IO String 139 | check typ _ x = do 140 | res <- try_ $ evaluate $ force $ stringyTo $ asTypeOf (stringyFrom x) x 141 | case res of 142 | Left err -> error $ "Couldn't stringify the " ++ typ ++ " " ++ show x ++ ", got " ++ show err 143 | Right v -> return v 144 | 145 | 146 | defaultNames = words "Simon Lennart Dave Brian Warren Joseph Kevin Ralf Paul John Thomas Mark Erik Alastair Colin Philip" 147 | -------------------------------------------------------------------------------- /src/Development/Bake/Core/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, ViewPatterns, ScopedTypeVariables #-} 2 | 3 | module Development.Bake.Core.Client( 4 | startClient 5 | ) where 6 | 7 | import Development.Bake.Core.Type 8 | import Development.Bake.Core.Run 9 | import General.Extra 10 | import Development.Bake.Core.Message 11 | import Control.Concurrent 12 | import Control.Monad.Extra 13 | import System.Time.Extra 14 | import Data.IORef 15 | import Data.Tuple.Extra 16 | import System.Environment.Extra 17 | 18 | 19 | -- given server, name, threads 20 | startClient :: (Stringy state, Stringy patch, Stringy test) 21 | => (Host,Port) -> Author -> String -> Int -> [String] -> Double -> Oven state patch test -> IO () 22 | startClient hp author (toClient -> client) maxThreads provide ping (concrete -> (prettys, oven)) = do 23 | when (client == toClient "") $ error "You must give a name to the client, typically with --name" 24 | queue <- newChan 25 | nowThreads <- newIORef maxThreads 26 | 27 | unique <- newIORef 0 28 | root <- myThreadId 29 | exe <- getExecutablePath 30 | forkSlave $ forever $ do 31 | readChan queue 32 | now <- readIORef nowThreads 33 | q <- sendMessage hp $ Pinged $ Ping client author provide maxThreads now 34 | whenJust q $ \q@Question{..} -> do 35 | atomicModifyIORef nowThreads $ \now -> (now - qThreads, ()) 36 | writeChan queue () 37 | void $ forkSlave $ do 38 | i <- atomicModifyIORef unique $ dupe . succ 39 | putBlock "Client start" $ 40 | ["Client: " ++ fromClient client 41 | ,"Id: " ++ show i 42 | ,"Test: " ++ maybe "Prepare" fromTest qTest 43 | ,"State: " ++ fromState (fst qCandidate) 44 | ,"Patches:"] ++ 45 | map ((++) " " . fromPatch) (snd qCandidate) 46 | a@Answer{..} <- runTest (fst qCandidate) (snd qCandidate) qTest 47 | putBlock "Client stop" $ 48 | ["Client: " ++ fromClient client 49 | ,"Id: " ++ show i 50 | ,"Result: " ++ (if aSuccess then "Success" else "Failure") 51 | ,"Duration: " ++ maybe "none" showDuration aDuration 52 | ] 53 | atomicModifyIORef nowThreads $ \now -> (now + qThreads, ()) 54 | sendMessage hp $ Finished q a 55 | writeChan queue () 56 | 57 | forever $ writeChan queue () >> sleep ping 58 | -------------------------------------------------------------------------------- /src/Development/Bake/Core/GC.hs: -------------------------------------------------------------------------------- 1 | 2 | -- | Define a continuous integration system. 3 | module Development.Bake.Core.GC(garbageCollect) where 4 | 5 | import Control.Exception.Extra 6 | import General.Extra 7 | import System.Directory.Extra 8 | import System.FilePath 9 | import Control.Monad.Extra 10 | import Control.Applicative 11 | import Data.Time.Clock 12 | import Data.Either.Extra 13 | import Data.List.Extra 14 | import Data.Maybe 15 | import System.DiskSpace 16 | import Prelude 17 | 18 | 19 | -- | Garbage collect enough files to satisfy the requirements. 20 | garbageCollect 21 | :: Integer -- ^ Minimum number of bytes you want free on the drive (use 0 if you don't want any) 22 | -> Double -- ^ Ratio of the drive you want free, e.g. 0.25 to demand a quarter of the drive free (1 to delete everything you can) 23 | -> Seconds -- ^ Minimum age to delete in seconds 24 | -> [FilePath] -- ^ Directories containing Bake stuff 25 | -> IO () 26 | garbageCollect _ _ _ [] = return () 27 | garbageCollect bytes ratio limit dirs@(d:_) = do 28 | total <- diskTotal <$> getDiskUsage d 29 | gs <- reverse . sortOn gAge . filter ((>= limit) . gAge) <$> garbageQuery dirs 30 | 31 | bytes <- return $ max (floor $ fromIntegral total * ratio) bytes 32 | 33 | done <- flip loopM (False,gs) $ \(done,gs) -> case gs of 34 | [] -> return $ Right done 35 | g:gs -> do 36 | b <- getAvailSpace d 37 | if b >= bytes then 38 | return $ Right done 39 | else do 40 | putStr $ "[BAKE-GC] Deleting " ++ gPath g ++ "..." 41 | res <- try_ $ do 42 | renameDirectory (gPath g) (gPath g <.> "gc") 43 | removeDirectoryRecursive (gPath g <.> "gc") 44 | putStrLn $ either (\e -> "FAILED\n" ++ show e) (const "success") res 45 | return $ Left (True,gs) 46 | when done $ do 47 | totalAfterGC <- diskTotal <$> getDiskUsage d 48 | putStrLn $ "[BAKE-GC] Disk space garbage collection complete, collected " ++ show (total - totalAfterGC) 49 | 50 | 51 | data Garbage = Garbage 52 | {gPath :: FilePath 53 | ,gAge :: Seconds -- ^ Age in seconds, will be positive (unless clock adjustments) 54 | } deriving (Show) 55 | 56 | 57 | -- | Given a list of directories, find the possible garbage present. 58 | garbageQuery :: [FilePath] -> IO [Garbage] 59 | garbageQuery dirs = do 60 | now <- getCurrentTime 61 | 62 | let preserveStore file = takeFileName file /= "bake-store" 63 | 64 | let age garbage file = fmap eitherToMaybe $ try_ $ do 65 | t <- getModificationTime file 66 | return $ garbage $ fromRational $ toRational $ now `diffUTCTime` t 67 | 68 | fmap (concatMap catMaybes) $ forM dirs $ \dir -> do 69 | let inc = dir "bake-incremental.txt" 70 | exist <- doesFileExist inc 71 | preserveIncremental <- if exist 72 | then do 73 | incDir <- takeWhile (/= '\n') <$> readFile inc 74 | return (preserveIncrementalDirs incDir) 75 | else return $ const True 76 | dirs <- (filter preserveStore . filter preserveIncremental) <$> listContents dir 77 | forM dirs $ \dir -> age (Garbage dir) $ dir ".bake.name" 78 | 79 | -- | Compute all dirs pertaining to a specific test run 80 | -- 81 | -- Given a baseName of `bake-test-XYZ` this returns a filter for `xxx-XYZ`. 82 | preserveIncrementalDirs :: String -> FilePath -> Bool 83 | preserveIncrementalDirs baseName = case splitOn "-" baseName of 84 | [_,_,testNumber] -> \ dir -> not $ testNumber `isSuffixOf` takeFileName dir 85 | _ -> const True 86 | -------------------------------------------------------------------------------- /src/Development/Bake/Core/Message.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, OverloadedStrings #-} 2 | 3 | module Development.Bake.Core.Message( 4 | Message(..), Ping(..), Question(..), Answer(..), 5 | sendMessage, messageToInput, messageFromInput, questionToOutput 6 | ) where 7 | 8 | import Development.Bake.Core.Type 9 | import General.Web 10 | import General.BigString 11 | import Control.Applicative 12 | import Control.Monad 13 | import Control.DeepSeq 14 | import Data.Aeson hiding (Success) 15 | import System.Time.Extra 16 | import Safe 17 | import qualified Data.ByteString.Lazy.Char8 as LBS 18 | import Prelude 19 | 20 | 21 | data Message 22 | -- Send by the user 23 | = SetState Author State 24 | | AddPatch Author Patch 25 | | DelPatch Patch 26 | | Requeue 27 | | Pause 28 | | Unpause 29 | | AddSkip Author Test 30 | | DelSkip Test 31 | -- Sent by the client 32 | | Pinged Ping 33 | | Finished {question :: Question, answer :: Answer} 34 | deriving Show 35 | 36 | instance NFData Message where 37 | rnf (AddPatch x y) = rnf x `seq` rnf y 38 | rnf (DelPatch x) = rnf x 39 | rnf Requeue = () 40 | rnf (SetState x y) = rnf x `seq` rnf y 41 | rnf Pause = () 42 | rnf Unpause = () 43 | rnf (AddSkip x y) = rnf x `seq` rnf y 44 | rnf (DelSkip x) = rnf x 45 | rnf (Pinged x) = rnf x 46 | rnf (Finished x y) = rnf x `seq` rnf y 47 | 48 | data Question = Question 49 | {qCandidate :: (State, [Patch]) 50 | ,qTest :: Maybe Test 51 | ,qThreads :: Int 52 | ,qClient :: Client 53 | } 54 | deriving (Show,Eq,Ord) 55 | 56 | instance NFData Question where 57 | rnf (Question a b c d) = rnf (a,b,c,d) 58 | 59 | data Answer = Answer 60 | {aStdout :: BigString 61 | ,aDuration :: Maybe Seconds -- Nothing for a skip 62 | ,aTests :: [Test] 63 | ,aSuccess :: Bool 64 | } 65 | deriving Show 66 | 67 | instance NFData Answer where 68 | rnf (Answer a b c d) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d 69 | 70 | data Ping = Ping 71 | {pClient :: Client 72 | ,pAuthor :: Author 73 | ,pProvide :: [String] -- matches with testRequire 74 | ,pMaxThreads :: Int 75 | ,pNowThreads :: Int 76 | } 77 | deriving (Show,Eq) 78 | 79 | instance NFData Ping where 80 | rnf (Ping a b c d e) = rnf a `seq` rnf b `seq` rnf c `seq` rnf d `seq` rnf e 81 | 82 | 83 | instance ToJSON Question where 84 | toJSON Question{..} = object 85 | ["candidate" .= toJSONCandidate qCandidate 86 | ,"test" .= qTest 87 | ,"threads" .= qThreads 88 | ,"client" .= qClient] 89 | 90 | instance FromJSON Question where 91 | parseJSON (Object v) = Question <$> 92 | (fromJSONCandidate =<< (v .: "candidate")) <*> (v .: "test") <*> (v .: "threads") <*> (v .: "client") 93 | parseJSON _ = mzero 94 | 95 | toJSONCandidate (s, ps) = object ["state" .= s, "patches" .= ps] 96 | 97 | fromJSONCandidate (Object v) = (,) <$> (v .: "state") <*> (v .: "patches") 98 | fromJSONCandidate _ = mzero 99 | 100 | 101 | messageToInput :: Message -> Input 102 | messageToInput (AddPatch author patch) = Input ["api","add"] [("author",author),("patch",fromPatch patch)] [] 103 | messageToInput (DelPatch patch) = Input ["api","del"] [("patch",fromPatch patch)] [] 104 | messageToInput Requeue = Input ["api","requeue"] [] [] 105 | messageToInput (SetState author state) = Input ["api","set"] [("author",author),("state",fromState state)] [] 106 | messageToInput Pause = Input ["api","pause"] [] [] 107 | messageToInput Unpause = Input ["api","unpause"] [] [] 108 | messageToInput (AddSkip author test) = Input ["api","addskip"] [("author",author),("test",fromTest test)] [] 109 | messageToInput (DelSkip test) = Input ["api","delskip"] [("test",fromTest test)] [] 110 | messageToInput (Pinged Ping{..}) = Input ["api","ping"] 111 | ([("client",fromClient pClient),("author",pAuthor)] ++ 112 | [("provide",x) | x <- pProvide] ++ 113 | [("maxthreads",show pMaxThreads),("nowthreads",show pNowThreads)]) [] 114 | messageToInput (Finished Question{..} Answer{..}) = Input ["api","finish"] [] 115 | [("state", bigStringFromString $ fromState $ fst qCandidate) 116 | ,("patch", bigStringFromString $ unlines $ map fromPatch $ snd qCandidate) 117 | ,("test", bigStringFromString $ maybe "" fromTest qTest) 118 | ,("threads", bigStringFromString $ show qThreads) 119 | ,("client", bigStringFromString $ fromClient qClient) 120 | ,("stdout", aStdout) 121 | ,("duration", bigStringFromString $ maybe "" show aDuration) 122 | ,("tests", bigStringFromString $ unlines $ map fromTest aTests) 123 | ,("success", bigStringFromString $ show aSuccess)] 124 | 125 | 126 | -- return either an error message (not a valid message), or a message 127 | messageFromInput :: Input -> Either String Message 128 | messageFromInput (Input [msg] args body) 129 | | msg == "add" = AddPatch <$> str "author" <*> (toPatch <$> str "patch") 130 | | msg == "del" = DelPatch <$> (toPatch <$> str "patch") 131 | | msg == "addskip" = AddSkip <$> str "author" <*> (toTest <$> str "test") 132 | | msg == "delskip" = DelSkip <$> (toTest <$> str "test") 133 | | msg == "requeue" = pure Requeue 134 | | msg == "set" = SetState <$> str "author" <*> (toState <$> str "state") 135 | | msg == "pause" = pure Pause 136 | | msg == "unpause" = pure Unpause 137 | | msg == "ping" = Pinged <$> (Ping <$> (toClient <$> str "client") <*> 138 | str "author" <*> strs "provide" <*> int "maxthreads" <*> int "nowthreads") 139 | where strs x = Right $ map snd $ filter ((==) x . fst) args 140 | str x | Just v <- lookup x args = Right v 141 | | otherwise = Left $ "Missing field " ++ show x ++ " from " ++ show msg 142 | int x = readNote "messageFromInput, expecting Int" <$> str x 143 | messageFromInput (Input [msg] args body) 144 | | msg == "finish" = do 145 | let f x = case lookup x body of Nothing -> Left $ "Missing field " ++ show x ++ " from " ++ show (map fst body); Just x -> Right x 146 | state <- toState . bigStringToString <$> f "state" 147 | patch <- map toPatch . lines . filter (/= '\r') . bigStringToString <$> f "patch" 148 | qTest <- (\x -> if null x then Nothing else Just $ toTest x) . bigStringToString <$> f "test" 149 | qThreads <- read . bigStringToString <$> f "threads" 150 | qClient <- toClient . bigStringToString <$> f "client" 151 | aStdout <- f "stdout" 152 | aDuration <- (\x -> if null x then Nothing else Just $ read x) . bigStringToString <$> f "duration" 153 | aTests <- map toTest . lines . filter (/= '\r') . bigStringToString <$> f "tests" 154 | aSuccess <- read . bigStringToString <$> f "success" 155 | return $ Finished Question{qCandidate=(state,patch),..} Answer{..} 156 | messageFromInput (Input msg args body) = Left $ "Invalid API call, got " ++ show msg 157 | 158 | 159 | questionToOutput :: Maybe Question -> Output 160 | questionToOutput = OutputString . LBS.unpack . encode 161 | 162 | 163 | sendMessage :: (Host,Port) -> Message -> IO (Maybe Question) 164 | sendMessage hp msg = do 165 | res <- send hp $ messageToInput msg 166 | return $ decode res 167 | -------------------------------------------------------------------------------- /src/Development/Bake/Core/Run.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, DeriveDataTypeable #-} 2 | 3 | module Development.Bake.Core.Run( 4 | runInit, runUpdate, runTest, runExtra 5 | ) where 6 | 7 | import Development.Bake.Core.Type hiding (Client) 8 | import Development.Bake.Core.Message 9 | import Development.Shake.Command 10 | import Control.Exception.Extra 11 | import General.BigString 12 | import General.Extra 13 | import System.Time.Extra 14 | import Control.DeepSeq 15 | import Control.Concurrent.Extra 16 | import System.IO.Unsafe 17 | import Data.Tuple.Extra 18 | import System.IO.Extra 19 | import System.Environment.Extra 20 | import System.FilePath 21 | import Data.Maybe 22 | import System.Exit 23 | import Safe 24 | import qualified Data.Text as T 25 | import qualified Data.Text.Lazy as TL 26 | 27 | 28 | {-# NOINLINE running #-} 29 | running :: Var Int 30 | running = unsafePerformIO $ newVar 0 31 | 32 | 33 | state x = "--state=" ++ fromState x 34 | patch x = "--patch=" ++ fromPatch x 35 | test x = "--test=" ++ fromTest x 36 | 37 | runInit :: IO (Maybe State, Answer) 38 | runInit = runAll "init" [] [] toState 39 | 40 | runUpdate :: State -> [Patch] -> IO (Maybe State, Answer) 41 | runUpdate s ps = runAll "update" (state s : map patch ps) [] toState 42 | 43 | runTest :: State -> [Patch] -> Maybe Test -> IO Answer 44 | runTest s ps t = do 45 | (ex, ans) <- runAll "test" (state s : map patch ps) (map test $ maybeToList t) (map toTest . readNote "runTest") 46 | return $ maybe ans (\ex -> ans{aTests=ex}) (if t == Nothing then ex else Nothing) 47 | 48 | runExtra :: State -> Maybe Patch -> IO (Maybe (T.Text, TL.Text), Answer) 49 | runExtra s ps = runAll "extra" (state s : map patch (maybeToList ps)) [] ((T.pack *** TL.pack) . readNote "runExtra") 50 | 51 | 52 | runAll :: NFData a => String -> [String] -> [String] -> (String -> a) -> IO (Maybe a, Answer) 53 | runAll name args1 args2 parse = do 54 | exe <- getExecutablePath 55 | dir <- createDir ("bake-" ++ name) args1 56 | 57 | (time, res) <- duration $ try_ $ do 58 | exe <- getExecutablePath 59 | (out, exit) <- bigStringFromFile $ \file -> do 60 | res <- bracket_ (modifyVar_ running $ return . succ) (modifyVar_ running $ return . pred) $ do 61 | v <- readVar running 62 | print $ "RUNNING = " ++ show v 63 | cmd [Cwd dir, FileStdout file, FileStderr file] exe ("run" ++ name) args1 args2 64 | v <- readVar running 65 | print $ "RUNNING = " ++ show v 66 | return res 67 | ex <- if exit /= ExitSuccess then return Nothing else do 68 | ans <- fmap parse $ readFile' $ dir ".bake.result" 69 | evaluate $ rnf ans 70 | return $ Just ans 71 | return (ex, Answer out (Just 0) [] (exit == ExitSuccess)) 72 | case res of 73 | Left e -> do 74 | e <- showException e 75 | return (Nothing, Answer (bigStringFromString e) (Just time) [] False) 76 | Right (ex,ans) -> return (ex, ans{aDuration=Just time}) 77 | -------------------------------------------------------------------------------- /src/Development/Bake/Core/Send.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Development.Bake.Core.Send( 4 | sendAddPatch, sendDelPatch, sendSetState, 5 | sendPause, sendUnpause, sendRequeue, 6 | sendAddSkip, sendDelSkip 7 | ) where 8 | 9 | import Control.Monad 10 | import Development.Bake.Core.Type 11 | import Development.Bake.Core.Message 12 | 13 | sendPause :: (Host,Port) -> IO () 14 | sendPause hp = void $ sendMessage hp Pause 15 | 16 | sendUnpause :: (Host,Port) -> IO () 17 | sendUnpause hp = void $ sendMessage hp Unpause 18 | 19 | sendAddPatch :: (Host,Port) -> Author -> String -> IO () 20 | sendAddPatch hp author x = void $ sendMessage hp $ AddPatch author $ toPatch x 21 | 22 | sendDelPatch :: (Host,Port) -> String -> IO () 23 | sendDelPatch hp x = void $ sendMessage hp $ DelPatch $ toPatch x 24 | 25 | sendRequeue :: (Host,Port) -> IO () 26 | sendRequeue hp = void $ sendMessage hp Requeue 27 | 28 | sendAddSkip :: (Host,Port) -> Author -> String -> IO () 29 | sendAddSkip hp author x = void $ sendMessage hp $ AddSkip author $ toTest x 30 | 31 | sendDelSkip :: (Host,Port) -> String -> IO () 32 | sendDelSkip hp x = void $ sendMessage hp $ DelSkip $ toTest x 33 | 34 | sendSetState :: (Host,Port) -> Author -> String -> IO () 35 | sendSetState hp author x = void $ sendMessage hp $ SetState author $ toState x 36 | -------------------------------------------------------------------------------- /src/Development/Bake/Core/Type.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving, ScopedTypeVariables, DeriveDataTypeable #-} 2 | {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, ViewPatterns #-} 3 | 4 | -- | Define a continuous integration system. 5 | module Development.Bake.Core.Type( 6 | Host, Port, 7 | Stringy(..), 8 | Oven(..), TestInfo(..), defaultOven, ovenTest, 9 | ovenNotifyAdd, ovenNotifyStdout, 10 | threads, threadsAll, depend, run, require, priority, 11 | State, toState, fromState, 12 | Patch, toPatch, fromPatch, 13 | Test, toTest, fromTest, 14 | Client, toClient, fromClient, 15 | Point, 16 | concrete, Prettys(..), 17 | validTests, 18 | Author 19 | ) where 20 | 21 | import General.Extra 22 | import Control.Monad.Extra 23 | import Control.DeepSeq 24 | import Data.Monoid 25 | import Data.Aeson 26 | import Data.Hashable 27 | import Data.Typeable 28 | import Database.SQLite.Simple.FromField 29 | import Database.SQLite.Simple.ToField 30 | import General.Database 31 | import Data.List.Extra 32 | import Prelude 33 | 34 | 35 | type Author = String 36 | 37 | type Host = String 38 | 39 | type Port = Int 40 | 41 | -- | The central type defining a continuous integration system. 42 | -- Usually constructed with 'defaultOven' then filled out with other 43 | -- 'Oven' modifiers such as 'ovenGit' and 'ovenTest'. 44 | -- 45 | -- The types are: @state@ is the base state of the system (think HEAD on the master branch); 46 | -- @patch@ is a change that is proposed (think a diff); @test@ is the type of tests that 47 | -- are run. 48 | -- 49 | -- All IO operations will be called in a direct subdirectory of the directory you start 50 | -- 'bake' from. In particular: 51 | -- 'ovenInit' will always be called single-threaded from @bake-init@; 52 | -- 'ovenUpdate' will always be called single-threaded from @bake-update-/hash/@; 53 | -- 'ovenPatchExtra' will always be called from @bake-extra-/hash/@; 54 | -- 'ovenPrepare' and 'run' will always be called from @bake-test-/hash/@. 55 | data Oven state patch test = Oven 56 | {ovenInit :: IO state 57 | -- ^ Get an initial state 58 | ,ovenUpdate :: state -> [patch] -> IO state 59 | -- ^ Given a state, and a set of candiates that have passed, 60 | -- merge to create a new state 61 | ,ovenPrepare :: state -> [patch] -> IO [test] 62 | -- ^ Prepare a candidate to be run, produces the tests that must pass 63 | ,ovenTestInfo :: test -> TestInfo test 64 | -- ^ Produce information about a test 65 | ,ovenNotify :: Author -> String -> String -> IO () 66 | -- ^ Tell an author some information. The first 'String' is a subject line, the second an HTML fragment. 67 | ,ovenPatchExtra :: state -> Maybe patch -> IO (String, String) 68 | -- ^ Extra information about a patch, a single line (HTML span), 69 | -- and a longer chunk (HTML block) 70 | ,ovenServer :: (Host, Port) 71 | -- ^ Default server to use 72 | ,ovenSupersede :: patch -> patch -> Bool 73 | -- ^ Given two patches (first on submitted first) is the first now redundant 74 | } 75 | 76 | -- | Given a 'Stringy' for @test@, and a function that when run on a code base 77 | -- returns the list of tests that need running, and a function to populate 78 | -- a 'TestInfo', modify the 'Oven' with a test type. 79 | ovenTest :: IO [test] -> (test -> TestInfo test) 80 | -> Oven state patch () -> Oven state patch test 81 | ovenTest prepare info o = o{ovenPrepare= \_ _ -> prepare, ovenTestInfo=info} 82 | 83 | -- | Add an additional notification to the list. 84 | ovenNotifyAdd :: (Author -> String -> String -> IO ()) -> Oven state patch test -> Oven state patch test 85 | ovenNotifyAdd f o = o{ovenNotify = \a s b -> f a s b >> ovenNotify o a s b} 86 | 87 | -- | Produce notifications on 'stdout' when users should be notified about success/failure. 88 | ovenNotifyStdout :: Oven state patch test -> Oven state patch test 89 | ovenNotifyStdout = ovenNotifyAdd $ \author subject body -> 90 | putBlock "Email" ["To: " ++ author, "Subject: " ++ subject, body] 91 | 92 | -- | A type representing a translation between a value and a string, which can be 93 | -- produced by 'readShowStringy' if the type has both 'Read' and 'Show' instances. 94 | -- The functions 'stringyTo' and 'stringyFrom' should be inverses of each other. 95 | -- The function 'stringyPretty' shows a value in a way suitable for humans, and can 96 | -- discard uninteresting information. 97 | class Stringy s where 98 | stringyTo :: s -> String 99 | stringyFrom :: String -> s 100 | stringyPretty :: s -> String 101 | stringyPretty = stringyTo 102 | 103 | instance Stringy () where 104 | stringyTo () = "_" 105 | stringyFrom "_" = () 106 | stringyFrom x = error $ "Invalid stringyFrom on (), expected \"_\", got " ++ show x 107 | 108 | instance Stringy String where 109 | stringyTo = id 110 | stringyFrom = id 111 | stringyPretty x 112 | | (pre,sha) <- spanEnd (`elem` "0123456789abcdef") x 113 | , length sha >= 32 -- git is 40 114 | = pre ++ take 7 sha 115 | stringyPretty x = x 116 | 117 | 118 | -- | The default oven, which doesn't do anything interesting. Usually the starting point. 119 | defaultOven :: Oven () () () 120 | defaultOven = Oven 121 | {ovenInit = return () 122 | ,ovenUpdate = \_ _ -> return () 123 | ,ovenNotify = \_ _ _ -> return () 124 | ,ovenPrepare = \_ _ -> return [] 125 | ,ovenTestInfo = \_ -> mempty 126 | ,ovenPatchExtra = \_ _ -> return ("","") 127 | ,ovenServer = ("127.0.0.1",80) 128 | ,ovenSupersede = \_ _ -> False 129 | } 130 | 131 | -- | Information about a test. 132 | data TestInfo test = TestInfo 133 | {testThreads :: Maybe Int -- number of threads, defaults to 1, Nothing for use all 134 | ,testAction :: IO () 135 | ,testRequire :: [String] -- attributes that are required 136 | ,testDepend :: [test] 137 | ,testPriority :: Int 138 | } 139 | 140 | instance Functor TestInfo where 141 | fmap f t = t{testDepend = map f $ testDepend t} 142 | 143 | instance Monoid (TestInfo test) where 144 | mempty = TestInfo (Just 1) (return ()) [] [] 0 145 | mappend (TestInfo x1 x2 x3 x4 x5) (TestInfo y1 y2 y3 y4 y5) = 146 | TestInfo (liftM2 (+) x1 y1) (x2 >> y2) (x3 ++ y3) (x4 ++ y4) (x5 + y5) 147 | 148 | -- | Change the number of threads a test requires, defaults to 1. 149 | threads :: Int -> TestInfo test -> TestInfo test 150 | threads j t = t{testThreads=Just j} 151 | 152 | -- | Record that a test requires all available threads on a machine, 153 | -- typically used for the build step. 154 | -- Use 'getNumCapabilities' to find out how many threads you were allocated. 155 | threadsAll :: TestInfo test -> TestInfo test 156 | threadsAll t = t{testThreads=Nothing} 157 | 158 | 159 | -- | Require the following tests have been evaluated on this machine 160 | -- before this test is run. Typically used to require compilation 161 | -- before running most tests. 162 | depend :: [test] -> TestInfo test -> TestInfo test 163 | depend xs t = t{testDepend=testDepend t++xs} 164 | 165 | -- | The action associated with a @test@. 166 | run :: IO () -> TestInfo test 167 | run act = mempty{testAction=act} 168 | 169 | -- | Set the priority of a test, those with higher priority are run first. 170 | -- Tests have a default priority of 0. 171 | priority :: Int -> TestInfo test -> TestInfo test 172 | priority p t = t{testPriority = p + testPriority t} 173 | 174 | -- | Is a particular client capable of running a test. 175 | -- Usually an OS check. To run a test must have all its requirements met. 176 | -- Clients can satisfy a requirement by passing @--provide=...@ on the command line. 177 | require :: [String] -> TestInfo test -> TestInfo test 178 | require xs t = t{testRequire = xs ++ testRequire t} 179 | 180 | 181 | newtype State = State {fromState :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable,NFData,Typeable,FromField,ToField,TypeField,Stringy) 182 | newtype Patch = Patch {fromPatch :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable,NFData,Typeable,FromField,ToField,TypeField,Stringy) 183 | newtype Test = Test {fromTest :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable,NFData,Typeable,FromField,ToField,TypeField,Stringy) 184 | newtype Client = Client {fromClient :: String} deriving (Show,Eq,Ord,ToJSON,FromJSON,Hashable,NFData,Typeable,FromField,ToField,TypeField) 185 | 186 | toState :: String -> State; toState = State 187 | toPatch :: String -> Patch; toPatch = Patch 188 | toTest :: String -> Test; toTest = Test 189 | toClient :: String -> Client; toClient = Client 190 | 191 | type Point = (State, [Patch]) 192 | 193 | data Prettys = Prettys 194 | {prettyState :: State -> String 195 | ,prettyPatch :: Patch -> String 196 | ,prettyTest :: Test -> String 197 | } 198 | 199 | concrete :: (Stringy state, Stringy patch, Stringy test) => Oven state patch test -> (Prettys, Oven State Patch Test) 200 | concrete o@Oven{..} = (Prettys prestate prepatch pretest, o 201 | {ovenInit = fmap restate ovenInit 202 | ,ovenUpdate = \s ps -> fmap restate $ ovenUpdate (unstate s) (map unpatch ps) 203 | ,ovenPrepare = \s ps -> fmap (map retest) $ ovenPrepare (unstate s) (map unpatch ps) 204 | ,ovenTestInfo = fmap retest . ovenTestInfo . untest 205 | ,ovenPatchExtra = \s p -> ovenPatchExtra (unstate s) (fmap unpatch p) 206 | ,ovenSupersede = \p1 p2 -> ovenSupersede (unpatch p1) (unpatch p2) 207 | }) 208 | where 209 | (unstate,restate,prestate) = f State fromState 210 | (unpatch,_ ,prepatch) = f Patch fromPatch 211 | (untest ,retest ,pretest ) = f Test fromTest 212 | 213 | f :: forall o s . Stringy o => (String -> s) -> (s -> String) -> (s -> o, o -> s, s -> String) 214 | f inj proj = 215 | (check . stringyFrom . proj 216 | ,inj . stringyTo . check 217 | ,stringyPretty . flip asTypeOf (undefined :: o) . check . stringyFrom . proj) 218 | 219 | check :: forall o . Stringy o => o -> o 220 | check s | null $ stringyTo s = error "Problem with stringyTo/stringyFrom, generated blank string" 221 | | stringyTo s == stringyTo (stringyFrom (stringyTo s) :: o) = s 222 | | otherwise = error $ "Problem with stringyTo/stringyFrom on " ++ stringyTo s 223 | 224 | 225 | -- | Check a set of tests is valid - no cycles and no dependencies that cannot be satisfied 226 | validTests :: Stringy test => (test -> TestInfo test) -> [test] -> Either String () 227 | validTests info (map stringyTo -> res) 228 | | Just xs <- findCycle follow res = Left $ unlines $ "Tests form a cycle:" : xs 229 | | missing@(_:_) <- transitiveClosure follow res \\ res = Left $ unlines $ "Test is a dependency that cannot be reached:" : missing 230 | | otherwise = Right () 231 | where follow t = map stringyTo $ testDepend $ info $ stringyFrom t 232 | -------------------------------------------------------------------------------- /src/Development/Bake/Email.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | 3 | module Development.Bake.Email(ovenNotifyEmail) where 4 | 5 | import Development.Bake.Core.Type 6 | import Network.Mail.SMTP 7 | import Data.String 8 | 9 | 10 | -- | Send notifications using the given SMTP host/port. 11 | ovenNotifyEmail :: (Host, Port) -> Oven state patch test -> Oven state patch test 12 | ovenNotifyEmail (h,p) = ovenNotifyAdd $ \author subject body -> do 13 | sendMail' h (fromIntegral p) $ simpleMail 14 | (addr "bake@example.com") [addr author] [] [] 15 | (fromString $ "[Bake] " ++ subject) [htmlPart $ fromString body] 16 | where addr x = Address Nothing (fromString x) 17 | -------------------------------------------------------------------------------- /src/Development/Bake/Git.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | 3 | module Development.Bake.Git( 4 | SHA1, fromSHA1, toSHA1, ovenGit, 5 | gitPatchExtra, gitInit 6 | ) where 7 | 8 | import Development.Bake.Core.Type 9 | import General.Extra 10 | import Development.Shake.Command 11 | import Control.Monad.Extra 12 | import Data.List.Extra 13 | import General.HTML 14 | import System.Directory.Extra 15 | import System.FilePath 16 | import Data.Maybe 17 | import Data.Tuple.Extra 18 | import Data.Char 19 | import Data.Hashable 20 | import Data.Monoid 21 | import Prelude 22 | 23 | 24 | data SHA1 = SHA1 Int String deriving (Show,Eq) -- a number of leading primes, followed by a valid SHA1 25 | 26 | -- | Convert a SHA1 obtained from Git into a SHA1. Only done by ovenInit or ovenUpdate 27 | toSHA1 :: String -> SHA1 28 | toSHA1 x = checkSHA1 x $ SHA1 0 x 29 | 30 | fromSHA1 :: SHA1 -> String 31 | fromSHA1 (SHA1 _ x) = x 32 | 33 | instance Stringy SHA1 where 34 | stringyFrom x = checkSHA1 b $ SHA1 (length a) b 35 | where (a,b) = span (== '\'') x 36 | stringyTo (SHA1 primes sha) = replicate primes '\'' ++ sha 37 | stringyPretty (SHA1 primes sha) = replicate primes '\'' ++ take 7 sha 38 | 39 | -- either returns the second argument, or raises an error 40 | checkSHA1 :: String -> a -> a 41 | checkSHA1 x res 42 | | length x /= 40 = error $ "SHA1 for Git must be 40 characters long, got " ++ show x 43 | | not $ all (`elem` "0123456789abcdef") x = error $ "SHA1 for Git must be all lower case hex, got " ++ show x 44 | | otherwise = res 45 | 46 | 47 | -- | Modify an 'Oven' to work with the Git version control system. 48 | -- Requires the name of the repo (e.g. @https:\/\/github.com\/ndmitchell\/bake.git@) 49 | -- and the name of a branch (e.g. @master@). You can optionally give a path fragment 50 | -- which is used to clone into. 51 | ovenGit :: String -> String -> Maybe FilePath -> Oven () () test -> Oven SHA1 SHA1 test 52 | ovenGit repo branch (fromMaybe "." -> path) o = o 53 | {ovenInit = gitInit repo branch 54 | ,ovenUpdate = gitUpdate 55 | ,ovenPrepare = \s ps -> do gitCheckout s ps; ovenPrepare o () $ map (const ()) ps 56 | ,ovenPatchExtra = \s p -> gitPatchExtra s p =<< gitInitMirror 57 | ,ovenSupersede = \_ _ -> False 58 | } 59 | where 60 | gitSafe dir = do 61 | time_ $ cmd (Cwd dir) "git config user.email" ["https://github.com/ndmitchell/bake"] 62 | time_ $ cmd (Cwd dir) "git config user.name" ["Bake Continuous Integration"] 63 | 64 | -- initialise the mirror, or make it up to date 65 | gitInitMirror = traced "gitInitMirror" $ do 66 | -- make sure we descend one directory, since bake writes .bake.name 67 | mirror <- fmap ( "mirror") $ createDir "../bake-git" [repo] 68 | createDirectoryIfMissing True mirror 69 | -- see http://blog.plataformatec.com.br/2013/05/how-to-properly-mirror-a-git-repository/ 70 | ready <- doesFileExist $ mirror "HEAD" 71 | if ready then 72 | time_ $ cmd (Cwd mirror) "git fetch --prune" 73 | else do 74 | time_ $ cmd (Cwd mirror) "git clone --mirror" [repo] "." 75 | gitSafe mirror 76 | return mirror 77 | 78 | gitUpdate s ps = traced "gitUpdate" $ do 79 | gitCheckout s ps 80 | Stdout x <- time $ cmd (Cwd path) "git rev-parse" [branch] 81 | time_ $ cmd (Cwd path) "git push" [repo] [branch ++ ":" ++ branch] 82 | return $ toSHA1 $ trim x 83 | 84 | gitCheckout s ps = traced "gitCheckout" $ do 85 | createDirectoryIfMissing True path 86 | mirror <- gitInitMirror 87 | unlessM (doesDirectoryExist $ path ".git") $ do 88 | time_ $ cmd (Cwd path) "git init" 89 | gitSafe path 90 | time_ $ cmd (Cwd path) "git remote add origin" [(if path == "." then "" else "../") ++ mirror] 91 | time_ $ cmd (Cwd path) "git fetch" 92 | time_ $ cmd (Cwd path) "git reset" -- to unwedge a previous merge conflict 93 | time_ $ cmd (Cwd path) "git checkout" [branch] 94 | time_ $ cmd (Cwd path) "git reset --hard" ["origin/" ++ branch] 95 | Stdout x <- time $ cmd (Cwd path) "git rev-parse HEAD" 96 | when (trim x /= fromSHA1 s) $ error $ 97 | "The branch " ++ branch ++ " changed SHA1 independently of bake.\n" ++ 98 | "Expected value: " ++ fromSHA1 s ++ "\n" ++ 99 | "But has become: " ++ trim x 100 | forM_ ps $ \p -> 101 | time_ $ cmd (Cwd path) "git merge" (fromSHA1 p) 102 | 103 | 104 | gitInit :: String -> String -> IO SHA1 105 | gitInit repo branch = traced "gitInit" $ do 106 | Stdout hash <- time $ cmd "git ls-remote" [repo] [branch] 107 | case words $ concat $ takeEnd 1 $ lines hash of 108 | [] -> error "Couldn't find branch" 109 | x:xs -> return $ toSHA1 $ trim x 110 | 111 | 112 | traced :: String -> IO a -> IO a 113 | traced msg act = do 114 | putStrLn $ "% GIT: Begin " ++ msg 115 | res <- act 116 | putStrLn $ "% GIT: Finish " ++ msg 117 | return res 118 | 119 | 120 | --------------------------------------------------------------------- 121 | -- DIFF UTILITIES 122 | 123 | gitPatchExtra :: SHA1 -> Maybe SHA1 -> FilePath -> IO (String, String) 124 | gitPatchExtra s Nothing dir = do 125 | Stdout full <- time $ cmd (Cwd dir) "git log --no-merges -n10 --pretty=format:%s" [fromSHA1 s] 126 | Stdout count <- time $ cmd (Cwd dir) "git rev-list --count" [fromSHA1 s] 127 | let summary = takeWhile (/= '\n') full 128 | return (renderHTML $ do str_ $ count ++ " patches"; br_; str_ summary 129 | ,renderHTML $ pre_ $ str_ full) 130 | 131 | gitPatchExtra s (Just p) dir = do 132 | Stdout diff <- time $ cmd (Cwd dir) 133 | "git diff" [fromSHA1 s ++ "..." ++ fromSHA1 p] 134 | Stdout stat <- time $ cmd (Cwd dir) 135 | "git diff --stat" [fromSHA1 s ++ "..." ++ fromSHA1 p] 136 | Stdout log <- time $ cmd (Cwd dir) 137 | "git log --no-merges -n1 --pretty=format:%s" [fromSHA1 p] 138 | return (renderHTML $ do str_ $ reduceStat stat; br_; str_ $ take 120 $ takeWhile (/= '\n') log 139 | ,renderHTML $ pre_ $ do prettyStat stat; str_ "\n"; prettyDiff diff) 140 | 141 | 142 | reduceStat :: String -> String 143 | reduceStat = commasLimit 3 . map trim . map (takeWhile (/= '|')) . dropEnd 1 . lines 144 | 145 | 146 | diff :: FilePath -> String 147 | diff x = "diff:" ++ show (abs $ hash x) 148 | 149 | -- | 150 | -- > src/Paths.hs | 11 ++ 151 | -- > src/Test.hs | 258 ++++++++++++------------ 152 | -- > travis.hs | 4 +- 153 | -- > 28 files changed, 1612 insertions(+), 1302 deletions(-) 154 | prettyStat :: String -> HTML 155 | prettyStat = unlines_ . maybe [] (uncurry snoc . (map f *** str_)) . unsnoc . map trimStart . lines 156 | where 157 | f x = a__ [href_ $ "#" ++ diff a] (str_ a) <> str_ b <> g c 158 | where (ab,c) = break (== '|') x 159 | (a,b) = spanEnd isSpace ab 160 | g x@('+':_) = span__ [class_ "green"] (str_ a) <> g b 161 | where (a,b) = span (== '+') x 162 | g x@('-':_) = span__ [class_ "red"] (str_ a) <> g b 163 | where (a,b) = span (== '-') x 164 | g (x:xs) = str_ [x] <> g xs 165 | g [] = mempty 166 | 167 | 168 | -- | 169 | -- > diff --git a/bake.cabal b/bake.cabal 170 | -- > index 1aa1251..785cecc 100755 171 | -- > --- a/bake.cabal 172 | -- > +++ b/bake.cabal 173 | -- > @@ -1,7 +1,7 @@ 174 | -- > cabal-version: >= 1.10 175 | -- > build-type: Simple 176 | -- > name: bake 177 | -- > -version: 0.1 178 | -- > +version: 0.2 179 | prettyDiff :: String -> HTML 180 | prettyDiff = unlines_ . map f . lines 181 | where 182 | f x | "diff --git " `isPrefixOf` x = 183 | let files = [y | ab:'/':y <- drop 2 $ words x, ab `elem` "ab"] in 184 | a__ (take 1 [name_ $ diff y | y <- files]) mempty <> 185 | b_ (str_ x) 186 | f x | any (`isPrefixOf` x) ["index ","--- ","+++ "] = b_ $ str_ x 187 | f xs@('+':_) = span__ [class_ "green"] $ str_ xs 188 | f xs@('-':_) = span__ [class_ "red"] $ str_ xs 189 | f xs = str_ xs 190 | -------------------------------------------------------------------------------- /src/Development/Bake/Pretty.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, ViewPatterns #-} 2 | 3 | module Development.Bake.Pretty(ovenPretty, ovenPrettyMerge, Pretty(..)) where 4 | 5 | import Development.Bake.Core.Type 6 | import Data.List.Extra 7 | 8 | 9 | data Pretty a = Pretty String a deriving (Read,Show,Eq) 10 | 11 | instance Stringy a => Stringy (Pretty a) where 12 | stringyTo (Pretty a b) = a ++ "=" ++ stringyTo b 13 | stringyFrom s = case breakOn "=" s of 14 | (a,_:b) -> Pretty a $ stringyFrom b 15 | _ -> Pretty "" $ stringyFrom s 16 | stringyPretty (Pretty a b) = a ++ "=" ++ stringyPretty b 17 | 18 | 19 | -- | Define an oven that allows @foo=...@ annotations to be added to the strings. 20 | -- These can be used to annotate important information, e.g. instead of talking about 21 | -- Git SHA1's, you can talk about @person=SHA1@ or @branch=SHA1@. 22 | ovenPretty :: Oven state patch test -> Oven state (Pretty patch) test 23 | ovenPretty oven@Oven{..} = oven 24 | {ovenUpdate = \s ps -> ovenUpdate s (map unpretty ps) 25 | ,ovenPrepare = \s ps -> ovenPrepare s (map unpretty ps) 26 | ,ovenPatchExtra = \s p -> ovenPatchExtra s (fmap unpretty p) 27 | ,ovenSupersede = \p1 p2 -> ovenSupersede (unpretty p1) (unpretty p2) 28 | } 29 | where 30 | unpretty :: Pretty a -> a 31 | unpretty (Pretty _ x) = x 32 | 33 | -- | An oven suitable for use with 'ovenPretty' that supersedes patches which have the same 34 | -- pretty name. 35 | ovenPrettyMerge :: Oven state (Pretty patch) test -> Oven state (Pretty patch) test 36 | ovenPrettyMerge oven = oven 37 | {ovenSupersede = \(Pretty p1 _) (Pretty p2 _) -> p1 == p2 38 | } 39 | -------------------------------------------------------------------------------- /src/Development/Bake/Server/Brain.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, TupleSections #-} 2 | 3 | -- | Define a continuous integration system. 4 | module Development.Bake.Server.Brain( 5 | Memory(..), expire, 6 | Question(..), Answer(..), Ping(..), 7 | ClientInfo(..), 8 | prod 9 | ) where 10 | 11 | import Development.Bake.Core.Run 12 | import Development.Bake.Core.Type 13 | import Development.Bake.Core.Message 14 | import General.Extra 15 | import General.BigString 16 | import Data.Tuple.Extra 17 | import Data.Maybe 18 | import Data.Monoid 19 | import Control.Monad.Extra 20 | import Data.List.Extra 21 | import qualified Data.Map as Map 22 | import qualified Data.Set as Set 23 | import Development.Bake.Server.Store 24 | import Control.Exception.Extra 25 | import General.HTML 26 | import Prelude 27 | 28 | import Development.Bake.Server.Memory 29 | import Development.Bake.Server.Property 30 | 31 | 32 | -- any question that has been asked of a client who hasn't pinged since the time is thrown away 33 | expire :: UTCTime -> Memory -> Memory 34 | expire cutoff s 35 | | null died = s 36 | | otherwise = s{running = filter (flip notElem died . qClient . snd) $ running s 37 | ,clients = Map.map (\ci@ClientInfo{..} -> ci{ciAlive = ciAlive && pClient ciPing `notElem` died}) $ clients s} 38 | where died = [pClient ciPing | ClientInfo{..} <- Map.elems $ clients s, ciPingTime < cutoff, ciAlive] 39 | 40 | 41 | prod :: Memory -> Message -> IO (Memory, Maybe (Either String Question)) 42 | prod mem msg = safely $ do 43 | res <- update mem msg 44 | case res of 45 | Left err -> return (mem, Just $ Left err) 46 | Right mem -> do 47 | mem <- reacts mem 48 | case msg of 49 | Pinged p | null $ fatal mem, Just q <- output (ovenTestInfo $ oven mem) mem p -> 50 | case () of 51 | -- we still test things on the skip list when testing on a state (to get some feedback) 52 | _ | Just t <- qTest q, snd (qCandidate q) /= [], Just reason <- Map.lookup t (storeSkip $ store mem) -> do 53 | prod mem $ Finished q $ Answer (bigStringFromString $ "Skipped due to being on the skip list\n" ++ reason) Nothing [] True 54 | _ -> do 55 | now <- getCurrentTime 56 | return (mem{running = (now,q) : running mem}, Just $ Right q) 57 | _ -> return (mem, Nothing) 58 | where 59 | safely x = do 60 | res <- try_ x 61 | case res of 62 | Left e -> return (mem{fatal = show e : fatal mem}, Nothing) 63 | Right v -> return v 64 | 65 | 66 | reacts :: Memory -> IO Memory 67 | reacts = f 10 68 | where 69 | f 0 mem = return mem{fatal = "React got into a loop" : fatal mem} 70 | f i mem | null $ fatal mem, Just mem <- react mem = f (i-1) =<< mem 71 | | otherwise = return mem 72 | 73 | 74 | failingTestOutput :: Store -> Point -> Maybe Test -> Maybe String 75 | failingTestOutput store (state, patch) test = listToMaybe $ catMaybes 76 | [ storeRunFile store runid 77 | | (runid, _, _, Answer{aSuccess=False}) <- storeRunList store Nothing (Just test) (Just state) patch Nothing] 78 | 79 | 80 | react :: Memory -> Maybe (IO Memory) 81 | react mem@Memory{..} 82 | | xs <- rejectable mem 83 | , xs@(_:_) <- filter (\(p,t) -> t `Map.notMember` maybe Map.empty snd (paReject $ storePatch store p)) xs 84 | = Just $ do 85 | let fresh = filter (isNothing . paReject . storePatch store . fst) xs 86 | let point p = (fst active, takeWhile (/= p) (snd active) ++ [p]) 87 | bad <- if fresh == [] then return id else do 88 | -- only notify on the first rejectable test for each patch 89 | Shower{..} <- shower mem False 90 | notify mem "Rejected" 91 | [ (paAuthor,) $ do 92 | showPatch p <> str_ " submitted by " <> str_ paAuthor <> str_ " at " <> showTime paQueued 93 | str_ " rejected due to " <> showTestAt (point p) t 94 | whenJust (failingTestOutput store (point p) t) $ \s -> 95 | br_ <> br_ <> pre_ (summary s) 96 | | (p,t) <- nubOrdOn fst xs, let PatchInfo{..} = storePatch store p] 97 | 98 | store <- storeUpdate store 99 | [IUReject p t (point p) | (p,t) <- xs] 100 | return $ bad mem{store = store} 101 | 102 | | plausible mem 103 | , xs@(_:_) <- filter (isNothing . paPlausible . storePatch store) $ snd active 104 | = Just $ do 105 | Shower{..} <- shower mem False 106 | -- don't notify people twice in quick succession 107 | bad <- if mergeable mem then return id else 108 | notify mem "Plausible" 109 | [ (paAuthor, showPatch p <> str_ " submitted by " <> str_ paAuthor <> str_ " at " <> showTime paQueued <> str_ " is now plausible") 110 | | p <- xs, let PatchInfo{..} = storePatch store p] 111 | store <- storeUpdate store $ map IUPlausible xs 112 | return $ bad mem{store = store} 113 | 114 | | mergeable mem 115 | , not $ null $ snd active 116 | = Just $ do 117 | (s, answer) <- if not simulated then uncurry runUpdate active else do 118 | s <- ovenUpdate oven (fst active) (snd active) 119 | return (Just s, Answer mempty (Just 0) mempty True) 120 | 121 | case s of 122 | Nothing -> do 123 | return mem{fatal = ("Failed to update\n" ++ bigStringToString (aStdout answer)) : fatal} 124 | Just s -> do 125 | Shower{..} <- shower mem False 126 | bad <- notify mem "Merged" 127 | [ (paAuthor, showPatch p <> str_ " submitted by " <> str_ paAuthor <> str_ " at " <> showTime paQueued <> str_ " is now merged") 128 | | p <- snd active, let PatchInfo{..} = storePatch store p] 129 | store <- storeUpdate store $ IUState s answer (Just active) : map IUMerge (snd active) 130 | return $ bad mem{active = (s, []), store = store} 131 | 132 | | restrictActive mem 133 | , (reject@(_:_), keep) <- partition (isJust . paReject . storePatch store) $ snd active 134 | = Just $ do 135 | return mem{active = (fst active, keep)} 136 | 137 | | not paused 138 | , extendActive mem 139 | , add@(_:_) <- Set.toList $ storeAlive store `Set.difference` Set.fromList (snd active) 140 | = Just $ do 141 | add <- return $ sortOn (paQueued . storePatch store) add 142 | store <- storeUpdate store $ map IUStart add 143 | return mem 144 | {active = (fst active, snd active ++ add) 145 | ,store = store} 146 | 147 | | otherwise = Nothing 148 | 149 | 150 | update :: Memory -> Message -> IO (Either String Memory) 151 | update mem _ | fatal mem /= [] = return $ Right mem 152 | 153 | update mem@Memory{..} (AddPatch author p) = 154 | if storeIsPatch store p then 155 | return $ Left "patch has already been submitted" 156 | else do 157 | let queued = storeAlive store `Set.difference` Set.fromList (snd active) 158 | supersede = filter (\old -> ovenSupersede oven old p) $ Set.toList queued 159 | store <- storeUpdate store $ IUQueue p author : map IUSupersede supersede 160 | return $ Right mem{store = store} 161 | 162 | update mem@Memory{..} (DelPatch p) = 163 | if not $ p `Set.member` storeAlive store then 164 | return $ Left "patch is already dead or not known" 165 | else do 166 | store <- storeUpdate store [IUDelete p] 167 | return $ Right mem{store = store, active = second (delete p) active} 168 | 169 | update mem@Memory{..} (SetState author s) = 170 | if fst active == s then 171 | return $ Left "state is already at that value" 172 | else do 173 | store <- storeUpdate store [IUState s (Answer (bigStringFromString $ "From SetState by " ++ author) Nothing [] True) Nothing] 174 | return $ Right mem{store = store, active = (s, snd active)} 175 | 176 | update mem@Memory{..} Requeue = do 177 | let add = Set.toList $ storeAlive store `Set.difference` Set.fromList (snd active) 178 | add <- return $ sortOn (paQueued . storePatch store) add 179 | store <- storeUpdate store $ map IUStart add 180 | return $ Right mem 181 | {active = (fst active, snd active ++ add) 182 | ,store = store} 183 | 184 | update mem@Memory{..} Pause 185 | | paused = return $ Left "already paused" 186 | | otherwise = return $ Right mem{paused = True} 187 | 188 | update mem@Memory{..} Unpause 189 | | not paused = return $ Left "already unpaused" 190 | | otherwise = return $ Right mem{paused = False} 191 | 192 | update mem@Memory{..} (Pinged ping) = do 193 | now <- getCurrentTime 194 | return $ Right mem{clients = Map.alter (Just . ClientInfo now ping True . maybe Map.empty ciTests) (pClient ping) clients} 195 | 196 | update mem@Memory{..} (AddSkip author test) 197 | | test `Map.member` storeSkip store = return $ Left "already skipped" 198 | | otherwise = do 199 | store <- storeUpdate store [SUAdd test author] 200 | return $ Right mem{store = store} 201 | 202 | update mem@Memory{..} (DelSkip test) 203 | | test `Map.notMember` storeSkip store = return $ Left "already not skipped" 204 | | otherwise = do 205 | store <- storeUpdate store [SUDel test] 206 | return $ Right mem{store = store} 207 | 208 | update mem@Memory{..} (Finished q@Question{..} a@Answer{..}) = do 209 | bad <- case () of 210 | _ | snd qCandidate == [] -- on a state 211 | , not aSuccess 212 | , let skip = Set.mapMonotonic Just $ Map.keysSet $ storeSkip store 213 | , qTest `Set.notMember` skip -- not on the skip list 214 | , let failed = poFail $ storePoint store qCandidate 215 | , failed `Set.isSubsetOf` skip -- no notifications already 216 | -> do 217 | Shower{..} <- shower mem False 218 | notifyAdmins mem "State failure" $ do 219 | str_ "State " <> showState (fst qCandidate) 220 | str_ " failed due to " <> showTestAt qCandidate qTest <> br_ <> br_ 221 | pre_ (bigStringWithString aStdout summary) 222 | _ -> return id 223 | 224 | case () of 225 | _ | qTest == Nothing 226 | , Left bad <- validTests (ovenTestInfo oven) aTests 227 | -> fail bad 228 | _ -> return () 229 | 230 | now <- getCurrentTime 231 | let (eq,neq) = partition ((==) q . snd) running 232 | let time = head $ map fst eq ++ [now] 233 | store <- storeUpdate store [PURun time q a] 234 | let add ci = ci{ciTests = Map.insertWith (&&) (qCandidate, qTest) aSuccess $ ciTests ci} 235 | return $ Right $ bad mem 236 | {store = store 237 | ,clients = Map.adjust add qClient clients 238 | ,running = neq} 239 | 240 | 241 | -- | Given a state, figure out what you should do next. 242 | output :: (Test -> TestInfo Test) -> Memory -> Ping -> Maybe Question 243 | output info mem Ping{..} | pNowThreads == 0 = Nothing 244 | {- 245 | 1) try anyone who failed in active by bisecting 246 | 2) anyone not done in active or a superset 247 | 3) anyone not done in active 248 | -} 249 | output info mem@Memory{..} Ping{..} 250 | | False, pNowThreads == pMaxThreads, isNothing res = error $ show (enoughThreads $ listToMaybe $ filter suitable $ nubOrd $ concatMap dependencies $ bad ++ good, filter suitable good, concatMap dependencies $ bad ++ good, bad, good) 251 | | otherwise = res 252 | where 253 | res = fmap question $ enoughThreads $ listToMaybe $ filter suitable $ nubOrd $ concatMap dependencies $ bad ++ good 254 | 255 | self = storePoint store active 256 | failedSelf = Set.toList $ poFail self 257 | failedPrefix = Map.fromListWith mappend $ 258 | [ (t, case poTest po t of Just True -> ([i],[]); Just False -> ([],[i]); Nothing -> ([],[])) 259 | | (i, ps) <- zip [1..] $ tail $ inits $ snd active, let po = storePoint store (fst active, ps) 260 | , t <- failedSelf] 261 | 262 | bad = -- trace ("bisecting: " ++ show failedSelf) $ 263 | [(i, t) | (t,(pass,fail)) <- Map.toList failedPrefix 264 | -- assume 0 passed, so add to pass and delete from fail, 265 | -- ensures we never try and "blame" 0 (which we can't reject) 266 | , i <- bisect (0:pass) $ filter (/= 0) $ length (snd active):fail] 267 | 268 | setAddNothing = Set.insert Nothing . Set.mapMonotonic Just 269 | tests = setAddNothing $ fromMaybe Set.empty $ poTodo self 270 | doneSelf = poPass self `Set.union` poFail self 271 | passSuper = setAddNothing $ storeSupersetPass store active 272 | good = let (pri2,pri1) = partition (`Set.member` passSuper) $ 273 | sortOn (maybe 0 $ negate . testPriority . info) $ Set.toList $ 274 | tests `Set.difference` doneSelf 275 | in map (length $ snd active,) $ pri1 ++ pri2 276 | 277 | dependencies :: (Int, Maybe Test) -> [(Int, Maybe Test)] 278 | dependencies (i, t) = map (i,) $ flip transitiveClosure [t] $ \t -> case t of 279 | Nothing -> [] 280 | Just t -> Nothing : map Just (testDepend $ info t) 281 | 282 | histDone = ciTests $ clients Map.! pClient 283 | histStarted = Map.keysSet histDone `Set.union` Set.fromList [(qCandidate, qTest) | (_,Question{..}) <- running, qClient == pClient] 284 | threadsForTest = fromMaybe pMaxThreads . testThreads . info 285 | 286 | -- if there are not enough threads, don't do anything else, just wait for threads to become available 287 | enoughThreads :: Maybe (Int, Maybe Test) -> Maybe (Int, Maybe Test) 288 | enoughThreads (Just (i, t)) | pNowThreads >= maybe 1 threadsForTest t = Just (i, t) 289 | enoughThreads _ = Nothing 290 | 291 | unprefix i = second (take i) active 292 | 293 | suitable :: (Int, Maybe Test) -> Bool 294 | suitable (i, Nothing) 295 | | (unprefix i,Nothing) `Set.notMember` histStarted -- I have not done it 296 | = True 297 | suitable (i,Just t) 298 | | (unprefix i,Just t) `Set.notMember` histStarted -- I have not done it 299 | , Map.lookup (unprefix i,Nothing) histDone == Just True -- I have prepared 300 | , Just ts <- poTodo $ storePoint store (unprefix i) 301 | , t `Set.member` ts -- this test is relevant to this patch 302 | , all (`elem` pProvide) $ testRequire $ info t -- I can do this test 303 | , all (\t -> Map.lookup (unprefix i, Just t) histDone == Just True) $ testDepend $ info t -- I have done all the dependencies 304 | = True 305 | suitable _ = False 306 | 307 | question (i, t) = Question (second (take i) active) t (maybe 1 threadsForTest t) pClient 308 | 309 | 310 | -- | Given the passes, and the fails, suggest what you would like to try next 311 | bisect :: [Int] -> [Int] -> [Int] 312 | bisect pass fail 313 | | Just fail <- if null fail then Nothing else Just $ minimum fail 314 | , pass <- filter (< fail) pass 315 | , Just pass <- if null pass then Nothing else Just $ maximum pass 316 | = if fail - pass == 4 then [pass+2, pass+1, pass+3] 317 | else if fail - pass <= 3 then [pass+1 .. fail-1] 318 | else [(pass + fail) `div` 2] 319 | bisect _ _ = [] 320 | -------------------------------------------------------------------------------- /src/Development/Bake/Server/Database.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving, TemplateHaskell, FlexibleInstances, MultiParamTypeClasses, CPP #-} 2 | 3 | -- Stuff on disk on the server 4 | module Development.Bake.Server.Database( 5 | PointId, RunId, StateId, PatchId, patchIds, fromPatchIds, patchIdsSuperset, 6 | saTable, saId, saState, saCreate, saPoint, saDuration, 7 | #if OPALEYE 8 | SATable(..), SATableVal, SATableCol, saTable__, 9 | PCTable(..), PCTableVal, PCTableCol, pcTable__, 10 | #endif 11 | pcTable, pcId, pcPatch, pcAuthor, pcQueue, pcStart, pcDelete, pcSupersede, pcReject, pcPlausible, pcMerge, 12 | rjTable, rjPatch, rjTest, rjRun, 13 | ptTable, ptId, ptState, ptPatches, 14 | skTable, skTest, skComment, 15 | tsTable, tsPoint, tsTest, 16 | rnTable, rnId, rnPoint, rnTest, rnSuccess, rnClient, rnStart, rnDuration, 17 | create, save 18 | ) where 19 | 20 | import Development.Bake.Core.Type 21 | import Data.String 22 | import Control.Exception 23 | import General.Extra 24 | import qualified Database.SQLite3 as SQ 25 | import Database.SQLite.Simple 26 | import Database.SQLite.Simple.FromField 27 | import Database.SQLite.Simple.ToField 28 | import Data.Hashable 29 | import Data.List.Extra 30 | import Control.Monad 31 | import Data.Maybe 32 | import Safe 33 | import General.Database 34 | import Prelude 35 | 36 | #if OPALEYE 37 | import Opaleye hiding (Column) 38 | import Data.Profunctor.Product.TH(makeAdaptorAndInstance) 39 | import qualified Opaleye as O 40 | import qualified Opaleye.Internal.RunQuery as O 41 | #endif 42 | 43 | 44 | newtype PointId = PointId Int deriving (ToField, FromField, TypeField, Eq, Hashable) 45 | newtype RunId = RunId Int deriving (Eq, ToField, FromField, TypeField) 46 | newtype StateId = StateId Int deriving (ToField, FromField, TypeField) 47 | newtype PatchId = PatchId Int deriving (ToField, FromField, TypeField) 48 | 49 | instance Show PointId where show (PointId x) = "point-" ++ show x 50 | instance Show RunId where show (RunId x) = "run-" ++ show x 51 | instance Show StateId where show (StateId x) = "state-" ++ show x 52 | instance Show PatchId where show (PatchId x) = "patch-" ++ show x 53 | 54 | instance Read RunId where readsPrec i s = [x | Just s <- [stripPrefix "run-" s], x <- readsPrec i s] 55 | 56 | newtype PatchIds = PatchIds String deriving (ToField, FromField, TypeField) 57 | 58 | patchIds :: [PatchId] -> PatchIds 59 | patchIds = PatchIds . concatMap (\(PatchId x) -> "[" ++ show x ++ "]") 60 | 61 | patchIdsSuperset :: [PatchId] -> PatchIds 62 | patchIdsSuperset = PatchIds . ('%':) . concatMap (\(PatchId x) -> "[" ++ show x ++ "]%") 63 | 64 | fromPatchIds :: PatchIds -> [PatchId] 65 | fromPatchIds (PatchIds "") = [] 66 | fromPatchIds (PatchIds xs) = map (PatchId . readNote "fromPatchIds") $ splitOn "][" $ init $ tail xs 67 | 68 | 69 | #if OPALEYE 70 | data SATable a b c d e = SATable {saId_ :: a, saState_ :: b, saCreate_ :: c, saPoint_ :: d, saDuration_ :: e} 71 | type SATableVal = SATable StateId State UTCTime (Maybe PointId) (Maybe Seconds) 72 | type SATableCol = SATable (O.Column StateId) (O.Column State) (O.Column PGTimestamptz) (O.Column (Nullable Int)) (O.Column (Nullable PGFloat8)) 73 | type SATableColW = SATable (Maybe (O.Column StateId)) (O.Column State) (O.Column PGTimestamptz) (O.Column (Nullable Int)) (O.Column (Nullable PGFloat8)) 74 | 75 | $(makeAdaptorAndInstance "pSATable" ''SATable) 76 | 77 | saTable__ :: O.Table SATableColW SATableCol 78 | saTable__ = O.Table "state" $ pSATable $ 79 | SATable (optional "rowid") (required "state") (required "time") (required "point") (required "duration") 80 | 81 | instance O.QueryRunnerColumnDefault Patch Patch where 82 | queryRunnerColumnDefault = O.fieldQueryRunnerColumn 83 | instance O.QueryRunnerColumnDefault State State where 84 | queryRunnerColumnDefault = O.fieldQueryRunnerColumn 85 | #endif 86 | 87 | 88 | saTable = table "state" saId saState (saState,saCreate,saPoint,saDuration) 89 | saId = rowid saTable :: Column StateId 90 | saState = column saTable "state" :: Column State 91 | saCreate = column saTable "time" :: Column UTCTime 92 | saPoint = column saTable "point" :: Column (Maybe PointId) -- both are Nothing for a setstate 93 | saDuration = column saTable "duration" :: Column (Maybe Seconds) 94 | 95 | 96 | #if OPALEYE 97 | data PCTable a b c d e f g h i j = PCTable {pcId_ :: a, pcPatch_ :: b, pcAuthor_ :: c, pcQueue_ :: d, pcStart_ :: e, pcDelete_ :: f, pcSupersede_ :: g, pcReject_ :: h, pcPlausible_ :: i, pcMerge_ :: j} 98 | type PCTableVal = PCTable PatchId Patch String UTCTime (Maybe UTCTime) (Maybe UTCTime) (Maybe UTCTime) (Maybe UTCTime) (Maybe UTCTime) (Maybe UTCTime) 99 | type PCTableColW = PCTable (Maybe (O.Column PatchId)) (O.Column Patch) (O.Column PGText) (O.Column PGTimestamptz) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) 100 | type PCTableCol = PCTable (O.Column PatchId) (O.Column Patch) (O.Column PGText) (O.Column PGTimestamptz) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) (O.Column (Nullable PGTimestamptz)) 101 | 102 | $(makeAdaptorAndInstance "pPCTable" ''PCTable) 103 | 104 | pcTable__ :: O.Table PCTableColW PCTableCol 105 | pcTable__ = O.Table "patch" $ pPCTable $ 106 | PCTable (optional "rowid") (required "patch") (required "author") (required "queue") (required "start") 107 | (required "delete_") (required "supersede") (required "reject") (required "plausible") (required "merge") 108 | #endif 109 | 110 | 111 | pcTable = table "patch" pcId pcPatch (pcPatch, pcAuthor, pcQueue, pcStart, pcDelete, pcSupersede, pcReject, pcPlausible, pcMerge) 112 | pcId = rowid pcTable :: Column PatchId 113 | pcPatch = column pcTable "patch" :: Column Patch 114 | pcAuthor = column pcTable "author" :: Column String 115 | pcQueue = column pcTable "queue" :: Column UTCTime 116 | pcStart = column pcTable "start" :: Column (Maybe UTCTime) 117 | pcDelete = column pcTable "delete_" :: Column (Maybe UTCTime) 118 | pcSupersede = column pcTable "supersede" :: Column (Maybe UTCTime) 119 | pcReject = column pcTable "reject" :: Column (Maybe UTCTime) 120 | pcPlausible = column pcTable "plausible" :: Column (Maybe UTCTime) 121 | pcMerge = column pcTable "merge" :: Column (Maybe UTCTime) 122 | 123 | rjTable = table "reject" norowid () (rjPatch, rjTest, rjRun) 124 | rjPatch = column rjTable "patch" :: Column PatchId 125 | rjTest = column rjTable "test" :: Column (Maybe Test) 126 | rjRun = column rjTable "run" :: Column RunId 127 | 128 | ptTable = table "point" ptId (ptState, ptPatches) (ptState, ptPatches) 129 | ptId = rowid ptTable :: Column PointId 130 | ptState = column ptTable "state" :: Column StateId 131 | ptPatches = column ptTable "patches" :: Column PatchIds 132 | 133 | rnTable = table "run" rnId () (rnPoint, rnTest, rnSuccess, rnClient, rnStart, rnDuration) 134 | rnId = rowid rnTable :: Column RunId 135 | rnPoint = column rnTable "point" :: Column PointId 136 | rnTest = column rnTable "test" :: Column (Maybe Test) 137 | rnSuccess = column rnTable "success" :: Column Bool 138 | rnClient = column rnTable "client" :: Column Client 139 | rnStart = column rnTable "start" :: Column UTCTime 140 | rnDuration = column rnTable "duration" :: Column (Maybe Seconds) -- nothing for a skip 141 | 142 | tsTable = table "test" norowid () (tsPoint, tsTest) 143 | tsPoint = column tsTable "point" :: Column PointId 144 | tsTest = column tsTable "test" :: Column (Maybe Test) 145 | 146 | skTable = table "skip" norowid skTest (skTest, skComment) 147 | skTest = column skTable "test" :: Column Test 148 | skComment = column skTable "comment" :: Column String 149 | 150 | create :: Maybe FilePath -> IO Connection 151 | create file = do 152 | conn <- open $ fromMaybe ":memory:" file 153 | execute_ conn $ fromString "PRAGMA journal_mode = WAL;" 154 | execute_ conn $ fromString "PRAGMA synchronous = OFF;" 155 | sqlEnsureTable conn saTable 156 | sqlEnsureTable conn pcTable 157 | sqlEnsureTable conn rjTable 158 | sqlEnsureTable conn ptTable 159 | sqlEnsureTable conn rnTable 160 | sqlEnsureTable conn tsTable 161 | sqlEnsureTable conn skTable 162 | return conn 163 | 164 | save :: Connection -> FilePath -> IO () 165 | save conn file = void $ bracket (open file) close $ \dest -> bracket 166 | (SQ.backupInit (connectionHandle dest) (fromString "main") (connectionHandle conn) (fromString "main")) 167 | SQ.backupFinish $ 168 | \b -> SQ.backupStep b (-1) 169 | -------------------------------------------------------------------------------- /src/Development/Bake/Server/Memory.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes, TupleSections, GADTs, RecordWildCards #-} 2 | 3 | module Development.Bake.Server.Memory( 4 | ClientInfo(..), Memory(..), 5 | newMemory, stateFailure, 6 | notify, notifyAdmins, summary, 7 | Shower(..), shower, 8 | ) where 9 | 10 | import Development.Bake.Server.Store 11 | import qualified Data.Map as Map 12 | import Development.Bake.Core.Type 13 | import Data.Time 14 | import Development.Bake.Core.Message 15 | import Control.DeepSeq 16 | import qualified Data.Set as Set 17 | import Control.Exception.Extra 18 | import Data.Tuple.Extra 19 | import Data.List.Extra 20 | import Data.Maybe 21 | import General.HTML 22 | import Control.Monad 23 | import General.Extra 24 | import Data.Monoid 25 | import Prelude 26 | 27 | 28 | stateFailure = toState "" 29 | 30 | 31 | --------------------------------------------------------------------- 32 | -- THE DATA TYPE 33 | 34 | data ClientInfo = ClientInfo 35 | {ciPingTime :: UTCTime 36 | ,ciPing :: Ping 37 | ,ciAlive :: Bool 38 | ,ciTests :: Map.Map (Point, Maybe Test) Bool -- if a single failure, set to False 39 | } deriving (Eq,Show) 40 | 41 | data Memory = Memory 42 | -- READER 43 | {simulated :: Bool 44 | -- ^ Are we running in a simulation (don't spawn separate process) 45 | ,oven :: Oven State Patch Test 46 | -- ^ The oven under test 47 | ,prettys :: Prettys 48 | -- ^ The pretty functions 49 | 50 | -- STATE 51 | ,admins :: [Author] 52 | -- ^ People responsible for overall administration 53 | ,store :: Store 54 | -- ^ All the information on disk 55 | ,fatal :: [String] 56 | -- ^ A list of fatal error messages that have been raised by the server 57 | ,clients :: Map.Map Client ClientInfo 58 | -- ^ Latest time of a ping sent by each client 59 | ,running :: [(UTCTime, Question)] 60 | -- ^ Questions you have sent to clients and are waiting for. 61 | ,paused :: Bool 62 | -- ^ Pretend the queued is empty 63 | ,active :: Point 64 | -- ^ The target we are working at (some may already be rejected). 65 | -- Note that when restarting, we throw away the rejected ones. 66 | } 67 | 68 | newMemory :: Oven State Patch Test -> Prettys -> Store -> (State, Answer) -> IO Memory 69 | newMemory oven prettys store (state, answer) = do 70 | store <- storeUpdate store [IUState state answer Nothing] 71 | let ps = map fst $ sortOn (paQueued . snd) $ 72 | filter (isJust . paStart . snd) $ 73 | map (id &&& storePatch store) $ Set.toList $ storeAlive store 74 | return $ Memory False oven prettys [] store [] Map.empty [] False (state, ps) 75 | 76 | instance NFData Memory where 77 | rnf Memory{..} = () 78 | 79 | 80 | notify :: Memory -> String -> [(Author, HTML)] -> IO (Memory -> Memory) 81 | notify mem subject messages = do 82 | messages <- return $ concat [(a,b) : map (,b) (admins mem) | (a,b) <- messages] 83 | res <- try_ $ forM_ (groupSort messages) $ \(author, body) -> do 84 | let nl = br_ <> str_ "\n" -- important to include lots of lines or Outlook gets upset 85 | ovenNotify (oven mem) author subject $ renderHTML $ mconcat $ intersperse (nl <> nl) $ nubOrd body 86 | return $ \mem -> mem{fatal = ["Notification failure: " ++ show e | Left e <- [res]] ++ fatal mem} 87 | 88 | notifyAdmins :: Memory -> String -> HTML -> IO (Memory -> Memory) 89 | notifyAdmins mem subject message = notify mem subject $ map (,message) $ admins mem 90 | 91 | summary :: String -> HTML 92 | summary x | null $ drop 10000 x {- space efficient version of: length x < 10000 -} = str_ x 93 | | otherwise = str_ (take 5000 x) <> br_ <> str_ "..." <> br_ <> str_ (takeEnd 5000 x) 94 | 95 | data Shower = Shower 96 | {showLink :: String -> HTML -> HTML 97 | ,showPatch :: Patch -> HTML 98 | ,showExtra :: Either State Patch -> HTML 99 | ,showTest :: Maybe Test -> HTML 100 | ,showTestAt :: (State, [Patch]) -> Maybe Test -> HTML 101 | ,showQuestion :: Question -> HTML 102 | ,showClient :: Client -> HTML 103 | ,showState :: State -> HTML 104 | ,showCandidate :: (State, [Patch]) -> HTML 105 | ,showTime :: UTCTime -> HTML 106 | ,showThreads :: Int -> HTML 107 | } 108 | 109 | shower :: Memory -> Bool -> IO Shower 110 | shower Memory{prettys=Prettys{..},..} argsAdmin = do 111 | showRel <- showRelativeTime 112 | let shwState s | s == toState "" = span__ [class_ "bad" ] $ str_ $ "invalid state" 113 | shwState s = shwLink ("state=" ++ fromState s) $ str_ $ prettyState s 114 | let shwPatch p = shwLink ("patch=" ++ fromPatch p) $ str_ $ prettyPatch p 115 | return $ Shower 116 | {showLink = shwLink 117 | ,showPatch = shwPatch 118 | ,showState = shwState 119 | ,showCandidate = \(s,ps) -> do 120 | shwState s 121 | when (not $ null ps) $ str_ " plus " <> commas_ (map shwPatch ps) 122 | ,showExtra = \e -> raw_ $ maybe "" fst $ storeExtra store e 123 | ,showClient = \c -> shwLink ("client=" ++ url_ (fromClient c)) $ str_ $ fromClient c 124 | ,showTest = f Nothing Nothing [] 125 | ,showTestAt = \(s,ps) -> f Nothing (Just s) ps 126 | ,showQuestion = \Question{..} -> f (Just qClient) (Just $ fst qCandidate) (snd qCandidate) qTest 127 | ,showTime = \x -> span__ [class_ "nobr"] $ str_ $ showUTCTime "%H:%M" x ++ " UTC (" ++ showRel x ++ ")" 128 | ,showThreads = \i -> str_ $ show i ++ " thread" ++ ['s' | i /= 1] 129 | } 130 | where 131 | shwLink url = a__ [href_ $ (if argsAdmin then "?admin=&" else "?") ++ url] 132 | 133 | f c s ps t = 134 | shwLink (intercalate "&" parts) $ str_ $ 135 | maybe "Preparing" prettyTest t 136 | where parts = ["client=" ++ url_ (fromClient c) | Just c <- [c]] ++ 137 | ["state=" ++ url_ (fromState s) | Just s <- [s]] ++ 138 | ["patch=" ++ url_ (fromPatch p) | p <- ps] ++ 139 | ["test=" ++ url_ (maybe "" fromTest t)] 140 | -------------------------------------------------------------------------------- /src/Development/Bake/Server/Property.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, TupleSections #-} 2 | 3 | module Development.Bake.Server.Property( 4 | rejectable, plausible, mergeable, 5 | extendActive, restrictActive 6 | ) where 7 | 8 | import Development.Bake.Server.Memory 9 | import Development.Bake.Server.Store 10 | import qualified Data.Set as Set 11 | import qualified Data.Map as Map 12 | import Development.Bake.Core.Type 13 | import Data.Maybe 14 | import General.Extra 15 | import Data.List 16 | 17 | 18 | -- | I can reject the tests rejected because of the given patches 19 | rejectable :: Memory -> [(Patch, Maybe Test)] 20 | -- only look at failing tests in the current state 21 | -- find tests which have a passed/failed one apart 22 | -- assume the state passes everything 23 | -- if a test isn't avaiable at a point, it passes 24 | rejectable Memory{..} = 25 | [(last ps, t) 26 | | ps <- tail $ inits $ snd active 27 | , let me = storePoint store (fst active, ps) 28 | , let prev = if length ps == 1 then piState else storePoint store (fst active, init ps) 29 | , t <- failed 30 | , poTest me t == Just False && poTest prev t == Just True] 31 | where 32 | piState = PointInfo (Just Set.empty) (Set.singleton Nothing) Set.empty 33 | 34 | -- tests that are failing in self, interesting to consider 35 | failed = Set.toList $ poFail $ storePoint store active 36 | 37 | 38 | -- | I can mark all active patches as plausible 39 | plausible :: Memory -> Bool 40 | plausible Memory{..} 41 | | all (isNothing . paReject . storePatch store) $ snd active 42 | , PointInfo{..} <- storePoint store active 43 | , Just tests <- poTodo 44 | , Set.null poFail 45 | , tests `Set.isSubsetOf` Set.union (storeSupersetPass store active) (catMaybesSet poPass) 46 | = True 47 | plausible _ = False 48 | 49 | 50 | -- | I can merge all active patches 51 | mergeable :: Memory -> Bool 52 | mergeable mem@Memory{..} 53 | | plausible mem 54 | , PointInfo{..} <- storePoint store active 55 | , Just tests <- poTodo 56 | , tests == catMaybesSet poPass 57 | = True 58 | mergeable _ = False 59 | 60 | 61 | -- | Add in all extra patches that are queued 62 | extendActive :: Memory -> Bool 63 | -- either there are no patches being tested, or the ones being tested are all plausible 64 | -- relies on throwing out the rejected ones with restrictActive first 65 | extendActive Memory{..} = all (isJust . paPlausible . storePatch store) $ snd active 66 | 67 | 68 | -- | Throw out the patches that have been rejected 69 | restrictActive :: Memory -> Bool 70 | restrictActive Memory{..} 71 | -- I can reject someone for failing preparation 72 | | Nothing `Set.member` rejectedTests = True 73 | 74 | -- if all tests either (passed on active or a superset) 75 | -- or (failed on active and lead to a rejection) 76 | -- or (depend on a test that failed) 77 | | not $ Set.null rejectedTests 78 | , PointInfo{..} <- storePoint store active 79 | , Just tests <- poTodo 80 | , let pass = Set.union (storeSupersetPass store active) $ catMaybesSet $ poPass `Set.difference` poFail 81 | , flip all (Set.toList tests) $ \t -> 82 | t `Set.member` pass || any (flip Set.member rejectedTests . Just) (transitiveClosure (testDepend . ovenTestInfo oven) [t]) = True 83 | 84 | | otherwise = False 85 | 86 | where 87 | rejectedTests = Set.unions $ mapMaybe (fmap (Map.keysSet . snd) . paReject . storePatch store) $ snd active 88 | -------------------------------------------------------------------------------- /src/Development/Bake/Server/Start.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections, ViewPatterns #-} 2 | 3 | -- | Define a continuous integration system. 4 | module Development.Bake.Server.Start( 5 | startServer 6 | ) where 7 | 8 | import Development.Bake.Core.Type 9 | import General.Web 10 | import General.HTML 11 | import Development.Bake.Core.Message 12 | import Development.Bake.Core.Run 13 | import General.Extra 14 | import General.BigString 15 | import Development.Bake.Server.Brain 16 | import Development.Bake.Server.Web 17 | import Development.Bake.Server.Stats 18 | import Development.Bake.Server.Memory 19 | import Development.Bake.Server.Store 20 | import Control.Applicative 21 | import System.Time.Extra 22 | import Control.DeepSeq 23 | import Control.Exception.Extra 24 | import Data.List.Extra 25 | import Data.Maybe 26 | import Data.Tuple.Extra 27 | import Control.Monad.Extra 28 | import System.Console.CmdArgs.Verbosity 29 | import System.FilePath 30 | import qualified Data.Map as Map 31 | import qualified Data.Set as Set 32 | import qualified Data.Text as T 33 | import qualified Data.Text.Lazy as TL 34 | import Paths_bake 35 | import Prelude 36 | 37 | 38 | startServer :: (Stringy state, Stringy patch, Stringy test) 39 | => Port -> [Author] -> Seconds -> String -> Bool -> Oven state patch test -> IO () 40 | startServer port authors timeout admin fake (concrete -> (prettys, oven)) = do 41 | extra <- newWorker 42 | var <- newCVar =<< if fake then initialiseFake oven prettys else initialise oven prettys authors extra 43 | 44 | forkSlave $ forever $ do 45 | sleep timeout 46 | now <- getCurrentTime 47 | let prune = expire (addSeconds (negate timeout) now) 48 | modifyCVar_ var $ \s -> do 49 | let s2 = prune s 50 | bad <- clientChange s s2 51 | return $ bad s2 52 | 53 | putStrLn $ "Started server on port " ++ show port 54 | server port $ \i@Input{..} -> do 55 | whenLoud $ print i 56 | handle_ (fmap OutputError . showException) $ do 57 | now <- getCurrentTime 58 | let prune = expire (addSeconds (negate timeout) now) 59 | res <- 60 | if null inputURL then do 61 | -- prune but don't save, will reprune on the next ping 62 | fmap OutputHTML $ web admin inputArgs . prune =<< readCVar var 63 | else if ["html"] `isPrefixOf` inputURL then do 64 | datadir <- getDataDir 65 | return $ OutputFile $ datadir "html" last inputURL 66 | 67 | else if inputURL == ["dump"] then do 68 | mem <- readCVar var 69 | storeSave "temp.sqlite" $ store mem 70 | return $ OutputFile "temp.sqlite" 71 | 72 | else if inputURL == ["alive"] then do 73 | Memory{store} <- readCVar var 74 | let xs = sortOn (paQueued . storePatch store) $ Set.toList $ storeAlive store 75 | return $ OutputString $ unlines $ map fromPatch xs 76 | 77 | else if inputURL == ["active"] then do 78 | Memory{active} <- readCVar var 79 | return $ OutputString $ unlines $ map fromPatch $ snd active 80 | 81 | else if inputURL == ["state"] then do 82 | Memory{active} <- readCVar var 83 | return $ OutputString $ unlines [fromState $ fst active] 84 | 85 | else if inputURL == ["skip"] then do 86 | Memory{store} <- readCVar var 87 | return $ OutputString $ unlines $ map fromTest $ Map.keys $ storeSkip store 88 | 89 | else if ["api"] `isPrefixOf` inputURL then 90 | case messageFromInput i{inputURL = drop 1 inputURL} of 91 | Left e -> return $ OutputError $ "Encoding error when turning input into message, " ++ e ++ "\n\n" ++ take 100 (show i) 92 | Right v -> do 93 | evaluate $ rnf v 94 | res <- modifyCVar var $ \s -> do 95 | case v of 96 | AddPatch _ p -> extra $ do 97 | res <- patchExtra (fst $ active s) $ Just p 98 | storeExtraAdd (store s) (Right p) res 99 | _ -> return () 100 | (s2,q) <- recordIO $ (["brain",lower $ fst $ word1 $ show v],) <$> prod (prune s) v 101 | when (fst (active s2) /= fst (active s)) $ extra $ do 102 | res <- patchExtra (fst $ active s2) Nothing 103 | storeExtraAdd (store s2) (Left $ fst $ active s2) res 104 | bad <- clientChange s s2 105 | when (fatal s == [] && fatal s2 /= []) $ do 106 | void $ notifyAdmins s2 "Fatal error" $ pre_ $ summary $ head $ fatal s2 107 | return (bad s2,q) 108 | return $ case res of 109 | Just (Left e) -> OutputError e 110 | Just (Right q) -> questionToOutput $ Just q 111 | Nothing -> questionToOutput Nothing 112 | else 113 | return OutputMissing 114 | evaluate $ force res 115 | 116 | 117 | clientChange :: Memory -> Memory -> IO (Memory -> Memory) 118 | clientChange s1 s2 = do 119 | let before = Map.keysSet $ Map.filter ciAlive $ clients s1 120 | let after = Map.keysSet $ Map.filter ciAlive $ clients s2 121 | let f msg xs = sequence [notifyAdmins s2 (msg ++ ": " ++ fromClient x) $ str_ "" | x <- Set.toList xs] 122 | a <- f "Client added" $ after `Set.difference` before 123 | b <- f "Client timed out" $ before `Set.difference` after 124 | return $ foldr (.) id $ a ++ b 125 | 126 | 127 | initialiseFake :: Oven State Patch Test -> Prettys -> IO Memory 128 | initialiseFake oven prettys = do 129 | store <- newStore False "bake-store" 130 | mem <- newMemory oven prettys store (stateFailure, Answer (bigStringFromString "Initial state created by view mode") Nothing [] False) 131 | return mem{fatal = ["View mode, database is read-only"]} 132 | 133 | initialise :: Oven State Patch Test -> Prettys -> [Author] -> Worker -> IO Memory 134 | initialise oven prettys admins extra = do 135 | now <- getCurrentTime 136 | putStrLn "Initialising server, computing initial state..." 137 | (res, answer) <- runInit 138 | let state0 = fromMaybe stateFailure res 139 | putStrLn $ "Initial state: " ++ maybe "!FAILURE!" fromState res 140 | store <- newStore False "bake-store" 141 | when (isJust res) $ do 142 | extra $ storeExtraAdd store (Left state0) =<< patchExtra state0 Nothing 143 | mem <- newMemory oven prettys store (state0, answer) 144 | mem <- return mem{admins = admins ,fatal = ["Failed to initialise, " ++ bigStringToString (aStdout answer) | isNothing res]} 145 | 146 | bad <- if isJust res then notifyAdmins mem "Starting" $ str_ "Server starting" else 147 | notifyAdmins mem "Fatal error during initialise" $ 148 | str_ "Failed to initialise" <> br_ <> pre_ (bigStringWithString (aStdout answer) summary) 149 | return $ bad mem 150 | 151 | 152 | -- | Get information about a patch 153 | patchExtra :: State -> Maybe Patch -> IO (T.Text, TL.Text) 154 | patchExtra s p = do 155 | (ex,ans) <- runExtra s p 156 | case ex of 157 | Just x -> return x 158 | Nothing -> do 159 | let failSummary = T.pack $ renderHTML $ i_ $ str_ "Error when computing patch information" 160 | let failDetail = TL.pack $ renderHTML $ pre_ $ str_ (bigStringToString $ aStdout ans) 161 | return (failSummary, failDetail) 162 | -------------------------------------------------------------------------------- /src/Development/Bake/Server/Stats.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, TupleSections, ViewPatterns, ScopedTypeVariables, TypeOperators #-} 2 | 3 | module Development.Bake.Server.Stats( 4 | stats, 5 | record, recordIO 6 | ) where 7 | 8 | import Control.DeepSeq 9 | import Control.Applicative 10 | import Control.Monad 11 | import Development.Bake.Core.Type 12 | import Development.Bake.Server.Brain 13 | import Database.SQLite.Simple 14 | import Data.IORef 15 | import Data.Monoid 16 | import Data.List.Extra 17 | import General.HTML 18 | import General.Extra 19 | import Development.Bake.Server.Store 20 | import GHC.Stats 21 | import System.IO.Unsafe 22 | import System.Time.Extra 23 | import Control.Exception 24 | import Numeric.Extra 25 | import qualified Data.Map as Map 26 | import Prelude 27 | 28 | 29 | data Stat = Stat {statHistory :: [Double], statCount :: !Int, statSum :: !Double, statMax :: !Double} 30 | 31 | instance Monoid Stat where 32 | mempty = Stat [] 0 0 0 33 | mappend (Stat x1 x2 x3 x4) (Stat y1 y2 y3 y4) = Stat (take 10 $ x1 ++ y1) (x2+y2) (x3+y3) (x4 `max` y4) 34 | 35 | 36 | {-# NOINLINE recorded #-} 37 | recorded :: IORef (Map.Map String Stat) 38 | recorded = unsafePerformIO $ newIORef Map.empty 39 | 40 | record :: NFData b => (a -> ([String], b)) -> a -> b 41 | record f x = unsafePerformIO $ recordIO $ return $ f x 42 | 43 | recordIO :: NFData a => IO ([String], a) -> IO a 44 | recordIO x = do 45 | (d, (msg,x)) <- duration $ do x <- x; evaluate $ rnf x; return x 46 | forM_ (inits msg) $ \msg -> 47 | atomicModifyIORef recorded $ (,()) . Map.insertWith mappend (unwords msg) (Stat [d] 1 d d) 48 | return x 49 | 50 | 51 | stats :: Prettys -> Memory -> (Maybe Test -> HTML) -> IO HTML 52 | stats Prettys{..} Memory{..} showTest = do 53 | recorded <- readIORef recorded 54 | getGCStatsEnabled <- getGCStatsEnabled 55 | stats <- if getGCStatsEnabled then Just <$> getGCStats else return Nothing 56 | rel <- relativeTime 57 | 58 | [Only (patchCount :: Int)] <- storeSQL store "SELECT count(*) FROM patch" () 59 | [Only (stateCount :: Int)] <- storeSQL store "SELECT count(*) FROM state" () 60 | [Only (runCount :: Int)] <- storeSQL store "SELECT count(*) FROM run" () 61 | 62 | slowest :: [Only (Maybe Test) :. (Int, Seconds, Seconds, Seconds)] <- storeSQL store "SELECT test, count(*), avg(duration) as avg, sum(duration), max(duration) FROM run WHERE test NOT IN (SELECT test FROM skip) GROUP BY test ORDER BY avg DESC LIMIT 25" () 63 | [slowestAll :: (Int, Seconds, Seconds, Seconds)] <- storeSQL store "SELECT count(*), avg(duration) as avg, sum(duration), max(duration) FROM run" () 64 | rejections :: [(Maybe Test, Int)] <- storeSQL store "SELECT test, count(*) AS n FROM reject WHERE test IS NULL OR test NOT IN (SELECT test FROM skip) GROUP BY test ORDER BY n DESC LIMIT 10" () 65 | 66 | now <- getCurrentTime 67 | let periods = [addSeconds (negate x*24*60*60) now | x <- [1,7,30,365]] 68 | let one [Only x] = x 69 | one _ = 0 70 | plausibleCount :: [Int] <- forM periods $ \p -> one <$> storeSQL store "SELECT count(*) FROM patch WHERE plausible IS NOT NULL AND queue > ?" (Only p) 71 | plausibleAvg :: [Double] <- forM periods $ \p -> one <$> storeSQL store "SELECT ifnull(avg(julianday(plausible)-julianday(queue)),0.0) FROM patch WHERE plausible IS NOT NULL AND queue > ?" (Only p) 72 | percentiles <- forM [100,95,90,80,75,50,25,10,0] $ \perc -> (perc,) <$> do 73 | forM (zip periods plausibleCount) $ \(p,count) -> do 74 | let n = min (count - 1) $ ((count * perc) `div` 100) 75 | one <$> storeSQL store "SELECT julianday(plausible)-julianday(queue) AS x FROM patch WHERE plausible IS NOT NULL AND queue > ? ORDER BY x ASC LIMIT ?, 1" (p,n) 76 | 77 | deadSkip :: [(Test,String)] <- storeSQL store "SELECT skip.test, skip.comment FROM skip WHERE skip.test NOT IN (SELECT DISTINCT run.test FROM run WHERE run.test IS NOT NULL AND run.start > ?) ORDER BY test ASC" $ Only $ addSeconds (-7*24*60*60) now 78 | aliveSkip :: [(Test,String,Int, Int, Seconds)] <- storeSQL store "SELECT run.test, skip.comment, sum(run.success) AS good, count(*)-sum(run.success) AS bad, avg(run.duration) FROM run, skip WHERE run.test = skip.test AND run.duration IS NOT NULL AND run.start > ? GROUP BY skip.test ORDER BY bad ASC, good DESC" $ Only $ addSeconds (-7*24*60*60) now 79 | 80 | return $ do 81 | p_ $ str_ $ "Patches = " ++ show patchCount ++ ", states = " ++ show stateCount ++ ", runs = " ++ show runCount 82 | 83 | header_ "sampled" "Sampled statistics" 84 | let ms x = show (ceiling $ x * 1000 :: Integer) 85 | table ["Counter","Count","Mean (ms)","Sum (ms)","Max (ms)","Last 10 (ms)"] 86 | [ (if null name then i_ $ str_ "All" else str_ name) : 87 | map str_ [show statCount, ms $ statSum / intToDouble statCount, ms statSum 88 | ,ms statMax, unwords $ map ms statHistory] 89 | | (name,Stat{..}) <- Map.toAscList recorded] 90 | 91 | header_ "slowest" "Slowest tests (top 25)" 92 | table ["Test","Count","Mean","Sum","Max"] $ 93 | let f name (count, avg, sum, max) = name : map str_ [show count, showDuration avg, showDuration sum, showDuration max] 94 | in f (i_ $ str_ "All") slowestAll : [f (showTest test) x | (Only test :. x) <- slowest] 95 | 96 | header_ "rejects" "Most common rejection tests (top 10)" 97 | table ["Test","Rejections"] [[showTest t, str_ $ show x] | (t, x) <- rejections] 98 | 99 | header_ "plausible" "Speed to plausible" 100 | table ["Plausible","Last day","Last week","Last month","Last year"] $ 101 | let f x = str_ $ showDuration $ x*24*60*60 102 | perc 100 = "Maximum" 103 | perc 0 = "Minimum" 104 | perc x = show x ++ "% within" in 105 | (str_ "Count" : map (str_ . show) plausibleCount) : 106 | (str_ "Average" : map f plausibleAvg) : 107 | [str_ (perc p) : map f xs | (p,xs) <- percentiles] 108 | 109 | header_ "skip-stale" "Stale skips (not run in a week)" 110 | table ["Test","Comment"] 111 | [[showTest $ Just t, str_ c] | (t,c) <- deadSkip] 112 | 113 | header_ "skip-alive" "Alive skips (last week)" 114 | table ["Test","Comment","Successes","Failures","Avg duration"] $ 115 | [[showTest $ Just t, str_ c, str_ $ show s, str_ $ show f, str_ $ showDuration d] | (t,c,s,f,d) <- aliveSkip] 116 | 117 | header_ "ghc-stats" "GHC statistics" 118 | case stats of 119 | Nothing -> p_ $ str_ "No GHC stats, rerun with +RTS -T" 120 | Just x@GCStats{..} -> do 121 | ul_ $ do 122 | li_ $ str_ $ "Uptime of: " ++ showDuration wallSeconds 123 | li_ $ str_ $ "Haskell memory usage: " ++ show peakMegabytesAllocated ++ "Mb" 124 | li_ $ str_ $ "CPU time: " ++ showDuration cpuSeconds ++ 125 | " (mutator: " ++ showDuration mutatorCpuSeconds ++ ", GC: " ++ showDuration gcCpuSeconds ++ ")" 126 | pre_ $ str_ $ replace ", " "\n" $ takeWhile (/= '}') $ drop 1 $ dropWhile (/= '{') $ show x 127 | 128 | 129 | table :: [String] -> [[HTML]] -> HTML 130 | table cols body = table_ $ do 131 | thead_ $ tr_ $ mconcat $ map (td_ . str_) cols 132 | tbody_ $ mconcat $ [tr_ $ mconcat $ map td_ x | x <- body] 133 | -------------------------------------------------------------------------------- /src/Development/Bake/Server/Web.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, ViewPatterns, TupleSections #-} 2 | 3 | -- | Define a continuous integration system. 4 | module Development.Bake.Server.Web( 5 | web 6 | ) where 7 | 8 | import Development.Bake.Server.Brain 9 | import Development.Bake.Server.Store 10 | import Development.Bake.Server.Memory 11 | import Development.Bake.Server.Stats 12 | import Development.Bake.Core.Type 13 | import Development.Bake.Core.Message 14 | import General.Web 15 | import General.Extra 16 | import General.HTML 17 | import Data.List.Extra 18 | import Data.Tuple.Extra 19 | import Data.Either.Extra 20 | import System.Time.Extra 21 | import Data.Version 22 | import Data.Maybe 23 | import Data.Time.Calendar 24 | import Control.Monad.Extra 25 | import Data.Monoid 26 | import Paths_bake 27 | import qualified Data.Map as Map 28 | import qualified Data.Set as Set 29 | import Safe 30 | import Prelude 31 | 32 | 33 | web :: String -> [(String, String)] -> Memory -> IO String 34 | web admn (args admn -> a@Args{..}) mem@Memory{..} = recordIO $ fmap (first (\x -> ["web",x])) $ do 35 | shower@Shower{..} <- shower mem argsAdmin 36 | stats <- if argsStats then stats prettys mem showTest else return mempty 37 | now <- getCurrentTime 38 | return $ (valueHTML &&& renderHTML . void) $ template $ do 39 | when (fatal /= []) $ do 40 | h2__ [class_ "bad"] $ str_ "Fatal error" 41 | p_ $ str_ "The continuous integration server has been suspeneded due to fatal errors:" 42 | ul_ $ mconcat $ map (li_ . str_) fatal 43 | hr_ 44 | 45 | h1_ $ 46 | (if argsEmpty a then id else a__ [href_ $ if argsAdmin then "?admin=" else "."]) $ 47 | str_ "Bake Continuous Integration" 48 | 49 | if argsEmpty a{argsDate=Nothing} then do 50 | when (isNothing argsDate) $ do 51 | when paused $ 52 | p_ $ b_ (str_ "Paused") <> str_ ", new patches are paused until the queue is clear." 53 | failures shower mem 54 | progress shower mem 55 | 56 | p_ $ do 57 | str_ $ " Viewing " ++ maybe "yesterday and today" showDate argsDate ++ ": Goto " 58 | let shw d = showLink ("date=" ++ showDate d) $ str_ $ showDate d 59 | shw $ pred $ fromMaybe (timeToDate now) argsDate 60 | whenJust argsDate $ \d -> str_ ", " <> if timeToDate now == succ d then showLink "" $ str_ "today" else shw $ succ d 61 | 62 | table "No patches submitted" ["Submitted","Job","Status"] $ 63 | map (\p -> rowPatch shower mem argsAdmin p) $ 64 | map (either (Left . (id &&& storeState store)) (Right . (id &&& storePatch store))) $ 65 | storeItemsDate store $ (dateToTime *** fmap dateToTime) $ 66 | maybe (pred $ timeToDate now, Nothing) (\x -> (x, Just $ succ x)) argsDate 67 | 68 | unless (Map.null $ storeSkip store) $ do 69 | header_ "skipped" "Skipped tests" 70 | ul_ $ fmap mconcat $ forM (Map.toList $ storeSkip store) $ \(test,author) -> li_ $ do 71 | showTest (Just test) <> str_ (", by " ++ author ++ ".") 72 | when argsAdmin $ str_ " " <> admin (DelSkip test) (str_ "Remove") 73 | header_ "clients" "Clients" 74 | table "No clients available" ["Name","Running"] 75 | (map (rowClient shower mem) $ Nothing : map Just (Map.toList clients)) 76 | 77 | when argsAdmin $ do 78 | h2_ $ str_ "Admin" 79 | ul_ $ do 80 | li_ $ if null (Set.toList (storeAlive store) \\ snd active) 81 | then str_ "Cannot requeue, no queued patches" 82 | else admin Requeue $ str_ "Reqeue" 83 | li_ $ if paused 84 | then admin Unpause $ str_ "Unpause" 85 | else admin Pause $ str_ "Pause" 86 | return "home" 87 | 88 | else if argsStats then do 89 | stats 90 | return "stats" 91 | 92 | else if argsRaw then do 93 | let indent = (++) " " 94 | pre_ $ str_ $ unlines $ 95 | ["simulated = " ++ show simulated 96 | ,"store = " ++ show store 97 | ,"admins = " ++ show admins 98 | ,"fatal = " ++ show fatal 99 | ,"paused = " ++ show paused 100 | ,"active =", indent $ fromState $ fst active] ++ map (indent . fromPatch) (snd active) ++ 101 | ["clients = "] ++ [indent $ fromClient a ++ " = " ++ show b{ciTests=mempty} | (a,b) <- Map.toList clients] ++ 102 | ["running ="] ++ map (indent . show) running 103 | return "raw" 104 | 105 | else if isJust argsServer then do 106 | let s = fromJust argsServer 107 | table "No server operations" ["Time","Job","Duration"] $ 108 | map (("",) . rowUpdate shower mem) $ 109 | maybe (storeStateList store) (\s -> [(s, storeState store s)]) s 110 | whenJust s $ \s -> do 111 | h2_ $ str_ "Output" 112 | case storeStateFile store s of 113 | Nothing -> p_ $ i_ $ str_ "File missing" 114 | Just src -> pre_ $ str_ src 115 | return "server" 116 | 117 | else do 118 | let (keep,ignore) = splitAt 1000 $ 119 | map (\(t,q) -> (Nothing,t,q,Nothing)) (filter (argsFilter a . snd) running) ++ 120 | map (\(a,b,c,d) -> (Just a,b,c,Just d)) (storeRunList store argsClient argsTest argsState argsPatch argsRun) 121 | p_ $ let n = length keep in str_ $ "Found " ++ show n ++ " run" ++ ['s' | n /= 1] ++ (if null ignore then "" else ", truncated to 1000") 122 | table "No runs" ["Time","Job","Status"] $ 123 | map (rowHistory shower mem) keep 124 | 125 | case keep of 126 | _ | Just s <- argsState, argsEmpty a{argsState=Nothing} -> 127 | maybe' (storeExtra store $ Left s) (return "list") $ \(_, e) -> do 128 | h2_ $ str_ "State information"; raw_ e 129 | return "state" 130 | _ | [p] <- argsPatch, argsEmpty a{argsPatch=[]} -> 131 | maybe' (storeExtra store $ Right p) (return "list") $ \(_, e) -> do 132 | h2_ $ str_ "Patch information"; raw_ e 133 | return "patch" 134 | [(Just run,_,Question{..},Just Answer{..})] -> do 135 | when (argsAdmin && not aSuccess) $ whenJust qTest $ \t -> 136 | p_ $ admin (AddSkip "admin" t) $ str_ "Skip test" 137 | h2_ $ str_ "Output" 138 | pre_ $ str_ $ fromMaybe "Missing" $ storeRunFile store run 139 | return "output" 140 | _ -> return "list" 141 | 142 | 143 | data Args = Args 144 | {argsState :: Maybe State 145 | ,argsDate :: Maybe Day 146 | ,argsPatch :: [Patch] 147 | ,argsClient :: Maybe Client 148 | ,argsTest :: Maybe (Maybe Test) 149 | ,argsRun :: Maybe RunId 150 | ,argsServer :: Maybe (Maybe State) 151 | ,argsAdmin :: Bool 152 | ,argsStats :: Bool 153 | ,argsRaw :: Bool 154 | } 155 | deriving (Show,Eq) 156 | 157 | argsEmpty :: Args -> Bool 158 | argsEmpty x = x{argsAdmin=False} == args "" [] 159 | 160 | args :: String -> [(String, String)] -> Args 161 | args admn xs = Args 162 | (listToMaybe $ map toState $ ask "state") 163 | (listToMaybe $ map readDate $ ask "date") 164 | (map toPatch $ ask "patch") 165 | (listToMaybe $ map toClient $ ask "client") 166 | (listToMaybe $ map (\x -> if null x then Nothing else Just $ toTest x) $ ask "test") 167 | (listToMaybe $ map (readNote "run index") $ ask "run") 168 | (listToMaybe $ map (\x -> if null x then Nothing else Just $ toState x) $ ask "server") 169 | (any (if null admn then const True else (==) admn . encryptish) $ ask "admin") 170 | (not $ null $ ask "stats") 171 | (not $ null $ ask "raw") 172 | where ask x = map snd $ filter ((==) x . fst) xs 173 | 174 | argsFilter :: Args -> Question -> Bool 175 | argsFilter Args{..} Question{..} = 176 | isNothing argsRun && 177 | maybe True (== qClient) argsClient && 178 | maybe True (== qTest) argsTest && 179 | case argsState of 180 | Just s -> (s,argsPatch) == qCandidate 181 | Nothing | null argsPatch -> True 182 | _ -> not $ disjoint argsPatch (snd qCandidate) 183 | 184 | 185 | admin :: Message -> HTML -> HTML 186 | admin (messageToInput -> Input parts args _) body = a__ [href_ url, class_ "admin"] body 187 | where url = intercalate "/" parts ++ "?" ++ intercalate "&" [url_ a ++ "=" ++ url_ b | (a,b) <- args] 188 | 189 | table :: String -> [String] -> [(String, [HTML])] -> HTML 190 | table zero cols [] = p_ $ str_ zero 191 | table _ cols body = table_ $ do 192 | thead_ $ tr_ $ mconcat $ map (td_ . str_) cols 193 | tbody_ $ mconcat $ [tr__ [class_ cls] $ mconcat $ map td_ x | (cls,x) <- body] 194 | 195 | 196 | template :: HTML_ a -> HTML_ a 197 | template inner = do 198 | raw_ "" 199 | html_ $ do 200 | head_ $ do 201 | title_ $ str_ "Bake Continuous Integration" 202 | link__ [rel_ "shortcut icon", type_ "image/x-icon", href_ "html/favicon.ico"] 203 | style__ [type_ "text/css"] $ unlines 204 | ["body, td {font-family: sans-serif; font-size: 10pt;}" 205 | ,"table {border-collapse: collapse;}" 206 | ,"table, td {border: 1px solid #ccc;}" 207 | ,"td {padding: 2px; padding-right: 15px;}" 208 | ,"thead {font-weight: bold;}" 209 | ,"a {text-decoration: none; color: #4183c4;}" 210 | ,"a:hover {text-decoration: underline;}" 211 | ,".patch, .state {font-family: Consolas, monospace; white-space:nowrap;}" 212 | ,".info {font-size: 75%; color: #888;}" 213 | ,"a.info {color: #4183c4;}" -- tie breaker 214 | ,"a.self, a.self:hover {color: black; text-decoration: none;}" 215 | ,".good {font-weight: bold; color: darkgreen;}" 216 | ,".bad {font-weight: bold; color: darkred;}" 217 | ,".active {background-color: #ffc;}" 218 | ,".dull {background-color: #e6e6e6;}" 219 | ,".pass {background-color: #dfc;}" 220 | ,".fail {background-color: #fcc;}" 221 | ,".nobr {white-space: nowrap;}" 222 | ,".red {background-color: #ffdddd;}" 223 | ,".green {background-color: #ddffdd;}" 224 | ,"#footer {margin-top: 40px; font-size: 80%;}" 225 | ,"hr {margin-bottom: 30px;}" 226 | ,".admin {color: darkorange; font-weight: bold;}" 227 | ] 228 | body_ $ do 229 | inner 230 | p__ [id_ "footer"] $ 231 | a__ [href_ "https://github.com/ndmitchell/bake"] $ 232 | str_ $ "Copyright Neil Mitchell 2014-2015, version " ++ showVersion version 233 | return $ valueHTML inner 234 | 235 | 236 | failures :: Shower -> Memory -> HTML 237 | failures Shower{..} Memory{..} = when (snd active /= [] && ts /= []) $ do 238 | p_ $ str_ "Tracking down failures in:" 239 | ul_ $ mconcat $ map (li_ . showTest) ts 240 | where 241 | ts = Set.toList $ failed `Set.difference` reject 242 | failed = poFail $ storePoint store active 243 | reject = Set.unions $ mapMaybe (fmap (Map.keysSet . snd) . paReject . storePatch store) $ snd active 244 | 245 | 246 | progress :: Shower -> Memory -> HTML 247 | progress Shower{..} Memory{..} 248 | | null (snd active), Just todo <- poTodo, Set.size done == Set.size todo + 1 = return () -- Idle on a state 249 | | Just t <- poTodo = p_ $ b_ (str_ "Testing") <> 250 | str_ (", done " ++ show (Set.size done) ++ " tests out of " ++ show (Set.size t + 1) ++ superset) 251 | | isRunning = p_ $ b_ (str_ "Preparing") <> 252 | str_ (", getting ready to test" ++ superset) 253 | | otherwise = return () 254 | where 255 | PointInfo{..} = storePoint store active 256 | done = Set.union poPass poFail 257 | superset = let x = storeSupersetPass store active `Set.difference` catMaybesSet done 258 | x2 = maybe x (Set.intersection x) poTodo 259 | in if Set.null x2 then "" else ", and done " ++ show (Set.size x2) ++ " in a superset" 260 | isRunning = any ((==) active . qCandidate . snd) running 261 | 262 | 263 | showAnswer :: Maybe Answer -> HTML 264 | showAnswer Nothing = i_ $ str_ $ "Running..." 265 | showAnswer (Just Answer{..}) 266 | | Just d <- aDuration = if aSuccess 267 | then span__ [class_ "good"] $ str_ $ "Succeeded in " ++ showDuration d 268 | else span__ [class_ "bad" ] $ str_ $ "Failed in " ++ showDuration d 269 | | otherwise = str_ "Skipped" 270 | 271 | 272 | rowHistory :: Shower -> Memory -> (Maybe RunId, UTCTime, Question, Maybe Answer) -> (String, [HTML]) 273 | rowHistory Shower{..} Memory{..} (run, t, q@Question{..}, a) = ("", [showTime t, body, showAnswer a]) 274 | where 275 | body = do 276 | str_ "With " <> showCandidate qCandidate 277 | br_ 278 | str_ "Test " <> showQuestion q <> str_ " on " <> showClient qClient 279 | str_ " with " <> showThreads qThreads 280 | 281 | 282 | rowUpdate :: Shower -> Memory -> (State,StateInfo) -> [HTML] 283 | rowUpdate Shower{..} Memory{..} (s,StateInfo{..}) = [showTime stCreated, body, str_ $ maybe "" showDuration stDuration] 284 | where 285 | body = do 286 | showLink ("server=" ++ fromState s) $ str_ $ if isNothing stSource then "Initialised" else "Updated" 287 | whenJust stSource $ \src -> str_ " with " <> commas_ (map showPatch $ snd src) 288 | br_ 289 | whenJust stSource $ \src -> str_ "From " <> showState (fst src) 290 | str_ (if isJust stSource then " to " else "To ") <> showState s 291 | 292 | 293 | rowPatch :: Shower -> Memory -> Bool -> Either (State, StateInfo) (Patch,PatchInfo) -> (String, [HTML]) 294 | rowPatch Shower{..} mem@Memory{..} argsAdmin info = (code, [showTime time, state, body <> special]) 295 | where 296 | failed = case info of 297 | Right (p, PatchInfo{..}) -> fmap (second Map.toList) paReject 298 | Left (s, StateInfo{..}) -> if Set.null x then Nothing else Just (stCreated, map (,(s, [])) $ Set.toList x) 299 | where x = poFail (storePoint store (s, [])) `Set.difference` Set.mapMonotonic Just (Map.keysSet $ storeSkip store) 300 | 301 | code | Right (p,_) <- info, any (isSuffixOf [p] . snd . qCandidate . snd) running = "active" 302 | | Left (s,_) <- info, (s,[]) `elem` map (qCandidate . snd) running = "active" 303 | | isJust failed = "fail" 304 | | Right (_, PatchInfo{..}) <- info, isJust paDelete= "fail" 305 | | Right (_, PatchInfo{..}) <- info, isJust paSupersede || isNothing paStart = "dull" 306 | | Right (_, PatchInfo{..}) <- info, isJust paMerge || isJust paPlausible = "pass" 307 | | Left (s,_) <- info, fst active /= s = "pass" 308 | | Left (s,_) <- info, PointInfo{poTodo=Just todo,..} <- storePoint store (s,[]) 309 | , Set.size todo + 1 == Set.size (poPass `Set.union` poFail) = "pass" 310 | | otherwise = "" 311 | 312 | body 313 | | Just (time, xs) <- failed = do 314 | span__ [class_ "bad"] $ str_ $ if isLeft info then "Failed" else "Rejected" 315 | str_ " at " <> showTime time 316 | when (xs /= []) br_ 317 | span__ [class_ "info"] $ commasLimit_ 3 [showTestAt sps t | (t,sps) <- xs] 318 | | Right (_, p) <- info, paAlive p && isNothing (paStart p) = str_ "Queued" 319 | | Right (_, PatchInfo{paDelete=Just t}) <- info = span__ [class_ "bad"] (str_ "Deleted") <> str_ " at " <> showTime t 320 | | Right (_, PatchInfo{paSupersede=Just t}) <- info = str_ "Superseded at " <> showTime t 321 | | Right (_, PatchInfo{paMerge=Just t}) <- info = do 322 | span__ [class_ "good"] $ str_ "Merged" 323 | str_ " at " <> showTime t 324 | | Right (_, PatchInfo{paPlausible=Just t}) <- info = do 325 | span__ [class_ "good"] $ str_ "Plausible" 326 | str_ " at " <> showTime t 327 | | Left (s,_) <- info, fst active /= s = span__ [class_ "good"] $ str_ "Passed" 328 | | Left (s,_) <- info, PointInfo{poTodo=Just todo,..} <- storePoint store (s,[]) 329 | , Set.size todo + 1 == Set.size (poPass `Set.union` poFail) = span__ [class_ "good"] $ str_ "Passed" 330 | | otherwise = str_ "Active" 331 | 332 | special 333 | | argsAdmin, Right (p, pi) <- info = 334 | if paAlive pi then 335 | do br_; admin (DelPatch p) $ str_ "Delete" 336 | else if isNothing $ paMerge pi then 337 | do br_; admin (AddPatch (paAuthor pi) $ toPatch $ '\'' : fromPatch p) $ str_ "Retry" 338 | else 339 | mempty 340 | | otherwise = mempty 341 | 342 | state = do 343 | either ((str_ "State " <>) . showState . fst) ((str_ "Patch " <>) . showPatch . fst) info 344 | whenRight info $ \(pa, PatchInfo{..}) -> str_ $ " by " ++ paAuthor 345 | br_ 346 | span__ [class_ "info"] $ showExtra $ either (Left . fst) (Right . fst) info 347 | 348 | time = either (stCreated . snd) (paQueued . snd) info 349 | 350 | 351 | rowClient :: Shower -> Memory -> Maybe (Client, ClientInfo) -> (String, [HTML]) 352 | rowClient Shower{..} Memory{..} (Just (c, ClientInfo{..})) = ((if ciAlive then "" else "dull"),) $ 353 | [showLink ("client=" ++ url_ (fromClient c)) $ str_ $ fromClient c 354 | ,if null xs then i_ $ str_ "None" else mconcat $ intersperse br_ xs] 355 | where xs = reverse [showQuestion q <> str_ " started " <> showTime t | (t,q) <- running, qClient q == c] 356 | rowClient Shower{..} Memory{..} Nothing = ("",) $ 357 | [showLink "server=" $ i_ $ str_ "Server" 358 | ,showLink ("server=" ++ fromState (fst active)) (str_ $ if isNothing stSource then "Initialised" else "Updated") <> 359 | str_ " finished " <> showTime stCreated] 360 | where StateInfo{..} = storeState store $ fst active 361 | -------------------------------------------------------------------------------- /src/Development/Bake/StepGit.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, ViewPatterns #-} 2 | 3 | module Development.Bake.StepGit( 4 | ovenStepGit 5 | ) where 6 | 7 | import Development.Bake.Core.Type 8 | import Development.Bake.Git 9 | import Development.Shake.Command 10 | import Development.Shake.FilePath 11 | import Control.Exception.Extra 12 | import Control.Monad.Extra 13 | import System.Directory.Extra 14 | import General.Extra 15 | import Data.Maybe 16 | import Data.List.Extra 17 | import System.IO.Extra 18 | import System.IO.Unsafe 19 | 20 | 21 | -- | Oven creation for modules using git with the step strategy. 22 | -- Note that any files not in .gitignore will be removed at each step, so make sure your incremental build-products 23 | -- are properly ignored. 24 | ovenStepGit 25 | :: IO [FilePath] -- ^ Function that does a compile and returns the pieces that should be available at test time 26 | -> String -- ^ Git repo you are using 27 | -> String -- ^ Branch used as the initial starting point 28 | -> Maybe FilePath -- ^ Path under which the git will be checked out 29 | -> [String] -- ^ .gitignore patterns where build products live 30 | -> Oven () () test -- ^ Normal oven 31 | -> Oven SHA1 SHA1 test 32 | ovenStepGit act repo branch path keep o = o 33 | {ovenInit = gitInit repo branch 34 | ,ovenUpdate = stepUpdate 35 | ,ovenPrepare = \s ps -> do stepPrepare s ps; ovenPrepare o () $ map (const ()) ps 36 | ,ovenSupersede = \_ _ -> False 37 | ,ovenPatchExtra = stepExtra 38 | } 39 | where 40 | -- use a different failure name each run, so failures don't get persisted 41 | failure = unsafePerformIO $ do 42 | t <- getCurrentTime 43 | return $ "failure-" ++ showUTCTime "%Y-%m-%dT%H-%M-%S%Q" t <.> "txt" 44 | root = createDir "../bake-step-git" [repo,branch] 45 | 46 | gitEnsure = do 47 | root <- root 48 | let git = root fromMaybe "repo" path 49 | createDirectoryIfMissing True git 50 | withFileLock (root ".bake-lock") $ do 51 | ready <- doesFileExist $ git ".git/HEAD" 52 | if ready then do 53 | -- if a branch goes away on the server this is required 54 | time_ $ cmd (Cwd git) "git remote prune origin" 55 | -- for some reason git sometimes times out, not sure why 56 | -- hopefully this will help track it down 57 | time_ $ cmd (Cwd git) (Timeout $ 15*60) "git fetch" 58 | -- stops us creating lots of garbage in the reflog, which slows everything down 59 | -- time_ $ cmd (Cwd git) "git reflog expire --all --expire=all --expire-unreachable=all" 60 | time_ $ cmd (Cwd git) "git reset --hard" -- to unwedge a previous merge conflict 61 | time_ $ cmd (Cwd git) "git clean -dfx" ["-e" ++ x | x <- keep] -- to remove files left over from a previous merge conflict 62 | else do 63 | time_ $ cmd (Cwd git) "git clone" [repo] "." 64 | time_ $ cmd (Cwd git) "git config user.email" ["https://github.com/ndmitchell/bake"] 65 | time_ $ cmd (Cwd git) "git config user.name" ["Bake Continuous Integration"] 66 | return git 67 | 68 | gitSetState git s = do 69 | time_ $ cmd (Cwd git) "git checkout --force -B" [branch] [fromSHA1 s] 70 | 71 | gitApplyPatch git p = do 72 | time_ $ cmd (Cwd git) (WithStdout True) "git merge" [fromSHA1 p] 73 | 74 | stepExtra s p = do 75 | root <- root 76 | let (sh,a1) = splitAt 2 $ fromSHA1 $ fromMaybe s p 77 | unlessM (doesFileExist $ root fromMaybe "repo" path ".git/objects" sh a1) $ do 78 | void gitEnsure 79 | gitPatchExtra s p $ root fromMaybe "repo" path 80 | 81 | stepUpdate s ps = do 82 | root <- root 83 | git <- gitEnsure 84 | withFileLock (root ".bake-lock") $ do 85 | gitSetState git s 86 | forM_ ps $ gitApplyPatch git 87 | Stdout x <- time $ cmd (Cwd git) "git rev-parse" [branch] 88 | -- the branch may not already exist, or the update may not be a fast-forward 89 | -- since we support SetState 90 | Exit _ <- time $ cmd (Cwd git) "git push" [repo] [":" ++ branch] 91 | time_ $ cmd (Cwd git) "git push" [repo] [branch ++ ":" ++ branch] 92 | return $ toSHA1 $ trim x 93 | 94 | stepPrepare s ps = do 95 | root <- root 96 | dir <- createDir (root "../bake-step-point") $ map fromSHA1 $ s : ps 97 | unlessM (doesFileExist $ dir "result.tar") $ do 98 | git <- gitEnsure 99 | withFileLock (root ".bake-lock") $ do 100 | forM_ (inits ps) $ \ps -> do 101 | if null ps then 102 | gitSetState git s 103 | else 104 | gitApplyPatch git $ last ps 105 | dir <- createDir (root "../bake-step-point") $ map fromSHA1 $ s : ps 106 | unlessM (doesFileExist $ dir "result.tar") $ do 107 | whenM (doesFileExist $ dir failure) $ do 108 | hPutStrLn stderr "failure found" 109 | fail =<< readFile' (dir failure) 110 | res <- withCurrentDirectory git (timed "stepPrepare user action" act) `catch_` \e -> do 111 | writeFile (dir failure) =<< showException e 112 | throwIO e 113 | when (not $ null res) $ do 114 | -- FIXME: Should probably use tar -T rather than chunksOf (see #41) 115 | let tarfile = toStandard $ dir "result.tar" 116 | chunks = chunksOf 50 res 117 | time_ $ cmd "tar -cf" [tarfile] "-C" [toStandard git] (head chunks) 118 | forM_ (tail chunks) $ \srcfiles-> 119 | time_ $ cmd "tar -rf" [tarfile] "-C" [toStandard git] srcfiles 120 | 121 | createDirectoryIfMissing True $ fromMaybe "." path 122 | time_ $ cmd "tar -xf" [toStandard $ dir "result.tar"] "-C" [toStandard $ fromMaybe "." path] 123 | -------------------------------------------------------------------------------- /src/Development/Bake/Test/Simulate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, TupleSections, ViewPatterns #-} 2 | 3 | module Development.Bake.Test.Simulate( 4 | simulate 5 | ) where 6 | 7 | import Development.Bake.Core.Message 8 | import Development.Bake.Core.Type 9 | import Development.Bake.Server.Brain 10 | import Development.Bake.Server.Memory 11 | import Development.Bake.Server.Store 12 | import Control.Monad.Extra 13 | import Data.List.Extra 14 | import Data.Tuple.Extra 15 | import Data.Monoid 16 | import Data.Maybe 17 | import Numeric.Extra 18 | import General.Extra 19 | import System.Random 20 | import System.IO.Extra 21 | import System.Time.Extra 22 | import qualified Data.Set as Set 23 | import qualified Data.Map as Map 24 | import Control.Applicative 25 | import Prelude 26 | 27 | 28 | simulate :: IO () 29 | simulate = withBuffering stdout NoBuffering $ do 30 | performance 200 31 | basic 32 | bisect 33 | newTest 34 | quickPlausible 35 | replicateM_ 20 randomSimple 36 | 37 | --------------------------------------------------------------------- 38 | -- GENERIC SIMULATION ENGINE 39 | 40 | 41 | -- Properties! 42 | -- * By the time you finish, every patch must be propertly rejected or accepted 43 | -- * Clients must not be executing too much at one time 44 | 45 | data S s = S 46 | {user :: s 47 | ,memory :: Memory 48 | ,wait :: Int 49 | ,asked :: Set.Set Question 50 | ,patch :: [(Patch, Bool, Maybe Test -> Bool)] 51 | } 52 | 53 | unstate :: State -> [Patch] 54 | unstate = map toPatch . words . fromState 55 | 56 | restate :: [Patch] -> State 57 | restate = toState . unwords . map fromPatch 58 | 59 | data Step = Submit Patch Bool (Maybe Test -> Bool) -- are you OK for it to pass, are you OK for it to fail 60 | | Reply Question Bool [Test] 61 | | Request Client 62 | | Paused Bool 63 | 64 | simulation 65 | :: (Test -> TestInfo Test) -- ^ Static test information 66 | -> [(Client, Int)] -- ^ Clients, plus their maximum thread count 67 | -> s -- ^ initial seed 68 | -> ([Question] -> s -> IO (s, Bool, Step)) -- ^ step function 69 | -> IO s 70 | simulation testInfo workers u step = withTempDir $ \dir -> do 71 | t <- getCurrentTime 72 | s <- newStore True dir 73 | let oven = defaultOven 74 | {ovenUpdate = \s ps -> return $ restate $ unstate s ++ ps 75 | ,ovenTestInfo = testInfo 76 | ,ovenSupersede = \_ _ -> False 77 | ,ovenInit = undefined 78 | ,ovenPrepare = undefined 79 | ,ovenPatchExtra = undefined 80 | } 81 | mem <- newMemory oven (Prettys fromState fromPatch fromTest) s (restate [], Answer mempty (Just 0) [] True) 82 | mem <- return mem 83 | {active = (restate [], []) 84 | ,simulated = True} 85 | let s = S u mem 20 Set.empty [] 86 | 87 | let count s c = sum [qThreads | (_, Question{..}) <- running $ memory s, qClient == c] 88 | s@S{..} <- flip loopM s $ \s -> do 89 | -- print $ clients $ memory s 90 | -- print $ storePoint (store $ memory s) (active $ memory s) 91 | putChar '.' 92 | (u, cont, res) <- step (map snd $ running $ memory s) (user s) 93 | s <- return s{user = u} 94 | (msg,s) <- return $ case res of 95 | Submit p pass fail -> (AddPatch "" p, s{patch = (p,pass,fail) : patch s}) 96 | Reply q good tests -> 97 | let ans = Answer mempty (Just 0) (if good && isNothing (qTest q) then tests else []) good 98 | in (Finished q ans, s) 99 | Request c -> 100 | let Just mx = lookup c workers 101 | in (Pinged $ Ping c (fromClient c) [] mx $ mx - count s c, s) 102 | Paused b -> 103 | (if b then Pause else Unpause, s) 104 | (mem, q) <- prod (memory s) msg 105 | q <- return $ either error id <$> q 106 | -- print q 107 | when (fatal mem /= []) $ error $ "Fatal error, " ++ unlines (fatal mem) 108 | s <- return s{memory = mem} 109 | s <- return $ case q of 110 | Just q | q `Set.member` asked s -> error "asking a duplicate question" 111 | | otherwise -> s{asked = Set.insert q $ asked s} 112 | Nothing | not cont -> s{wait = wait s - 1} 113 | _ -> s 114 | return $ if wait s == 0 then Right s else Left s 115 | 116 | putStrLn "" 117 | let S{memory=Memory{..},..} = s 118 | 119 | -- putStrLn $ unlines $ map show $ Map.toList $ storePoints store 120 | 121 | unless (null running) $ error "Running should have been empty" 122 | unless (null $ snd active) $ error "Active should have been empty" 123 | unless (Set.null $ storeAlive store) $ error "Alive should have been empty" 124 | forM_ workers $ \(c,_) -> do 125 | (_, q) <- prod Memory{..} $ Pinged $ Ping c (fromClient c) [] maxBound maxBound 126 | when (isJust q) $ error "Brains should have returned sleep" 127 | 128 | forM_ patch $ \(p, pass, fail) -> 129 | case () of 130 | _ | pass -> unless (p `elem` unstate (fst active)) $ error $ show ("expected pass but not",p) 131 | | PatchInfo{paReject=Just (_,t)} <- storePatch store p -> unless (all fail $ Map.keys t) $ error "incorrect test failure" 132 | | otherwise -> error "missing patch" 133 | return user 134 | 135 | 136 | --------------------------------------------------------------------- 137 | -- SPECIFIC SIMULATIONS 138 | 139 | randomSimple :: IO () 140 | randomSimple = do 141 | let info t = mempty{testDepend = [toTest "1" | t /= toTest "1"]} 142 | 143 | i <- randomRIO (0::Int,10) 144 | patches <- forM [0..i] $ \i -> do 145 | j <- randomRIO (0::Int,9) 146 | return $ toPatch $ show i ++ show j 147 | let failure t p = maybe "0" fromTest t `isSuffixOf` fromPatch p 148 | 149 | let client = toClient "c" 150 | simulation info [(client,2)] patches $ \active patches -> do 151 | i <- randomRIO (0::Int, 20) 152 | let cont = not $ null active && null patches 153 | case i of 154 | 0 | p:patches <- patches -> do 155 | let pass = last (fromPatch p) > '3' 156 | return (patches, cont, Submit p pass (`failure` p)) 157 | 158 | i | i <= 2, not $ null active -> do 159 | i <- randomRIO (0, length active - 1) 160 | let q = active !! i 161 | let good = not $ any (failure $ qTest q) $ unstate (fst $ qCandidate q) ++ snd (qCandidate q) 162 | return (patches, cont, Reply q good $ map toTest ["1","2","3"]) 163 | 164 | _ -> return (patches, cont, Request client) 165 | putStrLn "Success at randomSimple" 166 | 167 | 168 | quickPlausible :: IO () 169 | quickPlausible = do 170 | let info t = mempty{testPriority = if t == toTest "3" then 1 else if t == toTest "1" then -1 else 0} 171 | let client = toClient "c" 172 | let tests = map toTest ["1","2","3","4","5"] 173 | -- start, process 2 tests, add a patch, then process the rest 174 | -- expect to see 1, X, 1, rest, X 175 | 176 | let todo = [Paused True 177 | ,Submit (toPatch "0") True (const False) 178 | ,Submit (toPatch "1") False (== Just (toTest "3")) 179 | ,Submit (toPatch "2") True (const False) 180 | ,Paused False 181 | ,Submit (toPatch "3") True (const False)] 182 | 183 | simulation info [(client,1)] todo $ \active todo -> return $ case () of 184 | _ | t:odo <- todo -> (odo, True, t) 185 | | q@Question{..}:_ <- active -> 186 | if snd qCandidate == [toPatch "0",toPatch "2"] && qTest `notElem` [Nothing, Just $ toTest "3"] then error "bad quickPlausible" 187 | else (todo, True, Reply q (not $ qTest == Just (toTest "3") && toPatch "1" `elem` unstate (fst qCandidate) ++ snd qCandidate) tests) 188 | | otherwise -> (todo, False, Request client) 189 | putStrLn $ "Success at quickPlausible" 190 | 191 | 192 | bisect :: IO () 193 | bisect = do 194 | let info t = mempty 195 | let tests = map (toTest . show) [1 .. 3 :: Int] 196 | let client = toClient "c" 197 | (done,_) <- simulation info [(client,1)] (0, map (toPatch . show) [1 .. 1024 :: Int]) $ \active (done,patches) -> return $ case () of 198 | _ | p:patches <- patches -> ((done,patches), True, Submit p (p /= toPatch "26") (\t -> p == toPatch "26" && t == Just (toTest "2"))) 199 | | q:_ <- active -> ((done+1,[]), True, Reply q (qTest q /= Just (toTest "2") || toPatch "26" `notElem` (unstate (fst $ qCandidate q) ++ snd (qCandidate q))) tests) 200 | | otherwise -> ((done,[]), False, Request client) 201 | when (done > 50) $ error "Did too many tests to bisect" 202 | putStrLn "Success at bisect" 203 | 204 | 205 | basic :: IO () 206 | basic = do 207 | -- have test x, fails in patch 4 of 5 208 | let info t = mempty 209 | let client = toClient "c" 210 | simulation info [(client,1)] (map (toPatch . show) [1..5 :: Int]) $ \active patches -> return $ case () of 211 | _ | p:patches <- patches -> (patches, True, Submit p (p /= toPatch "4") (\t -> p == toPatch "4" && t == Just (toTest "x"))) 212 | | q:_ <- active, let isX = qTest q == Just (toTest "x"), let has12 = toPatch "4" `elem` snd (qCandidate q) -> 213 | ([], True, Reply q (not $ isX && has12) (map toTest ["x"])) 214 | | otherwise -> ([], False, Request client) 215 | putStrLn "Success at basic" 216 | 217 | 218 | newTest :: IO () 219 | newTest = do 220 | -- had test x,y all along. Introduce z/q at newPatch, and z either always fails or always passes 221 | let info t = mempty 222 | let client = toClient "c" 223 | let tests = map toTest ["x","y"] 224 | let patches = map (toPatch . show) [1..20 :: Int] 225 | let newTest = toTest "z" 226 | let newPatch = toPatch "12" 227 | 228 | forM_ [False,True] $ \pass -> do 229 | simulation info [(client,1)] patches $ \active patches -> return $ case () of 230 | _ | p:patches <- patches -> (patches, True, Submit p (p /= newPatch || pass) (\t -> not pass && p == newPatch && t == Just newTest)) 231 | | q:_ <- active, let isTest = qTest q == Just newTest, let isPatch = newPatch `elem` snd (qCandidate q) -> 232 | if isTest && not isPatch then error $ "Running a test that doesn't exist, " ++ show q 233 | else ([], True, Reply q (not isTest || pass) (tests ++ [newTest | isPatch] ++ [toTest "q" | isPatch])) 234 | | otherwise -> ([], False, Request client) 235 | putStrLn "Success at newtest" 236 | 237 | performance :: Int -> IO () 238 | performance nTests = timed $ do 239 | -- TODO: ping the website regularly 240 | -- 1000 tests, 50 submissions, 7 failing, spawn about every 200 tests 241 | let nPatches = 50 242 | let f x = min (nTests-1) $ max 0 $ round $ intToDouble nTests * x 243 | let fails = [(3,f 0.2),(4,f 0),(10,f 0.1),(22,f 0.6),(40,f 0.6),(48,f 0.9),(49,f 0.9)] 244 | 245 | let pri = toTest $ show $ f 0.1 246 | let npri = length $ fromTest pri 247 | let info t = mempty{testPriority = case compare (length $ fromTest t) npri of 248 | LT -> 1; GT -> 0; EQ -> if t < pri then 1 else 0} 249 | let client = toClient "c" 250 | let tests = map (toTest . show) [0 :: Int .. nTests - 1] 251 | simulation info [(client,3)] (0::Int, 0::Int) $ \active (patch,tick) -> return $ case () of 252 | _ | tick >= f 0.2, patch < nPatches -> 253 | let pass = patch `notElem` map fst fails 254 | fail t = (patch,maybe (-1) (read . fromTest) t) `elem` fails 255 | in ((patch+1, 0), True, Submit (toPatch $ show patch) pass fail) 256 | | q:_ <- active -> 257 | let pass = and [ (read $ fromPatch p, maybe (-1) (read . fromTest) $ qTest q) `notElem` fails 258 | | p <- unstate (fst $ qCandidate q) ++ snd (qCandidate q)] 259 | in ((patch, tick+1), True, Reply q pass tests) 260 | | otherwise -> ((patch, tick), patch /= nPatches, Request client) 261 | putStrLn $ "Success at performance" 262 | where 263 | timed act = do 264 | (t, _) <- duration act 265 | putStrLn $ "Performance test took " ++ showDuration t 266 | -------------------------------------------------------------------------------- /src/Example.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | 3 | module Example(main, platforms) where 4 | 5 | import Development.Bake 6 | import Development.Shake.Command 7 | import System.Environment.Extra 8 | import System.FilePath 9 | import Data.List.Extra 10 | import Data.Tuple.Extra 11 | import System.Directory 12 | import Control.Monad 13 | import Data.Maybe 14 | import System.Time.Extra 15 | 16 | useStep = True 17 | 18 | data Platform = Linux | Windows deriving (Show,Read) 19 | data Action = Compile | Run Int deriving (Show,Read) 20 | 21 | instance Stringy (Platform, Action) where 22 | stringyTo (a,b) = show a ++ " " ++ show b 23 | stringyFrom = (read *** read) . word1 24 | 25 | 26 | platforms = [Linux,Windows] 27 | 28 | main :: IO () 29 | main = do 30 | let err = "You need to set an environment variable named $REPO for the Git repo" 31 | repo <- fromMaybe (error err) `fmap` lookupEnv "REPO" 32 | bake $ 33 | ovenPretty $ 34 | (if useStep 35 | then ovenStepGit compile repo "master" Nothing ["dist"] 36 | else ovenIncremental . ovenGit repo "master" Nothing) $ 37 | ovenNotifyStdout $ 38 | ovenTest (return allTests) execute 39 | defaultOven{ovenServer=("127.0.0.1",5000)} 40 | 41 | allTests = [(p,t) | p <- platforms, t <- Compile : map Run [1,10,0]] 42 | 43 | compile :: IO [FilePath] 44 | compile = do 45 | createDirectoryIfMissing True "dist" 46 | unit $ cmd "ghc --make Main.hs -o dist/Main" 47 | -- ghc --make only has 1 second timestamp resolution 48 | -- so sleep for a second to make sure we work with incremental compilation 49 | sleep 1 50 | return ["dist"] 51 | 52 | execute :: (Platform,Action) -> TestInfo (Platform,Action) 53 | execute (p,Compile) = require [show p] $ run $ unless useStep $ do 54 | incrementalStart 55 | compile 56 | incrementalDone 57 | execute (p,Run i) = depend [(p,Compile)] $ require [show p] $ run $ 58 | cmd ("dist" "Main") (show i) 59 | -------------------------------------------------------------------------------- /src/General/BigString.hs: -------------------------------------------------------------------------------- 1 | 2 | module General.BigString( 3 | BigString, 4 | bigStringFromFile, bigStringFromText, bigStringFromString, bigStringFromByteString, 5 | bigStringToFile, bigStringToText, bigStringToString, bigStringWithString, bigStringToByteString, 6 | bigStringBackEnd, withBigStringPart 7 | ) where 8 | 9 | import System.IO.Extra 10 | import Control.DeepSeq 11 | import Foreign.Ptr 12 | import Foreign.ForeignPtr 13 | import Foreign.Concurrent 14 | import System.IO.Unsafe 15 | import Control.Exception 16 | import Data.Monoid 17 | import System.Directory 18 | import qualified Data.Text as T 19 | import qualified Data.Text.Encoding as T 20 | import qualified Data.Text.IO as T 21 | import qualified Data.ByteString.Char8 as BS 22 | import qualified Data.ByteString.Lazy.Char8 as LBS 23 | import Network.Wai.Parse 24 | import Data.Function 25 | import Control.Monad 26 | import Network.HTTP.Client.MultipartFormData 27 | import Prelude 28 | 29 | limit = 5000 -- above this level, save to disk 30 | 31 | 32 | --------------------------------------------------------------------- 33 | -- DEFINITION 34 | 35 | data BigString = Memory T.Text 36 | | File FilePath (ForeignPtr ()) 37 | 38 | instance Monoid BigString where 39 | mempty = bigStringFromText mempty 40 | mappend (Memory a) (Memory b) | T.length a + T.length b <= limit = Memory $ a <> b 41 | mappend x y = unsafeWriteHandle $ \out -> do 42 | hSetBinaryMode out True 43 | forM_ [x,y] $ \inp -> readHandle inp $ \inp -> do 44 | hSetBinaryMode inp True 45 | src <- LBS.hGetContents inp 46 | LBS.hPut out src 47 | 48 | instance NFData BigString where 49 | rnf (Memory x) = rnf x 50 | rnf (File a b) = rnf a `seq` b `seq` () 51 | 52 | instance Show BigString where 53 | show _ = "" 54 | 55 | --------------------------------------------------------------------- 56 | -- PRIMITIVES 57 | 58 | bigStringFromFile :: (FilePath -> IO a) -> IO (BigString, a) 59 | bigStringFromFile op = do 60 | (file, close) <- newTempFile 61 | ptr <- newForeignPtr_ nullPtr 62 | Foreign.Concurrent.addForeignPtrFinalizer ptr close 63 | res <- withForeignPtr ptr $ const $ op file 64 | return (File file ptr, res) 65 | 66 | -- Not exported, as it is a bit unsafe - two invariants: 67 | -- 1) must not use file after returning 68 | -- 2) must not write to the file 69 | bigStringWithFile :: BigString -> (FilePath -> IO a) -> IO a 70 | bigStringWithFile (Memory x) op = withTempFile $ \file -> do T.writeFile file x; op file 71 | bigStringWithFile (File file ptr) op = withForeignPtr ptr $ const $ op file 72 | 73 | 74 | writeHandle :: (Handle -> IO ()) -> IO BigString 75 | writeHandle op = fmap fst $ bigStringFromFile $ \file -> 76 | withFile file WriteMode $ \h -> do 77 | hSetNewlineMode h noNewlineTranslation 78 | hSetEncoding h utf8 79 | op h 80 | 81 | readHandle :: BigString -> (Handle -> IO a) -> IO a 82 | readHandle x op = bigStringWithFile x $ \file -> 83 | withFile file ReadMode $ \h -> do 84 | hSetNewlineMode h noNewlineTranslation 85 | hSetEncoding h utf8 86 | op h 87 | 88 | 89 | {-# NOINLINE unsafeWriteHandle #-} 90 | unsafeWriteHandle :: (Handle -> IO ()) -> BigString 91 | unsafeWriteHandle op = unsafePerformIO $ writeHandle op 92 | 93 | {-# NOINLINE unsafeReadHandle #-} 94 | unsafeReadHandle :: BigString -> (Handle -> IO a) -> a 95 | unsafeReadHandle x op = unsafePerformIO $ readHandle x op 96 | 97 | 98 | --------------------------------------------------------------------- 99 | -- DERIVED 100 | 101 | bigStringFromText :: T.Text -> BigString 102 | bigStringFromText x | T.length x <= limit = Memory x 103 | | otherwise = unsafeWriteHandle (`T.hPutStr` x) 104 | 105 | bigStringFromString :: String -> BigString 106 | bigStringFromString x | null $ drop limit x = Memory $ T.pack x 107 | | otherwise = unsafeWriteHandle (`hPutStr` x) 108 | 109 | bigStringToFile :: BigString -> FilePath -> IO () 110 | bigStringToFile (Memory x) out = withFile out WriteMode $ \h -> do 111 | hSetNewlineMode h noNewlineTranslation 112 | hSetEncoding h utf8 113 | T.hPutStr h x 114 | bigStringToFile x out = bigStringWithFile x $ \file -> copyFile file out 115 | 116 | bigStringToText :: BigString -> T.Text 117 | bigStringToText (Memory x) = x 118 | bigStringToText x = unsafeReadHandle x T.hGetContents 119 | 120 | bigStringToString :: BigString -> String 121 | bigStringToString (Memory x) = T.unpack x 122 | bigStringToString x = unsafeReadHandle x $ fmap T.unpack . T.hGetContents 123 | 124 | bigStringWithString :: NFData a => BigString -> (String -> a) -> a 125 | bigStringWithString (Memory x) op = let res = op $ T.unpack x in rnf res `seq` res 126 | bigStringWithString x op = unsafeReadHandle x $ \h -> do 127 | src <- hGetContents h 128 | let res = op src 129 | evaluate $ rnf res 130 | return res 131 | 132 | bigStringFromByteString :: BS.ByteString -> BigString 133 | bigStringFromByteString x | BS.length x <= limit = Memory $ T.decodeUtf8 x 134 | | otherwise = unsafeWriteHandle $ \h -> do hSetBinaryMode h True; BS.hPutStr h x 135 | 136 | bigStringToByteString :: BigString -> BS.ByteString 137 | bigStringToByteString (Memory x) = T.encodeUtf8 x 138 | bigStringToByteString x = unsafeReadHandle x $ \h -> do hSetBinaryMode h True; BS.hGetContents h 139 | 140 | 141 | --------------------------------------------------------------------- 142 | -- WEBBY 143 | 144 | bigStringBackEnd :: BackEnd BigString 145 | bigStringBackEnd _ _ ask = writeHandle $ \h -> do 146 | fix $ \loop -> do 147 | bs <- ask 148 | unless (BS.null bs) $ do 149 | BS.hPut h bs 150 | loop 151 | 152 | withBigStringPart :: String -> BigString -> (Part -> IO a) -> IO a 153 | withBigStringPart name (Memory x) op = op $ partBS (T.pack name) (T.encodeUtf8 x) 154 | withBigStringPart name body op = bigStringWithFile body $ \file -> op $ partFileSourceChunked (T.pack name) file 155 | -------------------------------------------------------------------------------- /src/General/Database.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, TupleSections, ViewPatterns, RankNTypes, TypeOperators, TypeFamilies, ExistentialQuantification #-} 2 | {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-} 3 | 4 | module General.Database( 5 | Pred, (%==), (%==%), (%>), (%<), (%/=), (%&&), nullP, likeP, 6 | orderDesc, orderAsc, distinct, limit, 7 | Upd(..), 8 | TypeField(..), 9 | Table, table, Column, column, rowid, norowid, 10 | sqlInsert, sqlUpdate, sqlSelect, sqlDelete, sqlEnsureTable, sqlUnsafe 11 | ) where 12 | 13 | import Data.List.Extra 14 | import Data.String 15 | import Data.Maybe 16 | import Data.Time.Clock 17 | import Data.Tuple.Extra 18 | import Database.SQLite.Simple hiding ((:=)) 19 | import Database.SQLite.Simple.FromField 20 | import Database.SQLite.Simple.ToField 21 | 22 | 23 | type family Uncolumns cs 24 | type instance Uncolumns () = () 25 | type instance Uncolumns (Column a) = Only a 26 | type instance Uncolumns (Only (Column a)) = Only a 27 | type instance Uncolumns (Column a, Column b) = (a, b) 28 | type instance Uncolumns (Column a, Column b, Column c) = (a, b, c) 29 | type instance Uncolumns (Column a, Column b, Column c, Column d) = (a, b, c, d) 30 | type instance Uncolumns (Column a, Column b, Column c, Column d, Column e) = (a, b, c, d, e) 31 | type instance Uncolumns (Column a, Column b, Column c, Column d, Column e, Column f) = (a, b, c, d, e, f) 32 | type instance Uncolumns (Column a, Column b, Column c, Column d, Column e, Column f, Column g) = (a, b, c, d, e, f, g) 33 | type instance Uncolumns (Column a, Column b, Column c, Column d, Column e, Column f, Column g, Column h) = (a, b, c, d, e, f, g, h) 34 | type instance Uncolumns (Column a, Column b, Column c, Column d, Column e, Column f, Column g, Column h, Column i) = (a, b, c, d, e, f, g, h, i) 35 | 36 | data Table rowid cs = Table {tblName :: String, tblKeys :: [Column_], tblCols :: [Column_]} 37 | 38 | data Column c = Column {colTable :: String, colName :: String, colSqlType :: String} deriving (Eq,Show) 39 | 40 | type Column_ = Column () 41 | 42 | column_ :: Column c -> Column_ 43 | column_ Column{..} = Column{..} 44 | 45 | class TypeField field where 46 | typeField :: field -> String 47 | 48 | instance TypeField String where typeField _ = "TEXT NOT NULL" 49 | instance TypeField Int where typeField _ = "INTEGER NOT NULL" 50 | instance TypeField Double where typeField _ = "REAL NOT NULL" 51 | instance TypeField UTCTime where typeField _ = "TEXT NOT NULL" 52 | instance TypeField Bool where typeField _ = "INTEGER NOT NULL" 53 | instance TypeField a => TypeField (Maybe a) where 54 | typeField x | Just s <- stripSuffix " NOT NULL" s = s 55 | | otherwise = error "Can't remove the NULL constraint" 56 | where s = typeField $ fromJust x 57 | 58 | class Columns cs where columns :: cs -> [Column_] 59 | instance Columns () where columns () = [] 60 | instance Columns (Column c1) where columns c1 = [column_ c1] 61 | instance Columns (Only (Column c1)) where columns (Only c1) = [column_ c1] 62 | instance Columns (Column c1, Column c2) where columns (c1, c2) = [column_ c1, column_ c2] 63 | instance Columns (Column c1, Column c2, Column c3) where columns (c1, c2, c3) = [column_ c1, column_ c2, column_ c3] 64 | instance Columns (Column c1, Column c2, Column c3, Column c4) where columns (c1, c2, c3, c4) = [column_ c1, column_ c2, column_ c3, column_ c4] 65 | instance Columns (Column c1, Column c2, Column c3, Column c4, Column c5) where columns (c1, c2, c3, c4, c5) = [column_ c1, column_ c2, column_ c3, column_ c4, column_ c5] 66 | instance Columns (Column c1, Column c2, Column c3, Column c4, Column c5, Column c6) where columns (c1, c2, c3, c4, c5, c6) = [column_ c1, column_ c2, column_ c3, column_ c4, column_ c5, column_ c6] 67 | instance Columns (Column c1, Column c2, Column c3, Column c4, Column c5, Column c6, Column c7) where columns (c1, c2, c3, c4, c5, c6, c7) = [column_ c1, column_ c2, column_ c3, column_ c4, column_ c5, column_ c6, column_ c7] 68 | instance Columns (Column c1, Column c2, Column c3, Column c4, Column c5, Column c6, Column c7, Column c8) where columns (c1, c2, c3, c4, c5, c6, c7, c8) = [column_ c1, column_ c2, column_ c3, column_ c4, column_ c5, column_ c6, column_ c7, column_ c8] 69 | instance Columns (Column c1, Column c2, Column c3, Column c4, Column c5, Column c6, Column c7, Column c8, Column c9) where columns (c1, c2, c3, c4, c5, c6, c7, c8, c9) = [column_ c1, column_ c2, column_ c3, column_ c4, column_ c5, column_ c6, column_ c7, column_ c8, column_ c9] 70 | 71 | table :: (Columns keys, Columns cols) => String -> Column rowid -> keys -> cols -> Table rowid (Uncolumns cols) 72 | -- important to produce name before looking at columns 73 | table name rowid (columns -> keys) (columns -> cols) = Table name (check keys) (check cols) 74 | where 75 | check x | nubOrd (map colTable $ keys ++ cols) /= [name] = error "Column with the wrong table" 76 | | not $ null $ map colName keys \\ map colName cols = error "Key column which is not one of the normal columns" 77 | | colName rowid `notElem` ["","rowid"] = error "Rowid column must have name rowid" 78 | | otherwise = x 79 | 80 | column :: forall c rowid cs . TypeField c => Table rowid cs -> String -> Column c 81 | column tbl row = Column (tblName tbl) row (typeField (undefined :: c)) 82 | 83 | rowid :: Table rowid cs -> Column rowid 84 | rowid tbl = Column (tblName tbl) "rowid" "" 85 | 86 | norowid :: Column () 87 | norowid = Column "" "" "" 88 | 89 | sqlInsert :: (ToRow cs, FromField rowid) => Connection -> Table rowid cs -> cs -> IO rowid 90 | sqlInsert conn tbl val = do 91 | let vs = toRow val 92 | -- FIXME: Should combine the last_insert_rowid with the INSERT INTO 93 | let str = "INSERT INTO " ++ tblName tbl ++ " VALUES (" ++ intercalate "," (replicate (length vs) "?") ++ ")" 94 | execute conn (fromString str) vs 95 | [Only row] <- query_ conn (fromString "SELECT last_insert_rowid()") 96 | return row 97 | 98 | 99 | sqlUpdate :: Connection -> [Upd] -> [Pred] -> IO () 100 | sqlUpdate conn upd pred = do 101 | let (updCs, updVs) = unzip $ map unupdate upd 102 | let (prdStr, _, prdCs, prdVs) = unpred pred 103 | let tbl = nubOrd $ map colTable $ updCs ++ prdCs 104 | case tbl of 105 | _ | null upd -> fail "Must update at least one column" 106 | [t] -> do 107 | let str = "UPDATE " ++ t ++ " SET " ++ intercalate ", " (map ((++ "=?") . colName) updCs) ++ " WHERE " ++ prdStr 108 | execute conn (fromString str) (updVs ++ prdVs) 109 | _ -> fail "Must update all in the same column" 110 | 111 | 112 | sqlDelete :: Connection -> Table rowid cs -> [Pred] -> IO () 113 | sqlDelete conn tbl pred = do 114 | let (prdStr, _, prdCs, prdVs) = unpred pred 115 | case nubOrd $ tblName tbl : map colTable prdCs of 116 | [t] -> do 117 | let str = "DELETE FROM " ++ t ++ " WHERE " ++ prdStr 118 | execute conn (fromString str) prdVs 119 | ts -> fail $ "sqlDelete, can only delete from one table but you are touching: " ++ unwords ts 120 | 121 | 122 | sqlSelect :: (FromRow (Uncolumns cs), Columns cs) => Connection -> cs -> [Pred] -> IO [Uncolumns cs] 123 | sqlSelect conn cols pred = do 124 | let outCs = columns cols 125 | let (prdStr, prdDs, prdCs, prdVs) = unpred pred 126 | let str = "SELECT " ++ intercalate ", " [(if c `elem` prdDs then "DISTINCT " else "") ++ colTable ++ "." ++ colName | c@Column{..} <- outCs] ++ " " ++ 127 | "FROM " ++ intercalate ", " (nubOrd $ map colTable $ outCs ++ prdCs) ++ " WHERE " ++ prdStr 128 | query conn (fromString str) prdVs 129 | 130 | 131 | sqlEnsureTable :: Connection -> Table rowid cs -> IO () 132 | sqlEnsureTable conn Table{..} = do 133 | let fields = intercalate ", " $ 134 | [colName ++ " " ++ colSqlType | Column{..} <- tblCols] ++ 135 | ["PRIMARY KEY (" ++ intercalate ", " (map colName tblKeys) ++ ")" | not $ null tblKeys] 136 | let str = "CREATE TABLE " ++ tblName ++ " (" ++ fields ++ ")" 137 | existing <- query conn (fromString "SELECT sql FROM sqlite_master WHERE type = ? AND name = ?") ("table", tblName) 138 | case existing of 139 | [Only s] | str == s -> return () 140 | [] -> execute_ conn $ fromString str 141 | _ -> error $ "Trying to ensure table " ++ tblName ++ " but mismatch" ++ 142 | "\nCreating:\n" ++ str ++ "\nGot:\n" ++ unlines (map fromOnly existing) 143 | 144 | 145 | sqlUnsafe :: (ToRow q, FromRow r) => Connection -> String -> q -> IO [r] 146 | sqlUnsafe conn str q = query conn (fromString str) q 147 | 148 | 149 | data Upd = forall a . ToField a => Column a := a 150 | 151 | unupdate :: Upd -> (Column_, SQLData) 152 | unupdate (c := v) = (column_ c, toField v) 153 | 154 | data Pred 155 | = PNull Column_ 156 | | PNotNull Column_ 157 | | PEq Column_ SQLData 158 | | PNEq Column_ SQLData 159 | | PGt Column_ SQLData 160 | | PLt Column_ SQLData 161 | | PEqP Column_ Column_ 162 | | PLike Column_ SQLData 163 | | PAnd [Pred] 164 | | PDistinct Column_ 165 | | POrder Column_ String 166 | | PLimit Int 167 | 168 | distinct :: Column c -> Pred 169 | distinct c = PDistinct (column_ c) 170 | 171 | limit :: Int -> Pred 172 | limit = PLimit 173 | 174 | orderDesc :: Column UTCTime -> Pred 175 | orderDesc c = POrder (column_ c) $ colTable c ++ "." ++ colName c ++ " DESC" 176 | 177 | orderAsc :: Column UTCTime -> Pred 178 | orderAsc c = POrder (column_ c) $ colTable c ++ "." ++ colName c ++ " ASC" 179 | 180 | nullP :: Column (Maybe c) -> Pred 181 | nullP c = PNull (column_ c) 182 | 183 | likeP :: ToField c => Column c -> c -> Pred 184 | likeP (column_ -> c) (toField -> v) = PLike c v 185 | 186 | (%&&) :: Pred -> Pred -> Pred 187 | (%&&) a b = PAnd [a,b] 188 | 189 | (%==) :: ToField c => Column c -> c -> Pred 190 | (%==) (column_ -> c) (toField -> v) 191 | | v == SQLNull = PNull c 192 | | otherwise = PEq c v 193 | 194 | (%>) :: ToField c => Column c -> c -> Pred 195 | (%>) (column_ -> c) (toField -> v) 196 | | v == SQLNull = error $ "Can't %> on a NULL" 197 | | otherwise = PGt c v 198 | 199 | (%<) :: ToField c => Column c -> c -> Pred 200 | (%<) (column_ -> c) (toField -> v) 201 | | v == SQLNull = error $ "Can't %> on a NULL" 202 | | otherwise = PLt c v 203 | 204 | (%/=) :: ToField c => Column c -> c -> Pred 205 | (%/=) (column_ -> c) (toField -> v) 206 | | v == SQLNull = PNotNull c 207 | | otherwise = PNEq c v 208 | 209 | (%==%) :: ToField c => Column c -> Column c -> Pred 210 | (%==%) c1 c2 211 | | isNull c1 || isNull c2 = error $ show ("Column must be NOT NULL to do %==%", show c1, show c2) 212 | | otherwise = PEqP (column_ c1) (column_ c2) 213 | where isNull c = not $ colSqlType c == "" || " NOT NULL" `isSuffixOf` colSqlType c 214 | 215 | unpred :: [Pred] -> (String, [Column_], [Column_], [SQLData]) 216 | unpred ps = 217 | let (a,b,c) = f $ PAnd pred 218 | in (a ++ (if null order then "" else " ORDER BY " ++ unwords [x | POrder _ x <- order]) ++ 219 | (if null limit then "" else " LIMIT " ++ head [show x | PLimit x <- limit]) 220 | , 221 | [x | PDistinct x <- dist], b ++ [x | POrder x _ <- order], c) 222 | where 223 | isDistinct PDistinct{} = True; isDistinct _ = False 224 | isOrder POrder{} = True; isOrder _ = False 225 | isLimit PLimit{} = True; isLimit _ = False 226 | (dist, (order, (limit, pred))) = second (second (partition isLimit) . partition isOrder) $ partition isDistinct ps 227 | 228 | g Column{..} = colTable ++ "." ++ colName 229 | 230 | f (PNull c) = (g c ++ " IS NULL", [c], []) 231 | f (PNotNull c) = (g c ++ " IS NOT NULL", [c], []) 232 | f (PEq c v) = (g c ++ " == ?", [c], [v]) -- IS always works, but is a LOT slower 233 | f (PNEq c v) = (g c ++ " != ?", [c], [v]) -- IS always works, but is a LOT slower 234 | f (PGt c v) = (g c ++ " > ?", [c], [v]) -- IS always works, but is a LOT slower 235 | f (PLt c v) = (g c ++ " < ?", [c], [v]) -- IS always works, but is a LOT slower 236 | f (PEqP c1 c2) = (g c1 ++ " = " ++ g c2, [c1,c2], []) 237 | f (PLike c v) = (g c ++ " LIKE ?", [c], [v]) 238 | f (PAnd []) = ("NULL IS NULL", [], []) 239 | f (PAnd [x]) = f x 240 | f (PAnd xs) = (intercalate " AND " ["(" ++ s ++ ")" | s <- ss], concat cs, concat vs) 241 | where (ss,cs,vs) = unzip3 $ map f xs 242 | f _ = error "Unrecognised Pred" 243 | 244 | instance FromField () where 245 | fromField _ = return () 246 | -------------------------------------------------------------------------------- /src/General/Equal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, TupleSections, ViewPatterns #-} 2 | 3 | module General.Equal( 4 | Equal, fromEqual, newEqual 5 | ) where 6 | 7 | import Data.IORef 8 | import Data.Unique 9 | import System.IO.Unsafe 10 | import Data.Hashable 11 | 12 | 13 | data Equal a = Equal (IORef Unique) Int a 14 | 15 | instance Show a => Show (Equal a) where 16 | show = show . fromEqual 17 | 18 | fromEqual :: Equal a -> a 19 | fromEqual (Equal _ _ x) = x 20 | 21 | newEqual :: Hashable a => a -> Equal a 22 | newEqual x = unsafePerformIO $ do u <- newIORef =<< newUnique; return $ Equal u (hash x) x 23 | 24 | instance Eq a => Eq (Equal a) where 25 | Equal u1 h1 x1 == Equal u2 h2 x2 26 | | h1 /= h2 = False 27 | | otherwise = unsafePerformIO $ do 28 | uu1 <- readIORef u1 29 | uu2 <- readIORef u2 30 | if uu1 == uu2 then return True 31 | else if x1 /= x2 then return False 32 | else do 33 | if uu1 > uu2 then writeIORef u1 uu2 else writeIORef u2 uu1 34 | return True 35 | 36 | instance Ord a => Ord (Equal a) where 37 | compare (Equal u1 h1 x1) (Equal u2 h2 x2) 38 | | h1 /= h2 = compare h1 h2 39 | | otherwise = unsafePerformIO $ do 40 | uu1 <- readIORef u1 41 | uu2 <- readIORef u2 42 | case compare x1 x2 of 43 | _ | uu1 == uu2 -> return EQ 44 | EQ -> do if uu1 > uu2 then writeIORef u1 uu2 else writeIORef u2 uu1; return EQ 45 | x -> return x 46 | -------------------------------------------------------------------------------- /src/General/Extra.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, GeneralizedNewtypeDeriving, TupleSections, CPP #-} 2 | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} 3 | -- time changed incompatibly, use the functions that work everywhere 4 | 5 | module General.Extra( 6 | Seconds, UTCTime, getCurrentTime, addSeconds, showRelativeTime, relativeTime, showUTCTime, 7 | readDate, showDate, timeToDate, dateToTime, 8 | createDir, 9 | withFileLock, 10 | pick, 11 | memoIO0, memoIO1, 12 | encryptish, 13 | catMaybesSet, 14 | whenLeft, whenRight, 15 | timeInit, timed, time, time_, 16 | eitherToMaybe, 17 | newCVar, readCVar, modifyCVar, modifyCVar_, 18 | registerMaster, forkSlave, 19 | Worker, newWorker, 20 | makeRelativeEx, 21 | transitiveClosure, findCycle, 22 | putBlock, 23 | maybe', 24 | withs, 25 | retrySleep, 26 | commas, commasLimit, unwordsLimit 27 | ) where 28 | 29 | import Data.Time.Clock 30 | import Data.Time.Calendar 31 | import System.Time.Extra 32 | import System.IO.Unsafe 33 | import System.IO.Extra 34 | import Data.IORef 35 | import Data.List.Extra 36 | import System.Directory.Extra 37 | import Data.Hashable 38 | import Numeric 39 | import System.FilePath 40 | import Control.Exception.Extra 41 | import Control.Applicative 42 | import Control.Monad.Extra 43 | import Control.Concurrent.Extra 44 | import Development.Shake.Command 45 | import Data.Maybe 46 | import System.Random 47 | import Data.Either.Extra 48 | import Data.Time.Format 49 | #if __GLASGOW_HASKELL__< 710 50 | import System.Locale 51 | #endif 52 | import qualified Data.HashMap.Strict as HashMap 53 | import qualified Data.Set as Set 54 | import Prelude 55 | 56 | 57 | addSeconds :: Seconds -> UTCTime -> UTCTime 58 | addSeconds x = addUTCTime (fromRational $ toRational x) 59 | 60 | -- | Calculate the difference between two times in seconds. 61 | diffTime :: UTCTime -> UTCTime -> Seconds 62 | diffTime end start = fromRational $ toRational $ end `diffUTCTime` start 63 | 64 | relativeTime :: IO (UTCTime -> Seconds) 65 | relativeTime = do 66 | now <- getCurrentTime 67 | return $ \old -> diffTime now old 68 | 69 | showRelativeTime :: IO (UTCTime -> String) 70 | showRelativeTime = do 71 | now <- getCurrentTime 72 | return $ \old -> 73 | let secs = diffTime now old in 74 | if timeToDate now /= timeToDate old then showDate (timeToDate old) 75 | else if secs < 60 then show (max 1 $ floor secs) ++ "s ago" -- 4.32s is too precise, 0s feels wrong 76 | else showDuration secs ++ " ago" 77 | 78 | showUTCTime :: String -> UTCTime -> String 79 | showUTCTime = formatTime defaultTimeLocale 80 | 81 | timeToDate :: UTCTime -> Day 82 | timeToDate = utctDay 83 | 84 | dateToTime :: Day -> UTCTime 85 | dateToTime = flip UTCTime 0 86 | 87 | readDate :: String -> Day 88 | readDate = readTime defaultTimeLocale (iso8601DateFormat Nothing) 89 | 90 | showDate :: Day -> String 91 | showDate = formatTime defaultTimeLocale (iso8601DateFormat Nothing) 92 | 93 | -- | One way function used for encrypting 94 | encryptish :: String -> String 95 | encryptish x = upper $ showHex (abs $ hash x) "" 96 | 97 | 98 | {-# NOINLINE logTime #-} 99 | logTime :: IO Seconds 100 | logTime = unsafePerformIO offsetTime 101 | 102 | timeInit :: IO () 103 | timeInit = void $ evaluate =<< logTime 104 | 105 | 106 | {-# NOINLINE createDirLock #-} 107 | createDirLock :: Lock 108 | createDirLock = unsafePerformIO newLock 109 | 110 | createDir :: String -> [String] -> IO FilePath 111 | createDir prefix info = do 112 | let name = prefix ++ (if null info then "" else "-" ++ show (abs $ hash info)) 113 | createDirectoryIfMissing True name 114 | withLock createDirLock $ writeFile (name ".bake.name") $ unlines info 115 | return name 116 | 117 | 118 | pick :: [a] -> IO a 119 | pick xs = randomRIO (0, (length xs - 1)) >>= return . (xs !!) 120 | 121 | 122 | timed :: String -> IO a -> IO a 123 | timed msg act = do 124 | (tim,res) <- duration act 125 | tot <- logTime 126 | putStrLn $ "[BAKE-TIME] " ++ showDuration tim ++ " (total of " ++ showDuration tot ++ "): " ++ msg 127 | return res 128 | 129 | time_ :: IO (CmdLine, CmdTime) -> IO () 130 | time_ act = time $ do (a,b) <- act; return (a,b,()) 131 | 132 | time :: IO (CmdLine, CmdTime, a) -> IO a 133 | time act = do 134 | (CmdLine msg, CmdTime tim, res) <- act 135 | tot <- logTime 136 | putStrLn $ "[BAKE-TIME] " ++ showDuration tim ++ " (total of " ++ showDuration tot ++ "): " ++ msg 137 | return res 138 | 139 | makeRelativeEx :: FilePath -> FilePath -> IO FilePath 140 | makeRelativeEx x y = do 141 | x <- splitDirectories <$> canonicalizePath x 142 | y <- splitDirectories <$> canonicalizePath y 143 | return $ joinPath $ if take 1 x /= take 1 y then y else f x y 144 | where 145 | f (x:xs) (y:ys) 146 | | x == y = f xs ys 147 | | otherwise = ".." : f xs (y:ys) 148 | f _ ys = ys 149 | 150 | 151 | -- Might be better off using the 'filelock' package 152 | withFileLock :: FilePath -> IO a -> IO a 153 | withFileLock lock act = do 154 | -- important to canonicalize everything as the act might change the current directory 155 | createDirectoryIfMissing True $ takeDirectory lock 156 | lock <- ( takeFileName lock) <$> canonicalizePath (takeDirectory lock) 157 | 158 | let stamp = lock <.> "stamp" 159 | let touch = do t <- show <$> getCurrentTime; ignore $ writeFile stamp t; return t 160 | unlessM (doesFileExist stamp) $ void touch 161 | 162 | (t,_) <- duration $ whileM $ do 163 | b <- try_ $ createDirectory lock 164 | if isRight b then do 165 | return False 166 | else do 167 | sleep 10 168 | now <- getCurrentTime 169 | mtime <- try_ $ getModificationTime stamp 170 | case mtime of 171 | Right x | addSeconds 30 x > now -> return True 172 | _ -> do 173 | -- try and take ownership of the stamp 174 | me <- touch 175 | sleep 10 -- wait for the stamp to settle down 176 | src <- try_ $ readFile' stamp 177 | return $ either (const True) (/= me) src 178 | putStrLn $ "Waited " ++ showDuration t ++ " to acquire the file lock " ++ lock 179 | 180 | active <- newVar True 181 | touch 182 | thread <- forkSlave $ forever $ do 183 | sleep 10 184 | withVar active $ \b -> when b $ void touch 185 | act `finally` do 186 | modifyVar_ active $ const $ return False 187 | killThread thread 188 | ignore $ removeDirectory lock 189 | 190 | {- 191 | tester :: IO () 192 | tester = do 193 | forM_ [1..2] $ \i -> do 194 | forkIO $ withFileLock "mylock" $ do 195 | print ("start", i) 196 | sleep 60 197 | print ("stop",i) 198 | sleep 1000 199 | -} 200 | 201 | --------------------------------------------------------------------- 202 | -- CVAR 203 | 204 | -- | A Var, but where readCVar returns the last cached value 205 | data CVar a = CVar {cvarCache :: Var a, cvarReal :: Var a} 206 | 207 | newCVar :: a -> IO (CVar a) 208 | newCVar x = liftM2 CVar (newVar x) (newVar x) 209 | 210 | readCVar :: CVar a -> IO a 211 | readCVar = readVar . cvarCache 212 | 213 | modifyCVar :: CVar a -> (a -> IO (a, b)) -> IO b 214 | modifyCVar CVar{..} f = 215 | modifyVar cvarReal $ \a -> do 216 | (a,b) <- f a 217 | modifyVar_ cvarCache $ const $ return a 218 | return (a,b) 219 | 220 | modifyCVar_ :: CVar a -> (a -> IO a) -> IO () 221 | modifyCVar_ cvar f = modifyCVar cvar $ fmap (,()) . f 222 | 223 | 224 | --------------------------------------------------------------------- 225 | -- SLAVE/MASTER 226 | 227 | {-# NOINLINE master #-} 228 | master :: IORef (Maybe ThreadId) 229 | master = unsafePerformIO $ newIORef Nothing 230 | 231 | registerMaster :: IO () 232 | registerMaster = writeIORef master . Just =<< myThreadId 233 | 234 | forkSlave :: IO () -> IO ThreadId 235 | forkSlave act = forkFinally act $ \v -> case v of 236 | Left e | fromException e /= Just ThreadKilled -> do 237 | m <- readIORef master 238 | whenJust m $ flip throwTo e 239 | _ -> return () 240 | 241 | type Worker = IO () -> IO () 242 | 243 | newWorker :: IO Worker 244 | newWorker = do 245 | lock <- newLock 246 | return $ \act -> void $ forkIO $ withLock lock act 247 | 248 | 249 | --------------------------------------------------------------------- 250 | -- UTILITIES 251 | 252 | -- | Given a relation and a starting value, find the transitive closure. 253 | -- The resulting list will be a set. 254 | transitiveClosure :: Ord a => (a -> [a]) -> [a] -> [a] 255 | transitiveClosure follow xs = f Set.empty xs 256 | where 257 | f seen [] = [] 258 | f seen (t:odo) | t `Set.member` seen = f seen odo 259 | | otherwise = t : f (Set.insert t seen) (follow t ++ odo) 260 | 261 | 262 | -- | Given a relation and a starting list, find a cycle if there is one. 263 | -- The resulting list will be a set, and will contain a cycle (but not necessarily be minimal). 264 | findCycle :: Ord a => (a -> [a]) -> [a] -> Maybe [a] 265 | findCycle follow = firstJust $ \x -> 266 | let children = transitiveClosure follow (follow x) 267 | -- if there is a cycle, make the element we know is cyclic first, so its easier to debug 268 | in if x `elem` children then Just (x : delete x children) else Nothing 269 | 270 | 271 | memoIO0 :: IO b -> IO (IO b) 272 | memoIO0 act = return $ unsafeInterleaveIO act 273 | 274 | memoIO1 :: (Hashable a, Eq a) => (a -> IO b) -> IO (a -> IO b) 275 | memoIO1 op = do 276 | var <- newVar HashMap.empty 277 | return $ \k -> modifyVar var $ \mp -> 278 | case HashMap.lookup k mp of 279 | Just v -> return (mp, v) 280 | Nothing -> do 281 | v <- op k 282 | return (HashMap.insert k v mp, v) 283 | 284 | 285 | catMaybesSet :: Ord a => Set.Set (Maybe a) -> Set.Set a 286 | catMaybesSet = Set.mapMonotonic fromJust . Set.delete Nothing 287 | 288 | whenLeft :: Applicative m => Either a b -> (a -> m ()) -> m () 289 | whenLeft x f = either f (const $ pure ()) x 290 | 291 | whenRight :: Applicative m => Either a b -> (b -> m ()) -> m () 292 | whenRight x f = either (const $ pure ()) f x 293 | 294 | retrySleep :: Exception e => Seconds -> Int -> (e -> Bool) -> IO a -> IO a 295 | retrySleep secs times test act 296 | | times <= 0 = act 297 | | otherwise = catchBool test act $ const $ sleep secs >> retrySleep secs (times-1) test act 298 | 299 | 300 | --------------------------------------------------------------------- 301 | -- FORMATTING 302 | 303 | putBlock :: String -> [String] -> IO () 304 | putBlock title body = putStrLn $ unlines $ 305 | let s = "-- " ++ title ++ " --" in 306 | (s ++ replicate (70 - length s) '-') : 307 | body ++ 308 | [replicate 70 '-'] 309 | 310 | commas :: [String] -> String 311 | commas = intercalate ", " 312 | 313 | commasLimit :: Int -> [String] -> String 314 | commasLimit = limit commas 315 | 316 | unwordsLimit :: Int -> [String] -> String 317 | unwordsLimit = limit unwords 318 | 319 | limit :: ([String] -> String) -> Int -> [String] -> String 320 | limit rejoin i xs = rejoin a ++ (if null b then "" else "...") 321 | where (a,b) = splitAt i xs 322 | 323 | maybe' :: Maybe a -> b -> (a -> b) -> b 324 | maybe' x nothing just = maybe nothing just x 325 | 326 | withs :: [(a -> r) -> r] -> ([a] -> r) -> r 327 | withs [] act = act [] 328 | withs (f:fs) act = f $ \a -> withs fs $ \as -> act $ a:as 329 | -------------------------------------------------------------------------------- /src/General/HTML.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns, GeneralizedNewtypeDeriving #-} 2 | 3 | -- | Library for defining HTML fragments. 4 | -- The tags will be properly nested, and all strings will be HTML escaped. 5 | -- As an example: 6 | -- 7 | -- > renderHTML $ html_ $ 8 | -- > ol__ [style_ "color:darkgreen"] $ 9 | -- > forM_ [1..10] $ \i -> li_ $ str_ $ "item number: " & show i 10 | module General.HTML( 11 | -- * HTML data type 12 | HTML, HTML_, renderHTML, valueHTML, 13 | -- * Constructing pieces 14 | Attribute, attribute_, tag_, tag__, str_, raw_, 15 | -- * Tags 16 | br_, style__, link__, hr_, 17 | pre_, b_, html_, head_, title_, body_, h1_, h2_, ul_, ol_, li_, p_, table_, thead_, tr_, td_, tbody_, i_, 18 | a__, span__, p__, h2__, tr__, ol__, 19 | -- * Attributes 20 | href_, class_, name_, rel_, type_, style_, id_, 21 | -- * Functions 22 | (<>), 23 | url_, 24 | unlines_, commas_, commasLimit_, header_ 25 | ) where 26 | 27 | import Control.Applicative 28 | import Data.Monoid 29 | import Data.List 30 | import Control.Monad 31 | import Control.Monad.Trans.Writer 32 | import Control.DeepSeq 33 | import Data.Char 34 | import Numeric 35 | import Prelude 36 | 37 | 38 | --------------------------------------------------------------------- 39 | -- LIBRARY 40 | 41 | data Rope = Branch [Rope] | Leaf String 42 | 43 | instance Eq Rope where a == b = renderRope a == renderRope b 44 | instance Ord Rope where compare a b = compare (renderRope a) (renderRope b) 45 | 46 | instance NFData Rope where 47 | rnf (Branch x) = rnf x 48 | rnf (Leaf x) = rnf x 49 | 50 | renderRope :: Rope -> String 51 | renderRope x = f x "" 52 | where f (Branch []) k = k 53 | f (Branch (x:xs)) k = f x $ f (Branch xs) k 54 | f (Leaf x) k = x ++ k 55 | 56 | nullRope :: Rope -> Bool 57 | nullRope (Branch xs) = all nullRope xs 58 | nullRope (Leaf x) = null x 59 | 60 | instance Monoid Rope where 61 | mempty = Branch [] 62 | mappend a b = Branch [a,b] 63 | mconcat = Branch 64 | 65 | 66 | -- | Escape a URL using % encoding. 67 | url_ :: String -> String 68 | url_ = concatMap f 69 | where 70 | f x | (x >= 'A' && x <= 'Z') || (x >= 'a' && x <= 'z') || (x >= '0' && x <= '9') || x `elem` "-_.~" = [x] 71 | f (ord -> x) = "%" ++ ['0' | x < 16] ++ showHex x "" 72 | 73 | -- | The type for constructing HTML. It is a 'Monad' and 'Monoid'. 74 | -- Typically the value paramter is '()', in which case use 'HTML'. 75 | newtype HTML_ a = HTML_ {fromHTML_ :: Writer Rope a} 76 | deriving (Eq,Ord,Functor,Applicative,Monad) 77 | 78 | -- | An alias for 'HTML_' with no interesting type. 79 | type HTML = HTML_ () 80 | 81 | -- | Get the value out of an 'HTML_'. 82 | valueHTML :: HTML_ a -> a 83 | valueHTML = fst . runWriter . fromHTML_ 84 | 85 | -- | Render some 'HTML'. 86 | renderHTML :: HTML -> String 87 | renderHTML = renderRope . execWriter . fromHTML_ 88 | 89 | nullHTML :: HTML -> Bool 90 | nullHTML = nullRope . execWriter . fromHTML_ 91 | 92 | instance Monoid a => Monoid (HTML_ a) where 93 | mempty = return mempty 94 | mappend = liftM2 mappend 95 | 96 | instance NFData a => NFData (HTML_ a) where 97 | rnf = rnf . runWriter . fromHTML_ 98 | 99 | -- | Turn a string into a text fragment of HTML, escaping any characters which mean something in HTML. 100 | str_ :: String -> HTML 101 | str_ = raw_ . escapeHTML 102 | 103 | -- | Turn a string into an HTML fragment, applying no escaping. Use this function carefully. 104 | raw_ :: String -> HTML 105 | raw_ = HTML_ . tell . Leaf 106 | 107 | escapeHTML :: String -> String 108 | escapeHTML = concatMap $ \c -> case c of 109 | '<' -> "<" 110 | '>' -> ">" 111 | '&' -> "&" 112 | '\"' -> """ 113 | '\'' -> "'" 114 | x -> [x] 115 | 116 | 117 | -- | An attribute for a tag. 118 | data Attribute = Attribute {fromAttribute :: String} 119 | 120 | valid (x:xs) | isAlpha x && all isAlphaNum xs = True 121 | valid x = error $ "Not a valid HTML name, " ++ show x 122 | 123 | -- | Construct an Attribute from a key and value string. The value will be escaped. 124 | attribute_ :: String -> String -> Attribute 125 | attribute_ a b | valid a = Attribute $ a ++ "=\"" ++ escapeHTML b ++ "\"" 126 | | otherwise = error $ "Invalid attribute name, " ++ a 127 | 128 | 129 | -- | Given a tag name, a list of attributes, and some content HTML, produce some new HTML. 130 | tag__ :: String -> [Attribute] -> HTML -> HTML 131 | tag__ name at inner | not $ valid name = error $ "Invalid tag name, " ++ name 132 | | otherwise = do 133 | -- if you collapse an "a", it goes wrong 134 | -- if you don't collapse a "br", it goes wrong 135 | let zero = nullHTML inner && name `elem` ["br","link"] 136 | raw_ $ 137 | "<" ++ 138 | unwords (name : map fromAttribute at) ++ 139 | (if zero then " /" else "") ++ ">" 140 | unless zero $ do 141 | inner 142 | raw_ $ "" 143 | 144 | -- | Like 'tag__' but with no attributes. 145 | tag_ :: String -> HTML -> HTML 146 | tag_ name = tag__ name [] 147 | 148 | 149 | --------------------------------------------------------------------- 150 | -- TAGS 151 | 152 | br_ = tag_ "br" mempty 153 | hr_ = tag_ "hr" mempty 154 | link__ at = tag__ "link" at mempty 155 | style__ at body = tag__ "style" at $ raw_ body 156 | 157 | pre_ = tag_ "pre" 158 | b_ = tag_ "b" 159 | i_ = tag_ "i" 160 | html_ = tag_ "html" 161 | head_ = tag_ "head" 162 | title_ = tag_ "title" 163 | body_ = tag_ "body" 164 | h1_ = tag_ "h1" 165 | h2_ = tag_ "h2" 166 | ul_ = tag_ "ul" 167 | ol_ = tag_ "ol" 168 | li_ = tag_ "li" 169 | p_ = tag_ "p" 170 | table_ = tag_ "table" 171 | thead_ = tag_ "thead" 172 | tr_ = tag_ "tr" 173 | td_ = tag_ "td" 174 | tbody_ = tag_ "tbody" 175 | 176 | a__ = tag__ "a" 177 | span__ = tag__ "span" 178 | p__ = tag__ "p" 179 | h2__ = tag__ "h2" 180 | tr__ = tag__ "tr" 181 | ol__ = tag__ "ol" 182 | 183 | href_ = attribute_ "href" 184 | class_ = attribute_ "class" 185 | name_ = attribute_ "name" 186 | rel_ = attribute_ "rel" 187 | type_ = attribute_ "type" 188 | style_ = attribute_ "style" 189 | id_ = attribute_ "id" 190 | 191 | unlines_ = mconcat . map (<> str_ "\n") 192 | commas_ = mconcat . intersperse (str_ ", ") 193 | commasLimit_ = limit_ commas_ 194 | 195 | limit_ :: ([HTML] -> HTML) -> Int -> [HTML] -> HTML 196 | limit_ rejoin i xs = rejoin a <> str_ (if null b then "" else "...") 197 | where (a,b) = splitAt i xs 198 | 199 | 200 | -- FIXME: hack, very much app-specific 201 | header_ :: String -> String -> HTML 202 | header_ tag x = a__ [id_ tag,href_ $ "#" ++ tag,class_ "self"] $ h2_ $ str_ x 203 | -------------------------------------------------------------------------------- /src/General/Index.hs: -------------------------------------------------------------------------------- 1 | 2 | module General.Index( 3 | Index, newIndex, addIndex, askIndex 4 | ) where 5 | 6 | import qualified Data.Map as Map 7 | import Data.IORef 8 | import System.IO.Unsafe 9 | 10 | 11 | data Index filt val = Index 12 | (filt -> val -> Bool) 13 | (Int, [val]) 14 | (IORef (Map.Map filt (Int, [val]))) 15 | -- for each list of filters, store the number you have processed, and the number that matched 16 | -- [] is everything 17 | -- throw away filters which are more than half empty on an add 18 | -- (is that necessary? by definition, they are relatively small) 19 | 20 | newIndex :: (filt -> val -> Bool) -> Index filt val 21 | newIndex filt = Index filt (0, []) $ unsafePerformIO $ newIORef Map.empty 22 | 23 | addIndex :: val -> Index filt val -> Index filt val 24 | addIndex x (Index filt (n,xs) ref) = unsafePerformIO $ do 25 | ref <- newIORef =<< readIORef ref 26 | return $ Index filt (n+1, x:xs) ref 27 | 28 | askIndex :: Ord filt => filt -> Index filt val -> [val] 29 | askIndex p (Index filt (n,xs) ref) = unsafePerformIO $ atomicModifyIORef ref $ \mp -> 30 | let (n',xs') = Map.findWithDefault (0,[]) p mp 31 | xs2 = filter (filt p) (take (n-n') xs) ++ xs' 32 | in (Map.insert p (n,xs2) mp, xs2) 33 | -------------------------------------------------------------------------------- /src/General/Lens.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, Rank2Types, TupleSections, NoMonomorphismRestriction #-} 2 | 3 | -- | Simple lenses 4 | module General.Lens( 5 | Lens, makeLens, view, set, over, (&), 6 | (^.), (.~), (%~), 7 | at, at_, atm, _1, _2 8 | ) where 9 | 10 | import Control.Applicative 11 | import Data.Functor.Identity 12 | import qualified Data.Map.Strict as Map 13 | import Data.Maybe 14 | import Data.Monoid 15 | import Prelude 16 | 17 | 18 | infixl 8 ^. 19 | infixl 1 & 20 | infixr 4 .~, %~ 21 | 22 | 23 | type Lens s a = forall f . Functor f => (a -> f a) -> s -> f s 24 | 25 | 26 | makeLens :: (s -> a) -> (a -> s -> s) -> Lens s a 27 | makeLens sel upd f s = flip upd s <$> f (sel s) 28 | 29 | view :: Lens s a -> s -> a 30 | view l s = getConst $ l Const s 31 | 32 | set :: Lens s a -> a -> s -> s 33 | set l x = over l (const x) 34 | 35 | over :: Lens s a -> (a -> a) -> s -> s 36 | over l f s = runIdentity $ l (Identity . f) s 37 | 38 | (^.) :: s -> Lens s a -> a 39 | s ^. l = getConst $ l Const s 40 | -- flip view doesn't work in 7.10, I guess because the forall gets lifted to the top 41 | 42 | (&) :: a -> (a -> b) -> b 43 | (&) = flip ($) 44 | 45 | (.~) :: Lens s a -> a -> s -> s 46 | (.~) = set 47 | 48 | (%~) :: Lens s a -> (a -> a) -> s -> s 49 | (%~) = over 50 | 51 | 52 | at :: Ord k => k -> Lens (Map.Map k v) (Maybe v) 53 | at k f mp = maybe (Map.delete k mp) (\v -> Map.insert k v mp) <$> f (Map.lookup k mp) 54 | 55 | at_ :: Ord k => k -> v -> Lens (Map.Map k v) v 56 | at_ k d = at k . makeLens (fromMaybe d) (\x _ -> Just x) 57 | 58 | atm :: (Ord k, Monoid v) => k -> Lens (Map.Map k v) v 59 | atm k = at_ k mempty 60 | 61 | _1 :: Lens (a, b) a 62 | _1 f (a, b) = (,b) <$> f a 63 | 64 | _2 :: Lens (a, b) b 65 | _2 f (a, b) = (a,) <$> f b 66 | -------------------------------------------------------------------------------- /src/General/MRU.hs: -------------------------------------------------------------------------------- 1 | 2 | module General.MRU( 3 | MRU, empty, insert, lookup, delete, toList 4 | ) where 5 | 6 | import Prelude hiding (lookup) 7 | import qualified Data.Map as Map 8 | import qualified Data.IntMap as IntMap 9 | import Data.Tuple.Extra 10 | 11 | 12 | -- Basically a bimap where we can do minview on the second element 13 | data MRU k v = MRU 14 | Int -- usage index 15 | (Map.Map k (Int, v)) -- when did I last use this thing 16 | (IntMap.IntMap k) -- what was used at which point 17 | 18 | 19 | empty :: MRU k v 20 | empty = MRU 0 Map.empty IntMap.empty 21 | 22 | toList :: MRU k v -> [(k, v)] 23 | toList (MRU _ mp1 _) = map (second snd) $ Map.toList mp1 24 | 25 | insert :: Ord k => k -> v -> MRU k v -> MRU k v 26 | insert k v (MRU n mp1 mp2) = MRU (n+1) (Map.insert k (n, v) mp1) (IntMap.insert n k mp22) 27 | where mp22 = case Map.lookup k mp1 of Nothing -> mp2; Just (i,_) -> IntMap.delete i mp2 28 | 29 | lookup :: Ord k => k -> MRU k v -> Maybe v 30 | lookup k (MRU _ mp1 _) = fmap snd $ Map.lookup k mp1 31 | 32 | delete :: Ord k => MRU k v -> Maybe (k, MRU k v) 33 | delete (MRU n mp1 mp2) = case IntMap.minViewWithKey mp2 of 34 | Nothing -> Nothing 35 | Just ((i,k), mp2) -> Just (k, MRU n (Map.delete k mp1) mp2) 36 | -------------------------------------------------------------------------------- /src/General/Web.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, RecordWildCards, OverloadedStrings, CPP #-} 2 | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Use conduitManagerSettings to work with http-conduit-2.1.6 and below 3 | 4 | module General.Web( 5 | Input(..), Output(..), send, server 6 | ) where 7 | 8 | -- #define PROFILE 9 | 10 | -- For some reason, profiling stops working if I import warp 11 | -- Tracked as https://github.com/yesodweb/wai/issues/311 12 | #ifndef PROFILE 13 | import Network.Wai.Handler.Warp hiding (Port) 14 | #endif 15 | 16 | -- S for server, C for client 17 | import Development.Bake.Core.Type hiding (run) 18 | import Network.Wai as S 19 | import Network.Wai.Parse as P 20 | import Data.Function 21 | import General.Extra 22 | import General.BigString 23 | import Control.DeepSeq 24 | import Control.Exception 25 | import Control.Applicative 26 | import Control.Monad 27 | import System.IO 28 | import Network.HTTP.Conduit as C 29 | import Network.HTTP.Client.MultipartFormData 30 | import Network.HTTP.Types.Status 31 | import qualified Data.Text as Text 32 | import qualified Data.ByteString.Char8 as BS 33 | import qualified Data.ByteString.Lazy.Char8 as LBS 34 | import System.Console.CmdArgs.Verbosity 35 | import Prelude 36 | 37 | 38 | data Input = Input 39 | {inputURL :: [String] 40 | ,inputArgs :: [(String, String)] 41 | ,inputBody :: [(String, BigString)] 42 | } deriving Show 43 | 44 | data Output 45 | = OutputString String 46 | | OutputHTML String 47 | | OutputFile FilePath 48 | | OutputError String 49 | | OutputMissing 50 | deriving Show 51 | 52 | instance NFData Output where 53 | rnf (OutputString x) = rnf x 54 | rnf (OutputHTML x) = rnf x 55 | rnf (OutputFile x) = rnf x 56 | rnf (OutputError x) = rnf x 57 | rnf OutputMissing = () 58 | 59 | {- 60 | -- | Number of time to retry sending messages 61 | maxRetryCount :: Int 62 | maxRetryCount = 3 63 | 64 | -- | Timeout between each message sending attempt 65 | retryTimeout :: Seconds 66 | retryTimeout = 10 67 | -} 68 | 69 | 70 | send :: (Host,Port) -> Input -> IO LBS.ByteString 71 | send (host,port) Input{..} = do 72 | let url = "http://" ++ host ++ ":" ++ show port ++ concatMap ('/':) inputURL ++ 73 | concat (zipWith (++) ("?":repeat "&") [a ++ "=" ++ b | (a,b) <- inputArgs]) 74 | whenLoud $ print ("sending",length inputBody,host,port) 75 | req <- parseUrl url 76 | m <- newManager conduitManagerSettings 77 | withs (map (uncurry withBigStringPart) inputBody) $ \parts -> do 78 | body <- formDataBody parts req 79 | responseBody <$> httpLbs body m 80 | {- 81 | -- http-client 0.5 completely changes this API, so give up retrying until it can be tested 82 | responseBody <$> retrySleep retryTimeout maxRetryCount isConnFailure (httpLbs body m) 83 | where 84 | isConnFailure FailedConnectionException2{} = True 85 | isConnFailure _ = False 86 | -} 87 | 88 | 89 | server :: Port -> (Input -> IO Output) -> IO () 90 | #ifdef PROFILE 91 | server port act = return () 92 | #else 93 | server port act = runSettings settings $ \req reply -> do 94 | whenLoud $ print ("receiving", map Text.unpack $ pathInfo req, S.requestHeaders req, port) 95 | (params, files) <- parseRequestBody bigStringBackEnd req 96 | 97 | let pay = Input 98 | (map Text.unpack $ pathInfo req) 99 | [(BS.unpack a, maybe "" BS.unpack b) | (a,b) <- S.queryString req] $ 100 | [(BS.unpack name, bigStringFromByteString x) | (name,x) <- params] ++ [(BS.unpack name, fileContent) | (name, P.FileInfo{..}) <- files] 101 | res <- act pay 102 | -- from http://stackoverflow.com/questions/49547/making-sure-a-web-page-is-not-cached-across-all-browsers 103 | let nocache = [("Cache-Control","no-cache, no-store, must-revalidate") 104 | ,("Pragma","no-cache") 105 | ,("Expires","0")] 106 | reply $ case res of 107 | OutputFile file -> responseFile status200 nocache file Nothing 108 | OutputString msg -> responseLBS status200 nocache $ LBS.pack msg 109 | OutputHTML msg -> responseLBS status200 (("content-type","text/html"):nocache) $ LBS.pack msg 110 | OutputError msg -> responseLBS status500 nocache $ LBS.pack msg 111 | OutputMissing -> responseLBS status404 nocache $ LBS.pack "Resource not found" 112 | where 113 | settings = setOnExceptionResponse exceptionResponseForDebug $ 114 | setOnException exception $ 115 | setPort port defaultSettings 116 | 117 | 118 | 119 | exception :: Maybe S.Request -> SomeException -> IO () 120 | exception r e = when (defaultShouldDisplayException e) $ 121 | hPutStrLn stderr $ "Error when processing " ++ maybe "Nothing" (show . rawPathInfo) r ++ "\n " ++ show e 122 | #endif 123 | -------------------------------------------------------------------------------- /src/Paths.hs: -------------------------------------------------------------------------------- 1 | -- | Fake cabal module for local building 2 | {-# OPTIONS_GHC -w #-} 3 | 4 | module Paths_bake where 5 | 6 | import Data.Version 7 | import System.IO.Unsafe 8 | import System.Directory 9 | import Control.Exception 10 | import System.Environment.Extra 11 | 12 | 13 | getDataDir :: IO FilePath 14 | getDataDir = unsafePerformIO $ do 15 | -- so that it gets cached the first time 16 | x <- maybe getCurrentDirectory return =<< lookupEnv "bake_datadir" 17 | return $ do 18 | evaluate $ length x 19 | return x 20 | 21 | version :: Version 22 | version = Version {versionBranch = [0,0], versionTags = []} 23 | -------------------------------------------------------------------------------- /src/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | 3 | module Test(main) where 4 | 5 | import Development.Shake.Command 6 | import System.Directory.Extra 7 | import System.IO.Extra 8 | import System.Time.Extra 9 | import System.Environment.Extra 10 | import System.FilePath 11 | import Control.Monad 12 | import Control.Exception.Extra 13 | import Control.Concurrent 14 | import System.Process 15 | import Data.List.Extra 16 | import Data.IORef 17 | import Data.Char 18 | import Control.Applicative 19 | import qualified Example 20 | import Prelude 21 | 22 | import Development.Bake.Test.Simulate 23 | 24 | 25 | main :: IO () 26 | main = do 27 | args <- getArgs 28 | if args /= [] then Example.main else do 29 | simulate 30 | dir <- getCurrentDirectory 31 | test $ dir ++ "/.bake-test" 32 | 33 | test :: FilePath -> IO () 34 | test dir = do 35 | let repo = "file:///" ++ dropWhile (== '/') (replace "\\" "/" dir) ++ "/repo" 36 | b <- doesDirectoryExist dir 37 | when b $ do 38 | unit $ cmd "chmod -R 755 .bake-test" 39 | unit $ cmd "rm -rf .bake-test" 40 | return () 41 | #if __GLASGOW_HASKELL__ >= 708 42 | setEnv "http_proxy" "" 43 | #endif 44 | 45 | createDirectoryIfMissing True (dir "repo") 46 | withCurrentDirectory (dir "repo") $ do 47 | unit $ cmd "git init" 48 | unit $ cmd "git config user.email" ["gwen@example.com"] 49 | unit $ cmd "git config user.name" ["Ms Gwen"] 50 | writeFile "Main.hs" "module Main where\n\n-- Entry point\nmain = print 1\n" 51 | unit $ cmd "git add Main.hs" 52 | unit $ cmd "git commit -m" ["Initial version"] 53 | unit $ cmd "git checkout -b none" -- so I can git push to master 54 | 55 | forM_ ["bob","tony"] $ \s -> do 56 | createDirectoryIfMissing True (dir "repo-" ++ s) 57 | withCurrentDirectory (dir "repo-" ++ s) $ do 58 | print "clone" 59 | unit $ cmd "git clone" repo "." 60 | unit $ cmd "git config user.email" [s ++ "@example.com"] 61 | unit $ cmd "git config user.name" ["Mr " ++ toUpper (head s) : map toLower (tail s)] 62 | unit $ cmd "git checkout -b" s 63 | 64 | aborting <- newIORef False 65 | let createProcessAlive p = do 66 | t <- myThreadId 67 | (_,_,_,pid) <- createProcess p 68 | forkIO $ do 69 | waitForProcess pid 70 | b <- readIORef aborting 71 | when (not b) $ throwTo t $ ErrorCall "Process died" 72 | sleep 2 73 | return pid 74 | exe <- getExecutablePath 75 | createDirectoryIfMissing True $ dir "server" 76 | curdir <- getCurrentDirectory 77 | environment <- (\env -> ("REPO",repo):("bake_datadir",curdir):env) <$> getEnvironment 78 | p0 <- createProcessAlive (proc exe ["server","--author=admin"]) 79 | {cwd=Just $ dir "server", env=Just environment} 80 | sleep 5 81 | ps <- forM (zip [1..] Example.platforms) $ \(i,p) -> do 82 | sleep 0.5 -- so they don't ping at the same time 83 | createDirectoryIfMissing True $ dir "client-" ++ show p 84 | createProcessAlive (proc exe $ 85 | ["client","--ping=1","--name=" ++ show p,"--threads=" ++ show i,"--provide=" ++ show p]) 86 | {cwd=Just $ dir "client-" ++ show p,env=Just environment} 87 | flip finally (do writeIORef aborting True; mapM_ terminateProcess $ p0 : ps) $ do 88 | let edit name act = withCurrentDirectory (dir "repo-" ++ name) $ do 89 | act 90 | unit $ cmd "git add *" 91 | unit $ cmd "git commit -m" ["Update from " ++ name] 92 | unit $ cmd "git push origin" name 93 | Stdout sha1 <- cmd "git rev-parse HEAD" 94 | unit $ cmd exe "addpatch" ("--name=" ++ name ++ "=" ++ sha1) ("--author=" ++ name) 95 | 96 | putStrLn "% MAKING EDIT AS BOB" 97 | edit "bob" $ 98 | writeFile "Main.hs" "module Main(main) where\n\n-- Entry point\nmain = print 1\n" 99 | sleep 2 100 | putStrLn "% MAKING EDIT AS TONY" 101 | edit "tony" $ 102 | writeFile "Main.hs" "module Main where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n" 103 | 104 | retry 10 $ do 105 | sleep 10 106 | withTempDir $ \d -> withCurrentDirectory d $ do 107 | unit $ cmd "git clone" repo "." 108 | unit $ cmd "git checkout master" 109 | src <- readFile "Main.hs" 110 | let expect = "module Main(main) where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n" 111 | when (src /= expect) $ do 112 | error $ "Expected to have updated Main, but got:\n" ++ src 113 | 114 | unit $ cmd exe "pause" 115 | putStrLn "% MAKING A GOOD EDIT AS BOB" 116 | edit "bob" $ do 117 | unit $ cmd "git fetch origin" 118 | unit $ cmd "git merge origin/master" 119 | writeFile "Main.hs" "module Main(main) where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n\n" 120 | putStrLn "% MAKING A BAD EDIT AS BOB" 121 | edit "bob" $ 122 | writeFile "Main.hs" "module Main(main) where\nimport System.Environment\n-- Entry point\nmain :: IO ()\nmain = do [[_]] <- getArgs; print 1\n\n" 123 | putStrLn "% MAKING A GOOD EDIT AS TONY" 124 | edit "tony" $ do 125 | unit $ cmd "git fetch origin" 126 | unit $ cmd "git merge origin/master" 127 | writeFile "Main.hs" "-- Tony waz ere\nmodule Main(main) where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n" 128 | putStrLn "% MAKING A MERGE CONFLICT AS BOB" 129 | edit "bob" $ 130 | writeFile "Main.hs" "-- Bob waz ere\nmodule Main(main) where\nimport System.Environment\n-- Entry point\nmain :: IO ()\nmain = do [[_]] <- getArgs; print 1\n\n" 131 | putStrLn "% MAKING ANOTHER GOOD EDIT AS TONY" 132 | edit "tony" $ do 133 | writeFile "Main.hs" "-- Tony waz ere 1981\nmodule Main(main) where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n" 134 | unit $ cmd exe "unpause" 135 | 136 | retry 15 $ do 137 | sleep 10 138 | withTempDir $ \d -> withCurrentDirectory d $ do 139 | unit $ cmd "git clone" repo "." 140 | unit $ cmd "git checkout master" 141 | src <- readFile "Main.hs" 142 | let expect = "-- Tony waz ere 1981\nmodule Main(main) where\n\n-- Entry point\nmain :: IO ()\nmain = print 1\n\n" 143 | when (src /= expect) $ do 144 | error $ "Expected to have updated Main, but got:\n" ++ src 145 | 146 | putStrLn "Completed successfully!" 147 | -- putStrLn "Waiting (time to view webpage)..." >> sleep 120 148 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-10.3 2 | -------------------------------------------------------------------------------- /test/Bake/Test/GCSpec.hs: -------------------------------------------------------------------------------- 1 | module Bake.Test.GCSpec where 2 | 3 | import Test.Tasty 4 | import Test.Tasty.Hspec 5 | import System.Directory.Extra 6 | import System.FilePath 7 | import System.Directory 8 | import System.IO 9 | import System.IO.Extra 10 | import Control.Exception 11 | import Control.Monad 12 | import qualified Data.Set as Set 13 | 14 | import Development.Bake 15 | 16 | withTestDirectory :: (FilePath -> IO ()) -> IO () 17 | withTestDirectory action = withTempDir $ \ dir -> bracket 18 | (do 19 | let sourceTestDir = "test" "test-gc" 20 | allFiles <- listFilesRecursive sourceTestDir 21 | forM_ allFiles (\ file -> let file' = dir makeRelative sourceTestDir file 22 | in createDirectoryIfMissing True (takeDirectory file') >> copyFile file file') 23 | return dir 24 | ) 25 | removeDirectoryRecursive 26 | action 27 | 28 | gcSpec = describe "Garbage Collector" $ do 29 | 30 | it "preserve incremental build test directories" $ withTestDirectory $ \ dir -> do 31 | garbageCollect 0 1 0 [ dir ] 32 | filesAfterGc <- listFilesRecursive dir 33 | 34 | Set.fromList (map (makeRelative dir) filesAfterGc) `shouldBe` Set.fromList ["bake-incremental.txt" 35 | ,"bake-extra-467723236138728164/.bake.name" 36 | ,"bake-store/.bake.name" 37 | ,"bake-test-467723236138728164/.bake.name" 38 | ,"bake-update-467723236138728164/.bake.name"] 39 | 40 | 41 | 42 | 43 | -------------------------------------------------------------------------------- /test/bake-test.hs: -------------------------------------------------------------------------------- 1 | import Test.Tasty 2 | import Test.Tasty.Hspec 3 | import Bake.Test.GCSpec 4 | 5 | main = testSpec "Bake" gcSpec >>= defaultMain 6 | -------------------------------------------------------------------------------- /test/test-gc/bake-extra-467723236138728164/.bake.name: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/bake/967de648990e06fa1eb9a8fd629fcf155be5891f/test/test-gc/bake-extra-467723236138728164/.bake.name -------------------------------------------------------------------------------- /test/test-gc/bake-extra-7086488451789726956/.bake.name: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/bake/967de648990e06fa1eb9a8fd629fcf155be5891f/test/test-gc/bake-extra-7086488451789726956/.bake.name -------------------------------------------------------------------------------- /test/test-gc/bake-extra-8242524289800929962/.bake.name: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/bake/967de648990e06fa1eb9a8fd629fcf155be5891f/test/test-gc/bake-extra-8242524289800929962/.bake.name -------------------------------------------------------------------------------- /test/test-gc/bake-git-5401199084002705030/.bake.name: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/bake/967de648990e06fa1eb9a8fd629fcf155be5891f/test/test-gc/bake-git-5401199084002705030/.bake.name -------------------------------------------------------------------------------- /test/test-gc/bake-incremental.txt: -------------------------------------------------------------------------------- 1 | bake-test-467723236138728164 2 | -------------------------------------------------------------------------------- /test/test-gc/bake-init/.bake.name: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/bake/967de648990e06fa1eb9a8fd629fcf155be5891f/test/test-gc/bake-init/.bake.name -------------------------------------------------------------------------------- /test/test-gc/bake-store/.bake.name: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/bake/967de648990e06fa1eb9a8fd629fcf155be5891f/test/test-gc/bake-store/.bake.name -------------------------------------------------------------------------------- /test/test-gc/bake-test-467723236138728164/.bake.name: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/bake/967de648990e06fa1eb9a8fd629fcf155be5891f/test/test-gc/bake-test-467723236138728164/.bake.name -------------------------------------------------------------------------------- /test/test-gc/bake-test-657771599651844319.gc/.bake.name: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/bake/967de648990e06fa1eb9a8fd629fcf155be5891f/test/test-gc/bake-test-657771599651844319.gc/.bake.name -------------------------------------------------------------------------------- /test/test-gc/bake-test-657771599651844319/.bake.name: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/bake/967de648990e06fa1eb9a8fd629fcf155be5891f/test/test-gc/bake-test-657771599651844319/.bake.name -------------------------------------------------------------------------------- /test/test-gc/bake-test-7086488451789726956/.bake.name: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/bake/967de648990e06fa1eb9a8fd629fcf155be5891f/test/test-gc/bake-test-7086488451789726956/.bake.name -------------------------------------------------------------------------------- /test/test-gc/bake-update-467723236138728164/.bake.name: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ndmitchell/bake/967de648990e06fa1eb9a8fd629fcf155be5891f/test/test-gc/bake-update-467723236138728164/.bake.name -------------------------------------------------------------------------------- /travis.hs: -------------------------------------------------------------------------------- 1 | 2 | import System.Process.Extra 3 | 4 | main = system_ "bake-test" 5 | --------------------------------------------------------------------------------