├── .gitignore ├── .travis.yml ├── Guardfile ├── LICENSE ├── README.md ├── TODO ├── angel.cabal ├── changelog.md ├── example.conf ├── src └── Angel │ ├── Config.hs │ ├── Data.hs │ ├── Files.hs │ ├── Job.hs │ ├── Log.hs │ ├── Main.hs │ ├── PidFile.hs │ ├── Prelude.hs │ ├── Process.hs │ └── Util.hs └── test ├── Angel ├── ConfigSpec.hs ├── JobSpec.hs ├── LogSpec.hs ├── PidFileSpec.hs └── UtilSpec.hs ├── Spec.hs ├── SpecHelper.hs └── test_jobs ├── CompliantJob.hs └── StubbornJob.hs /.gitignore: -------------------------------------------------------------------------------- 1 | cabal-dev 2 | dist 3 | dist-newstyle 4 | *.o 5 | *.hi 6 | test/test_jobs/CompliantJob 7 | test/test_jobs/StubbornJob 8 | .cabal-sandbox 9 | cabal.sandbox.config 10 | .stack-work/ 11 | .ghc.environment* 12 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | matrix: 2 | allow_failures: 3 | - env: GHCVER=head 4 | 5 | env: 6 | - CABALVER=1.18 GHCVER=7.6.3 7 | - CABALVER=1.18 GHCVER=7.8.3 8 | - CABALVER=1.24 GHCVER=7.10.1 9 | - CABALVER=1.24 GHCVER=8.0.1 10 | 11 | # Note: the distinction between `before_install` and `install` is not important. 12 | before_install: 13 | - travis_retry sudo add-apt-repository -y ppa:hvr/ghc 14 | - travis_retry sudo apt-get update 15 | - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER # see note about happy/alex 16 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH 17 | 18 | install: 19 | - cabal --version 20 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 21 | - travis_retry cabal update 22 | - cabal install happy 23 | - cabal install --only-dependencies --enable-tests --enable-benchmarks 24 | 25 | # Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail. 26 | script: 27 | - cabal configure --enable-tests --enable-benchmarks -v2 # -v2 provides useful information for debugging 28 | - cabal test 29 | - cabal configure && (cabal check || true) 30 | - cabal sdist # tests that a source-distribution can be generated 31 | 32 | # The following scriptlet checks that the resulting source distribution can be built & installed 33 | - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ; 34 | cd dist/; 35 | if [ -f "$SRC_TGZ" ]; then 36 | cabal install --force-reinstalls "$SRC_TGZ"; 37 | else 38 | echo "expected '$SRC_TGZ' not found"; 39 | exit 1; 40 | fi 41 | -------------------------------------------------------------------------------- /Guardfile: -------------------------------------------------------------------------------- 1 | guard :shell, :all_after_pass => true do 2 | watch(%r{.*\.cabal$}) do 3 | run_all_tests 4 | end 5 | 6 | watch(%r{test/SpecHelper.hs$}) do 7 | run_all_tests 8 | end 9 | 10 | def run_all_tests 11 | ncmd("cabal configure && cabal build && cabal test") 12 | end 13 | 14 | def ncmd(cmd, msg = cmd) 15 | output = `#{cmd}` 16 | puts output 17 | summary = output.lines.grep(/examples/).first 18 | 19 | if $?.success? 20 | n "Build Success!", summary 21 | else 22 | n "Failed", summary 23 | end 24 | end 25 | 26 | def run_tests(mod) 27 | specfile = "test/#{mod}Spec.hs" 28 | if File.exists?(specfile) 29 | files = [specfile] 30 | else 31 | files = Dir['test/**/*.hs'] 32 | end 33 | 34 | if package_db = Dir[".cabal-sandbox/*packages.conf.d", "cabal-dev/*packages.conf.d"].first 35 | package_db_flag = "-package-db #{package_db}" 36 | end 37 | 38 | ncmd("ghc -isrc -itest #{package_db_flag} -e 'Test.Hspec.hspec spec' #{files.join(' ')}") 39 | end 40 | 41 | # can we join these? why does run all loop through each file? 42 | watch(%r{src/(.+)\.hs$}) do |m| 43 | run_tests(m[1]) 44 | end 45 | 46 | watch(%r{test/(.+)Spec\.hs$}) do |m| 47 | run_tests(m[1]) 48 | end 49 | end 50 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Jamie Turner 2011 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are 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 Jamie Turner 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Angel 2 | ===== 3 | [![Build Status](https://travis-ci.org/MichaelXavier/Angel.png?branch=master)](https://travis-ci.org/MichaelXavier/Angel) 4 | 5 | `angel` is a daemon that runs and monitors other processes. It 6 | is similar to djb's `daemontools` or the Ruby project `god`. 7 | 8 | It's goals are to keep a set of services running, and to facilitate 9 | the easy configuration and restart of those services. 10 | 11 | 12 | Maintainers Wanted 13 | ------------------ 14 | I do not actively use Angel anymore and don't have much time to work 15 | on it. If you are an invested user in Angel, you shold have a say in 16 | the direction of the project. Let me know in a Github issue and I will 17 | happily add you to the project. 18 | 19 | 20 | Motivation 21 | ---------- 22 | 23 | The author is a long-time user of `daemontools` due to its reliability 24 | and simplicity; however, `daemontools` is quirky and follows many 25 | unusual conventions. 26 | 27 | `angel` is an attempt to recreate `daemontools`'s capabilities (though 28 | not the various bundled utility programs which are still quite useful) 29 | in a more intuitive and modern unix style. 30 | 31 | 32 | Functionality 33 | ------------- 34 | 35 | `angel` is driven by a configuration file that contains a list of 36 | program specifications to run. `angel` assumes every program listed in 37 | the specification file should be running at all times. 38 | 39 | `angel` starts each program, and optionally sets the program's stdout 40 | and stderr to some file(s) which have been opened in append mode 41 | (or pipes stdout and stderr to some logger process); at 42 | this point, the program is said to be "supervised". 43 | 44 | If the program dies for any reason, `angel` waits a specified number 45 | of seconds (default, 5), then restarts the program. 46 | 47 | The `angel` process itself will respond to a HUP signal by 48 | re-processing its configuration file, and synchronizing the run 49 | states with the new configuration. Specifically: 50 | 51 | * If a new program has been added to the file, it is started and 52 | supervised 53 | * If a program's specification has changed (command line path, 54 | stdin/stdout path, delay time, etc) that supervised child 55 | process will be sent a TERM signal, and as a consequence of 56 | normal supervision, will be restarted with the updated spec 57 | * If a program has been removed from the configuration file, 58 | the corresponding child process will be sent a TERM signal; 59 | when it dies, supervision of the process will end, and 60 | therefore, it will not be restarted 61 | 62 | Safety and Reliability 63 | ---------------------- 64 | 65 | Because of `angel`'s role in policing the behavior of other 66 | daemons, it has been written to be very reliable: 67 | 68 | * It is written in Haskell, which boasts a combination of 69 | strong, static typing and purity-by-default that lends 70 | itself to very low bug counts 71 | * It uses multiple, simple, independent lightweight threads 72 | with specific roles, ownership, and interfaces 73 | * It uses STM for mutex-free state synchronization between 74 | these threads 75 | * It falls back to polling behavior to ensure eventual 76 | synchronization between configuration state and run 77 | state, just in case odd timing issues should make 78 | event-triggered changes fail 79 | * It simply logs errors and keeps running the last good 80 | configuration if it runs into problems on configuration 81 | reloads 82 | * It has logged hundreds of thousands of uptime-hours 83 | since 2010-07 supervising all the daemons that power 84 | http://bu.mp without a single memory leak or crash 85 | 86 | Building 87 | -------- 88 | 89 | 1. Install the haskell-platform (or somehow, ghc 7.6 + 90 | cabal-install) 91 | 2. Run `cabal install` in the project root (this directory) 92 | 3. Either add the ~/.cabal/bin file to your $PATH or copy 93 | the `angel` executable to /usr/local/bin 94 | 95 | Notes: 96 | 97 | * Angel is recommended to be built on GHC 7.6 and newer. 98 | 99 | Configuration and Usage Example 100 | ------------------------------- 101 | 102 | The `angel` executable takes a path to an angel configuration 103 | file. 104 | 105 | angel --help 106 | angel - Process management and supervision daemon 107 | 108 | Usage: angel CONFIG_FILE [-u USER] [-v VERBOSITY] 109 | 110 | Available options: 111 | -h,--help Show this help text 112 | -u USER Execute as this user 113 | -v VERBOSITY Verbosity from 0-2 (default: 2) 114 | 115 | If the -u option is specified on the command line, it will take precedence over 116 | any configuration command in the configuration file. 117 | 118 | `angel`'s configuration system is based on Bryan O'Sullivan's `configurator` 119 | package. A full description of the format can be found here: 120 | 121 | http://hackage.haskell.org/packages/archive/configurator/0.1.0.0/doc/html/Data-Configurator.html 122 | 123 | A basic configuration file might look like this: 124 | 125 | #user is optional with a default of the current user 126 | user = "alice" 127 | 128 | watch-date { 129 | exec = "watch date" 130 | } 131 | 132 | ls { 133 | exec = "ls" 134 | stdout = "/tmp/ls_log" 135 | stderr = "/tmp/ls_log" 136 | delay = 7 137 | termgrace = off 138 | } 139 | 140 | workers { 141 | directory = "/path/to/worker" 142 | exec = "run_worker" 143 | count = 30 144 | pidfile = "/path/to/pidfile.pid" 145 | env { 146 | FOO = "BAR" 147 | BAR = "BAZ" 148 | } 149 | termgrace = 10 150 | } 151 | 152 | By adding a "user" configuration command at the top level of the 153 | configuration it is possible to specify the user Angel will be executed as. 154 | Each of the programs listed in the specification file will also be executed 155 | as this user. This option is only read on first start up, and is not re-read 156 | if the configuration file changes. 157 | 158 | The user configuration command is ignored if a user is specified on the 159 | command line via the -u option. 160 | 161 | Angel will run as the invoking user if no user configuration command 162 | is specified. 163 | 164 | Each program that should be supervised starts a `program-id` block: 165 | 166 | watch-date { 167 | 168 | Then, a series of corresponding configuration commands follow: 169 | 170 | * `exec` is the exact command line to run (required) 171 | * `stdout` is a path to a file where the program's standard output 172 | should be appended (optional, defaults to /dev/null) 173 | * `stderr` is a path to a file where the program's standard error 174 | should be appended (optional, defaults to /dev/null) 175 | * `delay` is the number of seconds (integer) `angel` should wait 176 | after the program dies before attempting to start it again 177 | (optional, defaults to 5) 178 | * `directory` is the current working directory of the newly 179 | executed program (optional, defaults to angel's cwd) 180 | * `logger` is another process that should be launched to handle 181 | logging. The `exec` process will then have its stdout and stderr 182 | piped into stdin of this logger. Recommended log 183 | rotation daemons include [clog](https://github.com/jamwt/clog) 184 | or [multilog](http://cr.yp.to/daemontools.html). *Note that 185 | if you use a logger process, it is a configuration error 186 | to specify either stdout or stderr as well.* 187 | * `count` is an optional argument to specify the number of processes to spawn. 188 | For instance, if you specified a count of 2, it will spawn the program 189 | twice, internally as `workers-1` and `workers-2`, for example. Note that 190 | `count` will inject the environment variable `ANGEL_PROCESS_NUMBER` into the 191 | child process' environment variable. 192 | * `pidfile` is an optional argument to specify where a pidfile should be 193 | created. If you don't specify an absolute path, it will use the running 194 | directory of angel. When combined with the `count` option, specifying a 195 | pidfile of `worker.pid`, it will generate `worker-1.pid`, `worker-2.pid`, 196 | etc. If you don't specify a `pidfile` directive, then `angel` will *not* 197 | create a pidfile 198 | * `env` is a nested config of string key/value pairs. Non-string values are 199 | invalid. 200 | * `termgrace` is an optional number of seconds to wait between 201 | sending a SIGTERM and a SIGKILL to a program when it needs to shut 202 | down. Any positive number will be interpreted as seconds. `0`, 203 | `off`, or omission will be interpreted as disabling the feature and 204 | only a sigterm will be sent. This is useful for processes that must 205 | not be brought down forcefully to avoid corruption of data or other 206 | ill effects. 207 | 208 | Assuming the above configuration was in a file called "example.conf", 209 | here's what a shell session might look like: 210 | 211 | jamie@choo:~/random/angel$ angel example.conf 212 | [2010/08/24 15:21:22] {main} Angel started 213 | [2010/08/24 15:21:22] {main} Using config file: example.conf 214 | [2010/08/24 15:21:22] {process-monitor} Must kill=0, must start=2 215 | [2010/08/24 15:21:22] {- program: watch-date -} START 216 | [2010/08/24 15:21:22] {- program: watch-date -} RUNNING 217 | [2010/08/24 15:21:22] {- program: ls -} START 218 | [2010/08/24 15:21:22] {- program: ls -} RUNNING 219 | [2010/08/24 15:21:22] {- program: ls -} ENDED 220 | [2010/08/24 15:21:22] {- program: ls -} WAITING 221 | [2010/08/24 15:21:29] {- program: ls -} RESTART 222 | [2010/08/24 15:21:29] {- program: ls -} START 223 | [2010/08/24 15:21:29] {- program: ls -} RUNNING 224 | [2010/08/24 15:21:29] {- program: ls -} ENDED 225 | [2010/08/24 15:21:29] {- program: ls -} WAITING 226 | 227 | .. etc 228 | 229 | You can see that when the configuration is parsed, the process-monitor 230 | notices that two programs need to be started. A supervisor is started 231 | in a lightweight thread for each, and starts logging with the context 232 | `program: `. 233 | pp 234 | `watch-date` starts up and runs. Since `watch` is a long-running process 235 | it just keeps running in the background. 236 | 237 | `ls`, meanwhile, runs and immediately ends, of course; then, the WAITING 238 | state is entered until `delay` seconds pass. Finally, the RESTART event 239 | is triggered and it is started again, ad naseum. 240 | 241 | Now, let's see what happens if we modify the config file to look like this: 242 | 243 | #watch-date { 244 | # exec = "watch date" 245 | #} 246 | 247 | ls { 248 | exec = "ls" 249 | stdout = "/tmp/ls_log" 250 | stderr = "/tmp/ls_log" 251 | delay = 7 252 | } 253 | 254 | .. and then send HUP to angel. 255 | 256 | [2010/08/24 15:33:59] {config-monitor} HUP caught, reloading config 257 | [2010/08/24 15:33:59] {process-monitor} Must kill=1, must start=0 258 | [2010/08/24 15:33:59] {- program: watch-date -} ENDED 259 | [2010/08/24 15:33:59] {- program: watch-date -} QUIT 260 | [2010/08/24 15:34:03] {- program: ls -} RESTART 261 | [2010/08/24 15:34:03] {- program: ls -} START 262 | [2010/08/24 15:34:03] {- program: ls -} RUNNING 263 | [2010/08/24 15:34:03] {- program: ls -} ENDED 264 | [2010/08/24 15:34:03] {- program: ls -} WAITING 265 | 266 | As you can see, the config monitor reloaded on HUP, and then the 267 | process monitor marked the watch-date process for killing. TERM 268 | was sent to the child process, and then the supervisor loop QUIT 269 | because the watch-date program no longer had a config entry. 270 | 271 | This also works for when you specify count. Incrementing/decrementing the count 272 | will intelligently shut down excess processes and spin new ones up. 273 | 274 | Advanced Configuration 275 | ---------------------- 276 | 277 | The `configurator` package supports `import` statements, as 278 | well as environment variable expansion. Using collections 279 | of configuration files and host-based or service-based 280 | environment variables, efficient, templated `angel` 281 | configurations can be had. 282 | 283 | Testing 284 | ------- 285 | If you prefer to stick with haskell tools, use cabal to build the package. 286 | 287 | 288 | You can run the test suite with 289 | 290 | ``` 291 | cabal test 292 | ``` 293 | 294 | FAQ 295 | --- 296 | 297 | **Can I have multiple programs logging to the same file?** 298 | 299 | Yes, angel `dup()`s file descriptors and makes effort to safely 300 | allow concurrent writes by child programs; you should DEFINITELY 301 | make sure your child program is doing stdout/stderr writes in 302 | line-buffered mode so this doesn't result in a complete interleaved 303 | mess in the log file. 304 | 305 | **Will angel restart programs for me?** 306 | 307 | No; the design is just to send your programs TERM, then `angel` will 308 | restart them. `angel` tries to work in harmony with traditional 309 | Unix process management conventions. 310 | 311 | **How can I take a service down without wiping out its configuration?** 312 | 313 | Specify a `count` of 0 for the process. That will kill any running processes 314 | but still let you keep it in the config file. 315 | 316 | CHANGELOG 317 | --------- 318 | 319 | See [changelog.md](changelog.md) 320 | 321 | Author 322 | ------ 323 | 324 | Original Author: Jamie Turner 325 | Current Maintainer: Michael Xavier 326 | 327 | Thanks to Bump Technologies, Inc. (http://bu.mp) for sponsoring some 328 | of the work on angel. 329 | 330 | And, of course, thanks to all Angel's contributors: 331 | 332 | https://github.com/MichaelXavier/Angel/contributors 333 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | * ghc 6.10 support? (patches welcome) 2 | * replace bizarre usage of TVar with TMVar or just MVar 3 | * massive module cleanup 4 | -------------------------------------------------------------------------------- /angel.cabal: -------------------------------------------------------------------------------- 1 | Name: angel 2 | Version: 0.6.2 3 | License: BSD3 4 | License-file: LICENSE 5 | Author: Jamie Turner 6 | Synopsis: Process management and supervision daemon 7 | Description: @angel@ is a daemon that runs and monitors other processes. It 8 | is similar to djb's `daemontools` or the Ruby project `god`. 9 | . 10 | It's goals are to keep a set of services running, and to facilitate 11 | the easy configuration and restart of those services. 12 | 13 | See the homepage for documentation. 14 | 15 | Maintainer: Michael Xavier 16 | Homepage: http://github.com/MichaelXavier/Angel 17 | Bug-Reports: http://github.com/MichaelXavier/Angel/issues 18 | 19 | Stability: Stable 20 | Category: System 21 | Build-type: Simple 22 | 23 | Extra-source-files: README.md 24 | changelog.md 25 | test/test_jobs/CompliantJob.hs 26 | test/test_jobs/StubbornJob.hs 27 | 28 | Cabal-version: >=1.8 29 | 30 | 31 | source-repository head 32 | type: git 33 | location: https://github.com/MichaelXavier/Angel.git 34 | 35 | Executable angel 36 | Hs-Source-Dirs: src 37 | Main-is: Angel/Main.hs 38 | 39 | Build-depends: base >= 4.5 && < 5 40 | Build-depends: process >= 1.2.0.0 && < 2.0 41 | Build-depends: mtl 42 | Build-depends: configurator >= 0.1 43 | Build-depends: stm >= 2.0 44 | Build-depends: containers >= 0.3 45 | Build-depends: unordered-containers >= 0.1.4 46 | Build-depends: unix >= 2.4 47 | Build-depends: time >= 1.5 48 | Build-depends: old-locale 49 | Build-depends: text>=0.11 50 | Build-depends: transformers 51 | Build-depends: optparse-applicative >= 0.12 52 | 53 | 54 | Other-modules: Angel.Files, 55 | Angel.Config, 56 | Angel.Data, 57 | Angel.Job, 58 | Angel.Prelude, 59 | Angel.Process, 60 | Angel.Log, 61 | Angel.Util, 62 | Angel.PidFile 63 | 64 | Extensions: OverloadedStrings,ScopedTypeVariables,BangPatterns,ViewPatterns 65 | 66 | Ghc-Options: -threaded 67 | 68 | test-suite spec 69 | Type: exitcode-stdio-1.0 70 | Main-Is: Spec.hs 71 | Hs-Source-Dirs: src, test 72 | Other-modules: Angel.ConfigSpec 73 | Angel.JobSpec 74 | Angel.LogSpec 75 | Angel.PidFileSpec 76 | Angel.UtilSpec 77 | SpecHelper 78 | Build-Depends: base 79 | Build-Depends: tasty 80 | Build-Depends: tasty-hunit 81 | Build-Depends: tasty-quickcheck 82 | Build-depends: base >= 4.0 && < 5 83 | Build-depends: process >= 1.0 && < 2.0 84 | Build-depends: mtl 85 | Build-depends: configurator >= 0.1 86 | Build-depends: stm >= 2.0 87 | Build-depends: containers >= 0.3 88 | Build-depends: unordered-containers >= 0.1.4 89 | Build-depends: unix >= 2.4 90 | Build-depends: time 91 | Build-depends: old-locale 92 | Build-depends: text>=0.11 93 | Build-depends: transformers 94 | Extensions: OverloadedStrings,ScopedTypeVariables,BangPatterns,ViewPatterns 95 | Ghc-Options: -threaded -rtsopts -with-rtsopts=-N 96 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | 0.6.2 2 | * Switch to cabal-only build strategy 3 | 4 | 0.6.1 5 | * Fix build for GHC 7.10 by adding FlexibleContexts 6 | 7 | 0.6.0 8 | * Upgrade to time 1.5 9 | 10 | 0.5.2 11 | * Add -v flag to executable 12 | 13 | 0.5.0 14 | * Drop depdendency on MissingH 15 | 16 | 0.4.4 17 | 18 | * Add `env` option to config. 19 | * Inject `ANGEL_PROCESS_NUMBER` environment variable into processes started 20 | with `count`. 21 | 22 | 0.4.3 23 | 24 | * Fix install failure from pidfile module not being accounted for. 25 | 26 | 0.4.2 27 | 28 | * Add `pidfile` option to program spec to specify a pidfile location. 29 | 30 | 0.4.1 31 | 32 | * Add `count` option to program spec to launch multiple instances of a program. 33 | -------------------------------------------------------------------------------- /example.conf: -------------------------------------------------------------------------------- 1 | watch-date { 2 | exec = "watch date" 3 | } 4 | 5 | ls { 6 | directory = "/home/jamie/bump/server" 7 | exec = "ls" 8 | stdout = "/tmp/ls_log_$(USER)" 9 | stderr = "/tmp/ls_log_$(USER)" 10 | delay = 7 11 | } 12 | 13 | workers { 14 | directory = "/path/to/worker" 15 | exec = "run_worker" 16 | count = 30 17 | } 18 | -------------------------------------------------------------------------------- /src/Angel/Config.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE NoImplicitPrelude #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | module Angel.Config ( monitorConfig 6 | , modifyProg 7 | , expandByCount 8 | , loadInitialUserFromConfig 9 | -- for testing 10 | , processConfig) where 11 | 12 | import Control.Exception ( try 13 | , SomeException ) 14 | import qualified Data.Map as M 15 | import Control.Monad ( when 16 | , (>=>) ) 17 | import Control.Monad.IO.Class (liftIO) 18 | import Control.Concurrent.STM ( STM 19 | , TVar 20 | , writeTVar 21 | , readTVar 22 | , atomically ) 23 | import qualified Data.Configurator as C ( load 24 | , getMap 25 | , lookup 26 | , Worth(Required) ) 27 | import Data.Configurator.Types ( Value(Number, String, Bool) 28 | , Name ) 29 | import qualified Data.Traversable as T 30 | import qualified Data.HashMap.Lazy as HM 31 | import Data.List ( nub 32 | , foldl' ) 33 | import Data.Maybe ( isNothing 34 | , isJust ) 35 | import Data.Monoid ( (<>) ) 36 | import qualified Data.Text as T 37 | import Angel.Job ( syncSupervisors ) 38 | import Angel.Data ( Program( exec 39 | , delay 40 | , stdout 41 | , stderr 42 | , logExec 43 | , pidFile 44 | , workingDir 45 | , name 46 | , termGrace 47 | , env ) 48 | , SpecKey 49 | , AngelM 50 | , GroupConfig 51 | , Verbosity(..) 52 | , spec 53 | , defaultProgram ) 54 | import Angel.Log ( logger ) 55 | import Angel.Prelude 56 | import Angel.Util ( waitForWake 57 | , nnull 58 | , expandPath ) 59 | 60 | -- |produce a mapping of name -> program for every program 61 | buildConfigMap :: HM.HashMap Name Value -> SpecKey 62 | buildConfigMap = HM.foldlWithKey' addToMap M.empty . addDefaults 63 | where 64 | addToMap :: SpecKey -> Name -> Value -> SpecKey 65 | addToMap m n value 66 | | nnull basekey && nnull localkey = 67 | let !newprog = case M.lookup basekey m of 68 | Just prog -> modifyProg prog localkey value 69 | Nothing -> modifyProg defaultProgram {name = basekey, env = []} localkey value 70 | in 71 | M.insert basekey newprog m 72 | | otherwise = m 73 | where (basekey, '.':localkey) = break (== '.') $ T.unpack n 74 | 75 | addDefaults :: HM.HashMap Name Value -> HM.HashMap Name Value 76 | addDefaults conf = foldl' addDefault conf progs 77 | where 78 | graceKey prog = prog <> ".grace" 79 | progs = programNames conf 80 | addDefault conf' prog 81 | | HM.member (graceKey prog) conf' = conf' 82 | | otherwise = HM.insert (graceKey prog) defaultGrace conf 83 | defaultGrace = Bool False 84 | 85 | programNames :: HM.HashMap Name a -> [Name] 86 | programNames = nub . filter nnullN . map extractName . HM.keys 87 | where 88 | extractName = T.takeWhile (/= '.') 89 | 90 | checkConfigValues :: SpecKey -> IO SpecKey 91 | checkConfigValues progs = mapM_ checkProgram (M.elems progs) >> return progs 92 | where 93 | checkProgram p = do 94 | when (isNothing $ exec p) $ error $ name p ++ " does not have an 'exec' specification" 95 | when (isJust (logExec p) && 96 | (isJust (stdout p) || isJust (stderr p) )) $ error $ name p ++ " cannot have both a logger process and stderr/stdout" 97 | 98 | modifyProg :: Program -> String -> Value -> Program 99 | modifyProg prog "exec" (String s) = prog {exec = Just (T.unpack s)} 100 | modifyProg _ "exec" _ = error "wrong type for field 'exec'; string required" 101 | 102 | modifyProg prog "delay" (Number n) | n < 0 = error "delay value must be >= 0" 103 | | otherwise = prog{delay = Just $ round n} 104 | modifyProg _ "delay" _ = error "wrong type for field 'delay'; integer" 105 | 106 | modifyProg prog "stdout" (String s) = prog{stdout = Just (T.unpack s)} 107 | modifyProg _ "stdout" _ = error "wrong type for field 'stdout'; string required" 108 | 109 | modifyProg prog "stderr" (String s) = prog{stderr = Just (T.unpack s)} 110 | modifyProg _ "stderr" _ = error "wrong type for field 'stderr'; string required" 111 | 112 | modifyProg prog "directory" (String s) = prog{workingDir = Just (T.unpack s)} 113 | modifyProg _ "directory" _ = error "wrong type for field 'directory'; string required" 114 | 115 | modifyProg prog "logger" (String s) = prog{logExec = Just (T.unpack s)} 116 | modifyProg _ "logger" _ = error "wrong type for field 'logger'; string required" 117 | 118 | modifyProg prog "pidfile" (String s) = prog{pidFile = Just (T.unpack s)} 119 | modifyProg _ "pidfile" _ = error "wrong type for field 'pidfile'; string required" 120 | 121 | modifyProg prog ('e':'n':'v':'.':envVar) (String s) = prog{env = envVar'} 122 | where envVar' = (envVar, T.unpack s):env prog 123 | modifyProg _ ('e':'n':'v':'.':_) _ = error "wrong type for env field; string required" 124 | 125 | modifyProg prog "termgrace" (Bool False) = prog{termGrace = Nothing} 126 | modifyProg prog "termgrace" (Number n) | n < 0 = error "termgrace if it is a number must be >= 1" 127 | | n == 0 = prog{termGrace = Nothing} 128 | | otherwise = prog { termGrace = Just $ round n} 129 | modifyProg _ "termgrace" _ = error "wrong type for field 'termgrace'; number or boolean false required" 130 | 131 | modifyProg prog _ _ = prog 132 | 133 | loadInitialUserFromConfig :: FilePath -> IO (Maybe String) 134 | loadInitialUserFromConfig configPath = do 135 | C.load [C.Required configPath] >>= flip C.lookup "user" 136 | 137 | -- |invoke the parser to process the file at configPath 138 | -- |produce a SpecKey 139 | processConfig :: String -> IO (Either String SpecKey) 140 | processConfig configPath = do 141 | mconf <- try $ process =<< C.load [C.Required configPath] 142 | 143 | case mconf of 144 | Right config -> return $ Right config 145 | Left (e :: SomeException) -> return $ Left $ show e 146 | where process = C.getMap >=> 147 | return . expandByCount >=> 148 | return . buildConfigMap >=> 149 | expandPaths >=> 150 | checkConfigValues 151 | 152 | -- |preprocess config into multiple programs if "count" is specified 153 | expandByCount :: HM.HashMap Name Value -> HM.HashMap Name Value 154 | expandByCount cfg = HM.unions expanded 155 | where expanded :: [HM.HashMap Name Value] 156 | expanded = concat $ HM.foldlWithKey' expand' [] groupedByProgram 157 | expand' :: [[HM.HashMap Name Value]] -> Name -> HM.HashMap Name Value -> [[HM.HashMap Name Value]] 158 | expand' acc = fmap (:acc) . expand 159 | groupedByProgram :: HM.HashMap Name (HM.HashMap Name Value) 160 | groupedByProgram = HM.foldlWithKey' binByProg HM.empty cfg 161 | binByProg h fullKey v 162 | | prog /= "" && localKey /= "" = HM.insertWith HM.union prog (HM.singleton localKey v) h 163 | | otherwise = h 164 | where (prog, localKeyWithLeadingDot) = T.breakOn "." fullKey 165 | localKey = T.drop 1 localKeyWithLeadingDot 166 | expand :: Name -> HM.HashMap Name Value -> [HM.HashMap Name Value] 167 | expand prog pcfg = maybe [reflatten prog pcfg] 168 | expandWithCount 169 | (HM.lookup "count" pcfg) 170 | where expandWithCount (Number n) 171 | | n >= 0 = [ reflatten (genProgName i) (rewriteConfig i pcfg) | i <- [1..n] ] 172 | | otherwise = error "count must be >= 0" 173 | expandWithCount _ = error "count must be a number or not specified" 174 | genProgName i = prog <> "-" <> textNumber i 175 | 176 | rewriteConfig :: Rational -> HM.HashMap Name Value -> HM.HashMap Name Value 177 | rewriteConfig n = HM.insert "env.ANGEL_PROCESS_NUMBER" procNumber . HM.adjust rewritePidfile "pidfile" 178 | where procNumber = String n' 179 | n' = textNumber n 180 | rewritePidfile (String path) = String $ rewrittenFilename <> extension 181 | where rewrittenFilename = filename <> "-" <> n' 182 | (filename, extension) = T.breakOn "." path 183 | rewritePidfile x = x 184 | 185 | textNumber :: Rational -> T.Text 186 | textNumber = T.pack . show . (truncate :: Rational -> Integer) 187 | 188 | reflatten :: Name -> HM.HashMap Name Value -> HM.HashMap Name Value 189 | reflatten prog pcfg = HM.fromList asList 190 | where asList = map prependKey $ filter notCount $ HM.toList pcfg 191 | prependKey (k, v) = (prog <> "." <> k, v) 192 | notCount = not . (== "count") . fst 193 | 194 | -- |given a new SpecKey just parsed from the file, update the 195 | -- |shared state TVar 196 | updateSpecConfig :: TVar GroupConfig -> SpecKey -> STM () 197 | updateSpecConfig sharedGroupConfig newSpec = do 198 | cfg <- readTVar sharedGroupConfig 199 | writeTVar sharedGroupConfig cfg{spec=newSpec} 200 | 201 | -- |read the config file, update shared state with current spec, 202 | -- |re-sync running supervisors, wait for the HUP TVar, then repeat! 203 | monitorConfig :: String -> TVar GroupConfig -> TVar (Maybe Int) -> AngelM () 204 | monitorConfig configPath sharedGroupConfig wakeSig = do 205 | let logger' = logger "config-monitor" 206 | mspec <- liftIO $ processConfig configPath 207 | case mspec of 208 | Left e -> do 209 | logger' V1 $ " <<<< Config Error >>>>\n" ++ e 210 | logger' V2 " <<<< Config Error: Skipping reload >>>>" 211 | Right newSpec -> do 212 | liftIO $ atomically $ updateSpecConfig sharedGroupConfig newSpec 213 | syncSupervisors sharedGroupConfig 214 | liftIO $ waitForWake wakeSig 215 | logger' V2 "HUP caught, reloading config" 216 | 217 | expandPaths :: SpecKey -> IO SpecKey 218 | expandPaths = T.mapM expandProgramPaths 219 | 220 | expandProgramPaths :: Program -> IO Program 221 | expandProgramPaths prog = do exec' <- maybeExpand $ exec prog 222 | stdout' <- maybeExpand $ stdout prog 223 | stderr' <- maybeExpand $ stderr prog 224 | workingDir' <- maybeExpand $ workingDir prog 225 | pidFile' <- maybeExpand $ pidFile prog 226 | return prog { exec = exec', 227 | stdout = stdout', 228 | stderr = stderr', 229 | workingDir = workingDir', 230 | pidFile = pidFile' } 231 | where maybeExpand = T.traverse expandPath 232 | 233 | nnullN :: Name -> Bool 234 | nnullN = not . T.null 235 | -------------------------------------------------------------------------------- /src/Angel/Data.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | module Angel.Data ( GroupConfig(..) 4 | , SpecKey 5 | , RunKey 6 | , ProgramId 7 | , FileRequest 8 | , Program(..) 9 | , RunState(..) 10 | , Spec 11 | , KillDirective(..) 12 | , Verbosity(..) 13 | , Options(..) 14 | , AngelM(..) 15 | , defaultProgram 16 | , defaultDelay 17 | , defaultStdout 18 | , defaultStderr 19 | , runAngelM 20 | ) where 21 | 22 | import qualified Data.Map as M 23 | import System.Process (ProcessHandle) 24 | import Control.Applicative (Applicative) 25 | import Control.Monad.IO.Class (MonadIO) 26 | import Control.Monad.Reader (MonadReader, ReaderT, runReaderT) 27 | import Control.Concurrent.STM.TChan (TChan) 28 | import System.IO (Handle) 29 | 30 | import Angel.Prelude 31 | 32 | -- |the whole shared state of the program; spec is what _should_ 33 | -- |be running, while running is what actually _is_ running_ currently 34 | data GroupConfig = GroupConfig { 35 | spec :: SpecKey, 36 | running :: RunKey, 37 | fileRequest :: TChan FileRequest 38 | } 39 | 40 | -- |map program ids to relevant structure 41 | type SpecKey = M.Map ProgramId Program 42 | type RunKey = M.Map ProgramId RunState 43 | 44 | data RunState = RunState { 45 | rsProgram :: Program, 46 | rsHandle :: Maybe ProcessHandle, 47 | rsLogHandle :: Maybe ProcessHandle 48 | } 49 | 50 | type ProgramId = String 51 | type FileRequest = (String, TChan (Maybe Handle)) 52 | 53 | -- |the representation of a program is these 6 values, 54 | -- |read from the config file 55 | data Program = Program { 56 | name :: String, 57 | exec :: Maybe String, 58 | user :: Maybe String, 59 | delay :: Maybe Int, 60 | stdout :: Maybe String, 61 | stderr :: Maybe String, 62 | workingDir :: Maybe FilePath, 63 | logExec :: Maybe String, 64 | pidFile :: Maybe FilePath, 65 | env :: [(String, String)], 66 | termGrace :: Maybe Int -- ^ How long to wait after sending a SIGTERM before SIGKILL. Nothing = never SIGKILL. Default Nothing 67 | } deriving (Show, Eq, Ord) 68 | 69 | -- |represents all the data needed to handle terminating a process 70 | data KillDirective = SoftKill String ProcessHandle (Maybe ProcessHandle) | 71 | HardKill String ProcessHandle (Maybe ProcessHandle) Int 72 | 73 | -- instance Show KillDirective where 74 | -- show (SoftKill _) = "SoftKill" 75 | -- show (HardKill _ grace) = "HardKill after " ++ show grace ++ "s" 76 | 77 | -- |Lower-level atoms in the configuration process 78 | type Spec = [Program] 79 | 80 | 81 | data Verbosity = V0 82 | -- ^ Failures only 83 | | V1 84 | -- ^ Failures + program starts/stops 85 | | V2 86 | -- ^ Max verbosity. Default. Logs all of the above as well as state changes and other debugging info. 87 | deriving (Show, Eq, Ord) 88 | 89 | 90 | data Options = Options { 91 | configFile :: FilePath 92 | , userargument :: Maybe String 93 | , verbosity :: Verbosity 94 | } 95 | 96 | 97 | newtype AngelM a = AngelM { 98 | unAngelM :: ReaderT Options IO a 99 | } deriving (Functor, Applicative, Monad, MonadReader Options, MonadIO) 100 | 101 | 102 | runAngelM :: Options -> AngelM a -> IO a 103 | runAngelM o (AngelM f) = runReaderT f o 104 | 105 | -- |a template for an empty program; the variable set to "" 106 | -- |are required, and must be overridden in the config file 107 | defaultProgram :: Program 108 | defaultProgram = Program "" Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing 109 | 110 | defaultDelay :: Int 111 | defaultDelay = 5 112 | 113 | defaultStdout :: FilePath 114 | defaultStdout = "/dev/null" 115 | 116 | defaultStderr :: FilePath 117 | defaultStderr = "/dev/null" 118 | -------------------------------------------------------------------------------- /src/Angel/Files.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Angel.Files ( getFile ) where 4 | 5 | import System.IO ( Handle 6 | , openFile 7 | , IOMode(AppendMode) ) 8 | 9 | import Angel.Data ( GroupConfig ) 10 | import Angel.Prelude 11 | 12 | getFile :: String -> GroupConfig -> IO Handle 13 | getFile path _ = openFile path AppendMode 14 | -------------------------------------------------------------------------------- /src/Angel/Job.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE NoImplicitPrelude #-} 3 | module Angel.Job ( syncSupervisors 4 | , killProcess -- for testing 5 | , pollStale ) where 6 | 7 | import Control.Applicative ((<$>)) 8 | import Control.Exception ( finally ) 9 | import Control.Monad ( unless 10 | , when 11 | , forever ) 12 | import Control.Monad.Reader (ask) 13 | import Data.Maybe ( mapMaybe 14 | , fromMaybe 15 | , fromJust ) 16 | import System.Process ( createProcess 17 | , proc 18 | , waitForProcess 19 | , ProcessHandle 20 | , CreateProcess 21 | , std_out 22 | , std_err 23 | , std_in 24 | , cwd 25 | , env 26 | , StdStream(UseHandle, CreatePipe) ) 27 | import qualified System.Posix.User as U (setUserID, 28 | getUserEntryForName, 29 | UserEntry(userID) ) 30 | 31 | import Control.Concurrent ( forkIO ) 32 | import Control.Concurrent.STM ( TVar 33 | , writeTVar 34 | , readTVar 35 | , atomically ) 36 | import Control.Monad.IO.Class (liftIO) 37 | import qualified Data.Map.Strict as M 38 | import Angel.Log ( logger 39 | , programLogger ) 40 | import Angel.Data ( Program( delay 41 | , exec 42 | , logExec 43 | , name 44 | , pidFile 45 | , stderr 46 | , stdout 47 | , termGrace 48 | , workingDir ) 49 | , ProgramId 50 | , AngelM 51 | , GroupConfig 52 | , runAngelM 53 | , spec 54 | , running 55 | , KillDirective(SoftKill, HardKill) 56 | , RunState(..) 57 | , Verbosity(..) 58 | , defaultProgram 59 | , defaultDelay 60 | , defaultStdout 61 | , defaultStderr ) 62 | import Angel.Prelude 63 | import Angel.Process ( isProcessHandleDead 64 | , softKillProcessHandle 65 | , hardKillProcessHandle ) 66 | import qualified Angel.Data as D 67 | import Angel.Util ( sleepSecs 68 | , strip 69 | , split 70 | , nnull ) 71 | import Angel.Files ( getFile ) 72 | import Angel.PidFile ( startMaybeWithPidFile 73 | , clearPIDFile ) 74 | 75 | ifEmpty :: String -> a -> a -> a 76 | ifEmpty s a b = if s == "" then a else b 77 | 78 | switchUser :: String -> IO () 79 | switchUser name = do 80 | userEntry <- U.getUserEntryForName name 81 | U.setUserID $ U.userID userEntry 82 | 83 | -- |launch the program specified by `id'`, opening (and closing) the 84 | -- |appropriate fds for logging. When the process dies, either b/c it was 85 | -- |killed by a monitor, killed by a system user, or ended execution naturally, 86 | -- |re-examine the desired run config to determine whether to re-run it. if so, 87 | -- |tail call. 88 | supervise :: TVar GroupConfig -> String -> AngelM () 89 | supervise sharedGroupConfig id' = do 90 | logger' V2 "START" 91 | cfg <- liftIO $ atomically $ readTVar sharedGroupConfig 92 | let my_spec = find_spec cfg id' 93 | 94 | ifEmpty (name my_spec) 95 | (logger' V2 "QUIT (missing from config on restart)") 96 | (do 97 | let 98 | logProcessSpawn Nothing = return () 99 | logProcessSpawn (Just (cmd, args)) = do 100 | logger' V1 $ "Spawning process: " ++ cmd ++ " with env " ++ ((show . D.env) my_spec) ++ (maybe "" (" as user: " ++) (D.user my_spec)) 101 | superviseSpawner my_spec cfg cmd args sharedGroupConfig id' onValidHandle onPidError 102 | 103 | logProcessSpawn $ fmap (cmdSplit) (exec my_spec) 104 | 105 | cfg' <- liftIO $ atomically $ readTVar sharedGroupConfig 106 | if M.notMember id' (spec cfg') 107 | then logger' V2 "QUIT" 108 | else do 109 | logger' V2 "WAITING" 110 | liftIO $ sleepSecs . fromMaybe defaultDelay . delay $ my_spec 111 | logger' V2 "RESTART" 112 | supervise sharedGroupConfig id' 113 | ) 114 | 115 | where 116 | logger' = programLogger id' 117 | 118 | onValidHandle a_spec lph ph = do 119 | updateRunningPid a_spec (Just ph) lph 120 | logProcess logger' ph -- This will not return until the process has exited 121 | updateRunningPid a_spec Nothing Nothing 122 | 123 | onPidError a_spec lph ph = do 124 | logger' V2 "Failed to create pidfile" 125 | killProcess $ toKillDirective a_spec ph lph 126 | 127 | cmdSplit fullcmd = (head parts, tail parts) 128 | where parts = (filter (/="") . map strip . split ' ') fullcmd 129 | 130 | find_spec cfg id' = M.findWithDefault defaultProgram id' (spec cfg) 131 | 132 | updateRunningPid my_spec mpid mlpid = liftIO $ atomically $ do 133 | wcfg <- readTVar sharedGroupConfig 134 | let rstate = RunState { rsProgram = my_spec 135 | , rsHandle = mpid 136 | , rsLogHandle = mlpid 137 | } 138 | writeTVar sharedGroupConfig wcfg{ 139 | running=M.insertWith const id' rstate (running wcfg) 140 | } 141 | 142 | superviseSpawner 143 | :: Program 144 | -> GroupConfig 145 | -> String 146 | -> [String] 147 | -> TVar GroupConfig 148 | -> String 149 | -> (Program -> Maybe ProcessHandle -> ProcessHandle -> AngelM ()) 150 | -> (Program -> Maybe ProcessHandle -> ProcessHandle -> AngelM ()) 151 | -> AngelM () 152 | superviseSpawner the_spec cfg cmd args sharedGroupConfig id' onValidHandleAction onPidErrorAction = do 153 | opts <- ask 154 | let io = runAngelM opts 155 | liftIO $ do 156 | maybe (return ()) switchUser (D.user the_spec) 157 | -- start the logger process or if non is configured 158 | -- use the files specified in the configuration 159 | (attachOut, attachErr, lHandle) <- io $ makeFiles the_spec cfg 160 | 161 | let 162 | procSpec = (proc cmd args) { 163 | std_out = attachOut, 164 | std_err = attachErr, 165 | cwd = workingDir the_spec, 166 | env = Just $ D.env the_spec 167 | } 168 | 169 | startMaybeWithPidFile procSpec 170 | (pidFile the_spec) 171 | (io . onValidHandleAction the_spec lHandle) 172 | (io . onPidErrorAction the_spec lHandle) 173 | 174 | where 175 | cmdSplit fullcmd = (head parts, tail parts) 176 | where parts = (filter (/="") . map strip . split ' ') fullcmd 177 | 178 | makeFiles my_spec cfg = 179 | case logExec my_spec of 180 | Just path -> logWithExec path 181 | Nothing -> liftIO logWithFiles 182 | where 183 | logWithFiles = do 184 | let useout = fromMaybe defaultStdout $ stdout the_spec 185 | attachOut <- UseHandle <$> getFile useout cfg 186 | 187 | let useerr = fromMaybe defaultStderr $ stderr the_spec 188 | attachErr <- UseHandle <$> getFile useerr cfg 189 | 190 | return (attachOut, attachErr, Nothing) 191 | 192 | logWithExec path = do 193 | let (cmd, args) = cmdSplit path 194 | 195 | attachOut <- UseHandle <$> liftIO (getFile "/dev/null" cfg) 196 | 197 | (programLogger id') V2 "Spawning logger process" 198 | opts <- ask 199 | liftIO $ do 200 | (inPipe, _, _, logpHandle) <- createProcess (proc cmd args){ 201 | std_out = attachOut, 202 | std_err = attachOut, 203 | std_in = CreatePipe, 204 | cwd = workingDir my_spec 205 | } 206 | 207 | forkIO $ runAngelM opts $ logProcess (\v m -> loggerSink v m) logpHandle 208 | 209 | return (UseHandle (fromJust inPipe), 210 | UseHandle (fromJust inPipe), 211 | Just logpHandle) 212 | where 213 | loggerSink = programLogger $ "logger for " ++ id' 214 | 215 | logProcess :: (Verbosity -> String -> AngelM ()) -> ProcessHandle -> AngelM () 216 | logProcess logSink pHandle = do 217 | logSink V2 "RUNNING" 218 | liftIO $ waitForProcess pHandle 219 | logSink V2 "ENDED" 220 | 221 | --TODO: paralellize 222 | killProcesses :: [KillDirective] -> AngelM () 223 | killProcesses = mapM_ killProcess 224 | 225 | killProcess :: KillDirective -> AngelM () 226 | killProcess (SoftKill n pid lpid) = do 227 | logger' V2 $ "Soft killing " ++ n 228 | liftIO $ softKillProcessHandle pid 229 | case lpid of 230 | Just lph -> killProcess (SoftKill n lph Nothing) 231 | Nothing -> return () 232 | where logger' = logger "process-killer" 233 | killProcess (HardKill n pid lpid grace) = do 234 | logger' V2 $ "Attempting soft kill " ++ n ++ " before hard killing" 235 | liftIO $ softKillProcessHandle pid 236 | logger' V2 $ "Waiting " ++ show grace ++ " seconds for " ++ n ++ " to die" 237 | liftIO $ sleepSecs grace 238 | 239 | -- Note that this means future calls to get exits status will fail 240 | dead <- liftIO $ isProcessHandleDead pid 241 | 242 | unless dead $ do 243 | logger' V2 ("Hard killing " ++ n) 244 | liftIO $ hardKillProcessHandle pid 245 | case lpid of 246 | Just lph -> killProcess (HardKill n lph Nothing grace) 247 | Nothing -> return () 248 | where logger' = logger "process-killer" 249 | 250 | cleanPidfiles :: [Program] -> IO () 251 | cleanPidfiles progs = mapM_ clearPIDFile pidfiles 252 | where pidfiles = mapMaybe pidFile progs 253 | 254 | -- |fire up new supervisors for new program ids 255 | startProcesses :: TVar GroupConfig -> [String] -> AngelM () 256 | startProcesses sharedGroupConfig = mapM_ spawnWatcher 257 | where 258 | spawnWatcher s = do 259 | opts <- ask 260 | liftIO $ forkIO $ runAngelM opts $ wrapProcess sharedGroupConfig s 261 | 262 | wrapProcess :: TVar GroupConfig -> String -> AngelM () 263 | wrapProcess sharedGroupConfig id' = do 264 | opts <- ask 265 | liftIO $ do 266 | run <- createRunningEntry 267 | when run $ 268 | (runAngelM opts $ supervise sharedGroupConfig id') `finally` deleteRunning 269 | where 270 | deleteRunning = liftIO $ atomically $ do 271 | wcfg <- readTVar sharedGroupConfig 272 | writeTVar sharedGroupConfig wcfg{ 273 | running=M.delete id' (running wcfg) 274 | } 275 | 276 | createRunningEntry = 277 | atomically $ do 278 | cfg <- readTVar sharedGroupConfig 279 | let specmap = spec cfg 280 | case M.lookup id' specmap of 281 | Nothing -> return False 282 | Just target -> do 283 | let runmap = running cfg 284 | case M.lookup id' runmap of 285 | Just _ -> return False 286 | Nothing -> do 287 | let rstate = RunState { rsProgram = target 288 | , rsHandle = Nothing 289 | , rsLogHandle = Nothing 290 | } 291 | writeTVar sharedGroupConfig cfg{running= 292 | M.insert id' rstate runmap} 293 | return True 294 | 295 | -- |diff the requested config against the actual run state, and 296 | -- |do any start/kill action necessary 297 | syncSupervisors :: TVar GroupConfig -> AngelM () 298 | syncSupervisors sharedGroupConfig = do 299 | let logger' = logger "process-monitor" 300 | cfg <- liftIO $ atomically $ readTVar sharedGroupConfig 301 | let (killProgs, killHandles) = mustKill cfg 302 | let starts = mustStart cfg 303 | when (nnull killHandles || nnull starts) $ logger' V2 ( 304 | "Must kill=" ++ show (length killHandles) 305 | ++ ", must start=" ++ show (length starts)) 306 | killProcesses killHandles 307 | liftIO $ cleanPidfiles killProgs 308 | startProcesses sharedGroupConfig starts 309 | 310 | --TODO: make private 311 | mustStart :: GroupConfig -> [String] 312 | mustStart cfg = map fst $ filter (isNew $ running cfg) $ M.assocs (spec cfg) 313 | where isNew isRunning (id', _) = M.notMember id' isRunning 314 | 315 | --TODO: make private 316 | mustKill :: GroupConfig -> ([Program], [KillDirective]) 317 | mustKill cfg = unzip targets 318 | where runningAndDifferent :: (ProgramId, RunState) -> Maybe (Program, KillDirective) 319 | runningAndDifferent (_, RunState {rsHandle = Nothing}) = Nothing 320 | runningAndDifferent (id', RunState {rsProgram = pg, rsHandle = Just pid, rsLogHandle = lpid}) 321 | | M.notMember id' specMap || M.findWithDefault defaultProgram id' specMap /= pg = Just (pg, toKillDirective pg pid lpid) 322 | | otherwise = Nothing 323 | targets = mapMaybe runningAndDifferent allRunning 324 | specMap = spec cfg 325 | allRunning = M.assocs $ running cfg 326 | 327 | toKillDirective :: Program -> ProcessHandle -> Maybe ProcessHandle -> KillDirective 328 | toKillDirective D.Program { name = n 329 | , termGrace = Just g } ph lph = HardKill n ph lph g 330 | toKillDirective D.Program { name = n } ph lph = SoftKill n ph lph 331 | 332 | -- |periodically run the supervisor sync independent of config reload, 333 | -- |just in case state gets funky b/c of theoretically possible timing 334 | -- |issues on reload 335 | pollStale :: TVar GroupConfig -> AngelM () 336 | pollStale sharedGroupConfig = forever $ do 337 | liftIO $ sleepSecs 10 338 | syncSupervisors sharedGroupConfig 339 | -------------------------------------------------------------------------------- /src/Angel/Log.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module Angel.Log ( cleanCalendar 3 | , logger 4 | , programLogger ) where 5 | 6 | import Control.Monad (when) 7 | import Control.Monad.IO.Class (liftIO) 8 | import Control.Monad.Reader (asks) 9 | import Data.Time.LocalTime (ZonedTime, 10 | getZonedTime) 11 | import Data.Time.Format ( formatTime 12 | , defaultTimeLocale) 13 | 14 | import Text.Printf (printf) 15 | import Angel.Data 16 | import Angel.Prelude 17 | 18 | -- |provide a clean, ISO-ish format for timestamps in logs 19 | cleanCalendar :: ZonedTime -> String 20 | cleanCalendar = formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" 21 | 22 | -- |log a line to stdout; indented for use with partial application for 23 | -- |"local log"-type macroing 24 | logger :: String -> Verbosity -> String -> AngelM () 25 | logger lname v msg = do 26 | chk <- shouldLog v 27 | when chk $ liftIO $ do 28 | zt <- getZonedTime 29 | printf "[%s] {%s} %s\n" (cleanCalendar zt) lname msg 30 | 31 | programLogger :: String -> Verbosity -> String -> AngelM () 32 | programLogger id' = logger $ "- program: " ++ id' ++ " -" 33 | 34 | 35 | shouldLog :: Verbosity -> AngelM Bool 36 | shouldLog v = do 37 | maxV <- asks verbosity 38 | return $ v <= maxV 39 | -------------------------------------------------------------------------------- /src/Angel/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | module Main (main) where 4 | 5 | import Control.Concurrent (forkIO) 6 | import Control.Concurrent.MVar (newEmptyMVar, 7 | MVar, 8 | takeMVar, 9 | putMVar) 10 | import Control.Concurrent.STM (TVar, 11 | atomically, 12 | writeTVar, 13 | newTChan, 14 | readTVar, 15 | newTVarIO) 16 | import Control.Monad (forever) 17 | import Data.Monoid ( (<>) ) 18 | import Control.Monad.Reader 19 | import Options.Applicative (ParserInfo, ReadM) 20 | import qualified Options.Applicative as O 21 | import System.Environment (getArgs) 22 | import System.Exit (exitFailure, 23 | exitSuccess) 24 | import System.Posix.Signals (installHandler, 25 | sigHUP, 26 | sigTERM, 27 | sigINT, 28 | Handler(Catch)) 29 | import System.IO (hSetBuffering, 30 | hPutStrLn, 31 | BufferMode(LineBuffering), 32 | stdout, 33 | stderr) 34 | 35 | import qualified System.Posix.User as U (setUserID, 36 | getUserEntryForName, 37 | UserEntry(userID) ) 38 | 39 | import qualified Data.Map as M 40 | 41 | import Angel.Log (logger) 42 | import Angel.Config (monitorConfig, loadInitialUserFromConfig) 43 | import Angel.Data (GroupConfig(GroupConfig), 44 | Options(..), 45 | spec, 46 | Verbosity(..), 47 | AngelM, 48 | runAngelM) 49 | import Angel.Job (pollStale, 50 | syncSupervisors) 51 | import Angel.Prelude 52 | 53 | -- |Signal handler: when a HUP is trapped, write to the wakeSig Tvar 54 | -- |to make the configuration monitor loop cycle/reload 55 | handleHup :: TVar (Maybe Int) -> IO () 56 | handleHup wakeSig = atomically $ writeTVar wakeSig $ Just 1 57 | 58 | handleExit :: MVar Bool -> IO () 59 | handleExit mv = putMVar mv True 60 | 61 | main :: IO () 62 | main = runWithOpts =<< O.execParser opts 63 | 64 | opts :: ParserInfo Options 65 | opts = O.info (O.helper <*> opts') 66 | (O.fullDesc <> O.header "angel - Process management and supervision daemon") 67 | where 68 | opts' = Options 69 | <$> O.strArgument (O.metavar "CONFIG_FILE") 70 | <*> O.option readUserOpt (O.short 'u' <> 71 | O.value Nothing <> 72 | O.metavar "USER" <> 73 | O.help "Execute as user") 74 | <*> O.option readVOpt (O.short 'v' <> 75 | O.value V2 <> 76 | O.showDefaultWith vOptAsNumber <> 77 | O.metavar "VERBOSITY" <> 78 | O.help "Verbosity from 0-2") 79 | 80 | 81 | vOptAsNumber :: Verbosity -> String 82 | vOptAsNumber V2 = "2" 83 | vOptAsNumber V1 = "1" 84 | vOptAsNumber V0 = "0" 85 | 86 | readUserOpt :: ReadM (Maybe String) 87 | readUserOpt = O.eitherReader $ (return . Just) 88 | 89 | readVOpt :: ReadM Verbosity 90 | readVOpt = O.eitherReader $ \s -> 91 | case s of 92 | "0" -> return V0 93 | "1" -> return V1 94 | "2" -> return V2 95 | _ -> Left "Expecting 0-2" 96 | 97 | runWithOpts :: Options -> IO () 98 | runWithOpts os = runAngelM os runWithConfigPath 99 | 100 | switchUser :: String -> IO () 101 | switchUser name = do 102 | userEntry <- U.getUserEntryForName name 103 | U.setUserID $ U.userID userEntry 104 | 105 | switchRunningUser :: AngelM () 106 | switchRunningUser = do 107 | username <- asks userargument 108 | 109 | case username of 110 | Just user -> do 111 | logger "main" V2 $ "Running as user: " ++ user 112 | liftIO $ switchUser user 113 | Nothing -> do 114 | configPath <- asks configFile 115 | userFromConfig <- liftIO $ loadInitialUserFromConfig configPath 116 | case userFromConfig of 117 | Just configUser -> do 118 | logger "main" V2 $ "Running as user: " ++ configUser 119 | liftIO $ switchUser configUser 120 | Nothing -> return () 121 | 122 | runWithConfigPath :: AngelM () 123 | runWithConfigPath = do 124 | configPath <- asks configFile 125 | liftIO $ hSetBuffering stdout LineBuffering 126 | liftIO $ hSetBuffering stderr LineBuffering 127 | let logger' = logger "main" 128 | logger' V2 "Angel started" 129 | 130 | -- Switch to the specified user if one has been chosen 131 | switchRunningUser 132 | 133 | logger' V2 $ "Using config file: " ++ configPath 134 | 135 | -- Create the TVar that represents the "global state" of running applications 136 | -- and applications that _should_ be running 137 | fileReqChan <- liftIO $ atomically newTChan 138 | sharedGroupConfig <- liftIO $ newTVarIO $ GroupConfig M.empty M.empty fileReqChan 139 | 140 | -- The wake signal, set by the HUP handler to wake the monitor loop 141 | wakeSig <- liftIO $ newTVarIO Nothing 142 | liftIO $ installHandler sigHUP (Catch $ handleHup wakeSig) Nothing 143 | 144 | -- Handle dying 145 | bye <- liftIO newEmptyMVar 146 | liftIO $ installHandler sigTERM (Catch $ handleExit bye) Nothing 147 | liftIO $ installHandler sigINT (Catch $ handleExit bye) Nothing 148 | 149 | -- Fork off an ongoing state monitor to watch for inconsistent state 150 | forkIO' $ pollStale sharedGroupConfig 151 | 152 | -- Finally, run the config load/monitor thread 153 | forkIO' $ forever $ monitorConfig configPath sharedGroupConfig wakeSig 154 | 155 | liftIO $ takeMVar bye 156 | 157 | logger' V2 "INT | TERM received; initiating shutdown..." 158 | logger' V2 " 1. Clearing config" 159 | liftIO $ atomically $ do 160 | cfg <- readTVar sharedGroupConfig 161 | writeTVar sharedGroupConfig cfg {spec = M.empty} 162 | logger' V2 " 2. Forcing sync to kill running processes" 163 | syncSupervisors sharedGroupConfig 164 | logger' V2 "That's all folks!" 165 | 166 | errorExit :: String -> IO () 167 | errorExit msg = hPutStrLn stderr msg >> exitFailure 168 | 169 | 170 | forkIO' :: AngelM () -> AngelM () 171 | forkIO' f = do 172 | r <- ask 173 | void $ liftIO $ forkIO $ runAngelM r f 174 | -------------------------------------------------------------------------------- /src/Angel/PidFile.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | module Angel.PidFile ( startMaybeWithPidFile 3 | , startWithPidFile 4 | , clearPIDFile) where 5 | 6 | import Control.Exception.Base ( finally 7 | , onException ) 8 | 9 | import Control.Monad (when) 10 | import System.Process ( CreateProcess 11 | , createProcess 12 | , ProcessHandle ) 13 | 14 | -- Wish I didn't have to do this :( 15 | import System.Process.Internals ( PHANDLE 16 | , ProcessHandle__(OpenHandle, ClosedHandle) 17 | , withProcessHandle 18 | ) 19 | import System.Posix.Files ( removeLink 20 | , fileExist) 21 | 22 | import Angel.Prelude 23 | 24 | startMaybeWithPidFile :: CreateProcess 25 | -> Maybe FilePath 26 | -> (ProcessHandle -> IO a) 27 | -> (ProcessHandle -> IO a) 28 | -> IO a 29 | startMaybeWithPidFile procSpec (Just pidFile) action onPidError = startWithPidFile procSpec pidFile action onPidError 30 | startMaybeWithPidFile procSpec Nothing action _ = withPHandle procSpec action 31 | 32 | startWithPidFile :: CreateProcess 33 | -> FilePath 34 | -> (ProcessHandle -> IO a) 35 | -> (ProcessHandle -> IO a) 36 | -> IO a 37 | startWithPidFile procSpec pidFile action onPidError = 38 | withPHandle procSpec $ \pHandle -> do 39 | mPid <- getPID pHandle 40 | case mPid of 41 | Just pid -> write pid pHandle 42 | Nothing -> proceed pHandle 43 | where 44 | write pid pHandle = do 45 | writePID pidFile pid `onException` onPidError pHandle -- re-raises 46 | proceed pHandle 47 | proceed pHandle = action pHandle `finally` clearPIDFile pidFile 48 | 49 | withPHandle :: CreateProcess -> (ProcessHandle -> IO a) -> IO a 50 | withPHandle procSpec action = do 51 | (_, _, _, pHandle) <- createProcess procSpec 52 | action pHandle 53 | 54 | writePID :: FilePath -> PHANDLE -> IO () 55 | writePID pidFile = writeFile pidFile . show 56 | 57 | clearPIDFile :: FilePath -> IO () 58 | clearPIDFile pidFile = do ex <- fileExist pidFile 59 | when ex rm 60 | where rm = removeLink pidFile 61 | 62 | getPID :: ProcessHandle -> IO (Maybe PHANDLE) 63 | getPID pHandle = withProcessHandle pHandle getPID' 64 | where getPID' h @ (OpenHandle t) = return (Just t) 65 | getPID' h @ (ClosedHandle t) = return Nothing 66 | -------------------------------------------------------------------------------- /src/Angel/Prelude.hs: -------------------------------------------------------------------------------- 1 | -- | Compatibility Prelude to maximise GHC support. 2 | -- Re-exports from base only. 3 | 4 | {-# LANGUAGE NoImplicitPrelude #-} 5 | module Angel.Prelude ( 6 | module Control.Applicative 7 | , module Data.Functor 8 | , module Data.Monoid 9 | , module Prelude 10 | ) where 11 | 12 | import Control.Applicative (Applicative (..)) 13 | import Data.Functor ((<$>)) 14 | import Data.Monoid ((<>)) 15 | import Prelude 16 | -------------------------------------------------------------------------------- /src/Angel/Process.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Angel.Process ( getProcessHandleStatus 4 | , isProcessHandleDead 5 | , softKillProcessHandle 6 | , hardKillProcessHandle 7 | , signalProcessHandle ) where 8 | 9 | import Angel.Prelude 10 | import Control.Exception (catchJust) 11 | import Control.Monad ( join 12 | , void ) 13 | import Data.Maybe (isJust) 14 | import System.IO.Error ( catchIOError 15 | , isDoesNotExistError) 16 | import System.Process (ProcessHandle) 17 | import System.Process.Internals ( ProcessHandle__(OpenHandle, ClosedHandle) 18 | , withProcessHandle ) 19 | import System.Posix.Types (ProcessID) 20 | import System.Posix.Process ( ProcessStatus 21 | , getProcessStatus ) 22 | import System.Posix.Signals ( Signal 23 | , sigTERM 24 | , sigKILL 25 | , signalProcess ) 26 | 27 | withPid :: (ProcessID -> IO a) -> ProcessHandle -> IO (Maybe a) 28 | withPid action ph = withProcessHandle ph callback 29 | where callback (ClosedHandle _) = return Nothing 30 | callback (OpenHandle pid) = do res <- action pid 31 | return (Just res) 32 | 33 | getProcessHandleStatus :: ProcessHandle -> IO (Maybe ProcessStatus) 34 | getProcessHandleStatus ph = catchJust exPred getStatus handleDNE 35 | where shouldBlock = False 36 | includeStopped = True 37 | getStatus = fmap join $ withPid (getProcessStatus shouldBlock includeStopped) ph 38 | exPred e 39 | | isDoesNotExistError e = Just () 40 | | otherwise = Nothing 41 | handleDNE = const $ return Nothing -- ehhhhhhhhhhhhh, Nothing means not available? 42 | 43 | signalProcessHandle :: Signal -> ProcessHandle -> IO () 44 | signalProcessHandle sig = void . withPid (signalProcess sig) 45 | 46 | softKillProcessHandle :: ProcessHandle -> IO () 47 | softKillProcessHandle = signalProcessHandle sigTERM 48 | 49 | hardKillProcessHandle :: ProcessHandle -> IO () 50 | hardKillProcessHandle = signalProcessHandle sigKILL 51 | 52 | isProcessHandleDead :: ProcessHandle -> IO Bool 53 | isProcessHandleDead ph = catchIOError checkHandle (const $ return True) 54 | where 55 | checkHandle = fmap isJust $ getProcessHandleStatus ph 56 | -------------------------------------------------------------------------------- /src/Angel/Util.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE NoImplicitPrelude #-} 2 | -- |various utility functions 3 | module Angel.Util ( sleepSecs 4 | , waitForWake 5 | , expandPath 6 | , split 7 | , strip 8 | , nnull ) where 9 | 10 | import Angel.Prelude 11 | import Control.Concurrent.STM (atomically 12 | , retry 13 | , TVar 14 | , readTVar 15 | , writeTVar) 16 | import Control.Concurrent (threadDelay) 17 | import Data.Char (isSpace) 18 | import Data.Maybe (catMaybes) 19 | import System.Posix.User (getEffectiveUserName, 20 | UserEntry(homeDirectory), 21 | getUserEntryForName) 22 | 23 | -- |sleep for `s` seconds in an thread 24 | sleepSecs :: Int -> IO () 25 | sleepSecs s = threadDelay $ s * 1000000 26 | 27 | -- |wait for the STM TVar to be non-nothing 28 | waitForWake :: TVar (Maybe Int) -> IO () 29 | waitForWake wakeSig = atomically $ do 30 | state <- readTVar wakeSig 31 | case state of 32 | Just _ -> writeTVar wakeSig Nothing 33 | Nothing -> retry 34 | 35 | expandPath :: FilePath -> IO FilePath 36 | expandPath ('~':rest) = do home <- getHome =<< getUser 37 | return $ home ++ relativePath 38 | where (userName, relativePath) = span (/= '/') rest 39 | getUser = if null userName 40 | then getEffectiveUserName 41 | else return userName 42 | getHome user = homeDirectory `fmap` getUserEntryForName user 43 | expandPath path = return path 44 | 45 | nnull :: [a] -> Bool 46 | nnull = not . null 47 | 48 | split :: Eq a => a -> [a] -> [[a]] 49 | split a = catMaybes . foldr go [] 50 | where 51 | go x acc = case (x == a, acc) of 52 | (True, xs) -> Nothing:xs 53 | (False, []) -> [Just [x]] 54 | (False, Nothing:rest) -> Just [x]:Nothing:rest 55 | (False, Just xs:rest) -> Just (x:xs):rest 56 | 57 | strip :: String -> String 58 | strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace 59 | -------------------------------------------------------------------------------- /test/Angel/ConfigSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Angel.ConfigSpec (spec) where 3 | 4 | import Angel.Data hiding (spec, Spec) 5 | import Angel.Config 6 | 7 | import Control.Exception.Base 8 | import Data.Configurator.Types (Value(..)) 9 | import qualified Data.HashMap.Lazy as HM 10 | 11 | import SpecHelper 12 | 13 | spec :: TestTree 14 | spec = testGroup "Angel.Config" 15 | [ 16 | testGroup "modifyProg" 17 | [ 18 | testCase "modifies exec" $ 19 | modifyProg prog "exec" (String "foo") @?= 20 | prog { exec = Just "foo"} 21 | 22 | , testCase "errors for non-string execs" $ 23 | evaluate (modifyProg prog "exec" (Bool True)) `shouldThrow` 24 | anyErrorCall 25 | 26 | , testCase "modifies delay for positive numbers" $ 27 | modifyProg prog "delay" (Number 1) @?= 28 | prog { delay = Just 1} 29 | , testCase "modifies delay for 0" $ 30 | modifyProg prog "delay" (Number 0) @?= 31 | prog { delay = Just 0} 32 | , testCase "errors on negative delays" $ 33 | evaluate (modifyProg prog "delay" (Number (-1))) `shouldThrow` 34 | anyErrorCall 35 | 36 | , testCase "modifies stdout" $ 37 | modifyProg prog "stdout" (String "foo") @?= 38 | prog { stdout = Just "foo"} 39 | , testCase "errors for non-string stdout" $ 40 | evaluate (modifyProg prog "stdout" (Bool True)) `shouldThrow` 41 | anyErrorCall 42 | 43 | , testCase "modifies stderr" $ 44 | modifyProg prog "stderr" (String "foo") @?= 45 | prog { stderr = Just "foo"} 46 | , testCase "errors for non-string stderr" $ 47 | evaluate (modifyProg prog "stderr" (Bool True)) `shouldThrow` 48 | anyErrorCall 49 | 50 | , testCase "modifies directory" $ 51 | modifyProg prog "directory" (String "foo") @?= 52 | prog { workingDir = Just "foo"} 53 | , testCase "errors for non-string directory" $ 54 | evaluate (modifyProg prog "directory" (Bool True)) `shouldThrow` 55 | anyErrorCall 56 | 57 | , testCase "modifies pidfile" $ 58 | modifyProg prog "pidfile" (String "foo.pid") @?= 59 | prog { pidFile = Just "foo.pid"} 60 | , testCase "errors for non-string path" $ 61 | evaluate (modifyProg prog "pidfile" (Bool True)) `shouldThrow` 62 | anyErrorCall 63 | 64 | , testCase "appends env to the empty list" $ 65 | modifyProg prog "env.foo" (String "bar") @?= 66 | prog { env = [("foo", "bar")]} 67 | , testCase "errors for non-string value" $ 68 | evaluate (modifyProg prog "env.foo" (Bool True)) `shouldThrow` 69 | anyErrorCall 70 | , testCase "prepends env to an existing list" $ 71 | modifyProg prog { env = [("previous", "value")]} "env.foo" (String "bar") @?= 72 | prog { env = [("foo", "bar"), ("previous", "value")]} 73 | 74 | , testCase "interprets boolean False as Nothing" $ 75 | modifyProg prog "termgrace" (Bool False) @?= 76 | prog { termGrace = Nothing } 77 | , testCase "interprets 0 as Nothing" $ 78 | modifyProg prog "termgrace" (Number 0) @?= 79 | prog { termGrace = Nothing } 80 | , testCase "interprets > 0 as a set termGrace" $ 81 | modifyProg prog "termgrace" (Number 2) @?= 82 | prog { termGrace = Just 2 } 83 | , testCase "interprets boolean True as an error" $ 84 | evaluate (modifyProg prog "termgrace" (Bool True)) `shouldThrow` 85 | anyErrorCall 86 | , testCase "interprets negative numbers as an error" $ 87 | evaluate (modifyProg prog "termgrace" (Number (-1))) `shouldThrow` 88 | anyErrorCall 89 | , testCase "interprets anything else as an error" $ 90 | evaluate (modifyProg prog "termgrace" (String "yeah")) `shouldThrow` 91 | anyErrorCall 92 | 93 | , testCase "does nothing for all other cases" $ 94 | modifyProg prog "bogus" (String "foo") @?= 95 | prog 96 | ] 97 | 98 | , testGroup "expandByCount" 99 | [ 100 | testCase "doesn't affect empty hashes" $ 101 | expandByCount HM.empty @?= 102 | HM.empty 103 | , testCase "doesn't affect hashes without counts" $ 104 | expandByCount (HM.fromList [baseProgPair]) @?= 105 | HM.fromList [baseProgPair] 106 | , testCase "errors on mistyped count field" $ 107 | evaluate (expandByCount (HM.fromList [baseProgPair 108 | , ("prog.count", String "wat")])) `shouldThrow` 109 | anyErrorCall 110 | , testCase "errors on negative count field" $ 111 | evaluate (expandByCount (HM.fromList [ baseProgPair 112 | , ("prog.count", Number (-1))])) `shouldThrow` 113 | anyErrorCall 114 | , testCase "generates no configs with a count of 0" $ 115 | expandByCount (HM.fromList [ baseProgPair 116 | , ("prog.count", Number 0)]) @?= 117 | HM.empty 118 | , testCase "expands with a count of 1" $ 119 | expandByCount (HM.fromList [baseProgPair, ("prog.count", Number 1)]) @?= 120 | HM.fromList [ ("prog-1.exec", String "foo") 121 | , ("prog-1.env.ANGEL_PROCESS_NUMBER", String "1")] 122 | , testCase "expands with a count of > 1" $ 123 | expandByCount (HM.fromList [baseProgPair, ("prog.count", Number 2)]) @?= 124 | HM.fromList [ ("prog-1.exec", String "foo") 125 | , ("prog-1.env.ANGEL_PROCESS_NUMBER", String "1") 126 | , ("prog-2.exec", String "foo") 127 | , ("prog-2.env.ANGEL_PROCESS_NUMBER", String "2")] 128 | , testCase "preserves explicit env variables" $ 129 | expandByCount (HM.fromList [baseProgPair, ("prog.env.FOO", String "bar")]) @?= 130 | HM.fromList [ ("prog.exec", String "foo") 131 | , ("prog.env.FOO", String "bar")] 132 | , testCase "expands pidfiles with a count of 1" $ 133 | expandByCount (HM.fromList [ baseProgPair 134 | , ("prog.count", Number 1) 135 | , ("prog.pidfile", String "foo.pid")]) @?= 136 | HM.fromList [ ("prog-1.exec", String "foo") 137 | , ("prog-1.env.ANGEL_PROCESS_NUMBER", String "1") 138 | , ("prog-1.pidfile", String "foo-1.pid")] --TODO: try without expanding if count == 1 139 | ] 140 | 141 | , testGroup "processConfig internal API" 142 | [ 143 | testCase "can parse the example config" $ 144 | shouldReturnRight $ processConfig "example.conf" 145 | ] 146 | ] 147 | where prog = defaultProgram 148 | baseProgPair = ("prog.exec", String "foo") 149 | shouldReturnRight a = flip shouldSatisfy isRight =<< a 150 | 151 | isRight :: Either a b -> Bool 152 | isRight (Right _) = True 153 | isRight _ = False 154 | -------------------------------------------------------------------------------- /test/Angel/JobSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | module Angel.JobSpec (spec) where 3 | 4 | import Angel.Job (killProcess) 5 | import Angel.Process ( getProcessHandleStatus 6 | , hardKillProcessHandle ) 7 | import Angel.Data hiding (Spec, spec) 8 | import Angel.Util (sleepSecs) 9 | 10 | import Control.Monad.IO.Class 11 | import System.Exit (ExitCode(..)) 12 | import System.Posix.Directory (getWorkingDirectory) 13 | import System.Posix.Signals (sigKILL) 14 | import System.Posix.Process (ProcessStatus(..)) 15 | import System.Process ( createProcess 16 | , proc 17 | , ProcessHandle ) 18 | 19 | import SpecHelper 20 | 21 | spec :: TestTree 22 | spec = testGroup "Angel.Jon" 23 | [ 24 | testGroup "killProcess" 25 | [ 26 | testGroup "using SoftKill" 27 | [ 28 | testCase "cleanly kills well-behaved processes" $ runAngelM dummyOptions $ do 29 | ph <- liftIO launchCompliantJob 30 | killProcess $ SoftKill "thing" ph Nothing 31 | liftIO $ 32 | patientlyGetProcessExitCode ph `shouldReturn` (Just $ Exited ExitSuccess) 33 | 34 | , testCase "does not forcefully kill stubborn processes" $ runAngelM dummyOptions $ do 35 | ph <- liftIO launchStubbornJob 36 | killProcess $ SoftKill "thing" ph Nothing 37 | -- stubborn job gets marked as [defunct] here. no idea why. it should be able to survive a SIGTERM 38 | liftIO $ do 39 | patientlyGetProcessExitCode ph `shouldReturn` Nothing 40 | hardKillProcessHandle ph -- cleanup 41 | ], 42 | testGroup "using HardKill" 43 | [ 44 | testCase "cleanly kills well-behaved processes" $ runAngelM dummyOptions $ do 45 | ph <- liftIO launchCompliantJob 46 | killProcess $ HardKill "thing" ph Nothing 1 47 | -- Can't geth the exiit status because the life check in Job "uses up" the waitpid 48 | liftIO $ 49 | patientlyGetProcessExitCode ph `shouldReturn` Nothing 50 | , testCase "forcefully kills stubborn processes" $ runAngelM dummyOptions $ do 51 | ph <- liftIO launchStubbornJob 52 | killProcess $ HardKill "thing" ph Nothing 1 53 | liftIO $ 54 | #if MIN_VERSION_unix(2,7,0) 55 | patientlyGetProcessExitCode ph `shouldReturn` (Just $ Terminated sigKILL False) 56 | #else 57 | patientlyGetProcessExitCode ph `shouldReturn` (Just $ Terminated sigKILL) 58 | #endif 59 | ], 60 | testGroup "with a logger" 61 | [ 62 | testCase "cleanly kills well-behaved loggers" $ runAngelM dummyOptions $ do 63 | ph <- liftIO launchCompliantJob 64 | lph <- liftIO launchCompliantJob 65 | killProcess $ SoftKill "thing" ph (Just lph) 66 | liftIO $ 67 | patientlyGetProcessExitCode lph `shouldReturn` (Just $ Exited ExitSuccess) 68 | ] 69 | ] 70 | ] 71 | 72 | 73 | launchCompliantJob :: IO ProcessHandle 74 | launchCompliantJob = launchJob "CompliantJob" 75 | 76 | launchStubbornJob :: IO ProcessHandle 77 | launchStubbornJob = launchJob "StubbornJob" 78 | 79 | launchJob :: FilePath -> IO ProcessHandle 80 | launchJob n = do wd <- getWorkingDirectory 81 | let path = wd ++ "/test/test_jobs/" ++ n 82 | (_, _, _, ph) <- createProcess $ proc path [] 83 | sleepSecs 1 84 | return ph 85 | 86 | patientlyGetProcessExitCode :: ProcessHandle -> IO (Maybe ProcessStatus) 87 | patientlyGetProcessExitCode ph = sleepSecs 1 >> getProcessHandleStatus ph 88 | 89 | dummyOptions :: Options 90 | dummyOptions = Options { 91 | configFile = "" 92 | , verbosity = V0 93 | } 94 | -------------------------------------------------------------------------------- /test/Angel/LogSpec.hs: -------------------------------------------------------------------------------- 1 | module Angel.LogSpec (spec) where 2 | 3 | import Angel.Log 4 | 5 | import Data.Time 6 | import Data.Time.Calendar (fromGregorian) 7 | import Data.Time.LocalTime (timeOfDayToTime, 8 | TimeOfDay(..), 9 | TimeZone(..), 10 | ZonedTime(..)) 11 | 12 | import SpecHelper 13 | 14 | 15 | spec :: TestTree 16 | spec = testGroup "Angel.Log" 17 | [ 18 | testGroup "cleanCalendar" 19 | [ 20 | testCase "formats the time correctly" $ 21 | cleanCalendar dateTime @?= "2012/09/12 03:14:59" 22 | ] 23 | ] 24 | --where time = CalendarTime 2012 September 12 3 14 59 0 Tuesday 263 "Pacific" -25200 True 25 | where dateTime = ZonedTime localTime zone 26 | localTime = LocalTime day tod 27 | day = fromGregorian 2012 9 12 28 | tod = TimeOfDay 3 14 59 29 | zone = TimeZone (-420) False "PDT" 30 | -------------------------------------------------------------------------------- /test/Angel/PidFileSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Angel.PidFileSpec (spec) where 3 | 4 | import Angel.PidFile 5 | 6 | import Control.Exception.Base ( try 7 | , SomeException ) 8 | import Data.Char (isNumber) 9 | import Data.IORef ( newIORef 10 | , readIORef 11 | , writeIORef ) 12 | import System.Process (proc) 13 | import System.Posix.Files (fileExist) 14 | 15 | import SpecHelper 16 | 17 | spec :: TestTree 18 | spec = testGroup "Angel.PidFile" 19 | [ 20 | testGroup "startWithPidFile" 21 | [ 22 | testCase "creates the pidfile and cleans up" $ do 23 | startWithPidFile procSpec fileName jogOn $ \_pHandle -> do 24 | fileShouldExist fileName 25 | pid <- readFile fileName 26 | null pid @?= False 27 | all isNumber pid @?= True 28 | fileShouldNotExist fileName 29 | , testCase "calls the error callback when pidfile can't be created and re-raises" $ do 30 | called <- newIORef False 31 | let onPidError = const $ writeIORef called True 32 | (res :: Either SomeException ()) <- try $ startWithPidFile procSpec badPidFile jogOn onPidError 33 | readIORef called `shouldReturn` True 34 | isLeft res @?= True 35 | ] 36 | ] 37 | where 38 | fileName = "temp.pid" 39 | badPidFile = "/bogus/path/to/pidfile" 40 | procSpec = proc "pwd" [] 41 | fileShouldExist _name = fileExist fileName `shouldReturn` True 42 | fileShouldNotExist _name = fileExist fileName `shouldReturn` False 43 | jogOn = const $ return () 44 | isLeft (Left _) = True 45 | isLeft _ = False 46 | -------------------------------------------------------------------------------- /test/Angel/UtilSpec.hs: -------------------------------------------------------------------------------- 1 | module Angel.UtilSpec (spec) where 2 | 3 | import Angel.Util 4 | 5 | import System.Posix.User (getEffectiveUserID, 6 | getUserEntryForID, 7 | UserEntry(..)) 8 | 9 | import SpecHelper 10 | 11 | spec :: TestTree 12 | spec = testGroup "Angel.Util" 13 | [ 14 | testGroup "expandPath" 15 | [ 16 | testCase "generates the correct path for just a tilde" $ do 17 | UserEntry { homeDirectory = home } <- getUserEntry 18 | path <- expandPath "~/foo" 19 | path @?= home ++ "/foo" 20 | , testCase "generates the correct path for tilde with a specific user" $ do 21 | UserEntry { homeDirectory = home, 22 | userName = user } <- getUserEntry 23 | path <- expandPath $ "~" ++ user ++ "/foo" 24 | path @?= home ++ "/foo" 25 | , testCase "leaves paths without tildes alone" $ do 26 | path <- expandPath "/foo" 27 | path @?= "/foo" 28 | ] 29 | , testGroup "split" 30 | [ 31 | testProperty "produces no null values" $ \(a :: Char) (xs :: [Char]) -> 32 | none null $ split a xs 33 | , testProperty "produces no instances of the split element" $ \(a :: Char) (xs :: [Char]) -> 34 | none (elem a) $ split a xs 35 | , testCase "splits" $ 36 | split ' ' " foo bar baz " @?= ["foo", "bar", "baz"] 37 | ] 38 | ] 39 | where getUserEntry = getUserEntryForID =<< getEffectiveUserID 40 | none p = not . any p 41 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | ------------------------------------------------------------------------------- 4 | import qualified Angel.ConfigSpec 5 | import qualified Angel.JobSpec 6 | import qualified Angel.LogSpec 7 | import qualified Angel.PidFileSpec 8 | import qualified Angel.UtilSpec 9 | ------------------------------------------------------------------------------- 10 | import SpecHelper 11 | ------------------------------------------------------------------------------- 12 | import Control.Exception (throwIO) 13 | import System.Exit (ExitCode (..)) 14 | import System.Process (rawSystem) 15 | 16 | 17 | buildTestFixtures :: IO () 18 | buildTestFixtures = do 19 | run "ghc" ["--make", "test/test_jobs/StubbornJob.hs", "-o", "test/test_jobs/StubbornJob"] 20 | run "ghc" ["--make", "test/test_jobs/CompliantJob.hs", "-o", "test/test_jobs/CompliantJob"] 21 | where 22 | run a b = do 23 | e <- rawSystem a b 24 | case e of 25 | ExitSuccess -> 26 | return () 27 | ExitFailure _ -> 28 | throwIO e 29 | 30 | main :: IO () 31 | main = do 32 | buildTestFixtures 33 | defaultMain $ testGroup "angel" [ 34 | Angel.ConfigSpec.spec 35 | , Angel.JobSpec.spec 36 | , Angel.LogSpec.spec 37 | , Angel.PidFileSpec.spec 38 | , Angel.UtilSpec.spec 39 | ] 40 | -------------------------------------------------------------------------------- /test/SpecHelper.hs: -------------------------------------------------------------------------------- 1 | module SpecHelper 2 | ( module X 3 | , module SpecHelper 4 | ) where 5 | 6 | import Control.Exception 7 | import Test.Tasty as X 8 | import Test.Tasty.HUnit as X 9 | import Test.Tasty.QuickCheck as X 10 | 11 | 12 | 13 | ------------------------------------------------------------------------------- 14 | shouldReturn :: (Show a, Eq a) => IO a -> a -> Assertion 15 | shouldReturn f v = do 16 | v' <- f 17 | v' @?= v 18 | 19 | 20 | ------------------------------------------------------------------------------- 21 | shouldThrow :: Exception e => IO a -> (e -> Bool) -> Assertion 22 | shouldThrow f p = do 23 | res <- try f 24 | either (`shouldSatisfy` p) (const $ assertFailure "Did not throw an exception") res 25 | 26 | 27 | ------------------------------------------------------------------------------- 28 | anyErrorCall :: ErrorCall -> Bool 29 | anyErrorCall = const True 30 | 31 | 32 | ------------------------------------------------------------------------------- 33 | shouldSatisfy :: (Show a) => a -> (a -> Bool) -> Assertion 34 | shouldSatisfy a p = assertBool ("predicate failed on " ++ show a ) (p a) 35 | -------------------------------------------------------------------------------- /test/test_jobs/CompliantJob.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import GHC.IO.Handle 4 | import System.IO (stdout) 5 | import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) 6 | import System.Exit (exitWith, ExitCode(ExitSuccess)) 7 | import System.Posix.Signals (installHandler, sigTERM, Handler(Catch)) 8 | 9 | main :: IO () 10 | main = do 11 | hSetBuffering stdout NoBuffering 12 | putStrLn "Compliant job started" 13 | sig <- newEmptyMVar 14 | installHandler sigTERM (Catch $ print "term" >> putMVar sig ExitSuccess) Nothing 15 | exitWith =<< takeMVar sig 16 | -------------------------------------------------------------------------------- /test/test_jobs/StubbornJob.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import GHC.IO.Handle 4 | import System.IO (stdout) 5 | import Control.Concurrent (threadDelay, forkIO) 6 | import Control.Concurrent.MVar (newEmptyMVar, takeMVar, putMVar) 7 | import System.Posix.Signals (installHandler, sigTERM, Handler(Catch)) 8 | 9 | main :: IO () 10 | main = do 11 | hSetBuffering stdout NoBuffering 12 | putStrLn "Stubborn job started" 13 | sig <- newEmptyMVar 14 | installHandler sigTERM (Catch $ print "term, ignoring" >> return ()) Nothing 15 | forkIO $ threadDelay maxBound >> putMVar sig () 16 | () <- takeMVar sig 17 | return () 18 | --------------------------------------------------------------------------------