keter 2.1.8 → 2.1.9
raw patch · 26 files changed
+1200/−1186 lines, 26 filesdep −ghc-primdep −system-filepathdep ~containersdep ~http-reverse-proxydep ~process
Dependencies removed: ghc-prim, system-filepath
Dependency ranges changed: containers, http-reverse-proxy, process, random, tls, warp-tls
Files
- ChangeLog.md +153/−115
- README.md +168/−120
- keter.cabal +96/−100
- src/Keter/Aeson/KeyHelper.hs +6/−19
- src/Keter/App.hs +86/−91
- src/Keter/AppManager.hs +53/−59
- src/Keter/Cli.hs +23/−24
- src/Keter/Common.hs +27/−22
- src/Keter/Conduit/Process/Unix.hs +128/−116
- src/Keter/Config.hs +19/−19
- src/Keter/Config/Middleware.hs +19/−18
- src/Keter/Config/V04.hs +20/−20
- src/Keter/Config/V10.hs +38/−32
- src/Keter/Context.hs +7/−9
- src/Keter/HostManager.hs +42/−42
- src/Keter/LabelMap.hs +16/−18
- src/Keter/Logger.hs +5/−11
- src/Keter/Main.hs +65/−90
- src/Keter/Plugin/Postgres.hs +57/−60
- src/Keter/PortPool.hs +16/−16
- src/Keter/Proxy.hs +66/−80
- src/Keter/Rewrite.hs +22/−43
- src/Keter/TempTarball.hs +14/−24
- src/Keter/Yaml/FilePath.hs +25/−9
- src/main/keter.hs +5/−4
- test/Spec.hs +24/−25
ChangeLog.md view
@@ -1,219 +1,245 @@+# Changelog++## 2.1.9+- Add integration tests (@jezen)+- bump random package (@jappeace)+- fix log rotation bug (@jezen & @ktak-007)+- bunch of cleanup and formatting (@jezen)+ ## 2.1.8-+ Bump tls, make it build with new release +- Bump tls, make it build with new release+ ## 2.1.7-+ add lower limit for tar to 0.6.0.0, which fixes "FileNotExecutable" bug.++- add lower limit for tar to 0.6.0.0, which fixes "FileNotExecutable" bug. see #291, special thanks to @scheottl for finding and debugging. ## 2.1.6-+ Bump network +- Bump network+ ## 2.1.5-+ Fix OOM bug on logfile rotation +- Fix OOM bug on logfile rotation+ ## 2.1.4-+ bump package versions, tls, warp and zlib +- bump package versions, tls, warp and zlib+ ## 2.1.3 -* Add `healthcheck-path` global config for Keter-only healthchecks. PR #283+- Add `healthcheck-path` global config for Keter-only healthchecks. PR #283 -* Fix config keys `unknown-host-response-file` and `missing-host-response-file`+- Fix config keys `unknown-host-response-file` and `missing-host-response-file` accidentally flipped. PR #282-* In case reading any one of `*-host-response-file` fails, keter now logs a warning,+- In case reading any one of `*-host-response-file` fails, keter now logs a warning, and falls back to builtin defaults. Before 2.1.3, this is a fatal error.-* Add support for tar 0.6, drop NIH tar unpack.-+ Change CI to be cabal based instead of stack.+- Add support for tar 0.6, drop NIH tar unpack.+- Change CI to be cabal based instead of stack. ## 2.1.2 -* Bump bounds:- ```- aeson >=2.0.0 && <2.2 (latest: 2.2.0.0)- bytestring >=0.10.12 && <0.12 (latest: 0.12.0.0)- mtl >=2.2.2 && <2.3 (latest: 2.3.1)- optparse-applicative >=0.16.1 && <0.18 (latest: 0.18.1.0)- transformers >=0.5.6 && <0.6 (latest: 0.6.1.1)- unix >=2.7.2 && <2.8 (latest: 2.8.1.1)- warp-tls >=3.0.3 && <3.4.0 (latest: 3.4.0)+- Bump bounds:++ ```cabal+ aeson >=2.0.0 && <2.2 (latest: 2.2.0.0)+ bytestring >=0.10.12 && <0.12 (latest: 0.12.0.0)+ mtl >=2.2.2 && <2.3 (latest: 2.3.1)+ optparse-applicative >=0.16.1 && <0.18 (latest: 0.18.1.0)+ transformers >=0.5.6 && <0.6 (latest: 0.6.1.1)+ unix >=2.7.2 && <2.8 (latest: 2.8.1.1)+ warp-tls >=3.0.3 && <3.4.0 (latest: 3.4.0) ``` ## 2.1.1 -+ Bump unix-compat bound to accept 0.7-+ Add upper bounds to all dependencies in the main library-+ Run cabal-fmt-+ Drop support for stackage lts-17 and lts-18+- Bump unix-compat bound to accept 0.7+- Add upper bounds to all dependencies in the main library+- Run cabal-fmt+- Drop support for stackage lts-17 and lts-18 I don't think it's worth mainting these with the aeson issues involved. Eg you open yourself to a [DoS attack](https://github.com/haskell/aeson/issues/864) by staying on these old versions ## 2.1 -Please reference `MigrationGuide-2.1.md` for in-depth documentation on breaking changes to be aware of, examples of said changes, and potential solutions/workarounds for them if you plan on upgrading to this version of `keter`.+Please reference `MigrationGuide-2.1.md` for in-depth documentation on breaking+changes to be aware of, examples of said changes, and potential+solutions/workarounds for them if you plan on upgrading to this version of+`keter`. -+ Log naming and directory scheme has changed for both main keter logs and app logs. - Old logs were named `dir/current.log` for the current log and `%Y%m%d_%H%M%S.log` - (`time` package conventions) for rotated logs. - Current logs have been brought up one level and named after their old directory: - `logs/keter/current.log` -> `logs/keter.log` - Rotated logs will now simply have `.1` `.2` ascending appended to the name of the base logs - rather than be named after the date and time they were rotated at: - `logs/keter/20230413_231415.log` -> `logs/keter.log.1` - `logs/__builtin__/20230413_231415.log` -> `logs/__builtin__.log.1` - `logs/app-foo/20230413_231415.log` -> `logs/app-foo.log.1` - Please update anything that depended on the old log naming and directory conventions accordingly.-+ Added the `rotate-logs` option (default: true) in the keter config file. - When true, the main keter (non-app!) logs will rotate like they have in previous versions. - When false, the main keter logs will emit straight to stderr; this is useful e.g. if you're - running keter via systemd, which captures stderr output for you.-+ Internal logging implementation has been switched over to `fast-logger` instead of the- old in-house logging solution. - Please be aware that compared to the old logging solution, the usage of `fast-logger` does- not 100% guarantee consistent time ordering. If anything previously depended on tailing the last- line of a log and critically assumed that messages will be in order, it should now parse via - timestamp instead.-+ The `LogMessage` ADT has been removed.-+ Replaced individual logging calls with TH splice -style calls where sensible to have access to source location info.-+ Updated log message format to make use of the additional info: +- Log naming and directory scheme has changed for both main keter logs and app logs.+ Old logs were named `dir/current.log` for the current log and `%Y%m%d_%H%M%S.log`+ (`time` package conventions) for rotated logs.+ Current logs have been brought up one level and named after their old directory:+ `logs/keter/current.log` -> `logs/keter.log`+ Rotated logs will now simply have `.1` `.2` ascending appended to the name of+ the base logs+ rather than be named after the date and time they were rotated at:+ `logs/keter/20230413_231415.log` -> `logs/keter.log.1`+ `logs/__builtin__/20230413_231415.log` -> `logs/__builtin__.log.1`+ `logs/app-foo/20230413_231415.log` -> `logs/app-foo.log.1`+ Please update anything that depended on the old log naming and directory+ conventions accordingly.+- Added the `rotate-logs` option (default: true) in the keter config file.+ When true, the main keter (non-app!) logs will rotate like they have in+ previous versions.+ When false, the main keter logs will emit straight to stderr; this is useful+ e.g. if you're running keter via systemd, which captures stderr output for+ you.+- Internal logging implementation has been switched over to `fast-logger`+ instead of the old in-house logging solution.+ Please be aware that compared to the old logging solution, the usage of+ `fast-logger` does not 100% guarantee consistent time ordering. If anything+ previously depended on tailing the last line of a log and critically assumed+ that messages will be in order, it should now parse via timestamp instead.+- The `LogMessage` ADT has been removed.+- Replaced individual logging calls with TH splice -style calls where sensible+ to have access to source location info.+- Updated log message format to make use of the additional info: `"$time|$module$:$line_num|$log_level> $msg"`-+ Added `Keter.Context`, exposing the new `KeterM` monad and related functions. - This monad carries a mappable global config and logger around, eliminating the need to pass various configuration data and the logger to everything.-+ Refactored most `Keter.*` module functions to be actions in `KeterM` - Please anticipate breaking changes for anything written against the exposed API.+- Added `Keter.Context`, exposing the new `KeterM` monad and related functions.+ This monad carries a mappable global config and logger around, eliminating+ the need to pass various configuration data and the logger to everything.+- Refactored most `Keter.*` module functions to be actions in `KeterM`+ Please anticipate breaking changes for anything written against the exposed+ API. ## 2.0.1 -+ Force usage of http-reverse-proxy versions above 0.6.0.1.+- Force usage of http-reverse-proxy versions above 0.6.0.1. This prevents a DoS attack on a head request followed by a post. ## 2.0 -+ Improve missing sudo error messages in postgres plugin.-+ Reorganized most Haskell source files into /src.-+ Dropped support for http-client < 0.5.0.-+ Removed 'default' package.-+ All "Data" modules are now "Keter" modules.-+ Testing library switched from "hspec" to "tasty".-* Move Network.Http.ReverseProxy.Rewrite into Keter.Rewrite-* Move Codec.Archive.TempTarball into Keter.TempTarball-* Hide Keter.Aeson.KeyHelper-* Stop re-exporting common and rewrite from types-* Common no longer re-exports half of Haskell-* Rename Types to Config-* Move Common out of Config into root+- Improve missing sudo error messages in postgres plugin.+- Reorganized most Haskell source files into /src.+- Dropped support for http-client < 0.5.0.+- Removed 'default' package.+- All "Data" modules are now "Keter" modules.+- Testing library switched from "hspec" to "tasty".+- Move Network.Http.ReverseProxy.Rewrite into Keter.Rewrite+- Move Codec.Archive.TempTarball into Keter.TempTarball+- Hide Keter.Aeson.KeyHelper+- Stop re-exporting common and rewrite from types+- Common no longer re-exports half of Haskell+- Rename Types to Config+- Move Common out of Config into root ## 1.9 -+ Update status code of missing host responses.+- Update status code of missing host responses. They now emit a 502 on missing host, and 404 on host not found-+ Always restart keter in the nix config for systemd.+- Always restart keter in the nix config for systemd. It turns out that keter may exit with exit code 0 under load testing. Changing from on-failure to always in systemd should bring it back up.-+ Squash proxy exceptions if they occur and serve a default or custom error+- Squash proxy exceptions if they occur and serve a default or custom error response. Emits the exception to the log.-+ Add incoming folder to the CI build.+- Add incoming folder to the CI build. ## 1.8.4 -+ Get rid of ominious warning at the top.+- Get rid of ominious warning at the top. Thanks to /u/Opposite-Platypus-99 for pointing this out. ## 1.8.3 -+ HTML escape X-forwarded-host response as well.+- HTML escape X-forwarded-host response as well. -## 1.8.2 +## 1.8.2 -+ Fix XSS issue in the default response for host not found.+- Fix XSS issue in the default response for host not found. (special thanks to Max @ulidtko for spotting and fixing this) ## 1.8.1 -+ Fix haddock build+- Fix haddock build ## 1.8 -+ Add NixOS support-+ Describe debug port in readme.-+ Improve ensure alive error message due to - https://github.com/snoyberg/keter/issues/236-+ Add `missing-host-response-file` and `unknown-host-response-file`+- Add NixOS support+- Describe debug port in readme.+- Improve ensure alive error message due to+ <https://github.com/snoyberg/keter/issues/236>+- Add `missing-host-response-file` and `unknown-host-response-file` to the global keter config, which replace the default responses.-+ All missing-host responses will now fill the requested host in the+- All missing-host responses will now fill the requested host in the `X-Forwarded-Host: HOSTNAME` header, where HOSTNAME is the requested host. This is done because the default response fills in the hostname. Now javascript could potentially fix that by making another request to itself.-+ Document missing configuration options in `etc/keter-config.yaml`+- Document missing configuration options in `etc/keter-config.yaml` ## 1.7 -* Add support Aeson 2.*-* Add `Data.Aeson.KeyHelper.hs` in cabal file.-* And use the module where Aeson has changed how to handle Key and KeyMap.+- Add support Aeson 2.*+- Add `Data.Aeson.KeyHelper.hs` in cabal file.+- And use the module where Aeson has changed how to handle Key and KeyMap. ## 1.6-* Make keter more chatty on boot.++- Make keter more chatty on boot. This allows you to figure out in code where things go wrong.-* Add opt-in debug CLI, allowing you to inspect keters' internal state.+- Add opt-in debug CLI, allowing you to inspect keters' internal state. You can activate it by specifying a cli-port.-* Emit which pid is being killed by keter.+- Emit which pid is being killed by keter. This helps with process leakage issues, for example if the user launches from a bash script without using `exec`. ## 1.5 -* Builds with `process` 1.6-* add dependency for `tls-session-manager`-* Add show instance for App-* Add ensure alive timeout config-* Add `nc` example in incoming-* Change to github actions because travis ci stopped working.-* Fix hackage issues in cabal file-* Fix breaking changes with warp-tls.+- Builds with `process` 1.6+- add dependency for `tls-session-manager`+- Add show instance for App+- Add ensure alive timeout config+- Add `nc` example in incoming+- Change to github actions because travis ci stopped working.+- Fix hackage issues in cabal file+- Fix breaking changes with warp-tls. ## 1.4.3.1 -* Add cabal flag `system-filepath` for compatibility with older versions of fsnotify.+- Add cabal flag `system-filepath` for compatibility with older versions of fsnotify. ## 1.4.3 -* Update fsnotify dependency version and remove system-filepath.+- Update fsnotify dependency version and remove system-filepath. ## 1.4.2.1 -Bug fix: Change default connection time bound from 5 sec to 5 minutes [#107](https://github.com/snoyberg/keter/pull/107)+Bug fix: Change default connection time bound from 5 sec to 5 minutes+[#107](https://github.com/snoyberg/keter/pull/107) ## 1.4.1 -* Add configurable timeouts [#93](https://github.com/snoyberg/keter/pull/93)+- Add configurable timeouts [#93](https://github.com/snoyberg/keter/pull/93) ## 1.4.0.1 -* Avoid infinite loop traversing incoming directory [#96](https://github.com/snoyberg/keter/issues/96)+- Avoid infinite loop traversing incoming directory [#96](https://github.com/snoyberg/keter/issues/96) ## 1.4.0 -* Drop system-filepath+- Drop system-filepath ## 1.3.10 -* Configurable time bound [#92](https://github.com/snoyberg/keter/pull/92)+- Configurable time bound [#92](https://github.com/snoyberg/keter/pull/92) ## 1.3.9.2 -* Lower case PostgreSQL names [#88](https://github.com/snoyberg/keter/pull/88)+- Lower case PostgreSQL names [#88](https://github.com/snoyberg/keter/pull/88) ## 1.3.9.1 -* Allow blaze-builder 0.4+- Allow blaze-builder 0.4 ## 1.3.9 -* Support chain certificates in credentials [#82](https://github.com/snoyberg/keter/pull/82)+- Support chain certificates in credentials [#82](https://github.com/snoyberg/keter/pull/82) ## 1.3.7.1 @@ -221,7 +247,7 @@ ## 1.3.7 -* Add ability to use middleware [#63](https://github.com/snoyberg/keter/pulls/63)+- Add ability to use middleware [#63](https://github.com/snoyberg/keter/pulls/63) ## 1.3.6 @@ -229,7 +255,8 @@ ## 1.3.5.3 -More correct/complete solution for issue #44. Allows looking up hosts either with or without port numbers.+More correct/complete solution for issue #44. Allows looking up hosts either+with or without port numbers. ## 1.3.5.2 @@ -241,11 +268,13 @@ ## 1.3.5 -All stanzas may have the `requires-secure` property to force redirect to HTTPS. You can set additional environment variables in your global Keter config file.+All stanzas may have the `requires-secure` property to force redirect to HTTPS.+You can set additional environment variables in your global Keter config file. ## 1.3.4 -Support for overriding external ports. Support for keter.yml in addition to keter.yaml. Case insensitive hostname lookups.+Support for overriding external ports. Support for keter.yml in addition to+keter.yaml. Case insensitive hostname lookups. ## 1.3.3 @@ -265,20 +294,29 @@ ## 1.0.1 -Permit use of wildcard subdomains and exceptions to wildcards. Convert internal strings to use Data.Text in more places. (Although internationalized domain names are not supported unless entered in punycode in configuration files.)+Permit use of wildcard subdomains and exceptions to wildcards. Convert internal+strings to use Data.Text in more places. (Although internationalized domain+names are not supported unless entered in punycode in configuration files.) ## 1.0.0 -Significant overhaul. We now support monitoring of much more arbitrary jobs (e.g., background tasks), have a proper plugin system (PostgreSQL is no longer a required component), and have a much better system for tracking hostname mapping changes.+Significant overhaul. We now support monitoring of much more arbitrary jobs+(e.g., background tasks), have a proper plugin system (PostgreSQL is no longer+a required component), and have a much better system for tracking hostname+mapping changes. ## 0.4.0 -Switch to fsnotify to get cross-platform support. No longer using raw proxies, but instead WAI proxies.+Switch to fsnotify to get cross-platform support. No longer using raw proxies,+but instead WAI proxies. ## 0.3.7 -Sending a HUP signal reloads the list of deployed apps. This is useful for circumstances where inotify does not work correctly, such as on file systems which do not support it.+Sending a HUP signal reloads the list of deployed apps. This is useful for+circumstances where inotify does not work correctly, such as on file systems+which do not support it. ## 0.3.5 -You can now create Keter bundles without any applications. These can contain static hosts and redirects.+You can now create Keter bundles without any applications. These can contain+static hosts and redirects.
README.md view
@@ -1,28 +1,38 @@-[](https://github.com/snoyberg/keter/actions)+# Keter +[](https://github.com/snoyberg/keter/actions) Deployment system for web applications, originally intended for hosting Yesod applications. Keter does the following actions for your application: -* Binds to the main port (usually port 80) and reverse proxies requests to your application based on virtual hostnames.+* Binds to the main port (usually port 80) and reverse proxies requests to your+ application based on virtual hostnames. * Provides SSL support if requested.-* Automatically launches applications, monitors processes, and relaunches any processes which die.-* Provides graceful redeployment support, by launching a second copy of your application, performing a health check[1], and then switching reverse proxying to the new process.+* Automatically launches applications, monitors processes, and relaunches any+ processes which die.+* Provides graceful redeployment support, by launching a second copy of your+ application, performing a health check[1], and then switching reverse+ proxying to the new process. Keter provides many more advanced features and extension points. It allows configuration of static hosts, redirect rules, management of PostgreSQL databases, and more. It supports a simple bundle format for applications which allows for easy management of your web apps. -[1]: The health check happens trough checking if a port is opened.+[1]: The health check happens by checking if a port is opened. If your app doesn't open a port after 30 seconds it's presumed not healthy and gets a term signal. ## Quick Start -To get Keter up-and-running quickly for development purposes, on an Ubuntu system (not on your production server), run:+To get Keter up-and-running quickly for development purposes, on an Ubuntu+system (not on your production server), run: - wget -O - https://raw.githubusercontent.com/snoyberg/keter/master/setup-keter.sh | bash+```sh+wget -O - \+ https://raw.githubusercontent.com/snoyberg/keter/master/setup-keter.sh \+ | bash+``` (Note: This assumes you already have keter installed via cabal.) (Note: you may need to run the above command twice, if the shell exits after@@ -42,30 +52,30 @@ ## Bundling your app for Keter -1. Modify your web app to check for the `PORT` environment variable, and have- it listen for incoming HTTP requests on that port. Keter automatically- assigns arbitrary ports to each web app it manages. When building an app- based on the Yesod Scaffold, it may be necessary to change the `port`- variable in `config/settings.yaml` from `YESOD_PORT` to `PORT` for- compatibility with Keter.+1. Modify your web app to check for the `PORT` environment variable, and have+ it listen for incoming HTTP requests on that port. Keter automatically+ assigns arbitrary ports to each web app it manages. When building an app+ based on the Yesod Scaffold, it may be necessary to change the `port`+ variable in `config/settings.yaml` from `YESOD_PORT` to `PORT` for+ compatibility with Keter. -2. Create a file `config/keter.yaml`. The minimal file just has two settings:+2. Create a file `config/keter.yaml`. The minimal file just has two settings: - ```yaml- exec: ../path/to/executable- host: mydomainname.example.com- ```+ ```yaml+ exec: ../path/to/executable+ host: mydomainname.example.com+ ``` - See the bundles section below for more available settings.+ See the bundles section below for more available settings. -3. Create a gzipped tarball with the `config/keter.yaml` file, your- executable, and any other static resources you would like available to your- application. This file should be given a `.keter` file extension, e.g.- `myapp.keter`.+3. Create a gzipped tarball with the `config/keter.yaml` file, your+ executable, and any other static resources you would like available to your+ application. This file should be given a `.keter` file extension, e.g.+ `myapp.keter`. -4. Copy the `.keter` file to `/opt/keter/incoming`. Keter will monitor this- directory for file updates, and automatically redeploy new versions of your- bundle.+4. Copy the `.keter` file to `/opt/keter/incoming`. Keter will monitor this+ directory for file updates, and automatically redeploy new versions of your+ bundle. Examples are available in the [incoming](https://github.com/snoyberg/keter/tree/master/incoming) directory.@@ -79,51 +89,62 @@ First, install PostgreSQL: - sudo apt-get install postgresql+```sh+sudo apt-get install postgresql+``` Second, build the `keter` binary and place it at `/opt/keter/bin`. To do so, you'll need to install the Haskell Platform, and can then build with `cabal`. This would look something like: - sudo apt-get install haskell-platform- cabal update- cabal install keter- sudo mkdir -p /opt/keter/bin- sudo cp ~/.cabal/bin/keter /opt/keter/bin+```sh+sudo apt-get install haskell-platform+cabal update+cabal install keter+sudo mkdir -p /opt/keter/bin+sudo cp ~/.cabal/bin/keter /opt/keter/bin+``` Third, create a Keter config file. You can view a sample at-https://github.com/snoyberg/keter/blob/master/etc/keter-config.yaml.+<https://github.com/snoyberg/keter/blob/master/etc/keter-config.yaml>. Optionally, you may wish to change the owner on the `/opt/keter/incoming` folder to your user account, so that you can deploy without `sudo`ing. - sudo mkdir -p /opt/keter/incoming- sudo chown $USER /opt/keter/incoming+```sh+sudo mkdir -p /opt/keter/incoming+sudo chown $USER /opt/keter/incoming+``` ### Building keter for Redhat and derivatives (Centos, Fedora, etc) First, install PostgreSQL: - sudo dnf install postgresql+```sh+sudo dnf install postgresql+``` Second, build the `keter` binary and place it at `/opt/keter/bin`. To do so, you'll need to install the Haskell Platform, and can then build with `cabal`. This would look something like: - sudo dnf install haskell-platform- cabal update- cabal install keter- sudo mkdir -p /opt/keter/bin- sudo cp ~/.cabal/bin/keter /opt/keter/bin+```sh+sudo dnf install haskell-platform+cabal update+cabal install keter+sudo mkdir -p /opt/keter/bin+sudo cp ~/.cabal/bin/keter /opt/keter/bin+``` Third, create a Keter config file. You can view a sample at-https://github.com/snoyberg/keter/blob/master/etc/keter-config.yaml.- +<https://github.com/snoyberg/keter/blob/master/etc/keter-config.yaml>.+ ### Configuring startup -For versions of Ubuntu and derivatives 15.04 or greater and Redhat and derivatives (Centos, Fedora, etc) use systemd+For versions of Ubuntu and derivatives 15.04 or greater and Redhat and+derivatives (Centos, Fedora, etc) use systemd. -```+```ini # /etc/systemd/system/keter.service [Unit] Description=Keter@@ -139,27 +160,38 @@ Finally, enable and start the unit (Note: You may need to disable SELinux): - sudo systemctl enable keter- sudo systemctl start keter+```sh+sudo systemctl enable keter+sudo systemctl start keter+``` Verify that it's actually running with: - sudo systemctl status keter+```sh+sudo systemctl status keter+``` Optionally, you may wish to change the owner on the `/opt/keter/incoming` folder to your user account, so that you can deploy without `sudo`ing. - sudo mkdir -p /opt/keter/incoming- sudo chown $USER /opt/keter/incoming+```sh+sudo mkdir -p /opt/keter/incoming+sudo chown $USER /opt/keter/incoming+``` -Additionally, you may want to enable logging to stderr by disabling `rotate-logs` in `config/keter.yaml`, since systemd will automatically capture and manage stderr output for you:+Additionally, you may want to enable logging to stderr by disabling+`rotate-logs` in `config/keter.yaml`, since systemd will automatically capture+and manage stderr output for you: - rotate-logs: false+```yaml+rotate-logs: false+``` ---- +---+ For versions of Ubuntu and derivatives less than 15.04, configure an Upstart job. -```+```conf # /etc/init/keter.conf start on (net-device-up and local-filesystems and runlevel [2345]) stop on runlevel [016]@@ -174,24 +206,25 @@ Finally, start the job for the first time: - sudo start keter-+```sh+sudo start keter+``` -### NixOS +### NixOS -Keter is integrated within nixos:+Keter is integrated within NixOS: -https://search.nixos.org/options?channel=22.11&show=services.keter.keterPackage&from=0&size=50&sort=relevance&type=packages&query=keter+<https://search.nixos.org/options?channel=22.11&show=services.keter.keterPackage&from=0&size=50&sort=relevance&type=packages&query=keter> There is an example that integrates yesod into keter with NixOS here:-https://github.com/jappeace/yesod-keter-nix- +<https://github.com/jappeace/yesod-keter-nix>+ ## Bundles An application needs to be set up as a keter bundle. This is a GZIPed tarball with a `.keter` filename extension and which has one special file: `config/keter.yaml`. A sample file is available at-https://github.com/snoyberg/keter/blob/master/incoming/foo1_0/config/keter.yaml.+<https://github.com/snoyberg/keter/blob/master/incoming/foo1_0/config/keter.yaml>. Keter also supports wildcard subdomains and exceptions, as in this example configuration:@@ -260,68 +293,79 @@ postgres: true ``` -* Keter can be configured to connect to a remote postgres server using the following syntax:+* Keter can be configured to connect to a remote postgres server using the+ following syntax:+ ```yaml plugins:- postgres: + postgres: - server: remoteServerNameOrIP port: 1234 ``` -Different webapps can be configured to use different servers using the above syntax.-It should be noted that keter will prioritize it's own postgres.yaml record for an app. -So if moving an existing app from a local postgres server to a remote one (or -switching remote servers), the postgres.yaml file will need to be updated manually. +Different webapps can be configured to use different servers using the above+syntax. It should be noted that keter will prioritize it's own postgres.yaml+record for an app. So if moving an existing app from a local postgres server to+a remote one (or switching remote servers), the postgres.yaml file will need to+be updated manually. -Keter will connect to the remote servers using the `postgres` account. This setup -assumes the remote server's `pg_hba.conf` file has been configured to allow connections-from the keter-server IP using the `trust` method. +Keter will connect to the remote servers using the `postgres` account. This+setup assumes the remote server's `pg_hba.conf` file has been configured to+allow connections from the keter-server IP using the `trust` method. (Note: The `plugins` configuration option was added in v1.0 of the keter configuration syntax. If you are using v0.4 then use `postgres: true`. The remote-postgres server syntax was added in v1.4.2.) -* Modify your application to get its database connection settings from the following environment variables:- * `PGHOST`- * `PGPORT`- * `PGUSER`- * `PGPASS`- * `PGDATABASE`+* Modify your application to get its database connection settings from the+ following environment variables: + * `PGHOST`+ * `PGPORT`+ * `PGUSER`+ * `PGPASS`+ * `PGDATABASE`+ * The Yesod scaffold site is already equipped to read these environment variables when they are set. ## Known issues -* There are reports of Keter not working behind an nginx reverse proxy. From- the reports, this appears to be a limitation in nginx's implementation, not a- problem with Keter. Keter works fine behind other reverse proxies, including- Apache and Amazon ELB.+* There are reports of Keter not working behind an nginx reverse proxy. From+ the reports, this appears to be a limitation in nginx's implementation, not a+ problem with Keter. Keter works fine behind other reverse proxies, including+ Apache and Amazon ELB. - One possible workaround is to add the following lines to your nginx configuration:+ One possible workaround is to add the following lines to your nginx configuration: - proxy_set_header Connection "";- proxy_http_version 1.1;+ ```nginx+ proxy_set_header Connection "";+ proxy_http_version 1.1;+ ``` - This has not yet been confirmed to work in production. If you use this,- please report either its success or failure back to me.- - Additionally, to make sure that nginx does not reset the `Host` header - (which keter uses to choose the right target), you will need to add:+ This has not yet been confirmed to work in production. If you use this,+ please report either its success or failure back to me. - proxy_set_header Host $host;+ Additionally, to make sure that nginx does not reset the `Host` header+ (which keter uses to choose the right target), you will need to add: -* Keter does not handle password-protected SSL key files well. When provided- with such a key file, unlike Apache and Nginx, Keter will not pause to ask- for the password. Instead, your https connections will merely stall.+ ```nginx+ proxy_set_header Host $host;+ ``` - To get around this, you need to create a copy of the key without password- and deploy this new key:+* Keter does not handle password-protected SSL key files well. When provided+ with such a key file, unlike Apache and Nginx, Keter will not pause to ask+ for the password. Instead, your https connections will merely stall. - openssl rsa -in original.key -out new.key+ To get around this, you need to create a copy of the key without password+ and deploy this new key: - (Back up the original key first, just in case.)+ ```sh+ openssl rsa -in original.key -out new.key+ ``` + (Back up the original key first, just in case.)+ ## Stanza-based config files Starting with Keter 1.0, there is an alternate format for application Keter@@ -331,8 +375,8 @@ options. In the meanwhile, please see the following examples of how to use this file format: -* https://github.com/yesodweb/yesod-scaffold/blob/postgres/config/keter.yml-* https://github.com/snoyberg/keter/blob/master/incoming/foo1_0/config/keter.yaml+* <https://github.com/yesodweb/yesod-scaffold/blob/postgres/config/keter.yml>+* <https://github.com/snoyberg/keter/blob/master/incoming/foo1_0/config/keter.yaml> ## Multiple SSL Certificates @@ -340,7 +384,7 @@ allowing for the deployment of distinct domains using the same server. An example `keter-config.yaml` would look like:: -```+```yaml root: .. listeners: - host: "*4" # Listen on all IPv4 hosts@@ -353,11 +397,10 @@ certificate: certificate2.pem ``` - An alternative way to make this possible is adding the following `ssl:` argument to the `keter.yaml` file in your Yesod app's `config folder` as follows: -```+```yaml stanzas: - type: webapp exec: ../yourproject@@ -370,7 +413,7 @@ If you don't have your certificates bundled in one `.crt` file, you should add the other certificates in the following order -```+```yaml ssl: [..] chain-certificates:@@ -378,38 +421,43 @@ - /opt/keter/etc/root.crt ``` -This way you can designate certificates per Yesod App while still having one SSL certificate-in your main `/opt/keter/etc/keter-config.yaml` for your other Yesod apps to default to-if they don't have this `ssl:` argument in their `config/keter.yaml`.--NOTE: If you get an error that a Bool was expected instead of an Object when adding the `ssl:`-argument, then for this to work you might need to build Keter from Github, because at the time-of writing the version of Keter on Hackage does not have this functionality. Just clone or -download this repository and build it using stack.+This way you can designate certificates per Yesod App while still having one+SSL certificate in your main `/opt/keter/etc/keter-config.yaml` for your other+Yesod apps to default to if they don't have this `ssl:` argument in their+`config/keter.yaml`. +NOTE: If you get an error that a Bool was expected instead of an Object when+adding the `ssl:` argument, then for this to work you might need to build Keter+from Github, because at the time of writing the version of Keter on Hackage+does not have this functionality. Just clone or download this repository and+build it using stack. ## FAQ -* Keter spawns multiple failing process when run with `sudo start keter`.- * This may be due to Keter being unable to find the SSL certificate and key.- Try to run `sudo /opt/keter/bin/keter /opt/keter/etc/keter-config.yaml`.- If it fails with `keter: etc/certificate.pem: openBinaryFile: does not exist`- or something like it, you may need to provide valid SSL certificates and keys- or disable HTTPS, by commenting the key and certificate lines from- `/opt/keter/etc/keter-config.yaml`.+> Keter spawns multiple failing process when run with `sudo start keter`. +This may be due to Keter being unable to find the SSL certificate and key. Try+to run `sudo /opt/keter/bin/keter /opt/keter/etc/keter-config.yaml`. If it+fails with `keter: etc/certificate.pem: openBinaryFile: does not exist` or+something like it, you may need to provide valid SSL certificates and keys or+disable HTTPS, by commenting the key and certificate lines from+`/opt/keter/etc/keter-config.yaml`. ## Debugging+ There is a debug port option available in the global keter config:+ ```yaml cli-port = 1234 ``` This allows you to attach netcat to that port, and introspect which processes are running within keter:+ ```bash nc localhost 1234 ```+ Then type `--help` for options, currently it can only list the apps, but this approach is easily extensible if you need additional debug information.@@ -420,7 +468,7 @@ ## Contributing If you are interested in contributing, see-https://github.com/snoyberg/keter/blob/master/incoming/README.md for a+<https://github.com/snoyberg/keter/blob/master/incoming/README.md> for a complete testing workflow. If you have any questions, you can open an issue in the issue tracker, ask on the #yesod freenode irc channel, or-send an email to yesodweb@googlegroups.com.+send an email to <yesodweb@googlegroups.com>.
keter.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: keter-version: 2.1.8+version: 2.1.9 synopsis: Web application deployment manager, focusing on Haskell web frameworks. It mitigates downtime. @@ -12,7 +12,6 @@ It automatically launches applications, monitors processes, and relaunches any processes which die. It also provides graceful redeployment support, which mitigates downtime. - homepage: http://www.yesodweb.com/ license: MIT license-file: LICENSE@@ -24,68 +23,58 @@ ChangeLog.md README.md -flag system-filepath- description: Use system-filepath- default: False- library- default-language: Haskell98+ default-language: Haskell98+ default-extensions: ImportQualifiedPost build-depends:- aeson >=2.0.0 && <2.2 || ^>=2.2.0.0,- array >=0.5.4 && <0.6,- async >=2.2.4 && <2.3,- attoparsec >=0.14.4 && <0.15,- base >=4 && <5,- blaze-builder >=0.3 && <0.5,- bytestring >=0.10.12 && <0.12 || ^>=0.12.0.0,- case-insensitive >=1.2.1 && <1.3,- conduit >=1.3.4 && <1.4,- conduit-extra >=1.3.5 && <1.4,- containers >=0.6.4 && <0.7 || ^>=0.7,- directory >=1.3.6 && <1.4,- fast-logger >=3.0.0 && <4.0.0,- filepath >=1.4.2 && <1.6,- fsnotify >=0.3.0 && <0.5,- http-client >=0.7.11 && <0.8,- http-conduit >=2.3.8 && <2.4,- http-reverse-proxy >=0.6.0.1 && <0.7,- http-types >=0.12.3 && <0.13,- indexed-traversable >=0.1.2 && <0.2,- lifted-base >=0.2.3 && <0.3,- monad-logger >=0.3.0 && <0.4.0,- mtl >=2.2.2 && <2.3 || ^>=2.3.1,- network >=3.1.2 && <3.2 || ^>=3.2.0,- optparse-applicative >=0.16.1 && <0.18 || ^>=0.18.1.0,- process >=1.4.3 && <1.7,- random >=1.2.1 && <1.3,- regex-tdfa >=1.3.1 && <1.4,- stm >=2.5.0 && <2.6,- tar >=0.6.0.0 && <0.7,- template-haskell >=2.17.0 && <3.0,- text >=1.2.5 && <3.0,- time >=1.9.3 && <2.0,- tls >=1.5.7 && <2.1 || ^>= 2.1.0 || ^>=2.1.1,- tls-session-manager >=0.0.4 && <0.1,- transformers >=0.5.6 && <0.7,- unix >=2.7.2 && <2.9,- unix-compat >=0.3 && <0.8,- unliftio-core >=0.2.0.0 && <0.3.0.0,- unordered-containers >=0.2.17 && <0.3,- vector >=0.12.3.0 && <1.0.0.0,- wai >=3.2.3 && <3.3,- wai-app-static >=3.1 && <3.2,- wai-extra >=3.0.3 && <3.2,- warp >=3.3.20 && <3.4 || ^>=3.4.0,- warp-tls >=3.0.3 && <3.4.0 || ^>=3.4.0,- yaml >=0.8.4 && <0.12,- zlib >=0.6.2 && <0.7 || ^>=0.7.0-- if impl(ghc <7.6)- build-depends: ghc-prim-- if flag(system-filepath)- build-depends: system-filepath- cpp-options: -DSYSTEM_FILEPATH+ , aeson >=2.0.0 && <2.2 || ^>=2.2.0.0+ , array >=0.5.4 && <0.6+ , async >=2.2.4 && <2.3+ , attoparsec >=0.14.4 && <0.15+ , base >=4 && <5+ , blaze-builder >=0.3 && <0.5+ , bytestring >=0.10.12 && <0.12 || ^>=0.12.0.0+ , case-insensitive >=1.2.1 && <1.3+ , conduit >=1.3.4 && <1.4+ , conduit-extra >=1.3.5 && <1.4+ , containers ^>=0.6.4 || ^>=0.7+ , directory >=1.3.6 && <1.4+ , fast-logger >=3.0.0 && <4.0.0+ , filepath >=1.4.2 && <1.6+ , fsnotify >=0.3.0 && <0.5+ , http-client >=0.7.11 && <0.8+ , http-conduit >=2.3.8 && <2.4+ , http-reverse-proxy >=0.6.1 && <0.7+ , http-types >=0.12.3 && <0.13+ , indexed-traversable >=0.1.2 && <0.2+ , lifted-base >=0.2.3 && <0.3+ , monad-logger >=0.3.0 && <0.4.0+ , mtl >=2.2.2 && <2.3 || ^>=2.3.1+ , network >=3.1.2 && <3.2 || ^>=3.2.0+ , optparse-applicative >=0.16.1 && <0.18 || ^>=0.18.1.0+ , process >=1.6 && <1.7+ , random >=1.2.1 && <1.4+ , regex-tdfa >=1.3.1 && <1.4+ , stm >=2.5.0 && <2.6+ , tar >=0.6.0.0 && <0.7+ , template-haskell >=2.17.0 && <3.0+ , text >=1.2.5 && <3.0+ , time >=1.9.3 && <2.0+ , tls >=1.5.7 && <2.1 || ^>=2.1.0+ , tls-session-manager >=0.0.4 && <0.1+ , transformers >=0.5.6 && <0.7+ , unix >=2.7.2 && <2.9+ , unix-compat >=0.3 && <0.8+ , unliftio-core >=0.2.0.0 && <0.3.0.0+ , unordered-containers >=0.2.17 && <0.3+ , vector >=0.12.3.0 && <1.0.0.0+ , wai >=3.2.3 && <3.3+ , wai-app-static >=3.1 && <3.2+ , wai-extra >=3.0.3 && <3.2+ , warp >=3.3.20 && <3.4 || ^>=3.4.0+ , warp-tls ^>=3.0.3 || ^>=3.1 || ^>=3.2 || ^>=3.3 || ^>=3.4+ , yaml >=0.8.4 && <0.12+ , zlib >=0.6.2 && <0.7 || ^>=0.7.0 exposed-modules: Keter.App@@ -109,52 +98,59 @@ Keter.TempTarball Keter.Yaml.FilePath - other-modules: Keter.Aeson.KeyHelper- Paths_keter- ghc-options: -Wall- c-sources: cbits/process-tracker.c- hs-source-dirs: src+ other-modules:+ Keter.Aeson.KeyHelper+ Paths_keter + autogen-modules:+ Paths_keter++ ghc-options: -Wall+ c-sources: cbits/process-tracker.c+ hs-source-dirs: src+ executable keter- default-language: Haskell98- main-is: keter.hs- hs-source-dirs: src/main+ default-language: Haskell98+ default-extensions: ImportQualifiedPost+ main-is: keter.hs+ hs-source-dirs: src/main build-depends:- base,- filepath,- keter+ , base+ , filepath+ , keter - ghc-options: -threaded -Wall- other-modules: Paths_keter- autogen-modules: Paths_keter+ ghc-options: -threaded -Wall+ other-modules: Paths_keter+ autogen-modules: Paths_keter test-suite test- default-language: Haskell98- hs-source-dirs: test- main-is: Spec.hs- type: exitcode-stdio-1.0+ default-language: Haskell98+ hs-source-dirs: test+ default-extensions: ImportQualifiedPost+ main-is: Spec.hs+ type: exitcode-stdio-1.0 build-depends:- base,- bytestring,- conduit,- http-client,- http-conduit,- http-types,- HUnit,- keter,- lens,- monad-logger,- mtl,- stm,- tasty,- tasty-hunit,- transformers,- unix,- wai,- warp,- wreq+ , base+ , bytestring+ , conduit+ , http-client+ , http-conduit+ , http-types+ , HUnit+ , keter+ , lens+ , monad-logger+ , mtl+ , stm+ , tasty+ , tasty-hunit+ , transformers+ , unix+ , wai+ , warp+ , wreq - ghc-options: -Wall -threaded+ ghc-options: -Wall -threaded source-repository head type: git
src/Keter/Aeson/KeyHelper.hs view
@@ -1,33 +1,20 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-}--- | Utilities for dealing with Aeson version update +-- | Utilities for dealing with Aeson version update+--+-- TODO: This is no longer necessary, and should be removed. module Keter.Aeson.KeyHelper ( module KeyMap , toKey , toText ) where -import Prelude (id)-import qualified Data.Text as Text--#if MIN_VERSION_aeson (2,0,0)-import qualified Data.Aeson.Key as Key-import Data.Aeson.KeyMap as KeyMap hiding (map)+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap as KeyMap hiding (map)+import Data.Text qualified as Text toKey :: Text.Text -> Key.Key toKey = Key.fromText toText :: Key.Key -> Text.Text toText = Key.toText--#else-import Data.HashMap.Strict as KeyMap hiding (map)--toKey :: Text.Text -> Text.Text-toKey = id--toText :: Text.Text -> Text.Text-toText = id--#endif
src/Keter/App.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} module Keter.App ( App@@ -17,61 +17,57 @@ , showApp ) where +import Control.Arrow ((***))+import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.STM+import Control.Exception+ (IOException, SomeException, bracketOnError, catch, throwIO, try)+import Control.Monad (void, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Unlift (withRunInIO)+import Control.Monad.Logger+import Control.Monad.Reader (ask)+import Data.CaseInsensitive qualified as CI+import Data.Foldable (for_)+import Data.IORef+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Maybe (fromMaybe)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text, pack, unpack)+import Data.Text.Encoding (encodeUtf8)+import Data.Vector qualified as V+import Data.Yaml import Keter.Common+import Keter.Conduit.Process.Unix+ ( MonitoredProcess+ , ProcessTracker+ , monitorProcess+ , printStatus+ , terminateMonitoredProcess+ )+import Keter.Config import Keter.Context-import Data.Set (Set)-import Data.Text (Text)-import Data.ByteString (ByteString)-import System.FilePath (FilePath)-import Data.Map (Map)-import Keter.Rewrite (ReverseProxyConfig (..))-import Keter.TempTarball-import Control.Applicative ((<$>), (<*>))-import Control.Arrow ((***))-import Control.Concurrent (forkIO, threadDelay)-import Control.Concurrent.STM-import Control.Exception (IOException, SomeException,- bracketOnError,- throwIO, try, catch)-import Control.Monad (void, when, liftM)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.IO.Unlift (withRunInIO)-import Control.Monad.Logger -import Control.Monad.Reader (ask)-import qualified Data.CaseInsensitive as CI-import Keter.Logger (Logger)-import qualified Keter.Logger as Log-import Keter.Conduit.Process.Unix (MonitoredProcess, ProcessTracker,- monitorProcess,- terminateMonitoredProcess, printStatus)-import Data.Foldable (for_, traverse_)-import Data.IORef-import qualified Data.Map as Map-import Data.Maybe (fromMaybe)-import Data.Monoid ((<>), mempty)-import qualified Data.Set as Set-import Data.Text (pack, unpack)-import Data.Text.Encoding (decodeUtf8With, encodeUtf8)-import Data.Text.Encoding.Error (lenientDecode)-import qualified Data.Vector as V-import Data.Yaml-import Keter.Yaml.FilePath-import System.FilePath ((</>))-import System.Directory (canonicalizePath, doesFileExist,- removeDirectoryRecursive,- createDirectoryIfMissing)-import Keter.HostManager hiding (start)-import Keter.PortPool (PortPool, getPort, releasePort)-import Keter.Config-import Network.Socket-import Prelude hiding (FilePath)-import System.Environment (getEnvironment)-import System.IO (hClose, IOMode(..))-import qualified System.Log.FastLogger as FL-import System.Posix.Files (fileAccess)-import System.Posix.Types (EpochTime, GroupID, UserID)-import System.Timeout (timeout)-import qualified Network.TLS as TLS+import Keter.HostManager hiding (start)+import Keter.Logger (Logger)+import Keter.Logger qualified as Log+import Keter.PortPool (PortPool, getPort, releasePort)+import Keter.Rewrite (ReverseProxyConfig(..))+import Keter.TempTarball+import Keter.Yaml.FilePath+import Network.Socket+import Network.TLS qualified as TLS+import Prelude hiding (FilePath)+import System.Directory+ (canonicalizePath, doesFileExist, removeDirectoryRecursive)+import System.Environment (getEnvironment)+import System.FilePath (FilePath, (</>))+import System.IO (IOMode(..), hClose)+import System.Log.FastLogger qualified as FL+import System.Posix.Files (fileAccess)+import System.Posix.Types (EpochTime, GroupID, UserID)+import System.Timeout (timeout) data App = App { appModTime :: !(TVar (Maybe EpochTime))@@ -84,7 +80,7 @@ , appLog :: !(TVar (Maybe Logger)) } instance Show App where- show App {appId, ..} = "App{appId=" <> show appId <> "}"+ show App {appId} = "App{appId=" <> show appId <> "}" -- | within an stm context we can show a lot more then the show instance can do showApp :: App -> STM Text@@ -93,8 +89,8 @@ appRunning' <- readTVar appRunningWebApps appHosts' <- readTVar appHosts pure $ pack $- (show appId) <>- " modtime: " <> (show appModTime') <> ", webappsRunning: " <> show appRunning' <> ", hosts: " <> show appHosts'+ show appId <>+ " modtime: " <> show appModTime' <> ", webappsRunning: " <> show appRunning' <> ", hosts: " <> show appHosts' data RunningWebApp = RunningWebApp@@ -154,7 +150,7 @@ withConfig _aid (AIData bconfig) f = f Nothing bconfig Nothing withConfig aid (AIBundle fp modtime) f = do withRunInIO $ \rio ->- bracketOnError (rio $ unpackBundle fp aid) (\(newdir, _) -> removeDirectoryRecursive newdir) $ \(newdir, bconfig) -> + bracketOnError (rio $ unpackBundle fp aid) (\(newdir, _) -> removeDirectoryRecursive newdir) $ \(newdir, bconfig) -> rio $ f (Just newdir) bconfig (Just modtime) withReservations :: AppId@@ -167,7 +163,7 @@ withRunInIO $ \rio -> bracketOnError (rio $ withMappedConfig (const ascHostManager) $ reserveHosts aid $ Map.keysSet actions)- (\rsvs -> rio $ withMappedConfig (const ascHostManager) $ forgetReservations aid rsvs)+ (rio . withMappedConfig (const ascHostManager) . forgetReservations aid) (\_ -> rio $ f wacs backs actions) withActions :: BundleConfig@@ -185,7 +181,7 @@ loop [] wacs backs actions = f wacs backs actions loop (Stanza (StanzaWebApp wac) rs:stanzas) wacs backs actions = do AppStartConfig{..} <- ask- withRunInIO $ \rio -> + withRunInIO $ \rio -> liftIO $ bracketOnError (rio (getPort ascPortPool) >>= either throwIO (\p -> fmap (p,) <$> loadCert $ waconfigSsl wac)@@ -229,7 +225,7 @@ withLogger :: AppId -> Maybe (TVar (Maybe Logger))- -> ((TVar (Maybe Logger)) -> Logger -> KeterM AppStartConfig a)+ -> (TVar (Maybe Logger) -> Logger -> KeterM AppStartConfig a) -> KeterM AppStartConfig a withLogger aid Nothing f = do var <- liftIO $ newTVarIO Nothing@@ -238,14 +234,16 @@ AppStartConfig{..} <- ask mappLogger <- liftIO $ readTVarIO var case mappLogger of- Nothing -> withRunInIO $ \rio -> - bracketOnError (Log.createLoggerViaConfig ascKeterConfig (appLogName aid)) Log.loggerClose (rio . f var)+ Nothing -> withRunInIO $ \rio ->+ bracketOnError (Log.createLoggerViaConfig ascKeterConfig (appLogName aid))+ Log.loggerClose+ $ \appLogger -> do+ atomically $ writeTVar var $ Just appLogger+ rio $ f var appLogger Just appLogger -> f var appLogger- where withSanityChecks :: BundleConfig -> KeterM AppStartConfig a -> KeterM AppStartConfig a withSanityChecks BundleConfig{..} f = do- cfg@AppStartConfig{..} <- ask liftIO $ V.mapM_ go bconfigStanzas $logInfo "Sanity checks passed" f@@ -280,7 +278,7 @@ asc@AppStartConfig{..} <- ask liftIO $ mapM_ ensureAlive runningWebapps withMappedConfig (const ascHostManager) $ activateApp aid actions- liftIO $ + liftIO $ App <$> newTVarIO mmodtime <*> newTVarIO runningWebapps@@ -309,8 +307,8 @@ -> ([RunningWebApp] -> KeterM AppStartConfig a) -> KeterM AppStartConfig a withWebApps aid bconfig mdir appLogger configs0 f =- withRunInIO $ \rio -> - bracketedMap (\wac f -> rio $ alloc wac (liftIO <$> f)) (rio . f) configs0+ withRunInIO $ \rio ->+ bracketedMap (\wac f' -> rio $ alloc wac (liftIO <$> f')) (rio . f) configs0 where alloc = launchWebApp aid bconfig mdir appLogger @@ -347,7 +345,6 @@ , Map.singleton "APPROOT" $ scheme <> CI.original waconfigApprootHost <> pack extport ] exec <- liftIO $ canonicalizePath waconfigExec- mainLogger <- askLoggerIO withRunInIO $ \rio -> bracketOnError (rio $ monitorProcess ascProcessTracker@@ -408,7 +405,7 @@ tryToConnect addr = bracketOnError (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))- (close) -- only done if there's an error+ close -- only done if there's an error (\sock -> do connect sock (addrAddress addr) socketToHandle sock ReadWriteMode@@ -421,10 +418,10 @@ Right x -> return x Left e -> go (Just e) ps -- All operations failed, throw error if one exists- go Nothing [] = ioError $ userError $ "connectTo firstSuccessful: empty list"+ go Nothing [] = ioError $ userError "connectTo firstSuccessful: empty list" go (Just e) [] = throwIO e tryIO :: IO a -> IO (Either IOException a)- tryIO m = catch (liftM Right m) (return . Left)+ tryIO m = catch (fmap Right m) (return . Left) withBackgroundApps :: AppId@@ -435,14 +432,14 @@ -> ([RunningBackgroundApp] -> KeterM AppStartConfig a) -> KeterM AppStartConfig a withBackgroundApps aid bconfig mdir appLogger configs f =- withRunInIO $ \rio -> bracketedMap (\cfg f -> rio $ alloc cfg (liftIO <$> f)) (rio . f) configs+ withRunInIO $ \rio -> bracketedMap (\cfg f' -> rio $ alloc cfg (liftIO <$> f')) (rio . f) configs where alloc = launchBackgroundApp aid bconfig mdir appLogger launchBackgroundApp :: AppId -> BundleConfig -> Maybe FilePath- -> Logger + -> Logger -> BackgroundConfig -> (RunningBackgroundApp -> IO a) -> KeterM AppStartConfig a@@ -472,7 +469,6 @@ (count + 1, count < maxCount) when res delay return res- mainLogger <- askLoggerIO withRunInIO $ \rio -> bracketOnError (rio $ monitorProcess ascProcessTracker@@ -619,7 +615,7 @@ reload :: AppInput -> KeterM App () reload input = do App{..} <- ask- withMappedConfig (const appAsc) $ + withMappedConfig (const appAsc) $ withLogger appId (Just appLog) $ \_ appLogger -> withConfig appId input $ \newdir bconfig mmodtime -> withSanityChecks bconfig $@@ -628,7 +624,7 @@ withWebApps appId bconfig newdir appLogger webapps $ \runningWebapps -> do liftIO $ mapM_ ensureAlive runningWebapps liftIO (readTVarIO appHosts) >>= \hosts ->- withMappedConfig (const $ ascHostManager appAsc) $ + withMappedConfig (const $ ascHostManager appAsc) $ reactivateApp appId actions hosts (oldApps, oldBacks, oldDir, oldRlog) <- liftIO $ atomically $ do oldApps <- readTVar appRunningWebApps@@ -642,7 +638,7 @@ writeTVar appHosts $ Map.keysSet actions writeTVar appDir newdir return (oldApps, oldBacks, oldDir, oldRlog)- void $ withRunInIO $ \rio -> + void $ withRunInIO $ \rio -> forkIO $ rio $ terminateHelper appId oldApps oldBacks oldDir oldRlog terminate :: KeterM App ()@@ -669,7 +665,7 @@ deactivateApp appId hosts void $ withRunInIO $ \rio ->- forkIO $ rio $ withMappedConfig (const appAsc) $ + forkIO $ rio $ withMappedConfig (const appAsc) $ terminateHelper appId apps backs mdir appLogger liftIO $ maybe (return ()) Log.loggerClose appLogger @@ -679,14 +675,13 @@ -> Maybe FilePath -> Maybe Logger -> KeterM AppStartConfig ()-terminateHelper aid apps backs mdir appLogger = do- AppStartConfig{..} <- ask+terminateHelper aid apps backs mdir _appLogger = do liftIO $ threadDelay $ 20 * 1000 * 1000- $logInfo $ pack $ - "Sending old process TERM signal: " + $logInfo $ pack $+ "Sending old process TERM signal: " ++ case aid of { AINamed t -> unpack t; AIBuiltin -> "builtin" } mapM_ killWebApp apps- liftIO $ do + liftIO $ do mapM_ killBackgroundApp backs threadDelay $ 60 * 1000 * 1000 case mdir of@@ -704,7 +699,7 @@ getTimestamp = readTVar . appModTime pluginsGetEnv :: Plugins -> Appname -> Object -> IO [(Text, Text)]-pluginsGetEnv ps app o = fmap concat $ mapM (\p -> pluginGetEnv p app o) ps+pluginsGetEnv ps app o = concat <$> mapM (\p -> pluginGetEnv p app o) ps -- | For the forward-env option. From a Set of desired variables, create a -- Map pulled from the system environment.
src/Keter/AppManager.hs view
@@ -1,9 +1,8 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} -- | Used for management of applications. module Keter.AppManager ( -- * Types@@ -20,38 +19,35 @@ , renderApps ) where +import Control.Applicative+import Control.Concurrent.MVar (MVar, newMVar, withMVar)+import Control.Concurrent.STM+import Control.Exception (SomeException)+import Control.Exception qualified as E+import Control.Monad (forM_)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Unlift (withRunInIO)+import Control.Monad.Logger+import Control.Monad.Reader (ask)+import Data.Foldable (fold)+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Maybe (catMaybes, mapMaybe)+import Data.Set qualified as Set+import Data.Text (Text, pack, unpack)+import Data.Text.Lazy qualified as LT+import Data.Text.Lazy.Builder qualified as Builder+import Data.Traversable.WithIndex (itraverse)+import Keter.App (App, AppStartConfig, showApp)+import Keter.App qualified as App import Keter.Common+import Keter.Config import Keter.Context-import Data.Set (Set)-import Data.Text (Text)-import System.FilePath (FilePath)-import Data.Map (Map)-import Control.Exception (SomeException)-import Control.Applicative-import Control.Concurrent (forkIO)-import Control.Concurrent.MVar (MVar, newMVar, withMVar)-import Control.Concurrent.STM-import qualified Control.Exception as E-import Control.Monad (void)-import Control.Monad.IO.Class (liftIO)-import Control.Monad.IO.Unlift (withRunInIO)-import Control.Monad.Logger-import Control.Monad.Reader (ask)-import Data.Foldable (fold)-import qualified Data.Map as Map-import Data.Maybe (catMaybes, mapMaybe)-import qualified Data.Set as Set-import Data.Text (pack, unpack)-import qualified Data.Text.Lazy as LT-import qualified Data.Text.Lazy.Builder as Builder-import Data.Traversable.WithIndex (itraverse)-import Keter.App (App, AppStartConfig, showApp)-import qualified Keter.App as App-import Keter.Config-import Prelude hiding (FilePath, log)-import System.Posix.Files (getFileStatus, modificationTime)-import System.Posix.Types (EpochTime)-import Text.Printf (printf)+import Prelude hiding (FilePath, log)+import System.FilePath (FilePath)+import System.Posix.Files (getFileStatus, modificationTime)+import System.Posix.Types (EpochTime)+import Text.Printf (printf) data AppManager = AppManager { apps :: !(TVar (Map AppId (TVar AppState)))@@ -67,7 +63,7 @@ | ASTerminated showAppState :: AppState -> STM Text-showAppState (ASRunning x) = (\x -> "running(" <> x <> ")") <$> showApp x+showAppState (ASRunning x) = (\x' -> "running(" <> x' <> ")") <$> showApp x showAppState (ASStarting mapp tmtime tmaction) = do mtime <- readTVar tmtime maction <- readTVar tmaction@@ -78,7 +74,7 @@ renderApps :: AppManager -> STM Text renderApps mngr = do appMap <- readTVar $ apps mngr- x <- itraverse (\appId tappState -> do+ x <- itraverse (\_appId tappState -> do state <- readTVar tappState res <- showAppState state pure $ Builder.fromText $ res <> " \n"@@ -106,15 +102,15 @@ reloadAppList :: Map Appname (FilePath, EpochTime) -> KeterM AppManager () reloadAppList newApps = do- am@AppManager{..} <- ask- withRunInIO $ \rio -> + AppManager{..} <- ask+ withRunInIO $ \rio -> withMVar mutex $ const $ do actions <- atomically $ do m <- readTVar apps let currentApps = Set.fromList $ mapMaybe toAppName $ Map.keys m allApps = Set.toList $ Map.keysSet newApps `Set.union` currentApps- fmap catMaybes $ mapM (getAction m) allApps- sequence_ $ rio <$> actions+ catMaybes <$> mapM (getAction m) allApps+ mapM_ rio actions where toAppName AIBuiltin = Nothing toAppName (AINamed x) = Just x@@ -182,12 +178,12 @@ perform :: AppId -> Action -> KeterM AppManager () perform appid action = do am <- ask- withRunInIO $ \rio -> + withRunInIO $ \rio -> withMVar (mutex am) $ const $ rio $ performNoLock appid action performNoLock :: AppId -> Action -> KeterM AppManager () performNoLock aid action = do- am@AppManager{..} <- ask+ AppManager{..} <- ask withRunInIO $ \rio -> E.mask_ $ do launchWorker' <- liftIO $ atomically $ do m <- readTVar apps@@ -227,14 +223,14 @@ return $ launchWorker aid tstate tmnext Nothing action Terminate -> return noWorker -launchWorker :: AppId- -> TVar AppState- -> TVar (Maybe Action)- -> Maybe App- -> Action- -> KeterM AppManager ()-launchWorker appid tstate tmnext mcurrentApp0 action0 = - loop mcurrentApp0 action0+launchWorker ::+ AppId+ -> TVar AppState+ -> TVar (Maybe Action)+ -> Maybe App+ -> Action+ -> KeterM AppManager ()+launchWorker appid tstate tmnext = loop where loop :: Maybe App -> Action -> KeterM AppManager () loop mcurrentApp action = do@@ -255,17 +251,15 @@ Terminate -> Nothing writeTVar tstate $ ASStarting mRunningApp tmtimestamp tmnext return mnext- case mnext of- Nothing -> return ()- Just next -> loop mRunningApp next+ forM_ mnext (loop mRunningApp) reloadMsg :: String -> String -> Text reloadMsg app input = pack $ "Reloading from: " <> app <> input- + errorStartingBundleMsg :: String -> String -> Text- errorStartingBundleMsg name e = - pack $ "Error occured when launching bundle " <> name <> ": " <> e+ errorStartingBundleMsg bundleName e =+ pack $ "Error occured when launching bundle " <> bundleName <> ": " <> e processAction :: Maybe App -> Action -> KeterM AppManager (Maybe App) processAction Nothing Terminate = return Nothing@@ -276,7 +270,7 @@ processAction Nothing (Reload input) = do $logInfo (reloadMsg "Nothing" (show input)) AppManager{..} <- ask- eres <- withRunInIO $ \rio -> E.try @SomeException $ + eres <- withRunInIO $ \rio -> E.try @SomeException $ rio $ withMappedConfig (const appStartConfig) $ App.start appid input case eres of Left e -> do@@ -285,7 +279,7 @@ Right app -> return $ Just app processAction (Just app) (Reload input) = do $logInfo (reloadMsg (show $ Just app) (show input))- eres <- withRunInIO $ \rio -> E.try @SomeException $ + eres <- withRunInIO $ \rio -> E.try @SomeException $ rio $ withMappedConfig (const app) $ App.reload input case eres of Left e -> do
src/Keter/Cli.hs view
@@ -1,30 +1,29 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} module Keter.Cli ( launchCli , CliStates(..) ) where -import Keter.Common-import Keter.Context-import Keter.AppManager import Control.Concurrent (forkFinally)-import qualified Control.Exception as E-import Control.Monad (unless, forever, void, when)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.IO.Unlift (withRunInIO)-import Control.Monad.Trans.Class (MonadTrans, lift)+import Control.Exception qualified as E+import Control.Monad (forever, unless, void, when)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Unlift (withRunInIO) import Control.Monad.Logger-import Control.Monad.Reader (ask)-import qualified Data.ByteString as S+import Control.Monad.Reader (ask)+import Data.ByteString qualified as S+import Data.Foldable+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import GHC.Conc+import Keter.AppManager+import Keter.Common+import Keter.Context import Network.Socket import Network.Socket.ByteString (recv, sendAll)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T import Options.Applicative-import Data.Foldable-import GHC.Conc data Commands = CmdListRunningApps | CmdExit@@ -37,7 +36,7 @@ launchCli :: KeterM CliStates () launchCli = do MkCliStates{..} <- ask- void $ withRunInIO $ \rio -> forkIO $ + void $ withRunInIO $ \rio -> forkIO $ withSocketsDo $ do addr <- resolve $ show csPort E.bracket (open addr) close $ \x -> rio $ do@@ -71,7 +70,7 @@ setSocketOption sock ReuseAddr 1 -- If the prefork technique is not used, -- set CloseOnExec for the security reasons.- withFdSocket sock $ setCloseOnExecIfNeeded+ withFdSocket sock setCloseOnExecIfNeeded bind sock (addrAddress addr) listen sock 10 return sock@@ -80,13 +79,13 @@ loop sock = forever $ do (conn, peer) <- liftIO $ accept sock $logInfo $ T.pack $ "CLI Connection from " <> show peer- void $ withRunInIO $ \rio -> + void $ withRunInIO $ \rio -> forkFinally (rio $ talk conn) (\_ -> close conn) listRunningApps :: Socket -> KeterM CliStates () listRunningApps conn = do MkCliStates{..} <- ask- txt <- liftIO $ atomically $ renderApps csAppManager + txt <- liftIO $ atomically $ renderApps csAppManager liftIO $ sendAll conn $ T.encodeUtf8 txt <> "\n" talk :: Socket -> KeterM CliStates ()@@ -97,12 +96,12 @@ Left exception -> liftIO $ sendAll conn ("decode error: " <> T.encodeUtf8 (T.pack $ show exception)) Right txt -> do let res = execParserPure defaultPrefs (info (commandParser <**> helper)- (fullDesc <> header "server repl" <> progDesc (- "repl for inspecting program state. You can connect to a socket and ask predefined questions")) ) (T.unpack <$> T.words txt)+ (fullDesc <> header "server repl" <> progDesc+ "repl for inspecting program state. You can connect to a socket and ask predefined questions") ) (T.unpack <$> T.words txt) isLoop <- case res of- (Success (CmdListRunningApps)) -> True <$ listRunningApps conn- (Success (CmdExit )) -> False <$ liftIO (sendAll conn "bye\n")- (CompletionInvoked x) -> True <$ liftIO (sendAll conn "completion ignored \n")+ (Success CmdListRunningApps) -> True <$ listRunningApps conn+ (Success CmdExit) -> False <$ liftIO (sendAll conn "bye\n")+ (CompletionInvoked _) -> True <$ liftIO (sendAll conn "completion ignored \n") Failure failure -> True <$ liftIO (sendAll conn (T.encodeUtf8 (T.pack $ fst $ renderFailure failure "") <> "\n")) when isLoop $ talk conn
src/Keter/Common.hs view
@@ -1,35 +1,40 @@ {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-} -- | Provides logging, versioning and some type aliases module Keter.Common where -import qualified Network.Wai as Wai-import Control.Exception (Exception, SomeException)-import Data.Aeson (FromJSON, Object, ToJSON,- Value (Bool), object, withBool,- withObject, (.!=), (.:?), (.=))-import Data.ByteString (ByteString)-import Data.CaseInsensitive (CI, original)-import Data.Map (Map)-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Text (Text, pack, unpack)-import Data.Typeable (Typeable)-import Data.Vector (Vector)-import qualified Data.Vector as V-import qualified Data.Yaml-import Keter.Yaml.FilePath-import qualified Language.Haskell.TH.Syntax as TH-import Network.Socket (AddrInfo, SockAddr)-import System.Exit (ExitCode)-import System.FilePath (FilePath, takeBaseName)+import Control.Exception (Exception)+import Data.Aeson+ ( FromJSON+ , Object+ , ToJSON+ , Value(Bool)+ , object+ , withBool+ , withObject+ , (.!=)+ , (.:?)+ , (.=)+ )+import Data.ByteString (ByteString)+import Data.CaseInsensitive (CI)+import Data.Map (Map)+import Data.Text (Text, pack, unpack)+import Data.Typeable (Typeable)+import Data.Vector (Vector)+import Data.Vector qualified as V+import Data.Yaml qualified+import Keter.Yaml.FilePath+import System.Exit (ExitCode)+import System.FilePath (takeBaseName) -- | Name of the application. Should just be the basename of the application -- file. type Appname = Text +{-# ANN type Plugin ("HLint: ignore Use newtype instead of data" :: String) #-} data Plugin = Plugin { pluginGetEnv :: Appname -> Object -> IO [(Text, Text)] }
src/Keter/Conduit/Process/Unix.hs view
@@ -1,9 +1,9 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-} module Keter.Conduit.Process.Unix ( -- * Process tracking@@ -21,80 +21,100 @@ , printStatus ) where -import Data.Text(Text, pack)-import Data.Text.Encoding (decodeUtf8)-import Control.Applicative ((<$>), (<*>), pure)-import Control.Arrow ((***))-import Control.Concurrent (forkIO)-import Control.Concurrent (threadDelay)-import Control.Concurrent.MVar (MVar, modifyMVar, modifyMVar_,- newEmptyMVar, newMVar,- putMVar, readMVar, swapMVar,- takeMVar, tryReadMVar)-import Control.Exception (Exception, SomeException,- bracketOnError, finally,- handle, mask_,- throwIO, try)-import Control.Monad (void)-import Control.Monad.IO.Class-import Control.Monad.IO.Unlift-import Control.Monad.Logger -import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S8-import Data.Conduit (ConduitM, (.|), runConduit)-import Data.Conduit.Binary (sinkHandle, sourceHandle)-import qualified Data.Conduit.List as CL-import Data.IORef (IORef, newIORef, readIORef,- writeIORef)-import Data.Time (getCurrentTime)-import Data.Time (diffUTCTime)-import Data.Typeable (Typeable)-import Foreign.C.Types-import Prelude (Bool (..), Either (..), IO,- Maybe (..), Monad (..), Show,- const, error,- map, maybe, show,- ($), ($!), (*), (<),- (==))-import System.Exit (ExitCode)-import System.IO (hClose)-import System.Posix.IO.ByteString ( closeFd, createPipe,- fdToHandle)-import System.Posix.Signals (sigKILL, signalProcess)-import System.Posix.Types (CPid (..))-import System.Process (CmdSpec (..), CreateProcess (..),- StdStream (..), createProcess,- terminateProcess, waitForProcess,- getPid)-import System.Process.Internals (ProcessHandle (..),- ProcessHandle__ (..))-import Data.Monoid ((<>)) -- sauron+import Control.Applicative (pure, (<$>), (<*>))+import Control.Arrow ((***))+import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.MVar+ ( MVar+ , modifyMVar+ , modifyMVar_+ , newEmptyMVar+ , newMVar+ , putMVar+ , readMVar+ , swapMVar+ , takeMVar+ , tryReadMVar+ )+import Control.Exception+ ( Exception+ , SomeException+ , bracketOnError+ , finally+ , handle+ , mask_+ , throwIO+ , try+ )+import Control.Monad (void, when)+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as S8+import Data.Conduit (ConduitM, runConduit, (.|))+import Data.Conduit.Binary (sinkHandle, sourceHandle)+import Data.Conduit.List qualified as CL+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Monoid ((<>))+import Data.Text (Text, pack)+import Data.Text.Encoding (decodeUtf8)+import Data.Time (diffUTCTime, getCurrentTime)+import Data.Typeable (Typeable)+import Foreign.C.Types+import Prelude+ ( Bool(..)+ , Either(..)+ , IO+ , Maybe(..)+ , Monad(..)+ , Show+ , String+ , const+ , error+ , map+ , maybe+ , show+ , ($!)+ , ($)+ , (*)+ , (<)+ , (==)+ )+import System.Exit (ExitCode)+import System.IO (hClose)+import System.Posix.IO.ByteString (closeFd, createPipe, fdToHandle)+import System.Posix.Signals (sigKILL, signalProcess)+import System.Posix.Types (CPid(..))+import System.Process+ ( CmdSpec(..)+ , CreateProcess(..)+ , StdStream(..)+ , createProcess+ , getPid+ , terminateProcess+ , waitForProcess+ )+import System.Process.Internals (ProcessHandle(..), ProcessHandle__(..)) processHandleMVar :: ProcessHandle -> MVar ProcessHandle__-#if MIN_VERSION_process(1, 6, 0) processHandleMVar (ProcessHandle m _ _) = m-#elif MIN_VERSION_process(1, 2, 0)-processHandleMVar (ProcessHandle m _) = m-#else-processHandleMVar (ProcessHandle m) = m-#endif -withProcessHandle_- :: ProcessHandle- -> (ProcessHandle__ -> IO ProcessHandle__)- -> IO ()-withProcessHandle_ ph io = modifyMVar_ (processHandleMVar ph) io+withProcessHandle_ ::+ ProcessHandle+ -> (ProcessHandle__ -> IO ProcessHandle__)+ -> IO ()+withProcessHandle_ ph = modifyMVar_ (processHandleMVar ph) -- | Kill a process by sending it the KILL (9) signal. -- -- Since 0.1.0 killProcess :: ProcessHandle -> IO ()-killProcess ph = withProcessHandle_ ph $ \p_ ->- case p_ of- ClosedHandle _ -> return p_- OpenHandle h -> do- signalProcess sigKILL h- return p_+killProcess ph = withProcessHandle_ ph $ \p_ -> case p_ of+ ClosedHandle _ -> return p_+ OpenHandle h -> do+ signalProcess sigKILL h+ return p_+ _ -> error "Not implemented" ignoreExceptions :: IO () -> IO () ignoreExceptions = handle (\(_ :: SomeException) -> return ())@@ -170,6 +190,7 @@ OpenHandle pid -> do c_track_process pt pid 1 return $ Pid pid+ _ -> error "Not implemented" ipid <- newIORef mpid' baton <- newEmptyMVar let tp = TrackedProcess pt ipid (takeMVar baton)@@ -225,30 +246,22 @@ , std_err = UseHandle writerH , close_fds = True , create_group = True-#if MIN_VERSION_process(1, 5, 0) , use_process_jobs = False-#endif-#if MIN_VERSION_process(1, 2, 0) , delegate_ctlc = False-#endif-#if MIN_VERSION_process(1, 3, 0) , detach_console = True , create_new_console = False , new_session = True-#endif-#if MIN_VERSION_process(1, 4, 0) , child_group = Nothing , child_user = Nothing-#endif } ignoreExceptions $ addAttachMessage pipes ph void $ forkIO $ ignoreExceptions $- (runConduit $ sourceHandle readerH .| CL.mapM_ log) `finally` hClose readerH+ runConduit (sourceHandle readerH .| CL.mapM_ log) `finally` hClose readerH case (min, mstdin) of (Just h, Just source) -> void $ forkIO $ ignoreExceptions $- (runConduit $ source .| sinkHandle h) `finally` hClose h+ runConduit (source .| sinkHandle h) `finally` hClose h (Nothing, Nothing) -> return ()- _ -> error $ "Invariant violated: Data.Conduit.Process.Unix.forkExecuteLog"+ _ -> error "Invariant violated: Data.Conduit.Process.Unix.forkExecuteLog" return ph addAttachMessage pipes ph = withProcessHandle_ ph $ \p_ -> do@@ -271,6 +284,7 @@ , S8.pack $ show h , "\n\n" ]+ _ -> error "Not implemented" return p_ data Status = NeedsRestart | NoRestart | Running ProcessHandle@@ -291,43 +305,41 @@ withRunInIO $ \rio -> do mstatus <- newMVar NeedsRestart let loop mlast = do- next <- modifyMVar mstatus $ \status ->- case status of- NoRestart -> return (NoRestart, return ())- _ -> do- now <- getCurrentTime- case mlast of- Just last | diffUTCTime now last < 5 -> do- rio $ $logWarn $ "Process restarting too quickly, waiting before trying again: " <> decodeUtf8 exec- threadDelay $ 5 * 1000 * 1000- _ -> return ()- let (cmd, args') =- case msetuid of- Nothing -> (exec, args)- Just setuid -> ("sudo", "-E" : "-u" : setuid : "--" : exec : args)- res <- try $ forkExecuteLog- cmd- args'- (Just env')- (Just dir)- (Just $ return ())- rlog- case res of- Left e -> do- rio $ $logError $ "Data.Conduit.Process.Unix.monitorProcess: " <> pack (show (e :: SomeException))- return (NeedsRestart, return ())- Right pid -> do- rio $ $logInfo $ "Process created: " <> decodeUtf8 exec- return (Running pid, do- TrackedProcess _ _ wait <- trackProcess processTracker pid- ec <- wait- shouldRestart' <- shouldRestart ec- if shouldRestart'- then loop (Just now)- else return ())- next+ next <- modifyMVar mstatus $ \case+ NoRestart -> return (NoRestart, return ())+ _ -> do+ now <- getCurrentTime+ case mlast of+ Just last | diffUTCTime now last < 5 -> do+ rio $ $logWarn $ "Process restarting too quickly, waiting before trying again: " <> decodeUtf8 exec+ threadDelay $ 5 * 1000 * 1000+ _ -> return ()+ let (cmd, args') =+ case msetuid of+ Nothing -> (exec, args)+ Just setuid -> ("sudo", "-E" : "-u" : setuid : "--" : exec : args)+ res <- try $ forkExecuteLog+ cmd+ args'+ (Just env')+ (Just dir)+ (Just $ return ())+ rlog+ case res of+ Left e -> do+ rio $ $logError $ "Data.Conduit.Process.Unix.monitorProcess: " <> pack (show (e :: SomeException))+ return (NeedsRestart, return ())+ Right pid -> do+ rio $ $logInfo $ "Process created: " <> decodeUtf8 exec+ return (Running pid, do+ TrackedProcess _ _ wait <- trackProcess processTracker pid+ ec <- wait+ shouldRestart' <- shouldRestart ec+ when shouldRestart' $ loop (Just now))+ next _ <- forkIO $ loop Nothing return $ MonitoredProcess mstatus+{-# ANN monitorProcess ("HLint: ignore Use join" :: String) #-} -- | Abstract type containing information on a process which will be restarted. newtype MonitoredProcess = MonitoredProcess (MVar Status)
src/Keter/Config.hs view
@@ -4,23 +4,23 @@ ( module X ) where -import Keter.Config.V04 as X (PortSettings (..), TLSConfig (..))+import Keter.Config.V04 as X (PortSettings(..), TLSConfig(..)) import Keter.Config.V10 as X- ( BundleConfig (..)- , WebAppConfig (..)- , RedirectConfig (..)- , StaticFilesConfig (..)- , KeterConfig (..)- , Stanza (..)- , StanzaRaw (..)- , ProxyAction- , ProxyActionRaw (..)- , RedirectDest (..)- , RedirectAction (..)- , SourcePath (..)- , ListeningPort (..)- , AppInput (..)- , BackgroundConfig (..)- , RestartCount (..)- , RequiresSecure- )+ ( AppInput(..)+ , BackgroundConfig(..)+ , BundleConfig(..)+ , KeterConfig(..)+ , ListeningPort(..)+ , ProxyAction+ , ProxyActionRaw(..)+ , RedirectAction(..)+ , RedirectConfig(..)+ , RedirectDest(..)+ , RequiresSecure+ , RestartCount(..)+ , SourcePath(..)+ , Stanza(..)+ , StanzaRaw(..)+ , StaticFilesConfig(..)+ , WebAppConfig(..)+ )
src/Keter/Config/Middleware.hs view
@@ -1,32 +1,33 @@-{-# LANGUAGE OverloadedStrings, DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-} module Keter.Config.Middleware where import Data.Aeson import GHC.Generics-import Prelude import Network.Wai+import Prelude -import Control.Monad import Control.Arrow ((***))+import Control.Monad -- various Middlewares-import Network.Wai.Middleware.AcceptOverride (acceptOverride)-import Network.Wai.Middleware.Autohead (autohead)-import Network.Wai.Middleware.Jsonp (jsonp)-import Network.Wai.Middleware.Local (local)-import Network.Wai.Middleware.AddHeaders (addHeaders)-import Network.Wai.Middleware.MethodOverride (methodOverride)+import Network.Wai.Middleware.AcceptOverride (acceptOverride)+import Network.Wai.Middleware.AddHeaders (addHeaders)+import Network.Wai.Middleware.Autohead (autohead)+import Network.Wai.Middleware.HttpAuth (basicAuth)+import Network.Wai.Middleware.Jsonp (jsonp)+import Network.Wai.Middleware.Local (local)+import Network.Wai.Middleware.MethodOverride (methodOverride) import Network.Wai.Middleware.MethodOverridePost (methodOverridePost)-import Network.Wai.Middleware.HttpAuth (basicAuth) -import Data.ByteString.Lazy as L (ByteString)-import Data.ByteString as S (ByteString)+import Data.ByteString as S (ByteString)+import Data.ByteString.Lazy as L (ByteString) -import Data.Text.Lazy.Encoding as TL (encodeUtf8, decodeUtf8)-import Data.Text.Encoding as T (encodeUtf8, decodeUtf8) import Data.String (fromString)-import qualified Keter.Aeson.KeyHelper as AK (toKey, toText, toList, empty)+import Data.Text.Encoding as T (decodeUtf8, encodeUtf8)+import Data.Text.Lazy.Encoding as TL (decodeUtf8, encodeUtf8)+import Keter.Aeson.KeyHelper qualified as AK (empty, toKey, toList, toText) data MiddlewareConfig = AcceptOverride | Autohead@@ -48,7 +49,7 @@ parseJSON (String "method-override-post") = pure MethodOverridePost parseJSON (Object o) = case AK.toList o of- [("basic-auth", Object ( o'))] -> BasicAuth <$> o' .:? "realm" .!= "keter"+ [("basic-auth", Object o')] -> BasicAuth <$> o' .:? "realm" .!= "keter" <*> (map ((T.encodeUtf8 . AK.toText) *** T.encodeUtf8) . AK.toList <$> o' .:? "creds" .!= AK.empty) [("headers" , Object _ )] -> AddHeaders . map ((T.encodeUtf8 . AK.toText) *** T.encodeUtf8) . AK.toList <$> o .:? "headers" .!= AK.empty [("local" , Object o')] -> Local <$> o' .:? "status" .!= 401@@ -68,7 +69,7 @@ ] toJSON (AddHeaders headers) = object [ "headers" .= object ( map ((AK.toKey . T.decodeUtf8) *** String . T.decodeUtf8) headers) ] toJSON (Local sc msg) = object [ "local" .= object [ "status" .= sc- , "message" .= TL.decodeUtf8 msg + , "message" .= TL.decodeUtf8 msg ] ] @@ -91,7 +92,7 @@ toMiddleware (Local s c ) = local ( responseLBS (toEnum s) [] c ) toMiddleware MethodOverride = methodOverride toMiddleware MethodOverridePost = methodOverridePost-toMiddleware (BasicAuth realm cred) = basicAuth (\u p -> return $ maybe False (==p) $ lookup u cred ) (fromString realm)+toMiddleware (BasicAuth realm cred) = basicAuth (\u p -> return $ (Just p ==) $ lookup u cred ) (fromString realm) toMiddleware (AddHeaders headers) = addHeaders headers -- composeMiddleware :
src/Keter/Config/V04.hs view
@@ -3,23 +3,22 @@ -- compatibility in config file format. module Keter.Config.V04 where -import Control.Applicative-import Data.Aeson-import Data.Bool-import Data.Conduit.Network (HostPreference)-import Data.String (fromString)-import Keter.Yaml.FilePath-import qualified System.FilePath as F-import Keter.Common-import Keter.Rewrite(ReverseProxyConfig)-import Data.Text (Text)-import System.FilePath (FilePath)-import Data.Set (Set)-import qualified Data.Set as Set-import qualified Network.Wai.Handler.Warp as Warp-import qualified Network.Wai.Handler.WarpTLS as WarpTLS-import qualified Network.TLS.SessionManager as TLSSession-import Prelude hiding (FilePath)+import Control.Applicative+import Data.Aeson+import Data.Bool+import Data.Conduit.Network (HostPreference)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.String (fromString)+import Data.Text (Text)+import Keter.Common+import Keter.Rewrite (ReverseProxyConfig)+import Keter.Yaml.FilePath+import Network.TLS.SessionManager qualified as TLSSession+import Network.Wai.Handler.Warp qualified as Warp+import Prelude hiding (FilePath)+import System.FilePath (FilePath)+import System.FilePath qualified as F data AppConfig = AppConfig { configExec :: F.FilePath@@ -47,7 +46,7 @@ instance ParseYamlFile BundleConfig where parseYamlFile basedir = withObject "BundleConfig" $ \o -> BundleConfig- <$> ((Just <$> parseYamlFile basedir (Object o)) <|> pure Nothing)+ <$> optional (parseYamlFile basedir (Object o)) <*> lookupBaseMaybe basedir o "static-hosts" .!= Set.empty <*> o .:? "redirects" .!= Set.empty @@ -138,6 +137,7 @@ { portRange :: [Port] -- ^ Which ports to assign to apps. Defaults to unassigned ranges from IANA }+{-# ANN type PortSettings ("HLint: ignore Use newtype instead of data" :: String) #-} defaultPortSettings :: PortSettings defaultPortSettings = PortSettings@@ -155,5 +155,5 @@ } instance FromJSON PortSettings where- parseJSON = withObject "PortSettings" $ \_ -> PortSettings- <$> return (portRange defaultPortSettings)+ parseJSON = withObject "PortSettings" $ \_ ->+ return (PortSettings (portRange defaultPortSettings))
src/Keter/Config/V10.hs view
@@ -1,38 +1,44 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}+ module Keter.Config.V10 where -import Control.Applicative ((<$>), (<*>), (<|>))-import Data.Aeson (FromJSON (..), ToJSON (..), Object,- Value (Object, String, Bool),- withObject, (.!=), (.:),- (.:?), object, (.=))-import Keter.Aeson.KeyHelper as AK (lookup, singleton, empty, insert)-import qualified Data.CaseInsensitive as CI-import Data.Conduit.Network (HostPreference)-import qualified Data.Map as Map-import Data.Maybe (catMaybes, fromMaybe, isJust)-import qualified Data.Set as Set-import Data.String (fromString)-import Data.Vector (Vector)-import qualified Data.Vector as V-import Data.Word (Word)-import Keter.Yaml.FilePath-import qualified System.FilePath as F-import Keter.Common-import Keter.Config.Middleware-import qualified Keter.Config.V04 as V04-import qualified Network.Wai.Handler.Warp as Warp-import qualified Network.Wai.Handler.WarpTLS as WarpTLS-import System.Posix.Types (EpochTime)-import Keter.Rewrite(ReverseProxyConfig)-import Data.Text (Text)-import System.FilePath (FilePath)-import Data.Set (Set)-import Data.Map (Map)+import Control.Applicative ((<|>))+import Data.Aeson+ ( FromJSON(..)+ , Object+ , ToJSON(..)+ , Value(Bool, Object, String)+ , object+ , withObject+ , (.!=)+ , (.:)+ , (.:?)+ , (.=)+ )+import Data.CaseInsensitive qualified as CI+import Data.Conduit.Network (HostPreference)+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Maybe (catMaybes, fromMaybe, isJust)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.String (fromString)+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Vector qualified as V+import Keter.Aeson.KeyHelper as AK (empty, insert, lookup, singleton)+import Keter.Common+import Keter.Config.Middleware+import Keter.Config.V04 qualified as V04+import Keter.Rewrite (ReverseProxyConfig)+import Keter.Yaml.FilePath+import Network.Wai.Handler.Warp qualified as Warp+import System.FilePath qualified as F+import System.Posix.Types (EpochTime) data BundleConfig = BundleConfig { bconfigStanzas :: !(Vector (Stanza ()))@@ -43,7 +49,7 @@ type Previous BundleConfig = V04.BundleConfig toCurrent (V04.BundleConfig webapp statics redirs) = BundleConfig { bconfigStanzas = V.concat- [ maybe V.empty V.singleton $ fmap (flip Stanza False . StanzaWebApp . toCurrent) webapp+ [ maybe V.empty (V.singleton . flip Stanza False . StanzaWebApp . toCurrent) webapp , V.fromList $ map (flip Stanza False . StanzaStaticFiles . toCurrent) $ Set.toList statics , V.fromList $ map (flip Stanza False . StanzaRedirect . toCurrent) $ Set.toList redirs ]
src/Keter/Context.hs view
@@ -1,15 +1,13 @@+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DerivingStrategies #-} module Keter.Context where -import Keter.Common-import Control.Monad.Trans (lift)-import Control.Monad.IO.Class (MonadIO)-import Control.Monad.IO.Unlift (MonadUnliftIO)-import Control.Monad.Logger (MonadLogger, MonadLoggerIO, LoggingT(..), runLoggingT)-import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask- , withReaderT)+import Control.Monad.IO.Class (MonadIO)+import Control.Monad.IO.Unlift (MonadUnliftIO)+import Control.Monad.Logger+ (LoggingT(..), MonadLogger, MonadLoggerIO, runLoggingT)+import Control.Monad.Reader (MonadReader, ReaderT, withReaderT) -- | The top-level keter context monad, carrying around the main logger and some locally relevant configuration structure. --@@ -24,5 +22,5 @@ MonadReader cfg) withMappedConfig :: (cfg -> cfg') -> KeterM cfg' a -> KeterM cfg a-withMappedConfig f (KeterM ctx) = +withMappedConfig f (KeterM ctx) = KeterM $ LoggingT $ \logger -> withReaderT f $ runLoggingT ctx logger
src/Keter/HostManager.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ViewPatterns #-}+ module Keter.HostManager ( -- * Types HostManager@@ -17,28 +18,27 @@ , start ) where +import Control.Applicative+import Control.Exception (assert, throwIO)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Logger+import Control.Monad.Reader (ask)+import Data.CaseInsensitive qualified as CI+import Data.Either (partitionEithers)+import Data.IORef+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (pack, unpack)+import Data.Text.Encoding (encodeUtf8)+import Keter.Common+import Keter.Config import Keter.Context-import Control.Applicative-import Control.Exception (assert, throwIO)-import Control.Monad.Logger-import Control.Monad.IO.Class (liftIO)-import Control.Monad.Reader (ask)-import qualified Data.CaseInsensitive as CI-import Data.Either (partitionEithers)-import Data.IORef-import Data.Text (pack, unpack)-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Text.Encoding (encodeUtf8)-import Keter.Config-import Keter.LabelMap (LabelMap)-import qualified Keter.LabelMap as LabelMap-import Prelude hiding (log)-import qualified Network.TLS as TLS-import Keter.Common-import System.FilePath (FilePath)-import Data.Set (Set)-import Data.Map (Map)+import Keter.LabelMap (LabelMap)+import Keter.LabelMap qualified as LabelMap+import Network.TLS qualified as TLS+import Prelude hiding (log) data HostValue = HVActive !AppId !ProxyAction !TLS.Credentials | HVReserved !AppId@@ -70,12 +70,12 @@ -> KeterM HostManager Reservations reserveHosts aid hosts = do (HostManager mstate) <- ask- $logInfo $ pack $ - "Reserving hosts for app " + $logInfo $ pack $+ "Reserving hosts for app " ++ show aid- ++ ": " + ++ ": " ++ unwords (map (unpack . CI.original) $ Set.toList hosts)- liftIO $ either (throwIO . CannotReserveHosts aid) return + liftIO $ either (throwIO . CannotReserveHosts aid) return =<< atomicModifyIORef mstate (\entries0 -> case partitionEithers $ map (checkHost entries0) $ Set.toList hosts of ([], Set.unions -> toReserve) ->@@ -83,16 +83,16 @@ (conflicts, _) -> (entries0, Left $ Map.fromList conflicts)) where checkHost entries0 host =- case LabelMap.labelAssigned hostBS entries0 of- False -> Right $ Set.singleton host- True -> - case LabelMap.lookup hostBS entries0 of- Nothing -> Right $ Set.singleton host- Just (HVReserved aid') -> assert (aid /= aid')- $ Left (host, aid')- Just (HVActive aid' _ _)- | aid == aid' -> Right Set.empty- | otherwise -> Left (host, aid')+ if LabelMap.labelAssigned hostBS entries0+ then+ (case LabelMap.lookup hostBS entries0 of+ Nothing -> Right $ Set.singleton host+ Just (HVReserved aid') -> assert (aid /= aid')+ $ Left (host, aid')+ Just (HVActive aid' _ _)+ | aid == aid' -> Right Set.empty+ | otherwise -> Left (host, aid'))+ else Right $ Set.singleton host where hostBS = encodeUtf8 $ CI.original host hvres = HVReserved aid@@ -107,10 +107,10 @@ -> KeterM HostManager () forgetReservations app hosts = do (HostManager mstate) <- ask- $logInfo $ pack $ - "Forgetting host reservations for app " - ++ show app - ++ ": " + $logInfo $ pack $+ "Forgetting host reservations for app "+ ++ show app+ ++ ": " ++ unwords (map (unpack . CI.original) $ Set.toList hosts) liftIO $ atomicModifyIORef mstate $ \state0 -> (Set.foldr forget state0 hosts, ())
src/Keter/LabelMap.hs view
@@ -1,6 +1,6 @@+{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE NoImplicitPrelude #-} module Keter.LabelMap ( -- * Types LabelMap@@ -12,14 +12,14 @@ , empty ) where -import Prelude hiding (lookup)-import Data.Maybe (isJust)-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.ByteString.Char8 as BS import Data.ByteString (ByteString)-import qualified Data.CaseInsensitive as CI+import Data.ByteString.Char8 qualified as BS import Data.CaseInsensitive (CI)+import Data.CaseInsensitive qualified as CI+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Maybe (isJust)+import Prelude hiding (lookup) type LabelTree a = Map (CI ByteString) (LabelEntry a) @@ -97,7 +97,7 @@ getPortEntry (Unassigned _) = Nothing insert :: ByteString -> a -> LabelMap a -> LabelMap a-insert h e m = insertTree (hostToLabels h) e m+insert h = insertTree (hostToLabels h) --insert h e m = trace -- ( "Inserting hostname " ++ (show h) ++ "\n" -- ++" into tree " ++ (show m) ++ "\n"@@ -156,12 +156,10 @@ cleanup :: LabelMap a -> LabelMap a cleanup EmptyLabelMap = EmptyLabelMap cleanup m@(Static t) =- case Map.null (Map.filter p t) of- True -> EmptyLabelMap- False -> m- where- p (Unassigned EmptyLabelMap) = False- p _ = True+ if Map.null (Map.filter p t) then EmptyLabelMap else m+ where+ p (Unassigned EmptyLabelMap) = False+ p _ = True cleanup m@(Wildcard w) = case w of@@ -176,7 +174,7 @@ (_, False) -> m delete :: ByteString -> LabelMap a -> LabelMap a-delete h m = deleteTree (hostToLabels h) m+delete h = deleteTree (hostToLabels h) --delete h m = trace -- ( "Deleting hostname " ++ (show h) ++ "\n" -- ++" into tree " ++ (show m) ++ "\n"@@ -225,7 +223,7 @@ l' = CI.mk l lookup :: ByteString -> LabelMap a -> Maybe a-lookup h m = lookupTree (hostToLabels h) m+lookup h = lookupTree (hostToLabels h) --lookup h m = trace -- ( "Looking up hostname " ++ (show h) ++ "\n" -- ++" in tree " ++ (show m) ++ "\n"@@ -240,7 +238,7 @@ lookupTree _ EmptyLabelMap = Nothing lookupTree [l] (Static t) = Map.lookup (CI.mk l) t >>= getPortEntry-lookupTree [_] (Wildcard w) = getPortEntry $ w+lookupTree [_] (Wildcard w) = getPortEntry w lookupTree [l] (WildcardExcept w t) = case Map.lookup (CI.mk l) t >>= getPortEntry of Just e -> Just e@@ -273,7 +271,7 @@ -- Even so, labelAssigned will return false, foo.example.com has not -- been explicitly assigned. labelAssigned :: ByteString -> LabelMap a -> Bool-labelAssigned h m = memberTree (hostToLabels h) m+labelAssigned h = memberTree (hostToLabels h) --labelAssigned h m = trace -- ( "Checking label assignment for " ++ (show h) ++ "\n" -- ++" in tree " ++ (show m) ++ "\n"
src/Keter/Logger.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-} module Keter.Logger ( Logger(..) , createLoggerViaConfig@@ -9,23 +9,17 @@ , defaultBufferSize ) where -import Data.Time-import Debug.Trace-import qualified System.Log.FastLogger as FL-import System.Directory-import System.FilePath-import Control.Monad.Logger-import Control.Monad.Reader import Control.Monad.IO.Class-import Control.Monad.IO.Unlift-import Keter.Context import Keter.Config.V10+import System.Directory+import System.FilePath+import System.Log.FastLogger qualified as FL -- | Record wrapper over a fast logger (log,close) function tuple, just to make it less unwieldy and obscure. -- The 'LogType' is also tracked, in case formatting depends on it. data Logger = Logger { loggerLog :: forall a. FL.ToLogStr a => a -> IO ()- , loggerClose :: IO () + , loggerClose :: IO () , loggerType :: FL.LogType }
src/Keter/Main.hs view
@@ -1,71 +1,58 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-} module Keter.Main ( keter ) where -import Keter.Common-import System.FilePath (FilePath)-import qualified Keter.TempTarball as TempFolder-import Control.Concurrent.Async (waitAny, withAsync)-import Control.Monad (unless)-import qualified Keter.Logger as Log-import Data.Monoid (mempty)-import Data.String (fromString)-import qualified Data.Vector as V-import Keter.App (AppStartConfig (..))-import qualified Keter.AppManager as AppMan-import qualified Keter.HostManager as HostMan-import qualified Keter.PortPool as PortPool-import qualified Keter.Proxy as Proxy-import Keter.Config-import Keter.Config.V10-import System.Posix.Files (getFileStatus, modificationTime)-import System.Posix.Signals (Handler (Catch), installHandler,- sigHUP)--import Control.Applicative ((<$>))-import Control.Exception (throwIO, try, bracket, SomeException)-import Control.Monad (forM, void, when)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad.Trans.Class (MonadTrans, lift)-import qualified Control.Monad.Logger as L-import Control.Monad.Logger (MonadLogger, MonadLoggerIO, LoggingT, - runLoggingT, askLoggerIO, logInfo, logDebug)-import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask)-import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)-import Keter.Conduit.Process.Unix (initProcessTracker)-import qualified Data.Map as Map-import qualified Data.Text as T-import Data.Text.Encoding (encodeUtf8)-import qualified Data.Text.Read-import Data.Time (getCurrentTime)-import Keter.Yaml.FilePath-import Prelude hiding (FilePath, log)-import System.Directory (createDirectoryIfMissing,- createDirectoryIfMissing,- doesDirectoryExist, doesFileExist,- getDirectoryContents)-import System.FilePath (takeExtension, takeDirectory, (</>))-import qualified System.FSNotify as FSN-import qualified System.Log.FastLogger as FL-import System.Posix.User (getUserEntryForID,- getUserEntryForName, userGroupID,- userID, userName)-#ifdef SYSTEM_FILEPATH-import qualified Filesystem.Path as FP (FilePath)-import Filesystem.Path.CurrentOS (encodeString)-#endif+import Control.Concurrent.Async (waitAny, withAsync)+import Control.Exception (SomeException, bracket, throwIO, try)+import Control.Monad (forM, forM_, unless, void, when)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)+import Control.Monad.Logger (LoggingT, logInfo, runLoggingT)+import Control.Monad.Logger qualified as L+import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, runReaderT)+import Data.Map qualified as Map+import Data.String (fromString)+import Data.Text qualified as T+import Data.Text.Read qualified+import Data.Time (getCurrentTime)+import Data.Vector qualified as V+import Keter.App (AppStartConfig(..))+import Keter.AppManager qualified as AppMan import Keter.Cli+import Keter.Common+import Keter.Conduit.Process.Unix (initProcessTracker)+import Keter.Config+import Keter.Config.V10 import Keter.Context+import Keter.HostManager qualified as HostMan+import Keter.Logger qualified as Log+import Keter.PortPool qualified as PortPool+import Keter.Proxy qualified as Proxy+import Keter.TempTarball qualified as TempFolder+import Keter.Yaml.FilePath+import Prelude hiding (FilePath, log)+import System.Directory+ ( createDirectoryIfMissing+ , doesDirectoryExist+ , doesFileExist+ , getDirectoryContents+ )+import System.FilePath (FilePath, takeExtension, (</>))+import System.FSNotify qualified as FSN+import System.Log.FastLogger qualified as FL+import System.Posix.Files (getFileStatus, modificationTime)+import System.Posix.Signals (Handler(Catch), installHandler, sigHUP)+import System.Posix.User+ (getUserEntryForID, getUserEntryForName, userGroupID, userID, userName) keter :: FilePath -- ^ root directory or config file -> [FilePath -> IO Plugin]@@ -73,15 +60,15 @@ keter input mkPlugins = runKeterConfigReader input . runKeterLogger . runKeterM $ withManagers mkPlugins $ \hostman appMan -> do- cfg@KeterConfig{..} <- ask+ KeterConfig{..} <- ask $logInfo "Launching cli"- void $ forM kconfigCliPort $ \port ->+ forM_ kconfigCliPort $ \port -> withMappedConfig (const $ MkCliStates { csAppManager = appMan , csPort = port })- $ launchCli+ launchCli $logInfo "Launching initial" launchInitial appMan $logInfo "Started watching"@@ -107,15 +94,15 @@ runReaderT ctx config -- | Running the Keter logger requires a context with access to a KeterConfig, hence the--- MonadReader constraint. This is versatile: 'runKeterConfigReader', or use the free +-- MonadReader constraint. This is versatile: 'runKeterConfigReader', or use the free -- ((->) KeterConfig) instance. runKeterLogger :: (MonadReader KeterConfig m, MonadIO m, MonadUnliftIO m) => LoggingT m a -> m a runKeterLogger ctx = do- cfg@KeterConfig{..} <- ask+ cfg <- ask withRunInIO $ \rio -> bracket (Log.createLoggerViaConfig cfg "keter") Log.loggerClose $- rio . runLoggingT ctx . formatLog + rio . runLoggingT ctx . formatLog where formatLog logger loc _ lvl msg = do now <- liftIO getCurrentTime@@ -167,7 +154,7 @@ , ascPlugins = plugins , ascKeterConfig = cfg }- appMan <- withMappedConfig (const appStartConfig) $ AppMan.initialize+ appMan <- withMappedConfig (const appStartConfig) AppMan.initialize f hostman appMan launchInitial :: AppMan.AppManager -> KeterM KeterConfig ()@@ -190,7 +177,7 @@ startWatching :: AppMan.AppManager -> KeterM KeterConfig () startWatching appMan = do- incoming <- getIncoming <$> ask+ incoming <- asks getIncoming -- File system watching wm <- liftIO FSN.startManager withMappedConfig (const appMan) $ withRunInIO $ \rio -> do@@ -198,14 +185,14 @@ e' <- case e of FSN.Removed fp _ _ -> do- rio $ $logInfo $ "Watched file removed: " <> T.pack (fromFilePath fp)- return $ Left $ fromFilePath fp+ rio $ $logInfo $ "Watched file removed: " <> T.pack fp+ return $ Left fp FSN.Added fp _ _ -> do- rio $ $logInfo $ "Watched file added: " <> T.pack (fromFilePath fp)- return $ Right $ fromFilePath fp+ rio $ $logInfo $ "Watched file added: " <> T.pack fp+ return $ Right fp FSN.Modified fp _ _ -> do- rio $ $logInfo $ "Watched file modified: " <> T.pack (fromFilePath fp)- return $ Right $ fromFilePath fp+ rio $ $logInfo $ "Watched file modified: " <> T.pack fp+ return $ Right fp _ -> do rio $ $logInfo $ "Watched file unknown" <> T.pack mempty return $ Left []@@ -214,23 +201,12 @@ Right fp -> when (isKeter fp) $ AppMan.addApp $ incoming </> fp -- Install HUP handler for cases when inotify cannot be used. void $ flip (installHandler sigHUP) Nothing $ Catch $ do- bundles <- fmap (filter isKeter) $ listDirectoryTree incoming+ bundles <- filter isKeter <$> listDirectoryTree incoming newMap <- fmap Map.fromList $ forM bundles $ \bundle -> do time <- modificationTime <$> getFileStatus bundle return (getAppname bundle, (bundle, time)) rio $ AppMan.reloadAppList newMap ---- compatibility with older versions of fsnotify which used--- 'Filesystem.Path'-#ifdef SYSTEM_FILEPATH-fromFilePath :: FP.FilePath -> String-fromFilePath = encodeString-#else-fromFilePath :: forall a. a -> a-fromFilePath = id-#endif- listDirectoryTree :: FilePath -> IO [FilePath] listDirectoryTree fp = do dir <- getDirectoryContents fp@@ -246,11 +222,10 @@ startListening :: HostMan.HostManager -> KeterM KeterConfig () startListening hostman = do- cfg@KeterConfig{..} <- ask- logger <- askLoggerIO+ KeterConfig{..} <- ask settings <- Proxy.makeSettings hostman withMappedConfig (const settings) $ withRunInIO $ \rio ->- liftIO $ runAndBlock kconfigListeners $ \ls -> + liftIO $ runAndBlock kconfigListeners $ \ls -> rio $ Proxy.reverseProxy ls runAndBlock :: NonEmptyVector a
src/Keter/Plugin/Postgres.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards #-}+ module Keter.Plugin.Postgres ( -- * Settings Settings@@ -9,64 +10,58 @@ , load ) where -import Keter.Common-import Control.Applicative ((<$>), (<*>), pure)-import Keter.Aeson.KeyHelper as AK (lookup)-import Control.Concurrent (forkIO)-import Control.Concurrent.Chan-import Control.Concurrent.MVar-import Control.Exception (fromException, throwIO, try)-import Control.Monad (forever, mzero, replicateM, void)-import Control.Monad.Trans.Class (lift)-import qualified Control.Monad.Trans.State as S-import qualified Data.Char as C-import qualified Data.Map as Map-import Data.Maybe (fromMaybe)-import Data.Monoid ((<>))-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import Data.Text.Lazy.Builder (fromText, toLazyText)-import qualified Data.Vector as V-import Data.Yaml-import Prelude hiding (FilePath)-import System.Directory (createDirectoryIfMissing,- doesFileExist, renameFile)-import System.FilePath (takeDirectory, (<.>))-import System.IO.Error (annotateIOError,- ioeGetFileName,- isDoesNotExistError)-import System.Process (readProcess)-import qualified System.Random as R-import Data.Text (Text)-import System.FilePath (FilePath)-import Control.Exception (SomeException)+import Control.Concurrent (forkIO)+import Control.Concurrent.Chan+import Control.Concurrent.MVar+import Control.Exception (SomeException, fromException, throwIO, try)+import Control.Monad (forever, mzero, replicateM, void)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State qualified as S+import Data.Char qualified as C+import Data.Map qualified as Map+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Builder (fromText, toLazyText)+import Data.Vector qualified as V+import Data.Yaml+import Keter.Aeson.KeyHelper as AK (lookup)+import Keter.Common+import Prelude hiding (FilePath)+import System.Directory (createDirectoryIfMissing, doesFileExist, renameFile)+import System.FilePath (FilePath, takeDirectory, (<.>))+import System.IO.Error (annotateIOError, ioeGetFileName, isDoesNotExistError)+import System.Process (readProcess)+import System.Random qualified as R +{-# ANN type Settings ("HLint: ignore Use newtype instead of data" :: String) #-} data Settings = Settings { setupDBInfo :: DBInfo -> IO () -- ^ How to create the given user/database. Default: uses the @psql@ -- command line tool and @sudo -u postgres@. }+ defaultSettings :: Settings defaultSettings = Settings- { setupDBInfo = \DBInfo{..} -> do- let sql = toLazyText $- "CREATE USER " <> fromText dbiUser <>- " PASSWORD '" <> fromText dbiPass <>- "';\nCREATE DATABASE " <> fromText dbiName <>- " OWNER " <> fromText dbiUser <>- ";"- (cmd, args) - | ( dbServer dbiServer == "localhost" - || dbServer dbiServer == "127.0.0.1") = - ("sudo", ["-u", "postgres", "psql"])- | otherwise = - ("psql",- [ "-h", (T.unpack $ dbServer dbiServer)- , "-p", (show $ dbPort dbiServer)- , "-U", "postgres"])- _ <- readProcess cmd args $ TL.unpack sql- return ()- }+ { setupDBInfo = \DBInfo{..} -> do+ let sql = toLazyText $+ "CREATE USER " <> fromText dbiUser <>+ " PASSWORD '" <> fromText dbiPass <>+ "';\nCREATE DATABASE " <> fromText dbiName <>+ " OWNER " <> fromText dbiUser <>+ ";"+ (cmd, args)+ | dbServer dbiServer == "localhost" || dbServer dbiServer == "127.0.0.1" =+ ("sudo", ["-u", "postgres", "psql"])+ | otherwise =+ ("psql",+ [ "-h", T.unpack (dbServer dbiServer)+ , "-p", show (dbPort dbiServer)+ , "-U", "postgres"])+ _ <- readProcess cmd args $ TL.unpack sql+ return ()+ } -- | Information on an individual PostgreSQL database. data DBInfo = DBInfo@@ -85,7 +80,7 @@ randomDBI :: DBServerInfo -> R.StdGen -> (DBInfo, R.StdGen) randomDBI dbsi =- S.runState (DBInfo <$> rt <*> rt <*> rt <*> (pure dbsi)) + S.runState (DBInfo <$> rt <*> rt <*> rt <*> pure dbsi) where rt = T.pack <$> replicateM 10 (S.state $ R.randomR ('a', 'z')) @@ -149,11 +144,11 @@ _ -> return [] } where doenv chan appname dbs = do- x <- newEmptyMVar- writeChan chan $ GetConfig appname dbs $ putMVar x- edbi <- takeMVar x- edbiToEnv edbi- + x <- newEmptyMVar+ writeChan chan $ GetConfig appname dbs $ putMVar x+ edbi <- takeMVar x+ edbiToEnv edbi+ tmpfp = fp <.> "tmp" loop chan = do@@ -183,11 +178,13 @@ return $ Right dbi lift $ f dbi + -- TODO: Why so much ceremony here?+ -- Why not just Data.Char.isAlphaNum and lower it? sanitize = T.map sanitize' sanitize' c- | 'A' <= c && c <= 'Z' = C.toLower c- | 'a' <= c && c <= 'z' = c- | '0' <= c && c <= '9' = c+ | C.isAsciiUpper c = C.toLower c+ | C.isAsciiLower c = c+ | C.isDigit c = c | otherwise = '_' edbiToEnv :: Either SomeException DBInfo
src/Keter/PortPool.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+ -- | Manages a pool of available ports and allocates them. module Keter.PortPool ( -- * Types@@ -13,18 +14,17 @@ , start ) where -import Keter.Common-import Keter.Context-import Data.Text (pack)-import Control.Applicative ((<$>))-import Control.Concurrent.MVar-import Control.Exception-import Control.Monad.IO.Class (liftIO)-import Control.Monad.IO.Unlift (withRunInIO)-import Control.Monad.Logger-import Keter.Config-import Network.Socket-import Prelude hiding (log)+import Control.Concurrent.MVar+import Control.Exception+import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Unlift (withRunInIO)+import Control.Monad.Logger+import Data.Text (pack)+import Keter.Common+import Keter.Config+import Keter.Context+import Network.Socket+import Prelude hiding (log) data PPState = PPState { ppAvail :: ![Port]@@ -74,7 +74,7 @@ addr:_ <- getAddrInfo (Just hints) Nothing (Just port) bracketOnError (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr))- (close)+ close (\sock -> do setSocketOption sock ReuseAddr 1 bind sock (addrAddress addr)
src/Keter/Proxy.hs view
@@ -1,8 +1,8 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+ -- | A light-weight, minimalistic reverse HTTP proxy. module Keter.Proxy ( reverseProxy@@ -11,83 +11,69 @@ , TLSConfig (..) ) where -import qualified Network.HTTP.Conduit as HTTP-import qualified Data.CaseInsensitive as CI-import Data.Functor ((<&>))-import qualified Keter.HostManager as HostMan-import Blaze.ByteString.Builder (copyByteString, toByteString)-import Blaze.ByteString.Builder.Html.Word(fromHtmlEscapedByteString)-import Control.Applicative ((<$>), (<|>))-import Control.Monad.Reader (ask)-import Control.Monad.IO.Unlift (withRunInIO)-import Control.Monad.IO.Class (liftIO)-import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-#if MIN_VERSION_http_reverse_proxy(0,6,0)-import Network.Wai.Middleware.Gzip (def)-#endif-import Data.Monoid (mappend, mempty)-import Data.Text as T (Text, pack, unwords)-import Data.Text.Encoding (decodeUtf8With, encodeUtf8)-import Data.Text.Encoding.Error (lenientDecode)-import qualified Data.Vector as V-import GHC.Exts (fromString)-import Keter.Config-import Keter.Config.Middleware-import Network.HTTP.Conduit (Manager)--#if MIN_VERSION_http_reverse_proxy(0,4,2)-import Network.HTTP.ReverseProxy (defaultLocalWaiProxySettings)-#endif--#if MIN_VERSION_http_reverse_proxy(0,6,0)-import Network.HTTP.ReverseProxy (defaultWaiProxySettings)-#endif--import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest),- SetIpHeader (..),- WaiProxyResponse (..),- LocalWaiProxySettings,- setLpsTimeBound,- waiProxyToSettings,- wpsSetIpHeader,- wpsOnExc,- wpsGetDest)-import qualified Keter.Rewrite as Rewrite-import Data.ByteString (ByteString)+import Blaze.ByteString.Builder (copyByteString, toByteString)+import Blaze.ByteString.Builder.Html.Word (fromHtmlEscapedByteString)+import Control.Applicative ((<|>))+import Control.Exception (SomeException)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Unlift (withRunInIO)+import Control.Monad.Logger+import Control.Monad.Reader (ask)+import Data.ByteString (ByteString)+import Data.ByteString qualified as S+import Data.ByteString.Char8 qualified as S8+import Data.CaseInsensitive qualified as CI+import Data.Functor ((<&>))+import Data.Text as T (Text, pack, unwords)+import Data.Text.Encoding (decodeUtf8With, encodeUtf8)+import Data.Text.Encoding.Error (lenientDecode)+import Data.Vector qualified as V+import Data.Version (showVersion)+import GHC.Exts (fromString) import Keter.Common-import System.FilePath (FilePath)-import Control.Monad.Logger-import Control.Exception (SomeException)-import Network.HTTP.Types (mkStatus,- status200,- status301, status302,- status303, status307,- status404, status502)-import qualified Network.Wai as Wai-import Network.Wai.Application.Static (defaultFileServerSettings,- ssListing, staticApp)-import qualified Network.Wai.Handler.Warp as Warp-import qualified Network.Wai.Handler.WarpTLS as WarpTLS-import qualified Network.TLS.SessionManager as TLSSession-import Network.Wai.Middleware.Gzip (gzip, GzipSettings(..), GzipFiles(..))-import Prelude hiding (FilePath, (++))-import WaiAppStatic.Listing (defaultListing)-import qualified Network.TLS as TLS-import qualified System.Directory as Dir+import Keter.Config+import Keter.Config.Middleware import Keter.Context--import Data.Version (showVersion)-import qualified Paths_keter as Pkg--#if !MIN_VERSION_http_reverse_proxy(0,6,0)-defaultWaiProxySettings = def-#endif--#if !MIN_VERSION_http_reverse_proxy(0,4,2)-defaultLocalWaiProxySettings = def-#endif-+import Keter.HostManager qualified as HostMan+import Keter.Rewrite qualified as Rewrite+import Network.HTTP.Conduit (Manager)+import Network.HTTP.Conduit qualified as HTTP+import Network.HTTP.ReverseProxy+ ( LocalWaiProxySettings+ , ProxyDest(ProxyDest)+ , SetIpHeader(..)+ , WaiProxyResponse(..)+ , defaultLocalWaiProxySettings+ , defaultWaiProxySettings+ , setLpsTimeBound+ , waiProxyToSettings+ , wpsGetDest+ , wpsOnExc+ , wpsSetIpHeader+ )+import Network.HTTP.Types+ ( mkStatus+ , status200+ , status301+ , status302+ , status303+ , status307+ , status404+ , status502+ )+import Network.TLS qualified as TLS+import Network.TLS.SessionManager qualified as TLSSession+import Network.Wai qualified as Wai+import Network.Wai.Application.Static+ (defaultFileServerSettings, ssListing, staticApp)+import Network.Wai.Handler.Warp qualified as Warp+import Network.Wai.Handler.WarpTLS qualified as WarpTLS+import Network.Wai.Middleware.Gzip (GzipFiles(..), GzipSettings(..), def, gzip)+import Paths_keter qualified as Pkg+import Prelude hiding (FilePath, (++))+import System.Directory qualified as Dir+import System.FilePath (FilePath)+import WaiAppStatic.Listing (defaultListing) data ProxySettings = MkProxySettings { -- | Mapping from virtual hostname to port number.@@ -158,7 +144,7 @@ return mempty -- we could return default certificate here in s { WarpTLS.tlsServerHooks = newHooks{TLS.onServerNameIndication = newOnServerNameIndication}- , WarpTLS.tlsSessionManagerConfig = if session then (Just TLSSession.defaultConfig) else Nothing }+ , WarpTLS.tlsSessionManagerConfig = if session then Just TLSSession.defaultConfig else Nothing } withClient :: Bool -- ^ is secure?
src/Keter/Rewrite.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+ module Keter.Rewrite ( ReverseProxyConfig (..) , RewriteRule (..)@@ -9,41 +9,32 @@ ) where +import Blaze.ByteString.Builder (fromByteString) import Control.Applicative import Control.Exception (bracket)+import Control.Monad (unless)+import Data.Aeson+import Data.Array ((!))+import Data.Attoparsec.Text (Parser, endOfInput, parseOnly, string, takeWhile1)+import Data.ByteString qualified as S+import Data.CaseInsensitive qualified as CI+import Data.Char (isDigit) import Data.Function (fix)-import Data.Monoid ((<>))--import qualified Data.Set as Set+import Data.Map (Map)+import Data.Map qualified as Map import Data.Set (Set)-import qualified Data.Map as Map-import Data.Map ( Map )-import Data.Array ((!))-import Data.Aeson-import Control.Monad (unless)--import qualified Data.ByteString as S-import qualified Data.Text as T+import Data.Set qualified as Set import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8, decodeUtf8)-import qualified Data.CaseInsensitive as CI--import Blaze.ByteString.Builder (fromByteString)-+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Keter.Common---- Regular expression parsing, replacement, matching-import Data.Attoparsec.Text (string, takeWhile1, endOfInput, parseOnly, Parser)-import Text.Regex.TDFA (makeRegex, matchOnceText, MatchText)-import Text.Regex.TDFA.String (Regex)-import Data.Char (isDigit)---- Reverse proxy apparatus-import qualified Network.Wai as Wai-import qualified Network.Wai.Internal as I+import Network.HTTP.Client qualified as NHC import Network.HTTP.Client.Conduit-import qualified Network.HTTP.Client as NHC import Network.HTTP.Types+import Network.Wai qualified as Wai+import Network.Wai.Internal qualified as I+import Text.Regex.TDFA (MatchText, makeRegex, matchOnceText)+import Text.Regex.TDFA.String (Regex) data RPEntry = RPEntry { config :: ReverseProxyConfig@@ -51,7 +42,7 @@ } instance Show RPEntry where- show x = "RPEntry { config = " ++ (show $ config x) ++ " }"+ show x = "RPEntry { config = " ++ show (config x) ++ " }" getGroup :: MatchText String -> Int -> String getGroup matches i = fst $ matches ! i@@ -72,7 +63,7 @@ } <|> do { _ <- string "\\"- ; n <- (fmap (read . T.unpack) $ takeWhile1 isDigit) :: Parser Int+ ; n <- (read . T.unpack <$> takeWhile1 isDigit) :: Parser Int ; rest <- parseSubstitute ; return $ T.pack (getGroup match n) <> rest }@@ -189,18 +180,6 @@ , "rewrite-response" .= rewriteResponseRules , "rewrite-request" .= rewriteRequestRules ]--defaultReverseProxyConfig :: ReverseProxyConfig-defaultReverseProxyConfig = ReverseProxyConfig- { reversedHost = ""- , reversedPort = 80- , reversedUseSSL = False- , reversingHost = ""- , reversingUseSSL = SSLFalse- , reverseTimeout = Nothing- , rewriteResponseRules = Set.empty- , rewriteRequestRules = Set.empty- } data RewriteRule = RewriteRule { ruleHeader :: Text
src/Keter/TempTarball.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards #-} -- | Handles allocation of temporary directories and unpacking of bundles into -- them. Sets owner and group of all created files and directories as -- necessary.@@ -10,27 +10,17 @@ , unpackTempTar ) where -import qualified Codec.Archive.Tar as Tar-import qualified Codec.Archive.Tar.Check as Tar-import qualified Codec.Archive.Tar.Entry as Tar-import Codec.Compression.GZip (decompress)-import Control.Exception (bracket, bracketOnError, throwIO)-import Control.Monad (unless, when, forM)-import qualified Data.ByteString.Lazy as L-import Data.ByteString.Unsafe (unsafeUseAsCStringLen)-import qualified Data.IORef as I-import Data.Monoid ((<>))-import Data.Text (Text, pack, unpack)-import Data.Word (Word)-import System.FilePath ((</>))-import qualified System.FilePath as F-import qualified System.Directory as D-import Foreign.Ptr (castPtr)-import System.Posix.Files (setFdOwnerAndGroup,- setOwnerAndGroup)-import System.Posix.IO (FdOption (CloseOnExec), closeFd,- createFile, fdWriteBuf, setFdOption)-import System.Posix.Types (GroupID, UserID)+import Codec.Archive.Tar qualified as Tar+import Codec.Compression.GZip (decompress)+import Control.Exception (bracketOnError, throwIO)+import Control.Monad (forM_, when)+import Data.ByteString.Lazy qualified as L+import Data.IORef qualified as I+import Data.Text (Text, pack, unpack)+import System.Directory qualified as D+import System.FilePath ((</>))+import System.Posix.Files (setOwnerAndGroup)+import System.Posix.Types (GroupID, UserID) data TempFolder = TempFolder { tfRoot :: FilePath@@ -70,7 +60,7 @@ D.createDirectoryIfMissing True dir let entries = Tar.read $ decompress lbs Tar.unpack dir entries- _ <- forM muid $ \perms ->+ forM_ muid $ \perms -> Tar.foldEntries (setEntryPermission perms) (pure ()) throwIO entries withDir dir
src/Keter/Yaml/FilePath.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+ -- | Utilities for dealing with YAML config files which contain relative file -- paths. module Keter.Yaml.FilePath@@ -13,13 +13,27 @@ ) where import Control.Applicative ((<$>))-import Data.Yaml (decodeFileEither, ParseException (AesonException), parseJSON)-import Prelude (($!), ($), Either (..), return, IO, (.), (>>=), Maybe (..), maybe, mapM, Ord, fail, FilePath)-import Keter.Aeson.KeyHelper as AK-import Data.Aeson.Types ((.:), (.:?), Object, Parser, Value, parseEither)+import Data.Aeson.Types (Object, Parser, Value, parseEither, (.:), (.:?))+import Data.Set qualified as Set import Data.Text (Text, unpack)-import qualified Data.Set as Set-import qualified Data.Vector as V+import Data.Vector qualified as V+import Data.Yaml (ParseException(AesonException), decodeFileEither, parseJSON)+import Keter.Aeson.KeyHelper as AK+import Prelude+ ( Either(..)+ , FilePath+ , IO+ , Maybe(..)+ , Ord+ , fail+ , mapM+ , maybe+ , return+ , ($!)+ , ($)+ , (.)+ , (>>=)+ ) import System.FilePath (takeDirectory, (</>)) -- | The directory from which we're reading the config file.@@ -59,7 +73,9 @@ parseYamlFile :: BaseDir -> Value -> Parser a instance ParseYamlFile FilePath where- parseYamlFile (BaseDir dir) o = ((dir </>) . unpack) <$> parseJSON o+ parseYamlFile (BaseDir dir) o =+ (dir </>) . unpack <$> parseJSON o+ instance (ParseYamlFile a, Ord a) => ParseYamlFile (Set.Set a) where parseYamlFile base o = parseJSON o >>= ((Set.fromList <$>) . mapM (parseYamlFile base)) instance ParseYamlFile a => ParseYamlFile (V.Vector a) where
src/main/keter.hs view
@@ -1,11 +1,12 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-}-import Prelude (error, (++), ($), IO, putStrLn)-import System.Environment (getArgs, getProgName)++import Data.Version (showVersion) import Keter.Main (keter)+import Keter.Plugin.Postgres qualified as Postgres import Paths_keter (version)-import Data.Version (showVersion)-import qualified Keter.Plugin.Postgres as Postgres+import Prelude (IO, error, putStrLn, ($), (++))+import System.Environment (getArgs, getProgName) import System.FilePath ((</>)) main :: IO ()
test/Spec.hs view
@@ -1,29 +1,28 @@-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-} module Main where -import Network.HTTP.Types.Status(ok200)-import qualified Network.Wai.Handler.Warp as Warp-import Keter.Config.V10-import Control.Concurrent (forkIO, threadDelay)-import Data.Maybe (isJust)-import Keter.LabelMap as LM-import Test.Tasty-import Test.Tasty.HUnit+import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent.STM.TQueue import Control.Monad-import Control.Monad.Reader import Control.Monad.Logger-import Control.Exception (SomeException)-import Network.HTTP.Conduit (Manager)-import Data.ByteString(ByteString)-import qualified Network.Wreq as Wreq+import Control.Monad.Reader import Control.Monad.STM-import Control.Concurrent.STM.TQueue-import qualified Network.Wai as Wai-import qualified Network.HTTP.Conduit as HTTP+import Data.ByteString (ByteString)+import Data.Maybe (isJust)+import Keter.Config.V10 import Keter.Context+import Keter.LabelMap as LM import Keter.Proxy+import Network.HTTP.Conduit (Manager)+import Network.HTTP.Conduit qualified as HTTP+import Network.HTTP.Types.Status (ok200)+import Network.Wai qualified as Wai+import Network.Wai.Handler.Warp qualified as Warp+import Network.Wreq qualified as Wreq+import Test.Tasty+import Test.Tasty.HUnit main :: IO () main = defaultMain keterTests@@ -59,22 +58,22 @@ headThenPostNoCrash = do manager <- HTTP.newManager HTTP.tlsManagerSettings exceptions <- newTQueueIO- - forkIO $ do++ _ <- forkIO $ do Warp.run 6781 $ \req resp -> do void $ Wai.strictRequestBody req resp $ Wai.responseLBS ok200 [] "ok" - forkIO $ - flip runReaderT (settings manager) $ + _ <- forkIO $+ flip runReaderT (settings manager) $ flip runLoggingT (\_ _ _ msg -> atomically $ writeTQueue exceptions msg) $- filterLogger isException $ - runKeterM $ + filterLogger isException $+ runKeterM $ reverseProxy $ LPInsecure "*" 6780 threadDelay 0_100_000 - res <- Wreq.head_ "http://localhost:6780"+ _res <- Wreq.head_ "http://localhost:6780" void $ Wreq.post "http://localhost:6780" content @@ -83,7 +82,7 @@ where content :: ByteString content = "a"- + -- For 'reverseProxy', only exceptions (and strictly exceptions!) are logged as LevelError. isException :: LogSource -> LogLevel -> Bool isException _ LevelError = True