diff --git a/.github/workflows/nix.yaml b/.github/workflows/nix.yaml index 3e3b1e62..15dcf781 100644 --- a/.github/workflows/nix.yaml +++ b/.github/workflows/nix.yaml @@ -2,24 +2,18 @@ name: "Nix" on: pull_request: push: +# cancel previous runs when pushing new changes +concurrency: + group: ${{ github.workflow }}-${{ github.event.pull_request.number || github.ref }} + cancel-in-progress: true jobs: tests: runs-on: ubuntu-latest steps: - - uses: actions/checkout@v2.3.1 - - name: Local cache - uses: actions/cache@v2 - with: - path: /nix/store - key: "${{ runner.os }}-nix-cache" - - uses: cachix/install-nix-action@v12 - with: - nix_path: nixpkgs=channel:nixos-unstable - # - uses: cachix/cachix-action@v6 - # with: - # name: jappie - # signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}' - # # Only needed for private caches - # #authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' - # - run: nix-build . - # - run: nix-shell --run "cd incoming; make all" + - uses: actions/checkout@v4 + - uses: cachix/install-nix-action@v25 + with: + nix_path: nixpkgs=channel:nixos-unstable + extra_nix_config: "system-features = kvm nixos-test" + + - run: nix flake check -L diff --git a/.gitignore b/.gitignore index 4c0a5a42..20977854 100644 --- a/.gitignore +++ b/.gitignore @@ -22,3 +22,5 @@ log/ .stack-work/ cabal.sandbox.config *.sublime-* +dist-newstyle/ +.pre-commit-config.yaml diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 00000000..c693e423 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,229 @@ +# stylish-haskell configuration file +# ================================== + +# The stylish-haskell tool is mainly configured by specifying steps. These steps +# are a list, so they have an order, and one specific step may appear more than +# once (if needed). Each file is processed by these steps in the given order. +steps: + # Convert some ASCII sequences to their Unicode equivalents. This is disabled + # by default. + # - unicode_syntax: + # # In order to make this work, we also need to insert the UnicodeSyntax + # # language pragma. If this flag is set to true, we insert it when it's + # # not already present. You may want to disable it if you configure + # # language extensions using some other method than pragmas. Default: + # # true. + # add_language_pragma: true + + # Align the right hand side of some elements. This is quite conservative + # and only applies to statements where each element occupies a single + # line. + - simple_align: + cases: false + top_level_patterns: false + records: false + # Import cleanup + - imports: + # There are different ways we can align names and lists. + # + # - global: Align the import names and import list throughout the entire + # file. + # + # - file: Like global, but don't add padding when there are no qualified + # imports in the file. + # + # - group: Only align the imports per group (a group is formed by adjacent + # import lines). + # + # - none: Do not perform any alignment. + # + # Default: global. + align: none + # The following options affect only import list alignment. + # + # List align has following options: + # + # - after_alias: Import list is aligned with end of import including + # 'as' and 'hiding' keywords. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - with_alias: Import list is aligned with start of alias or hiding. + # + # > import qualified Data.List as List (concat, foldl, foldr, head, + # > init, last, length) + # + # - new_line: Import list starts always on new line. + # + # > import qualified Data.List as List + # > (concat, foldl, foldr, head, init, last, length) + # + # Default: after_alias + list_align: with_module_name + # Right-pad the module names to align imports in a group: + # + # - true: a little more readable + # + # > import qualified Data.List as List (concat, foldl, foldr, + # > init, last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # - false: diff-safe + # + # > import qualified Data.List as List (concat, foldl, foldr, init, + # > last, length) + # > import qualified Data.List.Extra as List (concat, foldl, foldr, + # > init, last, length) + # + # Default: true + pad_module_names: false + # Long list align style takes effect when import is too long. This is + # determined by 'columns' setting. + # + # - inline: This option will put as much specs on same line as possible. + # + # - new_line: Import list will start on new line. + # + # - new_line_multiline: Import list will start on new line when it's + # short enough to fit to single line. Otherwise it'll be multiline. + # + # - multiline: One line per import list entry. + # Type with constructor list acts like single import. + # + # > import qualified Data.Map as M + # > ( empty + # > , singleton + # > , ... + # > , delete + # > ) + # + # Default: inline + long_list_align: new_line_multiline + # Align empty list (importing instances) + # + # Empty list align has following options + # + # - inherit: inherit list_align setting + # + # - right_after: () is right after the module name: + # + # > import Vector.Instances () + # + # Default: inherit + empty_list_align: inherit + # List padding determines indentation of import list on lines after import. + # This option affects 'long_list_align'. + # + # - : constant value + # + # - module_name: align under start of module name. + # Useful for 'file' and 'group' align settings. + list_padding: 7 # length of "import " + # Separate lists option affects formatting of import list for type + # or class. The only difference is single space between type and list + # of constructors, selectors and class functions. + # + # - true: There is single space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable (fold, foldl, foldMap)) + # + # - false: There is no space between Foldable type and list of it's + # functions. + # + # > import Data.Foldable (Foldable(fold, foldl, foldMap)) + # + # Default: true + separate_lists: false + # Space surround option affects formatting of import lists on a single + # line. The only difference is single space after the initial + # parenthesis and a single space before the terminal parenthesis. + # + # - true: There is single space associated with the enclosing + # parenthesis. + # + # > import Data.Foo ( foo ) + # + # - false: There is no space associated with the enclosing parenthesis + # + # > import Data.Foo (foo) + # + # Default: false + space_surround: false + # Post qualify option moves any qualifies found in import declarations + # to the end of the declaration. This also adjust padding for any + # unqualified import declarations. + # + # - true: Qualified as is moved to the end of the + # declaration. + # + # > import Data.Bar + # > import Data.Foo qualified as F + # + # - false: Qualified remains in the default location and unqualified + # imports are padded to align with qualified imports. + # + # > import Data.Bar + # > import qualified Data.Foo as F + # + # Default: false + post_qualify: true + # Language pragmas + - language_pragmas: + # We can generate different styles of language pragma lists. + # + # - vertical: Vertical-spaced language pragmas, one per line. + # + # - compact: A more compact style. + # + # - compact_line: Similar to compact, but wrap each line with + # `{-#LANGUAGE #-}'. + # + # Default: vertical. + style: vertical + # Align affects alignment of closing pragma brackets. + # + # - true: Brackets are aligned in same column. + # + # - false: Brackets are not aligned together. There is only one space + # between actual import and closing bracket. + # + # Default: true + align: false + # stylish-haskell can detect redundancy of some language pragmas. If this + # is set to true, it will remove those redundant pragmas. Default: true. + remove_redundant: false + # Remove trailing whitespace + - trailing_whitespace: {} +# Replace tabs by spaces. This is disabled by default. +# - tabs: +# # Number of spaces to use for each tab. Default: 8, as specified by the +# # Haskell report. +# spaces: 8 +# Squash multiple spaces between the left and right hand sides of some +# elements into single spaces. Basically, this undoes the effect of +# simple_align but is a bit less conservative. +# - squash: {} +# A common setting is the number of columns (parts of) code will be wrapped +# to. Different steps take this into account. Default: 80. +columns: 80 +# By default, line endings are converted according to the OS. You can override +# preferred format here. +# +# - native: Native newline format. CRLF on Windows, LF on other OSes. +# +# - lf: Convert to LF ("\n"). +# +# - crlf: Convert to CRLF ("\r\n"). +# +# Default: native. +newline: lf +# Sometimes, language extensions are specified in a cabal file or from the +# command line instead of using language pragmas in the file. stylish-haskell +# needs to be aware of these, so it can parse the file correctly. +# +# No language extensions are enabled by default. +language_extensions: + - ImportQualifiedPost diff --git a/ChangeLog.md b/ChangeLog.md index 141d9b99..918fd71f 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,219 +1,239 @@ +# Changelog + ## 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`. - -+ 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: +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: `"$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 + +- 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 +241,7 @@ Bug fix: catch exceptions during reload [#64](https://github.com/snoyberg/keter/ ## 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 +249,8 @@ Support the `forward-env` setting. ## 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 +262,13 @@ Fix bug where the cleanup process would remain running. ## 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 +288,29 @@ Upgrade to conduit 1.1 ## 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. diff --git a/MigrationGuide-2.1.md b/MigrationGuide-2.1.md index a58bdda2..e5d139aa 100644 --- a/MigrationGuide-2.1.md +++ b/MigrationGuide-2.1.md @@ -2,7 +2,8 @@ ## What breaking changes can I expect from this version upgrade? -If your library/application used/referenced/relied on any of the following from `keter` <2.1, _it is now potentially broken with 2.1_: +If your library/application used/referenced/relied on any of the following from +`keter` <2.1, _it is now potentially broken with 2.1_: 1. Directories where `keter` and individual application (`app-*`) logs are located. 2. Log file name/format for both `keter` and `app-*` logs. @@ -12,56 +13,67 @@ If your library/application used/referenced/relied on any of the following from In the same order: -1. **NEW**: `keter` and individual `app-*` logs are now BOTH located in `log/` - - **OLD**: `keter` logs were located in `log/keter` and individual application logs were located in `log/app-*`. - -2. **NEW**: `keter` logs are now named `keter.log` and rotated to `keter.log.1`, `keter.log.2`, ...and so forth - `app-*` logs are now named `app-*.log` and rotated to `app-*.log.1`, `app-*.log.2`, ...and so forth - - **OLD**: Both `keter` and individual `app-*` logs were named `current.log` within their respective directories and were rotated to - `%Y%m%d_%H%M%S.log`. (Following time formatting conventions [as defined by the `time` package](https://hackage.haskell.org/package/time-1.12.2/docs/Data-Time-Format.html#v:formatTime). This was the timestamp when the log was ***rotated out*** of use, not into use.) -3. **NEW**: Log file message format for `keter` logs is now - `${time}|${module}:${line_num}|${log_level}> ${msg}` - - **OLD**: Log file message format for `keter` logs used to be +1. **NEW**: `keter` and individual `app-*` logs are now BOTH located in `log/` + + **OLD**: `keter` logs were located in `log/keter` and individual application + logs were located in `log/app-*`. + +2. **NEW**: + - `keter` logs are now named `keter.log` and rotated to `keter.log.1`, + `keter.log.2`, ...and so forth + - `app-*` logs are now named `app-*.log` and rotated to `app-*.log.1`, + `app-*.log.2`, ...and so forth + + **OLD**: Both `keter` and individual `app-*` logs were named `current.log` + within their respective directories and were rotated to `%Y%m%d_%H%M%S.log`. + (Following time formatting conventions [as defined by the `time` + package](https://hackage.haskell.org/package/time-1.12.2/docs/Data-Time-Format.html#v:formatTime). + This was the timestamp when the log was _rotated out_ of use, not into + use.) +3. **NEW**: Log file message format for `keter` logs is now + `${time}|${module}:${line_num}|${log_level}> ${msg}` + + **OLD**: Log file message format for `keter` logs used to be `%Y-%m-%d %H:%M:%S.${%q_9} UTC: ${msg}` Where: + - `${time}` is time formatted as `%Y%m%d_%H%M%S.${%q_2}`. - `${module}` is the `keter` source module the message was logged from. -- `${line_num}` is the source line number within `${module}` the message was logged from. +- `${line_num}` is the source line number within `${module}` the message was + logged from. - `${log_level}` is the log level (`Info` | `Warn` | `Error` | `Other`). - `${msg}` is the log message itself. -- `${%q_N}` (where N is 9 or 2 above) is the same as `%q` (picosecond formatting) from the `time` package, but truncated to the first N digits. +- `${%q_N}` (where N is 9 or 2 above) is the same as `%q` (picosecond + formatting) from the `time` package, but truncated to the first N digits. ## What are some examples of the aforementioned changes? In the same order: 1. (See below) -2. **NEW**: - * `log/keter.log` - * `log/keter.log.1` - * `log/keter.log.2` - * `log/app-blah.log` - * `log/app-blah.log.1` - * `log/app-blah.log.2` - - **OLD**: - * `log/keter/current.log` - * `log/keter/2023-12-31_245603.log` - * `log/keter/2023-01-01_010203.log` - * `log/app-blah/current.log` - * `log/app-blah/2023-12-31_245603.log` - * `log/app-blah/2023-01-01_010203.log` +2. **NEW**: + - `log/keter.log` + - `log/keter.log.1` + - `log/keter.log.2` + - `log/app-blah.log` + - `log/app-blah.log.1` + - `log/app-blah.log.2` + + **OLD**: + - `log/keter/current.log` + - `log/keter/2023-12-31_245603.log` + - `log/keter/2023-01-01_010203.log` + - `log/app-blah/current.log` + - `log/app-blah/2023-12-31_245603.log` + - `log/app-blah/2023-01-01_010203.log` 3. **NEW**: - * `2023-03-11 14:37:17.06|Keter.Main:84|Info> Launching initial` - * `2023-04-12 09:02:07.92|Keter.Whatever:279|Other> Something something` - + - `2023-03-11 14:37:17.06|Keter.Main:84|Info> Launching initial` + - `2023-04-12 09:02:07.92|Keter.Whatever:279|Other> Something something` + **OLD**: - * `2023-03-11 14:37:17.069101123 UTC: Launching initial` - * `2023-04-12 09:02:07.921023056 UTC: Something something` + - `2023-03-11 14:37:17.069101123 UTC: Launching initial` + - `2023-04-12 09:02:07.921023056 UTC: Something something` ## What suggestions do you have for addressing these breaking changes? @@ -69,25 +81,40 @@ In the same order: 1. Update the directories you are reading the log files from appropriately. 2. Update how you are referencing the actual log file name(s) apppropriately. - * If you had previously depended on the timestamp in the name of rotated log files, consider parsing the log message timestamps _within_ the individual log files instead. The timestamp of the first log message in any file should accurately tell you at what time logging was ***rotated to*** that file. You can then subtract the number suffixed to its file name by 1 to then find the name of the log file that was ***rotated out*** at that time, if maintaing old semantics is important to you. + - If you had previously depended on the timestamp in the name of rotated + log files, consider parsing the log message timestamps _within_ the + individual log files instead. The timestamp of the first log message in + any file should accurately tell you at what time logging was _rotated + to_ that file. You can then subtract the number suffixed to its file + name by 1 to then find the name of the log file that was _rotated + out_ at that time, if maintaing old semantics is important to you. 3. Update parsing of log messages appropriately. ## Other features you may want to make use of -Stderr logging has now been added! Please consider using this option instead if you are, say, integrating `keter` with `systemd`, which captures stderr output for you. By default, without updating your `keter` config, `keter` will still log to rotating files as usual. As such, this is not a breaking change. +Stderr logging has now been added! Please consider using this option instead if +you are, say, integrating `keter` with `systemd`, which captures stderr output +for you. By default, without updating your `keter` config, `keter` will still +log to rotating files as usual. As such, this is not a breaking change. You can enable stderr logging by setting `rotate-logs: false` in your `keter` config. -**NOTE:** When logging to stderr ( _not_ to rotating files), log messages are tagged with the prefixes `keter|` and `app-*>` to distinguish `keter` and individual `app-*` logs, respectively. This is necessary as both types of logs are emitted to the same destination (stderr) unlike when logging to files. +**NOTE:** When logging to stderr ( _not_ to rotating files), log messages are +tagged with the prefixes `keter|` and `app-*>` to distinguish `keter` and +individual `app-*` logs, respectively. This is necessary as both types of logs +are emitted to the same destination (stderr) unlike when logging to files. Explicitly stated, stderr log message formats will look like the following: - -* `keter|${time}|${module}:${line_num}|${log_level}> ${msg}` -* `app-*> ${msg}` + +- `keter|${time}|${module}:${line_num}|${log_level}> ${msg}` +- `app-*> ${msg}` Ex: -* `keter|2023-03-11 14:37:17.06|Keter.Main:84|Info> Launching initial` -* `app-blah> Something something` +- `keter|2023-03-11 14:37:17.06|Keter.Main:84|Info> Launching initial` +- `app-blah> Something something` -Please remember to account for this and not, say, blindly reuse the exact same parsers for both log file messages and stderr log messages. Generally it should suffice to compose a prefix parser in front of the same parser used for the equivalent log file message parser, however. +Please remember to account for this and not, say, blindly reuse the exact same +parsers for both log file messages and stderr log messages. Generally it should +suffice to compose a prefix parser in front of the same parser used for the +equivalent log file message parser, however. diff --git a/README.md b/README.md index 39d1aba1..2dc8a1c1 100755 --- a/README.md +++ b/README.md @@ -1,28 +1,38 @@ -[![Githbu actions build status](https://img.shields.io/github/workflow/status/snoyberg/keter/Stack)](https://github.com/snoyberg/keter/actions) +# Keter +[![Githbu actions build status](https://img.shields.io/github/workflow/status/snoyberg/keter/Stack)](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 @@ or similar strategy. ## 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 @@ like to assist with this). For now, the following steps should be sufficient: 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. +. 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. - +. + ### 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 @@ WantedBy=multi-user.target 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 @@ exec /opt/keter/bin/keter /opt/keter/etc/keter-config.yaml 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 + There is an example that integrates yesod into keter with NixOS here: -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. +. Keter also supports wildcard subdomains and exceptions, as in this example configuration: @@ -260,67 +293,78 @@ plugins: 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: + ```nginx + proxy_set_header Connection ""; + proxy_http_version 1.1; + ``` - 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. - 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: + 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: - proxy_set_header Host $host; + ```nginx + proxy_set_header Host $host; + ``` -* 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. +* 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. - To get around this, you need to create a copy of the key without password - and deploy this new key: + To get around this, you need to create a copy of the key without password + and deploy this new key: - openssl rsa -in original.key -out new.key + ```sh + openssl rsa -in original.key -out new.key + ``` - (Back up the original key first, just in case.) + (Back up the original key first, just in case.) ## Stanza-based config files @@ -331,8 +375,8 @@ redirects, etc). This README will eventually be updated to reflect all various 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 +* +* ## Multiple SSL Certificates @@ -340,7 +384,7 @@ Keter is able to serve different certificates for different hosts, 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 @@ listeners: 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 @@ stanzas: 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 @@ the other certificates in the following order - /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 @@ figure out what keter is doing. ## Contributing If you are interested in contributing, see -https://github.com/snoyberg/keter/blob/master/incoming/README.md for a + 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 . diff --git a/default.nix b/default.nix deleted file mode 100644 index a51e3038..00000000 --- a/default.nix +++ /dev/null @@ -1,8 +0,0 @@ -{ pkgs ? import ./nix/pkgs.nix, ... }: -let - ignore = import (builtins.fetchGit { - url = "https://github.com/hercules-ci/gitignore.nix"; - rev = "bff2832ec341cf30acb3a4d3e2e7f1f7b590116a"; - }) { inherit (pkgs) lib; }; -in -pkgs.haskellPackages.callCabal2nix "keter" (ignore.gitignoreSource ./.) { } diff --git a/flake.lock b/flake.lock new file mode 100644 index 00000000..ee9cfd1d --- /dev/null +++ b/flake.lock @@ -0,0 +1,135 @@ +{ + "nodes": { + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1696426674, + "narHash": "sha256-kvjfFW7WAETZlt09AgDn1MrtKzP7t90Vf7vypd3OL1U=", + "owner": "edolstra", + "repo": "flake-compat", + "rev": "0f9255e01c2351cc7d116c072cb317785dd33b33", + "type": "github" + }, + "original": { + "owner": "edolstra", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "gitignore": { + "inputs": { + "nixpkgs": [ + "pre-commit-hooks", + "nixpkgs" + ] + }, + "locked": { + "lastModified": 1709087332, + "narHash": "sha256-HG2cCnktfHsKV0s4XW83gU3F57gaTljL9KNSuG6bnQs=", + "owner": "hercules-ci", + "repo": "gitignore.nix", + "rev": "637db329424fd7e46cf4185293b9cc8c88c95394", + "type": "github" + }, + "original": { + "owner": "hercules-ci", + "repo": "gitignore.nix", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1737299813, + "narHash": "sha256-Qw2PwmkXDK8sPQ5YQ/y/icbQ+TYgbxfjhgnkNJyT1X8=", + "owner": "nixos", + "repo": "nixpkgs", + "rev": "107d5ef05c0b1119749e381451389eded30fb0d5", + "type": "github" + }, + "original": { + "owner": "nixos", + "ref": "nixos-24.11", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs_2": { + "locked": { + "lastModified": 1730768919, + "narHash": "sha256-8AKquNnnSaJRXZxc5YmF/WfmxiHX6MMZZasRP6RRQkE=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "a04d33c0c3f1a59a2c1cb0c6e34cd24500e5a1dc", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixpkgs-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "pre-commit-hooks": { + "inputs": { + "flake-compat": "flake-compat", + "gitignore": "gitignore", + "nixpkgs": "nixpkgs_2" + }, + "locked": { + "lastModified": 1737301351, + "narHash": "sha256-2UNmLCKORvdBRhPGI8Vx0b6l7M8/QBey/nHLIxOl4jE=", + "owner": "cachix", + "repo": "pre-commit-hooks.nix", + "rev": "15a87cedeb67e3dbc8d2f7b9831990dffcf4e69f", + "type": "github" + }, + "original": { + "owner": "cachix", + "repo": "pre-commit-hooks.nix", + "type": "github" + } + }, + "root": { + "inputs": { + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs", + "pre-commit-hooks": "pre-commit-hooks" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 00000000..9bbf9e1a --- /dev/null +++ b/flake.nix @@ -0,0 +1,78 @@ +{ + inputs = { + nixpkgs.url = "github:nixos/nixpkgs?ref=nixos-24.11"; + flake-utils.url = "github:numtide/flake-utils"; + pre-commit-hooks.url = "github:cachix/pre-commit-hooks.nix"; + }; + + outputs = { self, nixpkgs, flake-utils, pre-commit-hooks }: + flake-utils.lib.eachDefaultSystem + (system: + let + pkgs = import nixpkgs { + inherit system; + overlays = [ + self.overlays.default + ]; + }; + hl = pkgs.haskell.lib; + + in + { + packages = { + inherit (pkgs.haskellPackages) keter; + default = pkgs.haskellPackages.keter; + }; + + checks = { + inherit (pkgs.haskellPackages) keter; + + pre-commit-check = pre-commit-hooks.lib.${system}.run { + src = ./.; + hooks = { + cabal-fmt.enable = true; + deadnix.enable = true; + hlint.enable = true; + markdownlint.enable = true; + nixpkgs-fmt.enable = true; + statix.enable = true; + stylish-haskell.enable = true; + }; + }; + }; + + devShells.default = pkgs.haskellPackages.shellFor { + packages = + let devPkgs = [ ]; + in p: [ (hl.addBuildDepends p.keter devPkgs) ]; + buildInputs = with pkgs.haskellPackages; [ + cabal-fmt + cabal-install + hlint + ]; + inherit (self.checks.${system}.pre-commit-check) shellHook; + }; + }) // { + overlays.default = _: prev: { + haskell = prev.haskell // { + # override for all compilers + packageOverrides = prev.lib.composeExtensions prev.haskell.packageOverrides (_: hprev: { + + tar = hprev.tar_0_6_3_0; + + keter = + let + haskellSourceFilter = prev.lib.sourceFilesBySuffices ./. [ + ".cabal" + ".hs" + ".c" + "LICENSE" + ]; + in + hprev.callCabal2nix "keter" haskellSourceFilter { }; + + }); + }; + }; + }; +} diff --git a/incoming/README.md b/incoming/README.md index c5ce8dc6..241e205d 100644 --- a/incoming/README.md +++ b/incoming/README.md @@ -2,7 +2,9 @@ Build all examples: - $ make +```sh +make +``` The resulting build will attempt to use the `cabal.sandbox.config` in the parent directory to locate packages for the examples. @@ -13,24 +15,31 @@ incoming directory and remove all bundles. Build Keter app bundle with V1.0 configuration syntax: - $ make foo1_0 +```sh +make foo1_0 +``` Build Keter websocket app bundle: - $ make websockets +```sh +make websockets +``` Build Keter app bundle with V0.4 configuration syntax: - $ make foo - +```sh +make foo +``` ## Example Testing Workflow ### 1) Build and run keter - $ cd keter/ - $ cabal build - $ ./dist/build/keter/keter etc/keter-config.yaml +```sh +cd keter/ +cabal build +./dist/build/keter/keter etc/keter-config.yaml +``` *Using postgresql features requires sudo access*. @@ -38,24 +47,32 @@ Build Keter app bundle with V0.4 configuration syntax: You can modify test bundles in the `incoming/` directory: - $ cd keter/incoming - # edit foo1_0/etc/keter.yaml +```sh +cd keter/incoming +# edit foo1_0/etc/keter.yaml +``` Next, rebuild your changes: - $ make # or `make foo1_0` +```sh +make # or `make foo1_0` +``` ### 3) Monitor the keter logs - $ tail -f log/keter/current.log +```sh +tail -f log/keter/current.log +``` ### 4) Test requests to the new bundle Use `curl` to test requests to an app: - $ http://keter1_0 +```sh +http://keter1_0 +``` -*Make sure add keter1_0 to your /etc/hosts file* +*n.b.* Make sure add keter1_0 to your /etc/hosts file `incoming/foo1_0` contains a complete example of the v1.0 configuration. `incoming/foo` is the v0.4 configuration and is used to diff --git a/incoming/bundles/readme.md b/incoming/bundles/readme.md index 0abf3f98..400f396c 100644 --- a/incoming/bundles/readme.md +++ b/incoming/bundles/readme.md @@ -1,3 +1,5 @@ +# Example Keter Applications + These subfolders contain (nearly) empty example keter applications to be made into bundles for deployment. The goal of these different bundles is to ensure that adding and removing bundles is reproducible. @@ -10,7 +12,6 @@ and un-deploy it. Each bundle contains only a static "test" file that contains the name of the bundle. That file is then exposed to a variety of hostnames: - ```yaml # foo.yaml static-hosts: diff --git a/incoming/foo/hello.hs b/incoming/foo/hello.hs index 254b1275..34cddaac 100644 --- a/incoming/foo/hello.hs +++ b/incoming/foo/hello.hs @@ -1,16 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} -import Control.Monad.IO.Class -import qualified Data.ByteString.Lazy.Char8 as L8 -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Handler.Warp -import Network.Wai.Middleware.RequestLogger -import System.Directory -import System.Environment -import System.IO -import Control.Concurrent - +import Control.Concurrent +import Control.Monad.IO.Class +import Data.ByteString.Lazy.Char8 qualified as L8 +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Handler.Warp +import Network.Wai.Middleware.RequestLogger +import System.Directory +import System.Environment +import System.IO main :: IO () main = do @@ -25,7 +24,7 @@ main = do run port $ logger $ \req send -> do liftIO $ putStrLn $ "Received a request at: " ++ show (pathInfo req) liftIO $ hFlush stdout - liftIO $ hPutStrLn stderr $ "Testing standard error" + liftIO $ hPutStrLn stderr "Testing standard error" liftIO $ hFlush stderr send $ responseLBS status200 [("content-type", "text/plain")] $ L8.pack $ unlines diff --git a/incoming/foo1_0/hello.hs b/incoming/foo1_0/hello.hs index fca14fd0..c4149380 100644 --- a/incoming/foo1_0/hello.hs +++ b/incoming/foo1_0/hello.hs @@ -1,15 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -import Control.Monad.IO.Class -import qualified Data.ByteString.Lazy.Char8 as L8 -import Network.HTTP.Types -import Network.Wai -import Network.Wai.Handler.Warp -import Network.Wai.Middleware.RequestLogger -import System.Directory -import System.Environment -import System.IO - +import Control.Monad.IO.Class +import Data.ByteString.Lazy.Char8 qualified as L8 +import Network.HTTP.Types +import Network.Wai +import Network.Wai.Handler.Warp +import Network.Wai.Middleware.RequestLogger +import System.Directory +import System.Environment +import System.IO main :: IO () main = do @@ -24,7 +23,7 @@ main = do run port $ logger $ \req send -> do liftIO $ putStrLn $ "Received a request at: " ++ show (pathInfo req) liftIO $ hFlush stdout - liftIO $ hPutStrLn stderr $ "Testing standard error" + liftIO $ hPutStrLn stderr "Testing standard error" liftIO $ hFlush stderr send $ responseLBS status200 [("content-type", "text/plain")] $ L8.pack $ unlines diff --git a/incoming/nc/Readme.md b/incoming/nc/Readme.md index 808fe292..556b6b78 100644 --- a/incoming/nc/Readme.md +++ b/incoming/nc/Readme.md @@ -1,5 +1,6 @@ +# Flexible Timeout Example + Shows how to configure a flexible timeout in keter. -if the flexible timeout is below 10 seconds in this example, -keter will continously try rebooting it, -because the sleep takes 10 seconds inside `nc.sh`. +If the flexible timeout is below 10 seconds in this example, keter will +continously try rebooting it because the sleep takes 10 seconds inside `nc.sh`. diff --git a/incoming/websockets/chat.hs b/incoming/websockets/chat.hs index de7f6ef9..8810934b 100644 --- a/incoming/websockets/chat.hs +++ b/incoming/websockets/chat.hs @@ -1,24 +1,24 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} -import Control.Concurrent (threadDelay) -import Control.Concurrent.STM.Lifted -import Control.Monad (forever) -import Control.Monad.Trans.Reader -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text.Lazy as TL -import Data.Time -import Yesod.Core -import Yesod.WebSockets +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM.Lifted +import Control.Monad (forever) +import Control.Monad.Trans.Reader +import Data.Conduit +import Data.Conduit.List qualified as CL +import Data.Monoid ((<>)) +import Data.Text (Text) +import Data.Text.Lazy qualified as TL +import Data.Time +import Yesod.Core +import Yesod.WebSockets +{-# ANN type App ("HLint: ignore Use newtype instead of data" :: String) #-} data App = App (TChan Text) - mkYesod "App" [parseRoutes| / HomeR GET |] diff --git a/keter.cabal b/keter.cabal index c7ba3256..346a43ce 100644 --- a/keter.cabal +++ b/keter.cabal @@ -12,7 +12,6 @@ description: 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 @@ -29,56 +28,57 @@ flag 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.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 + , 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.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 + , 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 if impl(ghc <7.6) build-depends: ghc-prim @@ -109,52 +109,56 @@ library 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 + + 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 diff --git a/nix/pin.nix b/nix/pin.nix deleted file mode 100644 index b4c6855e..00000000 --- a/nix/pin.nix +++ /dev/null @@ -1,6 +0,0 @@ -import (builtins.fetchGit { - # Descriptive name to make the store path easier to identify - name = "nixos-pin-2024.06.26"; - url = "https://github.com/nixos/nixpkgs/"; - rev = "00ba4c2c35f5e450f28e13e931994c730df05563"; - }) diff --git a/nix/pkgs.nix b/nix/pkgs.nix deleted file mode 100644 index 8c09d33e..00000000 --- a/nix/pkgs.nix +++ /dev/null @@ -1,17 +0,0 @@ -import ./pin.nix { - config = { - - packageOverrides = pkgs: - let lib = pkgs.haskell.lib; - in - { - - haskell = pkgs.lib.recursiveUpdate pkgs.haskell { - packageOverrides = hpNew: hpOld: { - keter = hpNew.callPackage ../default.nix {}; - stm-lifted = lib.doJailbreak (lib.markUnbroken hpOld.stm-lifted); - }; - }; - }; - }; -} diff --git a/packaging/README.md b/packaging/README.md index cb2f671f..a75067b1 100644 --- a/packaging/README.md +++ b/packaging/README.md @@ -14,14 +14,17 @@ But will try to install the other dependencies on it's own. 2. Extract 3. Run the packaging script. + ```{sh} keter $ cd packaging keter/packaging $ ./mkketerdeb.sh ``` - This should produce a `.deb` file in the `keter-X.Y.Z` folder. + + This should produce a `.deb` file in the `keter-X.Y.Z` folder. *Note*: if the above command fails, try running it again. -## Building libgmp if not avaiable. +## Building libgmp if not avaiable -Similarly to building keter, `mklibgmp10deb.sh` can be used to build a `.deb` package of `libgmp10` on which keter depends. -This should only be necessary for *Debian __6__*. +Similarly to building keter, `mklibgmp10deb.sh` can be used to build a `.deb` +package of `libgmp10` on which keter depends. This should only be necessary for +*Debian __6__*. diff --git a/shell.nix b/shell.nix deleted file mode 100644 index 703dc5e7..00000000 --- a/shell.nix +++ /dev/null @@ -1,16 +0,0 @@ -{ pkgs ? import ./nix/pkgs.nix, ... }: -pkgs.haskellPackages.shellFor { - packages = ps : [ ps.keter ]; - # this is to build the examples from incoming - extraDependencies = ps: { - libraryHaskellDepends = [ - ps.yesod-websockets - ps.yesod-core - ps.stm-lifted - ]; - }; - buildInputs = [ - pkgs.cabal-install - pkgs.haskellPackages.hasktags - ]; -} diff --git a/src/Keter/Aeson/KeyHelper.hs b/src/Keter/Aeson/KeyHelper.hs index 3da02223..d1afbbf1 100644 --- a/src/Keter/Aeson/KeyHelper.hs +++ b/src/Keter/Aeson/KeyHelper.hs @@ -1,33 +1,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE NoImplicitPrelude #-} --- | Utilities for dealing with Aeson version update +-- | Utilities for dealing with Aeson version update 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 diff --git a/src/Keter/App.hs b/src/Keter/App.hs index ba7c14c1..7f1f371b 100644 --- a/src/Keter/App.hs +++ b/src/Keter/App.hs @@ -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 @@ module Keter.App , 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 @@ data App = App , 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 @@ showApp App{..} = do 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 :: AppId 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 @@ withReservations aid bconfig f = do 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 @@ withActions bconfig f = 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 @@ appLogName (AINamed x) = "app-" <> unpack x 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,12 @@ withLogger aid (Just var) f = do AppStartConfig{..} <- ask mappLogger <- liftIO $ readTVarIO var case mappLogger of - Nothing -> withRunInIO $ \rio -> + Nothing -> withRunInIO $ \rio -> bracketOnError (Log.createLoggerViaConfig ascKeterConfig (appLogName aid)) Log.loggerClose (rio . f var) 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 +274,7 @@ start aid input = asc@AppStartConfig{..} <- ask liftIO $ mapM_ ensureAlive runningWebapps withMappedConfig (const ascHostManager) $ activateApp aid actions - liftIO $ + liftIO $ App <$> newTVarIO mmodtime <*> newTVarIO runningWebapps @@ -309,8 +303,8 @@ withWebApps :: AppId -> ([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 +341,6 @@ launchWebApp aid BundleConfig {..} mdir appLogger WebAppConfig {..} f = do , Map.singleton "APPROOT" $ scheme <> CI.original waconfigApprootHost <> pack extport ] exec <- liftIO $ canonicalizePath waconfigExec - mainLogger <- askLoggerIO withRunInIO $ \rio -> bracketOnError (rio $ monitorProcess ascProcessTracker @@ -408,7 +401,7 @@ ensureAlive RunningWebApp {..} = do 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 +414,10 @@ ensureAlive RunningWebApp {..} = do 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 +428,14 @@ withBackgroundApps :: AppId -> ([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 +465,6 @@ launchBackgroundApp aid BundleConfig {..} mdir appLogger BackgroundConfig {..} f (count + 1, count < maxCount) when res delay return res - mainLogger <- askLoggerIO withRunInIO $ \rio -> bracketOnError (rio $ monitorProcess ascProcessTracker @@ -619,7 +611,7 @@ start tf muid processTracker portman plugins appLogger appname bundle removeFrom 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 +620,7 @@ reload input = do 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 +634,7 @@ reload input = do 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 +661,7 @@ terminate = do 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 +671,13 @@ terminateHelper :: AppId -> 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 +695,7 @@ getTimestamp :: App -> STM (Maybe EpochTime) 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. diff --git a/src/Keter/AppManager.hs b/src/Keter/AppManager.hs index 9ff311c0..0a98e38e 100644 --- a/src/Keter/AppManager.hs +++ b/src/Keter/AppManager.hs @@ -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 @@ module Keter.AppManager , 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 @@ data AppState = ASRunning App | 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 @@ showAppState ASTerminated = pure "terminated" 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 @@ initialize = do 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 @@ getAllApps AppManager {..} = atomically $ do 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 @@ performNoLock aid action = do 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 @@ launchWorker appid tstate tmnext mcurrentApp0 action0 = 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 @@ launchWorker appid tstate tmnext mcurrentApp0 action0 = 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 @@ launchWorker appid tstate tmnext mcurrentApp0 action0 = 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 diff --git a/src/Keter/Cli.hs b/src/Keter/Cli.hs index fe83b176..446a8dea 100644 --- a/src/Keter/Cli.hs +++ b/src/Keter/Cli.hs @@ -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 @@ data CliStates = MkCliStates 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 @@ open addr = do 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 :: Socket -> KeterM CliStates b 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 @@ talk conn = do 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 diff --git a/src/Keter/Common.hs b/src/Keter/Common.hs index 044d0f7d..e1d59e2a 100644 --- a/src/Keter/Common.hs +++ b/src/Keter/Common.hs @@ -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)] } diff --git a/src/Keter/Conduit/Process/Unix.hs b/src/Keter/Conduit/Process/Unix.hs index ecaf75db..3b5c0de9 100644 --- a/src/Keter/Conduit/Process/Unix.hs +++ b/src/Keter/Conduit/Process/Unix.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE CPP #-} +{-# 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,54 +22,80 @@ module Keter.Conduit.Process.Unix , 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) @@ -79,22 +106,22 @@ processHandleMVar (ProcessHandle m _) = m 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 +197,7 @@ trackProcess pt ph = mask_ $ do 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) @@ -243,12 +271,12 @@ forkExecuteLog cmd args menv mwdir mstdin log = bracketOnError } 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 +299,7 @@ forkExecuteLog cmd args menv mwdir mstdin log = bracketOnError , S8.pack $ show h , "\n\n" ] + _ -> error "Not implemented" return p_ data Status = NeedsRestart | NoRestart | Running ProcessHandle @@ -291,43 +320,41 @@ monitorProcess processTracker msetuid exec dir args env' rlog shouldRestart = 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) diff --git a/src/Keter/Config.hs b/src/Keter/Config.hs index 725dba25..7836dddd 100644 --- a/src/Keter/Config.hs +++ b/src/Keter/Config.hs @@ -4,23 +4,23 @@ module Keter.Config ( 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(..) + ) diff --git a/src/Keter/Config/Middleware.hs b/src/Keter/Config/Middleware.hs index 4f407099..8739c37c 100644 --- a/src/Keter/Config/Middleware.hs +++ b/src/Keter/Config/Middleware.hs @@ -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 @@ instance FromJSON MiddlewareConfig where 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 @@ instance ToJSON MiddlewareConfig where ] 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 Jsonp = jsonp 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 : diff --git a/src/Keter/Config/V04.hs b/src/Keter/Config/V04.hs index 2231cdd4..3fb8c489 100644 --- a/src/Keter/Config/V04.hs +++ b/src/Keter/Config/V04.hs @@ -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 @@ data BundleConfig = BundleConfig 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 @@ data PortSettings = PortSettings { 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 @@ defaultPortSettings = PortSettings } instance FromJSON PortSettings where - parseJSON = withObject "PortSettings" $ \_ -> PortSettings - <$> return (portRange defaultPortSettings) + parseJSON = withObject "PortSettings" $ \_ -> + return (PortSettings (portRange defaultPortSettings)) diff --git a/src/Keter/Config/V10.hs b/src/Keter/Config/V10.hs index 2bdff432..b2d92b08 100644 --- a/src/Keter/Config/V10.hs +++ b/src/Keter/Config/V10.hs @@ -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 @@ instance ToCurrent BundleConfig where 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 ] diff --git a/src/Keter/Context.hs b/src/Keter/Context.hs index 6035e3a9..f2d18dca 100644 --- a/src/Keter/Context.hs +++ b/src/Keter/Context.hs @@ -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 @@ newtype KeterM cfg a = KeterM { runKeterM :: LoggingT (ReaderT cfg IO) a } 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 diff --git a/src/Keter/HostManager.hs b/src/Keter/HostManager.hs index 58d3aa36..8d162b55 100644 --- a/src/Keter/HostManager.hs +++ b/src/Keter/HostManager.hs @@ -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 @@ module Keter.HostManager , 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 @@ reserveHosts :: AppId -> 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 @@ reserveHosts aid hosts = do (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 @@ forgetReservations :: AppId -> 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, ()) diff --git a/src/Keter/LabelMap.hs b/src/Keter/LabelMap.hs index 2a259aa0..f1390614 100644 --- a/src/Keter/LabelMap.hs +++ b/src/Keter/LabelMap.hs @@ -1,6 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} module Keter.LabelMap ( -- * Types LabelMap @@ -12,14 +12,14 @@ module Keter.LabelMap , 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 (Assigned e _) = Just e 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 @@ insertTree (l:ls) e (WildcardExcept w t) = 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 @@ cleanup m@(WildcardExcept w t) = (_, 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 @@ deleteTree (l:ls) (WildcardExcept w t) = cleanup $ 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 [] _ = Nothing 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 @@ lookupTree (l:ls) (WildcardExcept w t) = -- 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" diff --git a/src/Keter/Logger.hs b/src/Keter/Logger.hs index 103133e9..c4f077e5 100644 --- a/src/Keter/Logger.hs +++ b/src/Keter/Logger.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} module Keter.Logger ( Logger(..) , createLoggerViaConfig @@ -9,23 +9,17 @@ module Keter.Logger , 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 } diff --git a/src/Keter/Main.hs b/src/Keter/Main.hs index 8a9a95c0..5797ea9d 100644 --- a/src/Keter/Main.hs +++ b/src/Keter/Main.hs @@ -1,71 +1,64 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} module Keter.Main ( keter ) where +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 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 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) -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) +import Filesystem.Path qualified as FP (FilePath) +import Filesystem.Path.CurrentOS (encodeString) #endif -import Keter.Cli -import Keter.Context keter :: FilePath -- ^ root directory or config file -> [FilePath -> IO Plugin] @@ -73,15 +66,15 @@ keter :: FilePath -- ^ root directory or config file 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 +100,15 @@ runKeterConfigReader input ctx = do 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 +160,7 @@ withManagers mkPlugins f = do , 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 +183,7 @@ isKeter fp = takeExtension fp == ".keter" 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 @@ -214,7 +207,7 @@ startWatching appMan = do 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)) @@ -246,11 +239,10 @@ listDirectoryTree fp = do 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 diff --git a/src/Keter/Plugin/Postgres.hs b/src/Keter/Plugin/Postgres.hs index c929ecec..249ff0db 100644 --- a/src/Keter/Plugin/Postgres.hs +++ b/src/Keter/Plugin/Postgres.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} + module Keter.Plugin.Postgres ( -- * Settings Settings @@ -9,64 +10,58 @@ module Keter.Plugin.Postgres , 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 @@ data DBServerInfo = DBServerInfo 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 @@ load Settings{..} fp = do _ -> 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 @@ load Settings{..} fp = do 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 diff --git a/src/Keter/PortPool.hs b/src/Keter/PortPool.hs index facdce05..8c0095fa 100644 --- a/src/Keter/PortPool.hs +++ b/src/Keter/PortPool.hs @@ -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 @@ module Keter.PortPool , 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 @@ getPort (PortPool mstate) = 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) diff --git a/src/Keter/Proxy.hs b/src/Keter/Proxy.hs index cc39f88d..df8a360b 100644 --- a/src/Keter/Proxy.hs +++ b/src/Keter/Proxy.hs @@ -1,8 +1,9 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + -- | A light-weight, minimalistic reverse HTTP proxy. module Keter.Proxy ( reverseProxy @@ -11,83 +12,69 @@ module Keter.Proxy , 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 +145,7 @@ connectClientCertificates hl session s = 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? diff --git a/src/Keter/Rewrite.hs b/src/Keter/Rewrite.hs index fbc46dc7..fd6e12c1 100644 --- a/src/Keter/Rewrite.hs +++ b/src/Keter/Rewrite.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} + module Keter.Rewrite ( ReverseProxyConfig (..) , RewriteRule (..) @@ -9,41 +10,32 @@ module Keter.Rewrite ) 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 +43,7 @@ data RPEntry = RPEntry } 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 +64,7 @@ rewrite (before, match, after) input replacement = } <|> 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 } @@ -190,18 +182,6 @@ instance ToJSON ReverseProxyConfig where , "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 , ruleRegex :: Text diff --git a/src/Keter/TempTarball.hs b/src/Keter/TempTarball.hs index c424b2a0..34b3dac5 100644 --- a/src/Keter/TempTarball.hs +++ b/src/Keter/TempTarball.hs @@ -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 @@ module Keter.TempTarball , 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 @@ unpackTempTar muid tf bundle appname withDir = do 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 diff --git a/src/Keter/Yaml/FilePath.hs b/src/Keter/Yaml/FilePath.hs index bb7ec3c7..2a759b6b 100644 --- a/src/Keter/Yaml/FilePath.hs +++ b/src/Keter/Yaml/FilePath.hs @@ -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 @@ module Keter.Yaml.FilePath ) 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 @@ class ParseYamlFile a where 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 diff --git a/src/main/keter.hs b/src/main/keter.hs index 4f35143b..c04cbec8 100644 --- a/src/main/keter.hs +++ b/src/main/keter.hs @@ -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 () diff --git a/stack.yaml.lock b/stack.yaml.lock index 50e78f5a..1b9f111c 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,19 +5,26 @@ packages: - completed: - hackage: tar-0.6.2.0@sha256:619828cae098a7b6deeb0316e12f55011101d88f756787ed024ceedb81cf1eba,4576 pantry-tree: sha256: 1dde50961e9d1a6e6f820d918c0edbbd9673c83afdd300e0aae40a691e8151df size: 2168 + hackage: tar-0.6.2.0@sha256:619828cae098a7b6deeb0316e12f55011101d88f756787ed024ceedb81cf1eba,4576 original: hackage: tar-0.6.2.0@sha256:619828cae098a7b6deeb0316e12f55011101d88f756787ed024ceedb81cf1eba,4576 - completed: - hackage: os-string-2.0.2.1@sha256:0bf4ff8f387d7fd05a43c18fa677dd02259c99d63c2d02c5823f152736513bef,3261 pantry-tree: sha256: caa0b78b83a9d429324784e239c9bf33017f9f4a3c34ec8392b3d8a1e8968bd6 size: 2217 + hackage: os-string-2.0.2.1@sha256:0bf4ff8f387d7fd05a43c18fa677dd02259c99d63c2d02c5823f152736513bef,3261 original: hackage: os-string-2.0.2.1@sha256:0bf4ff8f387d7fd05a43c18fa677dd02259c99d63c2d02c5823f152736513bef,3261 +- completed: + pantry-tree: + sha256: 12f171b8932de1a2a1a2a0bbc28fda9315509c2c85873260eec61c697ee118ec + size: 388 + hackage: http-reverse-proxy-0.6.1.0@sha256:5bc151ed0c22e8493a7bb5e6e1a5de51fff0450f47733e9bc5044aaafdf7dac6,2542 + original: + hackage: http-reverse-proxy-0.6.1.0@sha256:5bc151ed0c22e8493a7bb5e6e1a5de51fff0450f47733e9bc5044aaafdf7dac6,2542 snapshots: - completed: sha256: 5a59b2a405b3aba3c00188453be172b85893cab8ebc352b1ef58b0eae5d248a2 diff --git a/test/Spec.hs b/test/Spec.hs index 201eb9ae..0419737d 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 :: IO () 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 @@ headThenPostNoCrash = do where content :: ByteString content = "a" - + -- For 'reverseProxy', only exceptions (and strictly exceptions!) are logged as LevelError. isException :: LogSource -> LogLevel -> Bool isException _ LevelError = True