5483bf2 · obelisk · git.iko.soy

git.iko.soy/obelisk

on master help sign in

Merge remote-tracking branch 'origin/develop' into use-android-deploy-script

5483bf2Matthew Bauer7 years ago

.github/pull_request_template.mdnew file+8

compare with master

unifiedsplit

@@ -0,0 +1,8 @@

1+

3+I have:

5+ - [ ] Based work on latest `develop` branch

6+ - [ ] Looked for lint in my changes with `hlint .` (lint found code you did not write can be left alone)

7+ - [ ] Run the test suite: `$(nix-build -A selftest --no-out-link)`

8+ - [ ] (Optional) Run CI tests locally: `nix-build release.nix -A build.x86_64-linux --no-out-link` (or `x86_64-darwin` on macOS)

.gitignore+1

@@ -2,6 +2,7 @@

2**/.cabal-sandbox

3**/cabal.sandbox.config

4result

5+result-*

5*.o

6*.o

6*.hi

7*.hi

7TAGS

8TAGS

.hlint.yamlnew file+65

@@ -0,0 +1,65 @@

1+# HLint configuration file

2+# https://github.com/ndmitchell/hlint

3+##########################

5+# This file contains a template configuration file, which is typically

6+# placed as .hlint.yaml in the root of your project

9+# Specify additional command line arguments

10+#

11+# - arguments: [--color, --cpp-simple, -XQuasiQuotes]

12+

13+

14+# Control which extensions/flags/modules/functions can be used

15+#

16+# - extensions:

17+# - default: false # all extension are banned by default

18+# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used

19+# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module

20+#

21+# - flags:

22+# - {name: -w, within: []} # -w is allowed nowhere

23+#

24+# - modules:

25+# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'

26+# - {name: Control.Arrow, within: []} # Certain modules are banned entirely

27+#

28+# - functions:

29+# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules

30+

31+

32+# Add custom hints for this project

33+#

34+# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"

35+# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}

36+

37+

38+# Turn on hints that are off by default

39+#

40+# Ban "module X(module X) where", to require a real export list

41+# - warn: {name: Use explicit module export list}

42+#

43+# Replace a $ b $ c with a . b $ c

44+# - group: {name: dollar, enabled: true}

45+#

46+# Generalise map to fmap, ++ to <>

47+# - group: {name: generalise, enabled: true}

48+

49+

50+# Ignore some builtin hints

51+- ignore: {name: Redundant do}

52+- ignore: {name: Redundant flip}

53+- ignore: {name: Use <$>}

54+- ignore: {name: Use camelCase}

55+- ignore: {name: Use if}

56+- ignore: {name: Use unless}

57+# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules

58+

59+

60+# Define some custom infix operators

61+# - fixity: infixr 3 ~^#^~

62+

63+

64+# To generate a suitable file for HLint do:

65+# $ hlint --default > .hlint.yaml

ChangeLog.md+44−9

@@ -4,19 +4,54 @@ This project's release branch is `master`. This log is written from the perspect

5## Unreleased

7+* Fix a bug in `Obelisk.Route.Frontend` where `routeLink`, `routeLinkDynAttr`, and `dynRouteLink` would not behave exactly like `<a href="...">` when run by JavaScript. These functions now scroll to the top of the page when the link is clicked. ([#540](https://github.com/obsidiansystems/obelisk/pull/540))

8+* Fix a bug in `ob run`/`ob watch`/`ob repl` where nested Obelisk projects would also be loaded into the session. These are now ignored. ([#652](https://github.com/obsidiansystems/obelisk/pull/652))

9+* Improve behavior of `ob run`/`ob watch`/`ob repl` when multiple packages with the same name are encountered. Obelisk now issues a warning and tells you which one it will use. ([#653](https://github.com/obsidiansystems/obelisk/pull/653))

10+* Removed `Obelisk.Backend.mkRouteToUrl` since it is easily written in terms of `Obelisk.Route.renderObeliskRoute`:

11+

12+ mkRouteToUrl validFullEncoder (k :/ v) = renderObeliskRoute validFullEncoder (FullRoute_Frontend (ObeliskRoute_App k) :/ v)

13+

14+* Added `Obelisk.Backend.renderAllJsPath` to expose URL path to `ghcjs/all.js`.

15+* Added argument to `serveDefaultObeliskApp`, `serveObeliskApp`, and `serveGhcjsApp` to take the path to `all.js` instead of hard-coding it.

16+

17+## v0.5.0.0 - 2020-02-07

18+

19+* Add `Obelisk.Route.(?/)`, a convenience function for constructing routes nested in `Maybe`. ([#457](https://github.com/obsidiansystems/obelisk/pull/457))

20+* Add local unpacked packages to the `ob run`, `ob watch`, and `ob repl` sessions. Any `.cabal` or hpack package inside the current obelisk project will be loaded into the session. For `ob run`/`ob watch` this means the session will automatically reload when you save a source file in any of those packages. For `ob repl` it means that `:r` will reload changes to any of those packages. There are some edge cases where this integration is still rough. Report any issues you encounter. ([#489](https://github.com/obsidiansystems/obelisk/pull/489))

21+* Add `ob hoogle` command to start a local [Hoogle](https://hoogle.haskell.org/) server for the project. ([#628](https://github.com/obsidiansystems/obelisk/pull/628))

22+* `ob thunk pack` will now attempt to automatically detect if the thunk is a private or public repo. To avoid this detection, specify `--private` or `--public` manually. ([#607](https://github.com/obsidiansystems/obelisk/pull/607))

23+* Fix a bug in the plain git thunk loader for thunks marked as 'private' when the revision is not in the default branch. ([#648](https://github.com/obsidiansystems/obelisk/pull/648))

24+* Improve handling of runtime nix dependencies. This may fix some issues encountered particularly by users on systems other than NixOS.

25+

26+## v0.4.0.0 - 2020-01-10

27+

28+* Bump reflex-platform which, notably, bumps nixpkgs to 19.09. ([#585](https://github.com/obsidiansystems/obelisk/pull/585))

29+* Add new thunk loader for Git repositories that supports `file://` Git remotes and supports private repositories via `builtins.fetchGit` for private repositories (when the `git.json` file specifies `"private": true`). ([#594](https://github.com/obsidiansystems/obelisk/pull/594))

30+* Add a new thunk loader for GitHub repositories that uses `builtins.fetchTarball` for public repositories to increase loader performance and uses `fetchFromGitHub` for private repositories (when the `github.json` file specifies `"private": true`). Note that `fetchFromGitHub` requires some Nix configuration for the Nix builder to access the repository. If `ob thunk pack` fails in this case, use `-v` to see Nix's helpful message. ([#594](https://github.com/obsidiansystems/obelisk/pull/594))

31+* Add `--public`/`--private` options to `ob thunk pack` to specify if a repository should be treated as a public or private. ([#594](https://github.com/obsidiansystems/obelisk/pull/594))

32+* Improve error messaging when a dependency doesn't have the expected `.cabal` or `package.yaml` file. ([#597](https://github.com/obsidiansystems/obelisk/pull/597))

33+* Improve the skeleton in small ways. ([#593](https://github.com/obsidiansystems/obelisk/pull/593), [#589](https://github.com/obsidiansystems/obelisk/pull/589))

34+* Fix `ob` commands to again support running from any subdirectory of an obelisk project ([#591](https://github.com/obsidiansystems/obelisk/pull/591))

35+* Add `reflex-platform-func` argument to Obelisk's `default.nix`. It defaults to it's prior behavior of using the reflex-platform in in `dep`. ([#612](https://github.com/obsidiansystems/obelisk/pull/612))

36+

37+## v0.3.0.0 - 2019-12-20

38+

7−* Generalised pathSegmentEncoder, added pathFieldEncoder.

39+* Generalised `pathSegmentEncoder`, added `pathFieldEncoder`.

8−* Added some Prisms to the encoder library for manipulating DSums (perhaps they should get moved to dependent-sum before release?)

40+* Added some `Prism`s to the encoder library for manipulating `DSum`s.

9−* Add "ob doc" command, which lists paths to haddock documentation for specified packages

41+* Add `ob doc` command, which lists paths to haddock documentation for specified packages.

10−* Bump reflex-platform so that obelisk now uses GHC 8.6.5 and the nixos-19.03 nixpkgs set

42+* Bump reflex-platform so that obelisk now uses GHC 8.6.5 and the nixos-19.03 nixpkgs set.

11−* Add support in obelisk-route for single parameters in URL paths

43+* Add support in `obelisk-route` for single parameters in URL paths.

12−* Bump reflex-platform so that obelisk now uses reflex-dom 0.5.2.0

44+* Bump reflex-platform so that obelisk now uses reflex-dom 0.5.2.0.

13* Use a `--pure` nix shell in `ob run` for parity with `ob repl` and more resilience against "works on my machine".

45* Use a `--pure` nix shell in `ob run` for parity with `ob repl` and more resilience against "works on my machine".

14−* Use `--keep NIX_PATH` for all pure shells so references to `<nixpkgs>` continues to work.

46+* Pin usages of `<nixpkgs>` in obelisk thunks, etc. to the nixpkgs used by the project's obelisk impl.

15* Backport ACMEv2 support in obelisk server to regain LetsEncrypt account creation.

47* Backport ACMEv2 support in obelisk server to regain LetsEncrypt account creation.

16−* Enable https in `ob run`

48+* Enable HTTPS in `ob run`.

17−* `ob run` now handles ghci errors better, and includes a custom ghcid

49+* `ob run` now handles `ghci` errors better, and includes a custom `ghcid`

18 version. As a result, you no longer need to have ghcid installed to

50 version. As a result, you no longer need to have ghcid installed to

19 use `ob run`, as we provide one for you.

51 use `ob run`, as we provide one for you.

52+* `ob` commands now complain less on systems with umasks other than `0022`.

53+* Ignore package environment files in `ob run` and `ob repl`.

54+* Add `Obelisk.Route.Frontend.routeLinkDynAttr`.

21## v0.2.0.0 - 2019-8-17

56## v0.2.0.0 - 2019-8-17

FAQ.md+1−1

@@ -81,7 +81,7 @@ project's dependencies and,

81Assuming we are in a project created with `ob init`, `ob run` calls (see

82`lib/command/src/Obelisk/Command.hs`):

84− nix-shell --pure --keep NIX_PATH -A shells.ghc --run 'ob --no-handoff internal run-static-io <real-run-function>'

84+ nix-shell --pure -A shells.ghc --run 'ob --no-handoff internal run-static-io <real-run-function>'

86where

LICENSEnew file+30

@@ -0,0 +1,30 @@

5+Redistribution and use in source and binary forms, with or without

6+modification, are permitted provided that the following conditions are met:

8+ * Redistributions of source code must retain the above copyright

9+ notice, this list of conditions and the following disclaimer.

10+

11+ * Redistributions in binary form must reproduce the above

12+ copyright notice, this list of conditions and the following

13+ disclaimer in the documentation and/or other materials provided

14+ with the distribution.

15+

16+ * Neither the name of Elliot Cameron nor the names of other

17+ contributors may be used to endorse or promote products derived

18+ from this software without specific prior written permission.

19+

20+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

21+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

22+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

23+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

24+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

25+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

26+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

27+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

28+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

29+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

30+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README.md+29−14

@@ -1,10 +1,13 @@

1# Obelisk

3+[![Haskell Programming Language](https://img.shields.io/badge/language-Haskell-blue.svg)](http://www.haskell.org)

4+[![BSD3 License](http://img.shields.io/badge/license-BSD3-brightgreen.svg)](https://tldrlegal.com/license/bsd-3-clause-license-%28revised%29)

3Obelisk provides an easy way to develop and deploy your [Reflex](https://github.com/reflex-frp/reflex) project as web apps and as mobile apps.

7Obelisk provides an easy way to develop and deploy your [Reflex](https://github.com/reflex-frp/reflex) project as web apps and as mobile apps.

5- [Installing Obelisk](#installing-obelisk)

9- [Installing Obelisk](#installing-obelisk)

6- [Developing an Obelisk project](#developing-an-obelisk-project)

10- [Developing an Obelisk project](#developing-an-obelisk-project)

7− - [Hoogle](#hoogle)

8 - [Adding Packages](#adding-packages)

11 - [Adding Packages](#adding-packages)

9 - [Adding Package Overrides](#adding-package-overrides)

12 - [Adding Package Overrides](#adding-package-overrides)

10 - [Running over https](#running-over-https)

13 - [Running over https](#running-over-https)

@@ -23,14 +26,15 @@ Obelisk provides an easy way to develop and deploy your [Reflex](https://github.

231. Set up nix caches

261. Set up nix caches

24 1. If you are running NixOS, add this to `/etc/nixos/configuration.nix`:

27 1. If you are running NixOS, add this to `/etc/nixos/configuration.nix`:

25 ```

28 ```

26− nix.binaryCaches = [ "https://cache.nixos.org/" "https://nixcache.reflex-frp.org" ];

29+ nix.binaryCaches = [ "https://nixcache.reflex-frp.org" ];

27 nix.binaryCachePublicKeys = [ "ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=" ];

30 nix.binaryCachePublicKeys = [ "ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=" ];

28 ```

31 ```

29 and rebuild your NixOS configuration (e.g. `sudo nixos-rebuild switch`).

32 and rebuild your NixOS configuration (e.g. `sudo nixos-rebuild switch`).

30 1. If you are using another operating system or linux distribution, ensure that these lines are present in your Nix configuration file (`/etc/nix/nix.conf` on most systems; [see full list](https://nixos.org/nix/manual/#sec-conf-file)):

33 1. If you are using another operating system or linux distribution, ensure that these lines are present in your Nix configuration file (`/etc/nix/nix.conf` on most systems; [see full list](https://nixos.org/nix/manual/#sec-conf-file)):

31 ```

34 ```

32− substituters = https://cache.nixos.org https://nixcache.reflex-frp.org

35+ binary-caches = https://cache.nixos.org https://nixcache.reflex-frp.org

33− trusted-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=

36+ binary-cache-public-keys = cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= ryantrinkle.com-1:JJiAKaRv9mWgpVAz8dwewnZe0AzzEAzPkagE9SP5NWI=

37+ binary-caches-parallel-connections = 40

34 ```

38 ```

35 * other Linux: enable sandboxing (see these [issue172](https://github.com/obsidiansystems/obelisk/issues/172#issuecomment-411507818) or [issue6](https://github.com/obsidiansystems/obelisk/issues/6) if you run into build problems)

39 * other Linux: enable sandboxing (see these [issue172](https://github.com/obsidiansystems/obelisk/issues/172#issuecomment-411507818) or [issue6](https://github.com/obsidiansystems/obelisk/issues/6) if you run into build problems)

36 ```

40 ```

@@ -69,8 +73,8 @@ nix-env -f /path/to/obelisk -iA command

69Note that `ob` will defer to the version found in your project's `.obelisk/impl` directory. To update that version specifically:

73Note that `ob` will defer to the version found in your project's `.obelisk/impl` directory. To update that version specifically:

71```shell

75```shell

72−ob thunk unpack ./obelisk/impl

76+ob thunk unpack ./.obelisk/impl

73−cd ./obelisk/impl

77+cd ./.obelisk/impl

74# apply your changes

78# apply your changes

75```

79```

@@ -111,12 +115,6 @@ Firefox will not be able to properly run the development website due to [issue 4

111

115

112Every time you change the Haskell source files in frontend, common or backend, `ob run` will automatically recompile the modified files and reload the server. Furthermore, it will display on screen compilation errors and warnings if any.

116Every time you change the Haskell source files in frontend, common or backend, `ob run` will automatically recompile the modified files and reload the server. Furthermore, it will display on screen compilation errors and warnings if any.

113

117

114−### Hoogle

115−

116−To enter a nix-shell from which you can run the hoogle command-line client or a hoogle server for your project:

117−

118−`nix-shell -A shells.ghc --arg withHoogle true`

119−

120### Adding packages

118### Adding packages

121

119

122In order to add package dependencies, declare them under the build-depends field in the appropriate cabal files (backend, common, and frontend each have their own). The corresponding Nix packages will automatically be selected when building.

120In order to add package dependencies, declare them under the build-depends field in the appropriate cabal files (backend, common, and frontend each have their own). The corresponding Nix packages will automatically be selected when building.

@@ -150,9 +148,26 @@ project ./. ({ pkgs, ... }: {

150

148

151For further information see [the Haskell section](https://nixos.org/nixpkgs/manual/#users-guide-to-the-haskell-infrastructure) of nixpkgs Contributors Guide.

149For further information see [the Haskell section](https://nixos.org/nixpkgs/manual/#users-guide-to-the-haskell-infrastructure) of nixpkgs Contributors Guide.

152

150

151+### Adding extra local packages

152+

153+If the standard packages (`frontend`, `backend`, and `common`) are not

154+enough, to add more local Haskell packages, define them with the

155+`packages` parameter. The sources of these packages will be

156+automatically reloaded by `ob run`.

157+

158+```nix

159+# ...

160+project ./. ({ pkgs, ... }: {

161+# ...

162+ packages = {

163+ another = ./another;

164+ };

165+# ...

166+```

167+

153### Running over https

168### Running over https

154

169

155−To run your app locally over https, update the protocol in `config/common/route` to `https`, and then use `ob run` as normal.

170+To run your app locally over https, update the protocol in `config/common/route` to `https`, and then use `ob run` as normal.

156

171

157Since Obelisk generates a self-signed certificate for running https, the browser will issue a warning about using an invalid certificate. On Chrome, you can go to `chrome://flags/#allow-insecure-localhost` to enable invalid certificates for localhost.

172Since Obelisk generates a self-signed certificate for running https, the browser will issue a warning about using an invalid certificate. On Chrome, you can go to `chrome://flags/#allow-insecure-localhost` to enable invalid certificates for localhost.

158

173

@@ -181,7 +196,7 @@ In this section we will demonstrate how to deploy your Obelisk app to an Amazon

181

196

182First create a new EC2 instance:

197First create a new EC2 instance:

183

198

184−1. Launch a NixOS 18.09 EC2 instance (we recommend [this AMI](https://console.aws.amazon.com/ec2/v2/home?region=us-east-1#LaunchInstanceWizard:ami=ami-009c9c3f1af480ff3))

199+1. Launch a NixOS 19.09 EC2 instance (we recommend [this AMI](https://console.aws.amazon.com/ec2/v2/home?region=us-east-1#LaunchInstanceWizard:ami=ami-00a8eeaf232a74f84))

1851. In the instance configuration wizard ensure that your instance has at least 1GB RAM and 10GB disk space.

2001. In the instance configuration wizard ensure that your instance has at least 1GB RAM and 10GB disk space.

1861. When prompted save your AWS private key (`~/myaws.pem`) somewhere safe. We'll need it later during deployment.

2011. When prompted save your AWS private key (`~/myaws.pem`) somewhere safe. We'll need it later during deployment.

1871. Go to "Security Groups", select your instance's security group and under "Inbound" tab add a new rule for HTTP port 80 and 443.

2021. Go to "Security Groups", select your instance's security group and under "Inbound" tab add a new rule for HTTP port 80 and 443.

acme.nixdeleted−397

@@ -1,397 +0,0 @@

1−### COPIED FROM

2−### https://github.com/NixOS/nixpkgs/blob/1d36ad6d16dbf1d3937f899a087a4360332eb141/nixos/modules/security/acme.nix

3−###

4−### to support new plugins in simp_le for ACMEv2 support.

5−### Changed lines are marked with a comment: ### CHANGED

6−

7−{ config, lib, pkgs, ... }:

8−

9−with lib;

10−

11−let

12−

13− cfg = config.security.acme;

14−

15− certOpts = { name, ... }: {

16− options = {

17− webroot = mkOption {

18− type = types.str;

19− example = "/var/lib/acme/acme-challenges";

20− description = ''

21− Where the webroot of the HTTP vhost is located.

22− <filename>.well-known/acme-challenge/</filename> directory

23− will be created below the webroot if it doesn't exist.

24− <literal>http://example.org/.well-known/acme-challenge/</literal> must also

25− be available (notice unencrypted HTTP).

26− '';

27− };

28−

29− domain = mkOption {

30− type = types.str;

31− default = name;

32− description = "Domain to fetch certificate for (defaults to the entry name)";

33− };

34−

35− email = mkOption {

36− type = types.nullOr types.str;

37− default = null;

38− description = "Contact email address for the CA to be able to reach you.";

39− };

40−

41− user = mkOption {

42− type = types.str;

43− default = "root";

44− description = "User running the ACME client.";

45− };

46−

47− group = mkOption {

48− type = types.str;

49− default = "root";

50− description = "Group running the ACME client.";

51− };

52−

53− allowKeysForGroup = mkOption {

54− type = types.bool;

55− default = false;

56− description = ''

57− Give read permissions to the specified group

58− (<option>security.acme.cert.<name>.group</option>) to read SSL private certificates.

59− '';

60− };

61−

62− postRun = mkOption {

63− type = types.lines;

64− default = "";

65− example = "systemctl reload nginx.service";

66− description = ''

67− Commands to run after new certificates go live. Typically

68− the web server and other servers using certificates need to

69− be reloaded.

70−

71− Executed in the same directory with the new certificate.

72− '';

73− };

74−

75− plugins = mkOption {

76− type = types.listOf (types.enum [

77− "cert.der" "cert.pem" "chain.pem" "external.sh"

78− "fullchain.pem" "full.pem" "key.der" "key.pem" "account_key.json" "account_reg.json" ### CHANGED

79− ]);

80− default = [ "fullchain.pem" "full.pem" "key.pem" "account_key.json" "account_reg.json" ]; ### CHANGED

81− description = ''

82− Plugins to enable. With default settings simp_le will

83− store public certificate bundle in <filename>fullchain.pem</filename>,

84− private key in <filename>key.pem</filename> and those two previous

85− files combined in <filename>full.pem</filename> in its state directory.

86− '';

87− };

88−

89− activationDelay = mkOption {

90− type = types.nullOr types.str;

91− default = null;

92− description = ''

93− Systemd time span expression to delay copying new certificates to main

94− state directory. See <citerefentry><refentrytitle>systemd.time</refentrytitle>

95− <manvolnum>7</manvolnum></citerefentry>.

96− '';

97− };

98−

99− preDelay = mkOption {

100− type = types.lines;

101− default = "";

102− description = ''

103− Commands to run after certificates are re-issued but before they are

104− activated. Typically the new certificate is published to DNS.

105−

106− Executed in the same directory with the new certificate.

107− '';

108− };

109−

110− extraDomains = mkOption {

111− type = types.attrsOf (types.nullOr types.str);

112− default = {};

113− example = literalExample ''

114− {

115− "example.org" = "/srv/http/nginx";

116− "mydomain.org" = null;

117− }

118− '';

119− description = ''

120− A list of extra domain names, which are included in the one certificate to be issued, with their

121− own server roots if needed.

122− '';

123− };

124− };

125− };

126−

127−in

128−

129−{

130−

131− ###### interface

132−

133− options = {

134− security.acme = {

135− directory = mkOption {

136− default = "/var/lib/acme";

137− type = types.str;

138− description = ''

139− Directory where certs and other state will be stored by default.

140− '';

141− };

142−

143− validMin = mkOption {

144− type = types.int;

145− default = 30 * 24 * 3600;

146− description = "Minimum remaining validity before renewal in seconds.";

147− };

148−

149− renewInterval = mkOption {

150− type = types.str;

151− default = "weekly";

152− description = ''

153− Systemd calendar expression when to check for renewal. See

154− <citerefentry><refentrytitle>systemd.time</refentrytitle>

155− <manvolnum>7</manvolnum></citerefentry>.

156− '';

157− };

158−

159− preliminarySelfsigned = mkOption {

160− type = types.bool;

161− default = true;

162− description = ''

163− Whether a preliminary self-signed certificate should be generated before

164− doing ACME requests. This can be useful when certificates are required in

165− a webserver, but ACME needs the webserver to make its requests.

166−

167− With preliminary self-signed certificate the webserver can be started and

168− can later reload the correct ACME certificates.

169− '';

170− };

171−

172− production = mkOption {

173− type = types.bool;

174− default = true;

175− description = ''

176− If set to true, use Let's Encrypt's production environment

177− instead of the staging environment. The main benefit of the

178− staging environment is to get much higher rate limits.

179−

180− See

181− <literal>https://letsencrypt.org/docs/staging-environment</literal>

182− for more detail.

183− '';

184− };

185−

186− certs = mkOption {

187− default = { };

188− type = with types; attrsOf (submodule certOpts);

189− description = ''

190− Attribute set of certificates to get signed and renewed.

191− '';

192− example = literalExample ''

193− {

194− "example.com" = {

195− webroot = "/var/www/challenges/";

196− email = "foo@example.com";

197− extraDomains = { "www.example.com" = null; "foo.example.com" = "/var/www/foo/"; };

198− };

199− "bar.example.com" = {

200− webroot = "/var/www/challenges/";

201− email = "bar@example.com";

202− };

203− }

204− '';

205− };

206− };

207− };

208−

209− ###### implementation

210− config = mkMerge [

211− (mkIf (cfg.certs != { }) {

212−

213− systemd.services = let

214− services = concatLists servicesLists;

215− servicesLists = mapAttrsToList certToServices cfg.certs;

216− certToServices = cert: data:

217− let

218− cpath = lpath + optionalString (data.activationDelay != null) ".staging";

219− lpath = "${cfg.directory}/${cert}";

220− rights = if data.allowKeysForGroup then "750" else "700";

221− cmdline = [ "-v" "-d" data.domain "--default_root" data.webroot "--valid_min" cfg.validMin ]

222− ++ optionals (data.email != null) [ "--email" data.email ]

223− ++ concatMap (p: [ "-f" p ]) data.plugins

224− ++ concatLists (mapAttrsToList (name: root: [ "-d" (if root == null then name else "${name}:${root}")]) data.extraDomains)

225− ++ optionals (!cfg.production) ["--server" "https://acme-staging.api.letsencrypt.org/directory"];

226− acmeService = {

227− description = "Renew ACME Certificate for ${cert}";

228− after = [ "network.target" "network-online.target" ];

229− wants = [ "network-online.target" ];

230− serviceConfig = {

231− Type = "oneshot";

232− SuccessExitStatus = [ "0" "1" ];

233− PermissionsStartOnly = true;

234− User = data.user;

235− Group = data.group;

236− PrivateTmp = true;

237− };

238− path = with pkgs; [ simp_le systemd ];

239− preStart = ''

240− mkdir -p '${cfg.directory}'

241− chown 'root:root' '${cfg.directory}'

242− chmod 755 '${cfg.directory}'

243− if [ ! -d '${cpath}' ]; then

244− mkdir '${cpath}'

245− fi

246− chmod ${rights} '${cpath}'

247− chown -R '${data.user}:${data.group}' '${cpath}'

248− mkdir -p '${data.webroot}/.well-known/acme-challenge'

249− chown -R '${data.user}:${data.group}' '${data.webroot}/.well-known/acme-challenge'

250− '';

251− script = ''

252− cd '${cpath}'

253− set +e

254− simp_le ${escapeShellArgs cmdline}

255− EXITCODE=$?

256− set -e

257− echo "$EXITCODE" > /tmp/lastExitCode

258− exit "$EXITCODE"

259− '';

260− postStop = ''

261− cd '${cpath}'

262−

263− if [ -e /tmp/lastExitCode ] && [ "$(cat /tmp/lastExitCode)" = "0" ]; then

264− ${if data.activationDelay != null then ''

265−

266− ${data.preDelay}

267−

268− if [ -d '${lpath}' ]; then

269− systemd-run --no-block --on-active='${data.activationDelay}' --unit acme-setlive-${cert}.service

270− else

271− systemctl --wait start acme-setlive-${cert}.service

272− fi

273− '' else data.postRun}

274−

275− # noop ensuring that the "if" block is non-empty even if

276− # activationDelay == null and postRun == ""

277− true

278− fi

279− '';

280−

281− before = [ "acme-certificates.target" ];

282− wantedBy = [ "acme-certificates.target" ];

283− };

284− delayService = {

285− description = "Set certificate for ${cert} live";

286− path = with pkgs; [ rsync ];

287− serviceConfig = {

288− Type = "oneshot";

289− };

290− script = ''

291− rsync -a --delete-after '${cpath}/' '${lpath}'

292− '';

293− postStop = data.postRun;

294− };

295− selfsignedService = {

296− description = "Create preliminary self-signed certificate for ${cert}";

297− path = [ pkgs.openssl ];

298− preStart = ''

299− if [ ! -d '${cpath}' ]

300− then

301− mkdir -p '${cpath}'

302− chmod ${rights} '${cpath}'

303− chown '${data.user}:${data.group}' '${cpath}'

304− fi

305− '';

306− script =

307− ''

308− workdir="$(mktemp -d)"

309−

310− # Create CA

311− openssl genrsa -des3 -passout pass:xxxx -out $workdir/ca.pass.key 2048

312− openssl rsa -passin pass:xxxx -in $workdir/ca.pass.key -out $workdir/ca.key

313− openssl req -new -key $workdir/ca.key -out $workdir/ca.csr \

314− -subj "/C=UK/ST=Warwickshire/L=Leamington/O=OrgName/OU=Security Department/CN=example.com"

315− openssl x509 -req -days 1 -in $workdir/ca.csr -signkey $workdir/ca.key -out $workdir/ca.crt

316−

317− # Create key

318− openssl genrsa -des3 -passout pass:xxxx -out $workdir/server.pass.key 2048

319− openssl rsa -passin pass:xxxx -in $workdir/server.pass.key -out $workdir/server.key

320− openssl req -new -key $workdir/server.key -out $workdir/server.csr \

321− -subj "/C=UK/ST=Warwickshire/L=Leamington/O=OrgName/OU=IT Department/CN=example.com"

322− openssl x509 -req -days 1 -in $workdir/server.csr -CA $workdir/ca.crt \

323− -CAkey $workdir/ca.key -CAserial $workdir/ca.srl -CAcreateserial \

324− -out $workdir/server.crt

325−

326− # Copy key to destination

327− cp $workdir/server.key ${cpath}/key.pem

328−

329− # Create fullchain.pem (same format as "simp_le ... -f fullchain.pem" creates)

330− cat $workdir/{server.crt,ca.crt} > "${cpath}/fullchain.pem"

331−

332− # Create full.pem for e.g. lighttpd

333− cat $workdir/{server.key,server.crt,ca.crt} > "${cpath}/full.pem"

334−

335− # Give key acme permissions

336− chown '${data.user}:${data.group}' "${cpath}/"{key,fullchain,full}.pem

337− chmod ${rights} "${cpath}/"{key,fullchain,full}.pem

338− '';

339− serviceConfig = {

340− Type = "oneshot";

341− PermissionsStartOnly = true;

342− PrivateTmp = true;

343− User = data.user;

344− Group = data.group;

345− };

346− unitConfig = {

347− # Do not create self-signed key when key already exists

348− ConditionPathExists = "!${cpath}/key.pem";

349− };

350− before = [

351− "acme-selfsigned-certificates.target"

352− ];

353− wantedBy = [

354− "acme-selfsigned-certificates.target"

355− ];

356− };

357− in (

358− [ { name = "acme-${cert}"; value = acmeService; } ]

359− ++ optional cfg.preliminarySelfsigned { name = "acme-selfsigned-${cert}"; value = selfsignedService; }

360− ++ optional (data.activationDelay != null) { name = "acme-setlive-${cert}"; value = delayService; }

361− );

362− servicesAttr = listToAttrs services;

363− injectServiceDep = {

364− after = [ "acme-selfsigned-certificates.target" ];

365− wants = [ "acme-selfsigned-certificates.target" "acme-certificates.target" ];

366− };

367− in

368− servicesAttr //

369− (if config.services.nginx.enable then { nginx = injectServiceDep; } else {}) //

370− (if config.services.lighttpd.enable then { lighttpd = injectServiceDep; } else {});

371−

372− systemd.timers = flip mapAttrs' cfg.certs (cert: data: nameValuePair

373− ("acme-${cert}")

374− ({

375− description = "Renew ACME Certificate for ${cert}";

376− wantedBy = [ "timers.target" ];

377− timerConfig = {

378− OnCalendar = cfg.renewInterval;

379− Unit = "acme-${cert}.service";

380− Persistent = "yes";

381− AccuracySec = "5m";

382− RandomizedDelaySec = "1h";

383− };

384− })

385− );

386−

387− systemd.targets."acme-selfsigned-certificates" = mkIf cfg.preliminarySelfsigned {};

388− systemd.targets."acme-certificates" = {};

389− })

390−

391− ];

392−

393− meta = {

394− maintainers = with lib.maintainers; [ abbradar fpletz globin ];

395− #doc = ./acme.xml; ### CHANGED

396− };

397−}

all-builds.nixnew file+106

@@ -0,0 +1,106 @@

1+{ self-args ? {

2+ config.android_sdk.accept_license = true;

3+ iosSdkVersion = "10.2";

4+ }

5+, local-self ? import ./. self-args

6+, supportedSystems ? [

7+ "x86_64-linux"

8+ "x86_64-darwin"

9+ ]

10+}:

11+

12+let

13+ inherit (local-self.nixpkgs) lib runCommand nix;

14+ cacheBuildSystems = supportedSystems;

15+

16+ obeliskPackagesCommon = [

17+ "obelisk-frontend"

18+ "obelisk-route"

19+ "obelisk-executable-config-lookup"

20+ ];

21+

22+ obeliskPackagesBackend = obeliskPackagesCommon ++ [

23+ "obelisk-asset-manifest"

24+ "obelisk-asset-serve-snap"

25+ "obelisk-backend"

26+ "obelisk-cliapp"

27+ "obelisk-command"

28+ "obelisk-executable-config-inject"

29+ "obelisk-frontend"

30+ "obelisk-run"

31+ "obelisk-route"

32+ "obelisk-selftest"

33+ "obelisk-snap-extras"

34+ ];

35+

36+ pnameToAttrs = pkgsSet: pnames:

37+ lib.listToAttrs (map

38+ (name: { inherit name; value = pkgsSet.${name}; })

39+ pnames);

40+

41+ collect = v:

42+ if lib.isDerivation v then [v]

43+ else if lib.isAttrs v then lib.concatMap collect (builtins.attrValues v)

44+ else if lib.isList v then lib.concatMap collect v

45+ else [];

46+

47+ perPlatform = lib.genAttrs cacheBuildSystems (system: let

48+ reflex-platform = import ./dep/reflex-platform { inherit system; };

49+

50+ mkPerProfiling = profiling: let

51+ obelisk = import ./. (self-args // { inherit system profiling; });

52+ ghc = pnameToAttrs

53+ obelisk.haskellPackageSets.ghc

54+ obeliskPackagesBackend;

55+ ghcjs = pnameToAttrs

56+ obelisk.haskellPackageSets.ghcjs

57+ obeliskPackagesCommon;

58+ command = obelisk.command;

59+ skeleton = import ./skeleton { inherit obelisk; };

60+ serverSkeletonExe = skeleton.exe;

61+ # TODO fix nixpkgs so it doesn't try to run the result of haskell shells as setup hooks.

62+ serverSkeletonShell = local-self.nixpkgs.runCommand "shell-safe-for-dep" {} ''

63+ touch "$out"

64+ echo "return" >> "$out"

65+ cat "${skeleton.shells.ghc}" >> "$out"

66+ '';

67+ androidSkeleton = (import ./skeleton { inherit obelisk; }).android.frontend;

68+ iosSkeleton = (import ./skeleton { inherit obelisk; }).ios.frontend;

69+ nameSuffix = if profiling then "profiled" else "unprofiled";

70+ packages = {

71+ inherit

72+ command

73+ serverSkeletonShell

74+ ghc

75+ ;

76+ } // lib.optionalAttrs (!profiling) {

77+ inherit

78+ ghcjs

79+ serverSkeletonExe

80+ ;

81+ } // lib.optionalAttrs reflex-platform.androidSupport {

82+ inherit androidSkeleton;

83+ } // lib.optionalAttrs reflex-platform.iosSupport {

84+ inherit iosSkeleton;

85+ };

86+ in packages // {

87+ cache = reflex-platform.pinBuildInputs

88+ "obelisk-${system}-${nameSuffix}"

89+ (collect packages);

90+ };

91+

92+ perProfiling = {

93+ profiled = mkPerProfiling true;

94+ unprofiled = mkPerProfiling false;

95+ };

96+ in perProfiling // {

97+ cache = reflex-platform.pinBuildInputs

98+ "obelisk-${system}"

99+ (map (p: p.cache) (builtins.attrValues perProfiling));

100+ });

101+

102+ metaCache = local-self.reflex-platform.pinBuildInputs

103+ "obelisk-everywhere"

104+ (map (a: a.cache) (builtins.attrValues perPlatform));

105+

106+in perPlatform // { inherit metaCache; }

all-tests.nixnew file+145

@@ -0,0 +1,145 @@

1+{

2+ supportedSystems ? [ builtins.currentSystem ]

3+}:

4+let

5+ nginxRoot = "/run/nginx";

6+ obelisk = import ./default.nix {};

7+ # Get NixOS a pre-release 20.03 that contains the python based tests and recursive nix

8+ pkgs = import (builtins.fetchTarball https://github.com/nixos/nixpkgs/archive/3de5266.tar.gz) {};

9+ sshKeys = import (pkgs.path + /nixos/tests/ssh-keys.nix) pkgs;

10+ make-test = import (pkgs.path + /nixos/tests/make-test-python.nix);

11+ obelisk-everywhere = (import ./all-builds.nix { inherit supportedSystems; }).x86_64-linux.cache;

12+ snakeOilPrivateKey = sshKeys.snakeOilPrivateKey.text;

13+ snakeOilPublicKey = sshKeys.snakeOilPublicKey;

14+in

15+ make-test ({...}: {

16+ name = "obelisk";

17+ nodes = {

18+ githost = {

19+ networking.firewall.allowedTCPPorts = [ 22 80 ];

20+ services.openssh = {

21+ enable = true;

22+ };

23+ environment.systemPackages = [

24+ pkgs.git

25+ ];

26+ users.users.root.openssh.authorizedKeys.keys = [

27+ snakeOilPublicKey

28+ ];

29+ };

30+

31+ client = {

32+ imports = [

33+ (pkgs.path + /nixos/modules/installer/cd-dvd/channel.nix)

34+ ];

35+ nix.useSandbox = false;

36+ nix.binaryCaches = [];

37+ environment.systemPackages = [

38+ obelisk.command

39+ obelisk.shell

40+ obelisk-everywhere

41+ pkgs.git

42+ ];

43+ };

44+ };

45+

46+ testScript =

47+ let

48+ privateKeyFile = pkgs.writeText "id_rsa" ''${snakeOilPrivateKey}'';

49+ thunkableSample = pkgs.writeText "default.nix" ''

50+ let pkgs = import <nixpkgs> {}; in pkgs.git

51+ '';

52+ invalidThunkableSample = pkgs.writeText "default.nix" ''

53+ let pkgs = import <nixpkgs> {}; in pkgtypo.git

54+ '';

55+ sshConfigFile = pkgs.writeText "ssh_config" ''

56+ Host *

57+ StrictHostKeyChecking no

58+ UserKnownHostsFile=/dev/null

59+ ConnectionAttempts=1

60+ ConnectTimeout=1

61+ IdentityFile=~/.ssh/id_rsa

62+ User=root

63+ '';

64+ in ''

65+ start_all()

66+ githost.wait_for_open_port("22")

67+

68+ with subtest("test obelisk is installed"):

69+ client.succeed("ob --help")

70+

71+ with subtest("test the client can access the server via ssh"):

72+ client.succeed("mkdir -p ~/.ssh/")

73+ client.succeed(

74+ "cp ${privateKeyFile} ~/.ssh/id_rsa"

75+ )

76+ client.succeed("chmod 600 ~/.ssh/id_rsa")

77+ client.wait_until_succeeds(

78+ "ssh -o UserKnownHostsFile=/dev/null -o StrictHostKeyChecking=no -i ~/.ssh/id_rsa githost true"

79+ )

80+ client.succeed(

81+ "cp ${sshConfigFile} ~/.ssh/config"

82+ )

83+ client.wait_until_succeeds("ssh githost true")

84+

85+ with subtest("test a remote bare repo can be started"):

86+ githost.succeed("mkdir -p ~/myorg/myapp.git")

87+ githost.succeed("cd ~/myorg/myapp.git && git init --bare")

88+

89+ with subtest("test a git project can be configured with a remote using ssh"):

90+ client.succeed("mkdir -p ~/code/myapp")

91+ client.succeed("cd ~/code/myapp && git init")

92+ client.succeed(

93+ "cp ${thunkableSample} ~/code/myapp/default.nix"

94+ )

95+ client.succeed("cd ~/code/myapp && git add .")

96+ client.succeed('git config --global user.email "you@example.com"')

97+ client.succeed('git config --global user.name "Your Name"')

98+ client.succeed('cd ~/code/myapp && git commit -m "Initial"')

99+ client.succeed(

100+ "cd ~/code/myapp && git remote add origin root@githost:/root/myorg/myapp.git"

101+ )

102+

103+

104+ with subtest("test pushing code to the remote"):

105+ client.succeed("cd ~/code/myapp && git push -u origin master")

106+ client.succeed("cd ~/code/myapp && git status")

107+

108+ with subtest("test obelisk can pack"):

109+ client.succeed("ob -v thunk pack ~/code/myapp")

110+ client.succeed("grep -qF 'git' ~/code/myapp/default.nix")

111+ client.succeed("grep -qF 'myorg' ~/code/myapp/git.json")

112+ client.succeed("ob -v thunk unpack ~/code/myapp")

113+

114+ with subtest("test obelisk can set the public / private flag"):

115+ client.succeed("ob -v thunk pack ~/code/myapp --private")

116+ client.fail("""grep -qF '"private": practice' ~/code/myapp/git.json""")

117+ client.succeed("""grep -qF '"private": true' ~/code/myapp/git.json""")

118+ client.succeed("nix-build ~/code/myapp")

119+ client.succeed("ob -v thunk unpack ~/code/myapp")

120+ client.succeed("ob -v thunk pack ~/code/myapp --public")

121+ client.succeed("""grep -qF '"private": false' ~/code/myapp/git.json""")

122+ client.succeed("nix-build ~/code/myapp")

123+ client.succeed("ob -v thunk unpack ~/code/myapp")

124+

125+ with subtest("test building an invalid thunk fails"):

126+ client.succeed("cd ~/code/myapp && git checkout -b bad")

127+ client.succeed(

128+ "cp ${invalidThunkableSample} ~/code/myapp/default.nix"

129+ )

130+ client.succeed("cd ~/code/myapp && git add .")

131+ client.succeed('git config --global user.email "you@example.com"')

132+ client.succeed('git config --global user.name "Your Name"')

133+ client.succeed('cd ~/code/myapp && git commit -m "Bad commit"')

134+ client.succeed("cd ~/code/myapp && git push -u origin bad")

135+ client.succeed("ob -v thunk pack ~/code/myapp --public")

136+ client.fail("nix-build ~/code/myapp")

137+ client.succeed("ob -v thunk unpack ~/code/myapp")

138+ client.succeed("cd ~/code/myapp && git checkout master")

139+

140+ with subtest("test obelisk can detect private repos"):

141+ client.succeed("ob -v thunk pack ~/code/myapp")

142+ client.succeed("""grep -qF '"private": true' ~/code/myapp/git.json""")

143+ client.succeed("ob -v thunk unpack ~/code/myapp")

144+ '';

145+ }) {}

default.nix+143−113

@@ -1,13 +1,8 @@

1−let

2− nixos1909 = import (builtins.fetchTarball {

3− url = https://github.com/NixOS/nixpkgs-channels/archive/nixos-19.09.tar.gz;

4− sha256 = "0ysb2017n8g0bpkxy3lsnlf6mcya5gqwggmwdjxlfnj1ilj3lnqz";

5− }) {};

6−in

7{ system ? builtins.currentSystem

1{ system ? builtins.currentSystem

8, profiling ? false

2, profiling ? false

9, iosSdkVersion ? "10.2"

3, iosSdkVersion ? "10.2"

10, config ? {}

4, config ? {}

5+, reflex-platform-func ? import ./dep/reflex-platform

11}:

6}:

12let

7let

13 cleanSource = builtins.filterSource (name: _: let baseName = builtins.baseNameOf name; in !(

8 cleanSource = builtins.filterSource (name: _: let baseName = builtins.baseNameOf name; in !(

@@ -22,7 +17,7 @@ let

22 openssh

17 openssh

23 ];

18 ];

25− getReflexPlatform = sys: import ./dep/reflex-platform {

20+ getReflexPlatform = sys: reflex-platform-func {

26 inherit iosSdkVersion config;

21 inherit iosSdkVersion config;

27 system = sys;

22 system = sys;

28 enableLibraryProfiling = profiling;

23 enableLibraryProfiling = profiling;

@@ -40,13 +35,10 @@ let

40 pkgs = self.callPackage ({ pkgs }: pkgs) {};

35 pkgs = self.callPackage ({ pkgs }: pkgs) {};

41 haskellLib = pkgs.haskell.lib;

36 haskellLib = pkgs.haskell.lib;

42 in {

37 in {

43− hnix = haskellLib.overrideCabal (self.callHackage "hnix" "0.6.1" { these = self.these_0_8; }) (_: {

38+ hnix = haskellLib.dontCheck (haskellLib.doJailbreak (self.callCabal2nix "hnix" (hackGet dep/hnix) {}));

44− jailbreak = true;

45− doCheck = false;

46− });

47 hnix-store-core = self.callHackage "hnix-store-core" "0.1.0.0" {};

39 hnix-store-core = self.callHackage "hnix-store-core" "0.1.0.0" {};

49− ghcid = haskellLib.justStaticExecutables (self.callCabal2nix "ghcid" (hackGet ./dep/ghcid) {});

41+ ghcid = self.callCabal2nix "ghcid" (hackGet ./dep/ghcid) {};

50 })

42 })

52 pkgs.obeliskExecutableConfig.haskellOverlay

44 pkgs.obeliskExecutableConfig.haskellOverlay

@@ -54,18 +46,35 @@ let

54 # Add obelisk packages

46 # Add obelisk packages

55 (self: super: let

47 (self: super: let

56 pkgs = self.callPackage ({ pkgs }: pkgs) {};

48 pkgs = self.callPackage ({ pkgs }: pkgs) {};

49+ onLinux = pkg: f: if pkgs.stdenv.isLinux then f pkg else pkg;

57 in {

50 in {

51+ shelly = self.callHackage "shelly" "1.9.0" {};

52+

58 obelisk-executable-config-inject = pkgs.obeliskExecutableConfig.platforms.web.inject self;

53 obelisk-executable-config-inject = pkgs.obeliskExecutableConfig.platforms.web.inject self;

60 obelisk-asset-manifest = self.callCabal2nix "obelisk-asset-manifest" (cleanSource ./lib/asset/manifest) {};

55 obelisk-asset-manifest = self.callCabal2nix "obelisk-asset-manifest" (cleanSource ./lib/asset/manifest) {};

61 obelisk-asset-serve-snap = self.callCabal2nix "obelisk-asset-serve-snap" (cleanSource ./lib/asset/serve-snap) {};

56 obelisk-asset-serve-snap = self.callCabal2nix "obelisk-asset-serve-snap" (cleanSource ./lib/asset/serve-snap) {};

62 obelisk-backend = self.callCabal2nix "obelisk-backend" (cleanSource ./lib/backend) {};

57 obelisk-backend = self.callCabal2nix "obelisk-backend" (cleanSource ./lib/backend) {};

63 obelisk-cliapp = self.callCabal2nix "obelisk-cliapp" (cleanSource ./lib/cliapp) {};

58 obelisk-cliapp = self.callCabal2nix "obelisk-cliapp" (cleanSource ./lib/cliapp) {};

64− obelisk-command = haskellLib.overrideCabal (self.callCabal2nix "obelisk-command" (cleanSource ./lib/command) {}) { librarySystemDepends = [ pkgs.nix self.ghcid ]; };

59+ obelisk-command = haskellLib.overrideCabal (self.callCabal2nix "obelisk-command" (cleanSource ./lib/command) {}) {

60+ librarySystemDepends = [

61+ pkgs.nix

62+ (haskellLib.justStaticExecutables self.ghcid)

63+ ];

64+ };

65 obelisk-frontend = self.callCabal2nix "obelisk-frontend" (cleanSource ./lib/frontend) {};

66− obelisk-run = self.callCabal2nix "obelisk-run" (cleanSource ./lib/run) {};

66+ obelisk-run = onLinux (self.callCabal2nix "obelisk-run" (cleanSource ./lib/run) {}) (pkg:

67+ haskellLib.overrideCabal pkg (drv: { librarySystemDepends = [ pkgs.iproute ]; })

68+ );

67 obelisk-route = self.callCabal2nix "obelisk-route" (cleanSource ./lib/route) {};

69 obelisk-route = self.callCabal2nix "obelisk-route" (cleanSource ./lib/route) {};

68− obelisk-selftest = self.callCabal2nix "obelisk-selftest" (cleanSource ./lib/selftest) {};

70+ obelisk-selftest = haskellLib.overrideCabal (self.callCabal2nix "obelisk-selftest" (cleanSource ./lib/selftest) {}) {

71+ librarySystemDepends = [

72+ pkgs.cabal-install

73+ pkgs.coreutils

74+ pkgs.git

75+ pkgs.nix

76+ ];

77+ };

69 obelisk-snap-extras = self.callCabal2nix "obelisk-snap-extras" (cleanSource ./lib/snap-extras) {};

78 obelisk-snap-extras = self.callCabal2nix "obelisk-snap-extras" (cleanSource ./lib/snap-extras) {};

70 tabulation = self.callCabal2nix "tabulation" (cleanSource ./lib/tabulation) {};

79 tabulation = self.callCabal2nix "tabulation" (cleanSource ./lib/tabulation) {};

71 })

80 })

@@ -114,19 +123,18 @@ in rec {

114 pathGit = ./.; # Used in CI by the migration graph hash algorithm to correctly ignore files.

123 pathGit = ./.; # Used in CI by the migration graph hash algorithm to correctly ignore files.

115 path = reflex-platform.filterGit ./.;

124 path = reflex-platform.filterGit ./.;

116 obelisk = ghcObelisk;

125 obelisk = ghcObelisk;

117− obeliskEnvs = ghcObeliskEnvs;

126+ obeliskEnvs = pkgs.lib.filterAttrs (k: _: pkgs.lib.strings.hasPrefix "obelisk-" k) ghcObeliskEnvs;

118 command = ghcObelisk.obelisk-command;

127 command = ghcObelisk.obelisk-command;

119 shell = pinBuildInputs "obelisk-shell" ([command] ++ commandRuntimeDeps pkgs);

128 shell = pinBuildInputs "obelisk-shell" ([command] ++ commandRuntimeDeps pkgs);

120

129

121 selftest = pkgs.writeScript "selftest" ''

130 selftest = pkgs.writeScript "selftest" ''

122− #!/usr/bin/env bash

131+ #!${pkgs.runtimeShell}

123 set -euo pipefail

132 set -euo pipefail

124

133

125 PATH="${command}/bin:$PATH"

134 PATH="${command}/bin:$PATH"

126− export OBELISK_IMPL="${hackGet ./.}"

135+ cd ${./.}

127 "${ghcObelisk.obelisk-selftest}/bin/obelisk-selftest" +RTS -N -RTS "$@"

136 "${ghcObelisk.obelisk-selftest}/bin/obelisk-selftest" +RTS -N -RTS "$@"

128 '';

137 '';

129− #TODO: Why can't I build ./skeleton directly as a derivation? `nix-build -E ./.` doesn't work

130 skeleton = pkgs.runCommand "skeleton" {

138 skeleton = pkgs.runCommand "skeleton" {

131 dir = builtins.filterSource (path: type: builtins.trace path (baseNameOf path != ".obelisk")) ./skeleton;

139 dir = builtins.filterSource (path: type: builtins.trace path (baseNameOf path != ".obelisk")) ./skeleton;

132 } ''

140 } ''

@@ -148,6 +156,7 @@ in rec {

148 compressedJs = frontend: optimizationLevel: pkgs.runCommand "compressedJs" {} ''

156 compressedJs = frontend: optimizationLevel: pkgs.runCommand "compressedJs" {} ''

149 mkdir $out

157 mkdir $out

150 cd $out

158 cd $out

159+ # TODO profiling + static shouldn't break and need an ad-hoc workaround like that

151 ln -s "${haskellLib.justStaticExecutables frontend}/bin/frontend.jsexe/all.js" all.unminified.js

160 ln -s "${haskellLib.justStaticExecutables frontend}/bin/frontend.jsexe/all.js" all.unminified.js

152 ${if optimizationLevel == null then ''

161 ${if optimizationLevel == null then ''

153 ln -s all.unminified.js all.js

162 ln -s all.unminified.js all.js

@@ -230,7 +239,7 @@ in rec {

230 pkgs.runCommand "serverExe" {} ''

239 pkgs.runCommand "serverExe" {} ''

231 mkdir $out

240 mkdir $out

232 set -eux

241 set -eux

233− ln -s "${haskellLib.justStaticExecutables backend}"/bin/* $out/

242+ ln -s "${if profiling then backend else haskellLib.justStaticExecutables backend}"/bin/* $out/

234 ln -s "${mkAssets assets}" $out/static.assets

243 ln -s "${mkAssets assets}" $out/static.assets

235 ln -s ${mkAssets (compressedJs frontend optimizationLevel)} $out/frontend.jsexe.assets

244 ln -s ${mkAssets (compressedJs frontend optimizationLevel)} $out/frontend.jsexe.assets

236 echo ${version} > $out/version

245 echo ${version} > $out/version

@@ -245,113 +254,134 @@ in rec {

245 imports = [

254 imports = [

246 (serverModules.mkBaseEc2 args)

255 (serverModules.mkBaseEc2 args)

247 (serverModules.mkObeliskApp args)

256 (serverModules.mkObeliskApp args)

248− ./acme.nix

249− ];

250− disabledModules = [

251− (pkgs.path + /nixos/modules/security/acme.nix)

252− ];

253− nixpkgs.overlays = [

254− (self: super: {

255− simp_le = nixos1909.simp_le;

256− })

257 ];

258 };

259 };

260

261−

262 # An Obelisk project is a reflex-platform project with a predefined layout and role for each component

261 # An Obelisk project is a reflex-platform project with a predefined layout and role for each component

263− project = base: projectDefinition:

262+ project = base': projectDefinition:

263+ let

264− let projectOut = sys: (getReflexPlatform sys).project (args@{ nixpkgs, ... }:

264+ projectOut = sys: let reflexPlatformProject = (getReflexPlatform sys).project; in reflexPlatformProject (args@{ nixpkgs, ... }:

265+ let

266+ inherit (lib.strings) hasPrefix;

267+ mkProject =

265− let mkProject = { android ? null #TODO: Better error when missing

268+ { android ? null #TODO: Better error when missing

266− , ios ? null #TODO: Better error when missing

269+ , ios ? null #TODO: Better error when missing

267− , packages ? {}

270+ , packages ? {}

268− , overrides ? _: _: {}

271+ , overrides ? _: _: {}

269− , staticFiles ? base + /static

272+ , staticFiles ? null

270− , tools ? _: []

273+ , tools ? _: []

271− , shellToolOverrides ? _: _: {}

274+ , shellToolOverrides ? _: _: {}

272− , withHoogle ? false # Setting this to `true` makes shell reloading far slower

275+ , withHoogle ? false # Setting this to `true` makes shell reloading far slower

273− , __closureCompilerOptimizationLevel ? "ADVANCED" # Set this to `null` to skip the closure-compiler step

276+ , __closureCompilerOptimizationLevel ? "ADVANCED" # Set this to `null` to skip the closure-compiler step

274− }:

277+ }:

278+ let

279+ allConfig = nixpkgs.lib.makeExtensible (self: {

280+ base = base';

281+ inherit args;

282+ userSettings = {

283+ inherit android ios packages overrides tools shellToolOverrides withHoogle __closureCompilerOptimizationLevel;

284+ staticFiles = if staticFiles == null then self.base + /static else staticFiles;

285+ };

275− let frontendName = "frontend";

286+ frontendName = "frontend";

276− backendName = "backend";

287+ backendName = "backend";

277− commonName = "common";

288+ commonName = "common";

278− staticName = "obelisk-generated-static";

289+ staticName = "obelisk-generated-static";

279− staticFilesImpure = if lib.isDerivation staticFiles then staticFiles else toString staticFiles;

290+ staticFilesImpure = let fs = self.userSettings.staticFiles; in if lib.isDerivation fs then fs else toString fs;

280− processedStatic = processAssets { src = staticFiles; };

291+ processedStatic = processAssets { src = self.userSettings.staticFiles; };

281− # The packages whose names and roles are defined by this package

292+ # The packages whose names and roles are defined by this package

282− predefinedPackages = lib.filterAttrs (_: x: x != null) {

293+ predefinedPackages = lib.filterAttrs (_: x: x != null) {

283− ${frontendName} = nullIfAbsent (base + "/frontend");

294+ ${self.frontendName} = nullIfAbsent (self.base + "/frontend");

284− ${commonName} = nullIfAbsent (base + "/common");

295+ ${self.commonName} = nullIfAbsent (self.base + "/common");

285− ${backendName} = nullIfAbsent (base + "/backend");

296+ ${self.backendName} = nullIfAbsent (self.base + "/backend");

286− };

297+ };

298+ shellPackages = {};

287− combinedPackages = predefinedPackages // packages;

299+ combinedPackages = self.predefinedPackages // self.userSettings.packages // self.shellPackages;

288− projectOverrides = self: super: {

300+ projectOverrides = self': super': {

289− ${staticName} = haskellLib.dontHaddock (self.callCabal2nix staticName processedStatic.haskellManifest {});

301+ ${self.staticName} = haskellLib.dontHaddock (self'.callCabal2nix self.staticName self.processedStatic.haskellManifest {});

290− ${backendName} = haskellLib.addBuildDepend super.${backendName} self.obelisk-run;

302+ ${self.backendName} = haskellLib.addBuildDepend super'.${self.backendName} self'.obelisk-run;

291− };

303+ };

292− totalOverrides = lib.composeExtensions projectOverrides overrides;

304+ totalOverrides = lib.composeExtensions self.projectOverrides self.userSettings.overrides;

293− inherit (lib.strings) hasPrefix;

294− privateConfigDirs = ["config/backend"];

305+ privateConfigDirs = ["config/backend"];

295− injectableConfig = builtins.filterSource (path: _:

306+ injectableConfig = builtins.filterSource (path: _:

296− !(lib.lists.any (x: hasPrefix (toString base + "/" + toString x) (toString path)) privateConfigDirs)

307+ !(lib.lists.any (x: hasPrefix (toString self.base + "/" + toString x) (toString path)) self.privateConfigDirs)

297− );

308+ );

298− __androidWithConfig = configPath: {

309+ __androidWithConfig = configPath: {

299− ${if android == null then null else frontendName} = {

310+ ${if self.userSettings.android == null then null else self.frontendName} = {

300− executableName = "frontend";

311+ executableName = "frontend";

301− ${if builtins.pathExists staticFiles then "assets" else null} =

312+ ${if builtins.pathExists self.userSettings.staticFiles then "assets" else null} =

302− nixpkgs.obeliskExecutableConfig.platforms.android.inject

313+ nixpkgs.obeliskExecutableConfig.platforms.android.inject

303− (injectableConfig configPath)

314+ (self.injectableConfig configPath)

304− processedStatic.symlinked;

315+ self.processedStatic.symlinked;

305− } // android;

316+ } // self.userSettings.android;

317+ };

318+ __iosWithConfig = configPath: {

319+ ${if self.userSettings.ios == null then null else self.frontendName} = {

320+ executableName = "frontend";

321+ ${if builtins.pathExists self.userSettings.staticFiles then "staticSrc" else null} =

322+ nixpkgs.obeliskExecutableConfig.platforms.ios.inject

323+ (self.injectableConfig configPath)

324+ self.processedStatic.symlinked;

325+ } // self.userSettings.ios;

326+ };

327+

328+ shells-ghc = builtins.attrNames (self.predefinedPackages // self.shellPackages);

329+

330+ shells-ghcjs = [

331+ self.frontendName

332+ self.commonName

333+ ];

334+

335+ shells-ghcSavedSplices = [

336+ self.commonName

337+ self.frontendName

338+ ];

339+

340+ project = reflexPlatformProject ({...}: self.projectConfig);

341+ projectConfig = {

342+ inherit (self.userSettings) shellToolOverrides tools withHoogle;

343+ overrides = self.totalOverrides;

344+ packages = self.combinedPackages;

345+ shells = {

346+ ${if self.userSettings.android == null && self.userSettings.ios == null then null else "ghcSavedSplices"} =

347+ lib.filter (x: lib.hasAttr x self.combinedPackages) self.shells-ghcSavedSplices;

348+ ghc = lib.filter (x: lib.hasAttr x self.combinedPackages) self.shells-ghc;

349+ ghcjs = lib.filter (x: lib.hasAttr x self.combinedPackages) self.shells-ghcjs;

306 };

350 };

307− __iosWithConfig = configPath: {

351+ android = self.__androidWithConfig (self.base + "/config");

308− ${if ios == null then null else frontendName} = {

352+ ios = self.__iosWithConfig (self.base + "/config");

309− executableName = "frontend";

353+

310− ${if builtins.pathExists staticFiles then "staticSrc" else null} =

354+ passthru = {

311− nixpkgs.obeliskExecutableConfig.platforms.ios.inject

355+ __unstable__.self = allConfig;

312− (injectableConfig configPath)

356+ inherit (self)

313− processedStatic.symlinked;

357+ staticFilesImpure processedStatic

314− } // ios;

358+ __iosWithConfig __androidWithConfig

359+ ;

360+ inherit (self.userSettings)

361+ android ios overrides packages shellToolOverrides staticFiles tools withHoogle

362+ __closureCompilerOptimizationLevel

363+ ;

315 };

364 };

316− in {

317− inherit shellToolOverrides tools withHoogle;

318− overrides = totalOverrides;

319− packages = combinedPackages;

320− shells = {

321− ${if android == null && ios == null then null else "ghcSavedSplices"} = (lib.filter (x: lib.hasAttr x combinedPackages) [

322− commonName

323− frontendName

324− ]);

325− ghc = (lib.filter (x: lib.hasAttr x combinedPackages) [

326− backendName

327− commonName

328− frontendName

329− ]);

330− ghcjs = lib.filter (x: lib.hasAttr x combinedPackages) [

331− frontendName

332− commonName

333− ];

334 };

365 };

335− android = __androidWithConfig (base + "/config");

336− ios = __iosWithConfig (base + "/config");

337− passthru = { inherit android ios packages overrides tools shellToolOverrides withHoogle staticFiles staticFilesImpure __closureCompilerOptimizationLevel processedStatic __iosWithConfig __androidWithConfig; };

338− };

366+ });

367+ in allConfig;

339− in mkProject (projectDefinition args));

368+ in (mkProject (projectDefinition args)).projectConfig);

369+ mainProjectOut = projectOut system;

340− serverOn = sys: version: serverExe

370+ serverOn = projectInst: version: serverExe

341− (projectOut sys).ghc.backend

371+ projectInst.ghc.backend

342− (projectOut system).ghcjs.frontend

372+ mainProjectOut.ghcjs.frontend

343− (projectOut sys).passthru.staticFiles

373+ projectInst.passthru.staticFiles

344− (projectOut sys).passthru.__closureCompilerOptimizationLevel

374+ projectInst.passthru.__closureCompilerOptimizationLevel

345 version;

375 version;

346− linuxExe = serverOn "x86_64-linux";

376+ linuxExe = serverOn (projectOut "x86_64-linux");

347 dummyVersion = "Version number is only available for deployments";

377 dummyVersion = "Version number is only available for deployments";

348− in projectOut system // {

378+ in mainProjectOut // {

349 linuxExeConfigurable = linuxExe;

379 linuxExeConfigurable = linuxExe;

350 linuxExe = linuxExe dummyVersion;

380 linuxExe = linuxExe dummyVersion;

351− exe = serverOn system dummyVersion;

381+ exe = serverOn mainProjectOut dummyVersion;

352 server = args@{ hostName, adminEmail, routeHost, enableHttps, version }:

382 server = args@{ hostName, adminEmail, routeHost, enableHttps, version }:

353 server (args // { exe = linuxExe version; });

383 server (args // { exe = linuxExe version; });

354− obelisk = import (base + "/.obelisk/impl") {};

384+ obelisk = import (base' + "/.obelisk/impl") {};

355 };

385 };

356 haskellPackageSets = {

386 haskellPackageSets = {

357 inherit (reflex-platform) ghc ghcjs;

387 inherit (reflex-platform) ghc ghcjs;

dep/ghcid/github.json+4−4

@@ -1,7 +1,7 @@

2− "owner": "obsidiansystems",

2+ "owner": "ndmitchell",

3 "repo": "ghcid",

4− "branch": "show-unexpected-exit-msg",

4+ "branch": "master",

5− "rev": "54e047560002711b30554a966d6fc511baf0eede",

5+ "rev": "f572318f32b1617f6054248e5888af68222f8e50",

6− "sha256": "18b86j078b9li3q3cvzf9i1l571k0ci8a3f8likzhc1p7bsb5b8d"

6+ "sha256": "1icg3r70lg2kmd9gdc024ih1n9nrja98yav74z9nvykqygvv5w0n"

dep/hnix/default.nixnew file+7

@@ -0,0 +1,7 @@

1+# DO NOT HAND-EDIT THIS FILE

2+import ((import <nixpkgs> {}).fetchFromGitHub (

3+ let json = builtins.fromJSON (builtins.readFile ./github.json);

4+ in { inherit (json) owner repo rev sha256;

5+ private = json.private or false;

6+ }

7+))

dep/hnix/github.jsonnew file+7

@@ -0,0 +1,7 @@

1+{

2+ "owner": "haskell-nix",

3+ "repo": "hnix",

4+ "branch": "master",

5+ "rev": "6c9c7c310c54372b3db0fdf5a0137b395cde1bdb",

6+ "sha256": "1i5903b7lxqn2s3jarb14h6wdq8bxiik1hp0xy43w5w1hgvvq0g5"

7+}

dep/reflex-platform/default.nix+7−6

@@ -1,7 +1,8 @@

1# DO NOT HAND-EDIT THIS FILE

2+let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:

3+ if !fetchSubmodules && !private then builtins.fetchTarball {

4+ url = "https://github.com/${owner}/${repo}/archive/${rev}.tar.gz"; inherit sha256;

2−import ((import <nixpkgs> {}).fetchFromGitHub (

5+ } else (import <nixpkgs> {}).fetchFromGitHub {

6+ inherit owner repo rev sha256 fetchSubmodules private;

7+ };

3− let json = builtins.fromJSON (builtins.readFile ./github.json);

8+in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))

4− in { inherit (json) owner repo rev sha256;

5− private = json.private or false;

6− }

7−))

dep/reflex-platform/github.json+4−3

@@ -1,7 +1,8 @@

2 "owner": "reflex-frp",

3 "repo": "reflex-platform",

4− "branch": "develop",

4+ "branch": "master",

5− "rev": "aa8a9d1ac3d41ad51fbe04e575d4350da65cf3db",

5+ "private": false,

6− "sha256": "0hffy5rcfy6ay06ww3cxykqzp024jfcdg6w1yrmnf0h80sjfgdcm"

6+ "rev": "5429278830e1555a577f2550e045ce7f7164aa65",

7+ "sha256": "1lp86cgccmim573rarsjny5vh0ygkfp5afq7006li0k9w2sw2d4c"

jobsets.nixdeleted−71

@@ -1,71 +0,0 @@

1−{ prs }:

2−

3−let

4− self = import ./. {};

5− pkgs = self.nixpkgs;

6− mkFetchGithub = value: {

7− inherit value;

8− type = "git";

9− emailresponsible = false;

10− };

11−in

12−with pkgs.lib;

13−let

14− defaults = jobs: {

15− inherit (jobs) description;

16− enabled = 1;

17− hidden = false;

18− keepnr = 10;

19− schedulingshares = 100;

20− checkinterval = 120;

21− enableemail = false;

22− emailoverride = "";

23− nixexprinput = "obelisk";

24− nixexprpath = "release.nix";

25− inputs = jobs.inputs // {

26− nixpkgs = {

27− type = "git";

28− value = "https://github.com/NixOS/nixpkgs-channels nixos-unstable";

29− emailresponsible = false;

30− };

31− };

32− self-args = {

33− type = "nix";

34− value = "{ config.android_sdk.accept_license = true; }";

35− emailresponsible = false;

36− };

37− };

38− branchJobset = branch: defaults {

39− description = "obelisk-${branch}";

40− inputs = {

41− obelisk = {

42− value = "https://github.com/obsidiansystems/obelisk ${branch}";

43− type = "git";

44− emailresponsible = false;

45− };

46− };

47− };

48− makePr = num: info: {

49− name = "obelisk-pr-${num}";

50− value = defaults {

51− description = "#${num}: ${info.title}";

52− inputs = {

53− obelisk = {

54− #NOTE: This should really use "pull/${num}/merge"; however, GitHub's

55− #status checks only operate on PR heads. This creates a race

56− #condition, which can currently only be solved by requiring PRs to be

57− #up to date before they're merged. See

58− #https://github.com/isaacs/github/issues/1002

59− value = "https://github.com/obsidiansystems/obelisk pull/${num}/head";

60− type = "git";

61− emailresponsible = false;

62− };

63− };

64− };

65− };

66− processedPrs = mapAttrs' makePr (builtins.fromJSON (builtins.readFile prs));

67− jobsetsAttrs = processedPrs //

68− genAttrs ["master"] branchJobset;

69−in {

70− jobsets = pkgs.writeText "spec.json" (builtins.toJSON jobsetsAttrs);

71−}

lib/asset/README.md+10−10

@@ -1,7 +1,7 @@

1## obelisk-asset

3−The 'assets.nix' file contains nix expressions that are a mutually

3+The 'assets.nix' file contains nix expressions that are a mutually

4−recursive set of attributes used to create static asset directories

4+recursive set of attributes used to create static asset directories

5with hashable file encodings. This file should be incorporated within

6your project's 'default.nix' file. (See ./example/default.nix , line 2)

7```

@@ -10,20 +10,20 @@ your project's 'default.nix' file. (See ./example/default.nix , line 2)

10```

12The 'mkAssets' and 'mkAssetsWith' functions within 'assets.nix' only

13−need to be passed an encoding('zopfliEncodings', 'gzipEncodings',

13+need to be passed an encoding('zopfliEncodings', 'gzipEncodings',

14'noEncodings') and a static directory of your choice as arguments.

16−In this example, 'mkAssets' is used on a directory that has a .png

16+In this example, 'mkAssets' is used on a directory that has a .png

17file inside of it. (See ./example/default.nix, line 11)

18```

19−myAssets = assets.mkAssets ./static;

19+myAssets = assets.mkAssets ./static;

20```

22−Once you have successfully incorporated 'assets.nix' into your

22+Once you have successfully incorporated 'assets.nix' into your

23−project's nix file(s), use nix-build to generate a symlink of

23+project's nix file(s), use nix-build to generate a symlink of

24−your 'mkAssets' expression. The following command from

24+your 'mkAssets' expression. The following command from

25−example/run-example (line 3) will generate an immutable symlink

25+example/run-example (line 3) will generate an immutable symlink

26−that holds hashed static assets.

26+that holds hashed static assets.

27```bash

28nix-build -o static.assets -A myAssets

29```

lib/asset/serve-snap/src/Obelisk/Asset/Accept.hs+6−6

@@ -136,16 +136,16 @@ qvalue = do

136 skipMany lws

137 q0 <|> q1

138 where q0 = do

139− char '0'

139+ _ <- char '0'

140 decimals <- option [] $ do

141− char '.'

141+ _ <- char '.'

142 starRule (Just 0) (Just numAllowedDigits) digit

143 return $ QValue $ MkFixed $ fromIntegral $ (read ('0' : decimals) :: Int) * 10 ^ (numAllowedDigits - length decimals)

144 q1 = do

145− char '1'

145+ _ <- char '1'

146 option () $ do

147− char '.'

147+ _ <- char '.'

148− starRule (Just 0) (Just numAllowedDigits) $ char '0'

148+ _ <- starRule (Just 0) (Just numAllowedDigits) $ char '0'

149 return ()

150 return $ QValue 1

151 numAllowedDigits :: Int

@@ -232,7 +232,7 @@ hashRule minNum maxNum element = do

232lws :: Parser ()

233lws = do

234 option () $ cr >> lf

235− starRule (Just 1) Nothing $ sp <|> ht

235+ _ <- starRule (Just 1) Nothing $ sp <|> ht

236 return ()

237

238-- | See http://www.w3.org/Protocols/rfc2616/rfc2616-sec2.html#sec2.2

lib/backend/src/Obelisk/Backend.hs+27−26

@@ -16,18 +16,15 @@ module Obelisk.Backend

16 , runSnapWithCommandLineArgs

17 , serveDefaultObeliskApp

18 , prettifyOutput

19+ , renderAllJsPath

19 , runBackend

20 , runBackend

20 , staticRenderContentType

21 , staticRenderContentType

21− , mkRouteToUrl

22 , getPublicConfigs

23 ) where

25−import Prelude hiding (id, (.))

26−import Control.Category

27import Control.Monad

25import Control.Monad

28import Control.Monad.Except

26import Control.Monad.Except

29import Control.Monad.Fail (MonadFail)

27import Control.Monad.Fail (MonadFail)

30−import Control.Categorical.Bifunctor

31import Data.ByteString (ByteString)

28import Data.ByteString (ByteString)

32import qualified Data.ByteString.Char8 as BSC8

29import qualified Data.ByteString.Char8 as BSC8

33import Data.Default (Default (..))

30import Data.Default (Default (..))

@@ -38,7 +35,6 @@ import qualified Data.Map as Map

38import Data.Monoid ((<>))

35import Data.Monoid ((<>))

39import Data.Text (Text)

36import Data.Text (Text)

40import qualified Data.Text as T

37import qualified Data.Text as T

41−import Data.Text.Encoding

42import Obelisk.Asset.Serve.Snap (serveAsset)

38import Obelisk.Asset.Serve.Snap (serveAsset)

43import qualified Obelisk.ExecutableConfig.Lookup as Lookup

39import qualified Obelisk.ExecutableConfig.Lookup as Lookup

44import Obelisk.Frontend

40import Obelisk.Frontend

@@ -66,15 +62,15 @@ data GhcjsApp route = GhcjsApp

66--TODO: The frontend should be provided together with the asset paths so that this isn't so easily breakable; that will probably make this function obsolete

62--TODO: The frontend should be provided together with the asset paths so that this isn't so easily breakable; that will probably make this function obsolete

67serveDefaultObeliskApp

63serveDefaultObeliskApp

68 :: (MonadSnap m, HasCookies m, MonadFail m)

64 :: (MonadSnap m, HasCookies m, MonadFail m)

69− => (R appRoute

65+ => (R appRoute -> Text)

70− -> Text)

66+ -> Text -- ^ URL to GHCJS app JavaScript

71− -> ([Text]

67+ -> ([Text] -> m ())

72− -> m ())

73 -> Frontend (R appRoute)

68 -> Frontend (R appRoute)

74 -> Map Text ByteString

69 -> Map Text ByteString

75 -> R (ObeliskRoute appRoute)

70 -> R (ObeliskRoute appRoute)

76 -> m ()

71 -> m ()

77−serveDefaultObeliskApp urlEnc serveStaticAsset frontend configs = serveObeliskApp urlEnc serveStaticAsset frontendApp configs

72+serveDefaultObeliskApp urlEnc allJsUrl serveStaticAsset frontend =

73+ serveObeliskApp urlEnc allJsUrl serveStaticAsset frontendApp

78 where frontendApp = GhcjsApp

74 where frontendApp = GhcjsApp

79 { _ghcjsApp_compiled = defaultFrontendGhcjsAssets

75 { _ghcjsApp_compiled = defaultFrontendGhcjsAssets

80 , _ghcjsApp_value = frontend

76 , _ghcjsApp_value = frontend

@@ -121,19 +117,24 @@ getRouteWith e = do

121 pageName <- getPageName

117 pageName <- getPageName

122 return $ tryDecode e pageName

118 return $ tryDecode e pageName

123

119

120+renderAllJsPath :: Encoder Identity Identity (R (FullRoute a b)) PageName -> Text

121+renderAllJsPath validFullEncoder =

122+ renderObeliskRoute validFullEncoder $ FullRoute_Frontend (ObeliskRoute_Resource ResourceRoute_Ghcjs) :/ ["all.js"]

123+

124serveObeliskApp

125 :: (MonadSnap m, HasCookies m, MonadFail m)

126 => (R appRoute -> Text)

127+ -> Text -- ^ URL to GHCJS app JavaScript

127 -> ([Text] -> m ())

128 -> ([Text] -> m ())

128 -> GhcjsApp (R appRoute)

129 -> GhcjsApp (R appRoute)

129 -> Map Text ByteString

130 -> Map Text ByteString

130 -> R (ObeliskRoute appRoute)

131 -> R (ObeliskRoute appRoute)

131 -> m ()

132 -> m ()

132−serveObeliskApp urlEnc serveStaticAsset frontendApp config = \case

133+serveObeliskApp urlEnc allJsUrl serveStaticAsset frontendApp config = \case

133− ObeliskRoute_App appRouteComponent :=> Identity appRouteRest -> serveGhcjsApp urlEnc frontendApp config $ GhcjsAppRoute_App appRouteComponent :/ appRouteRest

134+ ObeliskRoute_App appRouteComponent :=> Identity appRouteRest -> serveGhcjsApp urlEnc allJsUrl frontendApp config $ GhcjsAppRoute_App appRouteComponent :/ appRouteRest

134 ObeliskRoute_Resource resComponent :=> Identity resRest -> case resComponent :=> Identity resRest of

135 ObeliskRoute_Resource resComponent :=> Identity resRest -> case resComponent :=> Identity resRest of

135 ResourceRoute_Static :=> Identity pathSegments -> serveStaticAsset pathSegments

136 ResourceRoute_Static :=> Identity pathSegments -> serveStaticAsset pathSegments

136− ResourceRoute_Ghcjs :=> Identity pathSegments -> serveGhcjsApp urlEnc frontendApp config $ GhcjsAppRoute_Resource :/ pathSegments

137+ ResourceRoute_Ghcjs :=> Identity pathSegments -> serveGhcjsApp urlEnc allJsUrl frontendApp config $ GhcjsAppRoute_Resource :/ pathSegments

137 ResourceRoute_JSaddleWarp :=> Identity _ -> do

138 ResourceRoute_JSaddleWarp :=> Identity _ -> do

138 let msg = "Error: Obelisk.Backend received jsaddle request"

139 let msg = "Error: Obelisk.Backend received jsaddle request"

139 liftIO $ putStrLn $ T.unpack msg

140 liftIO $ putStrLn $ T.unpack msg

@@ -160,15 +161,16 @@ staticRenderContentType = "text/html; charset=utf-8"

160serveGhcjsApp

161serveGhcjsApp

161 :: (MonadSnap m, HasCookies m, MonadFail m)

162 :: (MonadSnap m, HasCookies m, MonadFail m)

162 => (R appRouteComponent -> Text)

163 => (R appRouteComponent -> Text)

164+ -> Text -- ^ URL to GHCJS app JavaScript

163 -> GhcjsApp (R appRouteComponent)

165 -> GhcjsApp (R appRouteComponent)

164 -> Map Text ByteString

166 -> Map Text ByteString

165 -> R (GhcjsAppRoute appRouteComponent)

167 -> R (GhcjsAppRoute appRouteComponent)

166 -> m ()

168 -> m ()

167−serveGhcjsApp urlEnc app config = \case

169+serveGhcjsApp urlEnc allJsUrl app config = \case

168 GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest -> do

170 GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest -> do

169 modifyResponse $ setContentType staticRenderContentType

171 modifyResponse $ setContentType staticRenderContentType

170 modifyResponse $ setHeader "Cache-Control" "no-store private"

172 modifyResponse $ setHeader "Cache-Control" "no-store private"

171− writeBS <=< renderGhcjsFrontend urlEnc (appRouteComponent :/ appRouteRest) config $ _ghcjsApp_value app

173+ writeBS <=< renderGhcjsFrontend urlEnc allJsUrl (appRouteComponent :/ appRouteRest) config $ _ghcjsApp_value app

172 GhcjsAppRoute_Resource :=> Identity pathSegments -> serveStaticAssets (_ghcjsApp_compiled app) pathSegments

174 GhcjsAppRoute_Resource :=> Identity pathSegments -> serveStaticAssets (_ghcjsApp_compiled app) pathSegments

173

175

174runBackend :: Backend backendRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()

176runBackend :: Backend backendRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()

@@ -176,30 +178,29 @@ runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend

176 Left e -> fail $ "backend error:\n" <> T.unpack e

178 Left e -> fail $ "backend error:\n" <> T.unpack e

177 Right validFullEncoder -> do

179 Right validFullEncoder -> do

178 publicConfigs <- getPublicConfigs

180 publicConfigs <- getPublicConfigs

179− _backend_run backend $ \serveRoute -> do

181+ _backend_run backend $ \serveRoute ->

180− runSnapWithCommandLineArgs $ do

182+ runSnapWithCommandLineArgs $

181 getRouteWith validFullEncoder >>= \case

183 getRouteWith validFullEncoder >>= \case

182 Identity r -> case r of

184 Identity r -> case r of

183 FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a

185 FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a

184 FullRoute_Frontend obeliskRoute :/ a ->

186 FullRoute_Frontend obeliskRoute :/ a ->

185− serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) (serveStaticAssets defaultStaticAssets) frontend publicConfigs $

187+ serveDefaultObeliskApp routeToUrl allJsUrl (serveStaticAssets defaultStaticAssets) frontend publicConfigs $

186 obeliskRoute :/ a

188 obeliskRoute :/ a

187−

189+ where

188−mkRouteToUrl :: Encoder Identity parse (R (FullRoute br fr)) PageName -> R fr -> Text

189−mkRouteToUrl validFullEncoder =

190− let pageNameEncoder' :: Encoder Identity (Either Text) PageName PathQuery = pageNameEncoder

191− in \(k :/ v) -> T.pack . uncurry (<>) . encode pageNameEncoder' . encode validFullEncoder $ (FullRoute_Frontend $ ObeliskRoute_App k) :/ v

190+ routeToUrl (k :/ v) = renderObeliskRoute validFullEncoder $ FullRoute_Frontend (ObeliskRoute_App k) :/ v

191+ allJsUrl = renderAllJsPath validFullEncoder

192

193renderGhcjsFrontend

194 :: (MonadSnap m, HasCookies m)

195 => (route -> Text)

196+ -> Text -- ^ URL to GHCJS app JavaScript

196 -> route

197 -> route

197 -> Map Text ByteString

198 -> Map Text ByteString

198 -> Frontend route

199 -> Frontend route

199 -> m ByteString

200 -> m ByteString

200−renderGhcjsFrontend urlEnc route configs f = do

201+renderGhcjsFrontend urlEnc allJsUrl route configs f = do

201− let ghcjsPreload = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: "ghcjs/all.js") blank

202+ let ghcjsPreload = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: allJsUrl) blank

202− ghcjsScript = elAttr "script" ("language" =: "javascript" <> "src" =: "ghcjs/all.js" <> "defer" =: "defer") blank

203+ ghcjsScript = elAttr "script" ("language" =: "javascript" <> "src" =: allJsUrl <> "defer" =: "defer") blank

203 cookies <- askCookies

204 cookies <- askCookies

204 renderFrontendHtml configs cookies urlEnc route f ghcjsPreload ghcjsScript

205 renderFrontendHtml configs cookies urlEnc route f ghcjsPreload ghcjsScript

205

206

lib/cliapp/obelisk-cliapp.cabal+3−2

@@ -7,9 +7,11 @@ cabal-version: >=1.2

7library

8 hs-source-dirs: src

9 build-depends:

10+ aeson

10− ansi-terminal

11+ , ansi-terminal

11 , base

12 , base

12 , bytestring

13 , bytestring

14+ , containers

13 , exceptions

15 , exceptions

14 , io-streams

16 , io-streams

15 , lens

17 , lens

@@ -23,7 +25,6 @@ library

23 , transformers

25 , transformers

24 exposed-modules:

26 exposed-modules:

25 Obelisk.CliApp

27 Obelisk.CliApp

26− Obelisk.CliApp.Demo

27 other-modules:

28 other-modules:

28 Obelisk.CliApp.Logging

29 Obelisk.CliApp.Logging

29 Obelisk.CliApp.Process

30 Obelisk.CliApp.Process

lib/cliapp/src/Obelisk/CliApp.hs+14−6

@@ -33,16 +33,24 @@ module Obelisk.CliApp

33 , Severity (..)

35 -- .Process

36− , ProcessFailure (..)

37 , AsProcessFailure (..)

36 , AsProcessFailure (..)

38− , readProcessAndLogStderr

37+ , ProcessFailure (..)

39− , readProcessAndLogOutput

38+ , ProcessSpec (..)

40− , readCreateProcessWithExitCode

39+ , callCommand

40+ , callProcess

41 , callProcessAndLogOutput

42 , createProcess_

43− , callProcess

43+ , overCreateProcess

44− , callCommand

44+ , proc

45+ , readCreateProcessWithExitCode

46+ , readProcessAndLogOutput

47+ , readProcessAndLogStderr

48+ , readProcessJSONAndLogStderr

45 , reconstructCommand

49 , reconstructCommand

50+ , setCwd

51+ , setDelegateCtlc

52+ , setEnvOverride

53+ , shell

46 ) where

54 ) where

48import Control.Monad.Log (Severity (..))

56import Control.Monad.Log (Severity (..))

lib/cliapp/src/Obelisk/CliApp/Demo.hsdeleted−53

@@ -1,53 +0,0 @@

1−{-# LANGUAGE FlexibleContexts #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−module Obelisk.CliApp.Demo where

5−

6−import Control.Concurrent (threadDelay)

7−import Control.Monad.Fail

8−import Control.Monad.IO.Class

9−import Data.Semigroup ((<>))

10−import qualified Data.Text as T

11−import System.Process (proc)

12−

13−import Control.Monad.Catch (MonadMask)

14−

15−import Obelisk.CliApp

16−

17−cliDemo

18− :: ( MonadIO m, MonadMask m, MonadFail m

19− , CliLog m, HasCliConfig e m, CliThrow e m, AsProcessFailure e, AsUnstructuredError e)

20− => m ()

21−cliDemo = withSpinner "CLI Demo" $ do

22− putLog Notice "This demo will showcase the CLI library functionality"

23− _ <- withSpinner' "Searching long for something" (Just $ \c -> "Discovered " <> T.pack (show c) <> " objects") $ do

24− delay

25− withSpinner "Nested task" $ do

26− delay

27− putLog Notice "In nested task"

28− -- This is a 'no trail' spinner that won't leave a trail (even its sub spinners)

29− withSpinnerNoTrail "In between, doing something temporary" $ do

30− withSpinner "Runnning something deep inside" $ do

31− delay

32− putLog Notice "You can still log from inside no-trail spinners"

33− delay

34− delay

35− putLog Error "Top nested task finished"

36− delay

37− putLog Error "Some user error while spinning"

38− delay

39− putLog Notice "This is some info mesage"

40− putLog Warning "And now a warning as well"

41− delay

42− return (42 :: Integer)

43− putLog Notice "Now we start a 2nd spinner, run a couple of process, the last of which fails:"

44− withSpinner "Looking around" $ do

45− delay

46− output <- readProcessAndLogStderr Notice $ proc "ls" ["-l", "/"]

47− putLog Notice $ "Output was: " <> output

48− delay

49− callProcessAndLogOutput (Notice, Error) $ proc "ls" ["-l", "/does-not-exist"]

50− delay

51− failWith "Something dangerous happened"

52− where

53− delay = liftIO $ threadDelay 1000000

lib/cliapp/src/Obelisk/CliApp/Logging.hs+11−10

@@ -39,7 +39,6 @@ import Control.Monad.Log (Severity (..), WithSeverity (..), logMessage, runLoggi

39import Control.Monad.Loops (iterateUntil)

40import Control.Monad.Reader (MonadIO, ReaderT (..))

41import Data.IORef (atomicModifyIORef', newIORef, readIORef, writeIORef)

42−import Data.Maybe

43import Data.Semigroup ((<>))

42import Data.Semigroup ((<>))

44import Data.Text (Text)

43import Data.Text (Text)

45import qualified Data.Text as T

44import qualified Data.Text as T

@@ -67,7 +66,7 @@ newCliConfig sev noColor noSpinner errorLogExitCode = do

67 tipDisplayed <- newIORef False

66 tipDisplayed <- newIORef False

68 stack <- newIORef ([], [])

67 stack <- newIORef ([], [])

69 textEncoding <- hGetEncoding stdout

68 textEncoding <- hGetEncoding stdout

70− let theme = if fromMaybe False $ supportsUnicode <$> textEncoding

69+ let theme = if maybe False supportsUnicode textEncoding

71 then unicodeTheme

70 then unicodeTheme

72 else noUnicodeTheme

71 else noUnicodeTheme

73 return $ CliConfig level noColor noSpinner lock tipDisplayed stack errorLogExitCode theme

72 return $ CliConfig level noColor noSpinner lock tipDisplayed stack errorLogExitCode theme

@@ -133,7 +132,7 @@ handleLog' noColor output = do

133 hFlush stdout

132 hFlush stdout

134 Output_Overwrite ts -> liftIO $ do

133 Output_Overwrite ts -> liftIO $ do

135 width <- TS.getTerminalWidth

134 width <- TS.getTerminalWidth

136− T.putStr $ "\r" <> (TS.render (not noColor) width ts)

135+ T.putStr $ "\r" <> TS.render (not noColor) width ts

137 hFlush stdout

136 hFlush stdout

138 Output_ClearLine -> liftIO $ do

137 Output_ClearLine -> liftIO $ do

139 -- Go to the first column and clear the whole line

138 -- Go to the first column and clear the whole line

@@ -179,14 +178,16 @@ withExitFailMessage msg f = f `catch` \(e :: ExitCode) -> do

179

178

180-- | Write log to stdout, with colors (unless `noColor`)

179-- | Write log to stdout, with colors (unless `noColor`)

181writeLog :: (MonadIO m, MonadMask m) => Bool -> Bool -> WithSeverity Text -> m ()

180writeLog :: (MonadIO m, MonadMask m) => Bool -> Bool -> WithSeverity Text -> m ()

182−writeLog withNewLine noColor (WithSeverity severity s)

181+writeLog withNewLine noColor (WithSeverity severity s) = if T.null s then pure () else write

183− | noColor && severity <= Warning = liftIO $ putFn $ T.pack (show severity) <> ": " <> s

184− | not noColor && severity <= Error = TS.putStrWithSGR errorColors h withNewLine s

185− | not noColor && severity <= Warning = TS.putStrWithSGR warningColors h withNewLine s

186− | not noColor && severity >= Debug = TS.putStrWithSGR debugColors h withNewLine s

187− | otherwise = liftIO $ putFn s

188 where

182 where

183+ write

184+ | noColor && severity <= Warning = liftIO $ putFn $ T.pack (show severity) <> ": " <> s

185+ | not noColor && severity <= Error = TS.putStrWithSGR errorColors h withNewLine s

186+ | not noColor && severity <= Warning = TS.putStrWithSGR warningColors h withNewLine s

187+ | not noColor && severity >= Debug = TS.putStrWithSGR debugColors h withNewLine s

188+ | otherwise = liftIO $ putFn s

189+

189− putFn = if withNewLine then (T.hPutStrLn h) else (T.hPutStr h)

190+ putFn = if withNewLine then T.hPutStrLn h else T.hPutStr h

190 h = if severity <= Error then stderr else stdout

191 h = if severity <= Error then stderr else stdout

191 errorColors = [SetColor Foreground Vivid Red]

192 errorColors = [SetColor Foreground Vivid Red]

192 warningColors = [SetColor Foreground Vivid Yellow]

193 warningColors = [SetColor Foreground Vivid Yellow]

lib/cliapp/src/Obelisk/CliApp/Process.hs+96−34

@@ -9,17 +9,25 @@

9-- | An extension of `System.Process` that integrates with logging (`Obelisk.CLI.Logging`)

10-- and is thus spinner friendly.

11module Obelisk.CliApp.Process

12+ ( AsProcessFailure (..)

12− ( ProcessFailure (..)

13+ , ProcessFailure (..)

13− , AsProcessFailure (..)

14+ , ProcessSpec (..)

14− , readProcessAndLogStderr

15+ , callCommand

15− , readProcessAndLogOutput

16+ , callProcess

16− , readCreateProcessWithExitCode

17 , callProcessAndLogOutput

18 , createProcess

19 , createProcess_

20− , callProcess

20+ , overCreateProcess

21− , callCommand

21+ , proc

22+ , readCreateProcessWithExitCode

23+ , readProcessAndLogOutput

24+ , readProcessAndLogStderr

25+ , readProcessJSONAndLogStderr

22 , reconstructCommand

26 , reconstructCommand

27+ , setCwd

28+ , setDelegateCtlc

29+ , setEnvOverride

30+ , shell

23 ) where

31 ) where

25import Control.Monad ((<=<), join, void)

33import Control.Monad ((<=<), join, void)

@@ -30,24 +38,51 @@ import Control.Lens (Prism', review)

30import qualified Data.ByteString as BS

38import qualified Data.ByteString as BS

31import qualified Data.ByteString.Char8 as BSC

39import qualified Data.ByteString.Char8 as BSC

32import Data.Function (fix)

40import Data.Function (fix)

41+import Data.Map (Map)

42+import qualified Data.Map as Map

33import Data.Monoid ((<>))

43import Data.Monoid ((<>))

34import Data.Text (Text)

44import Data.Text (Text)

35import qualified Data.Text as T

45import qualified Data.Text as T

36import qualified Data.Text.Encoding as T

46import qualified Data.Text.Encoding as T

37import Data.Text.Encoding.Error (lenientDecode)

47import Data.Text.Encoding.Error (lenientDecode)

48+import System.Environment (getEnvironment)

38import System.Exit (ExitCode (..))

49import System.Exit (ExitCode (..))

39import System.IO (Handle)

50import System.IO (Handle)

40import System.IO.Streams (InputStream, handleToInputStream)

51import System.IO.Streams (InputStream, handleToInputStream)

41import qualified System.IO.Streams as Streams

52import qualified System.IO.Streams as Streams

42import System.IO.Streams.Concurrent (concurrentMerge)

53import System.IO.Streams.Concurrent (concurrentMerge)

43−import System.Process (CreateProcess, ProcessHandle, StdStream (CreatePipe), cmdspec, std_err, std_out,

54+import System.Process (CreateProcess, ProcessHandle, StdStream (CreatePipe), std_err, std_out, waitForProcess)

44− waitForProcess)

45import qualified System.Process as Process

55import qualified System.Process as Process

56+import qualified Data.Aeson as Aeson

47import Control.Monad.Log (Severity (..))

58import Control.Monad.Log (Severity (..))

48import Obelisk.CliApp.Logging (putLog, putLogRaw)

59import Obelisk.CliApp.Logging (putLog, putLogRaw)

49import Obelisk.CliApp.Types (CliLog, CliThrow)

60import Obelisk.CliApp.Types (CliLog, CliThrow)

62+data ProcessSpec = ProcessSpec

63+ { _processSpec_createProcess :: !CreateProcess

64+ , _processSpec_overrideEnv :: !(Maybe (Map String String -> Map String String))

65+ }

66+

67+proc :: FilePath -> [String] -> ProcessSpec

68+proc cmd args = ProcessSpec (Process.proc cmd args) Nothing

69+

70+shell :: String -> ProcessSpec

71+shell cmd = ProcessSpec (Process.shell cmd) Nothing

72+

73+setEnvOverride :: (Map String String -> Map String String) -> ProcessSpec -> ProcessSpec

74+setEnvOverride f p = p { _processSpec_overrideEnv = Just f }

75+

76+overCreateProcess :: (CreateProcess -> CreateProcess) -> ProcessSpec -> ProcessSpec

77+overCreateProcess f (ProcessSpec p x) = ProcessSpec (f p) x

78+

79+setDelegateCtlc :: Bool -> ProcessSpec -> ProcessSpec

80+setDelegateCtlc b = overCreateProcess (\p -> p { Process.delegate_ctlc = b })

81+

82+setCwd :: Maybe FilePath -> ProcessSpec -> ProcessSpec

83+setCwd fp = overCreateProcess (\p -> p { Process.cwd = fp })

84+

85+

51-- TODO put back in `Obelisk.CliApp.Process` and use prisms for extensible exceptions

86-- TODO put back in `Obelisk.CliApp.Process` and use prisms for extensible exceptions

52data ProcessFailure = ProcessFailure Process.CmdSpec Int -- exit code

87data ProcessFailure = ProcessFailure Process.CmdSpec Int -- exit code

53 deriving Show

88 deriving Show

@@ -62,17 +97,31 @@ instance AsProcessFailure ProcessFailure where

63readProcessAndLogStderr

98readProcessAndLogStderr

64 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

99 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

65− => Severity -> CreateProcess -> m Text

100+ => Severity -> ProcessSpec -> m Text

66readProcessAndLogStderr sev process = do

101readProcessAndLogStderr sev process = do

67 (out, _err) <- withProcess process $ \_out err -> do

102 (out, _err) <- withProcess process $ \_out err -> do

68 streamToLog =<< liftIO (streamHandle sev err)

103 streamToLog =<< liftIO (streamHandle sev err)

69 liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out

104 liftIO $ T.decodeUtf8With lenientDecode <$> BS.hGetContents out

105

106+readProcessJSONAndLogStderr

107+ :: (Aeson.FromJSON a, MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

108+ => Severity -> ProcessSpec -> m a

109+readProcessJSONAndLogStderr sev process = do

110+ (out, _err) <- withProcess process $ \_out err -> do

111+ streamToLog =<< liftIO (streamHandle sev err)

112+ json <- liftIO $ BS.hGetContents out

113+ case Aeson.eitherDecodeStrict json of

114+ Right a -> pure a

115+ Left err -> do

116+ putLog Error $ "Could not decode process output as JSON: " <> T.pack err

117+ throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) 0

118+

71readCreateProcessWithExitCode

119readCreateProcessWithExitCode

72 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)

120 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)

73− => CreateProcess -> m (ExitCode, String, String)

121+ => ProcessSpec -> m (ExitCode, String, String)

74−readCreateProcessWithExitCode process = do

122+readCreateProcessWithExitCode procSpec = do

123+ process <- mkCreateProcess procSpec

75− putLog Debug $ "Creating process: " <> reconstructCommand (cmdspec process)

124+ putLog Debug $ "Creating process: " <> reconstructProcSpec procSpec

76 liftIO $ Process.readCreateProcessWithExitCode process ""

125 liftIO $ Process.readCreateProcessWithExitCode process ""

126

78-- | Like `System.Process.readProcess` but logs the combined output (stdout and stderr)

127-- | Like `System.Process.readProcess` but logs the combined output (stdout and stderr)

@@ -84,10 +133,10 @@ readCreateProcessWithExitCode process = do

84-- `callProcessAndLogOutput (Debug, Debug)`.

133-- `callProcessAndLogOutput (Debug, Debug)`.

85readProcessAndLogOutput

134readProcessAndLogOutput

86 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

135 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

87− => (Severity, Severity) -> CreateProcess -> m Text

136+ => (Severity, Severity) -> ProcessSpec -> m Text

88readProcessAndLogOutput (sev_out, sev_err) process = do

137readProcessAndLogOutput (sev_out, sev_err) process = do

89− (_, Just out, Just err, p) <- createProcess $ process

138+ (_, Just out, Just err, p) <- createProcess $ overCreateProcess

90− { std_out = CreatePipe , std_err = CreatePipe }

139+ (\p -> p { std_out = CreatePipe , std_err = CreatePipe }) process

140

92 -- TODO interleave stdout and stderr in log correctly

141 -- TODO interleave stdout and stderr in log correctly

93 streamToLog =<< liftIO (streamHandle sev_err err)

142 streamToLog =<< liftIO (streamHandle sev_err err)

@@ -96,9 +145,9 @@ readProcessAndLogOutput (sev_out, sev_err) process = do

145

97 liftIO (waitForProcess p) >>= \case

146 liftIO (waitForProcess p) >>= \case

98 ExitSuccess -> pure outText

147 ExitSuccess -> pure outText

99− ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (cmdspec process) code

148+ ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) code

100

149

101−-- | Like `System.Process.callProcess` but logs the combined output (stdout and stderr)

150+-- | Like 'System.Process.callProcess' but logs the combined output (stdout and stderr)

102-- with the corresponding severity.

151-- with the corresponding severity.

103--

152--

104-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However

153-- Usually this function is called as `callProcessAndLogOutput (Debug, Error)`. However

@@ -106,9 +155,8 @@ readProcessAndLogOutput (sev_out, sev_err) process = do

106-- which case it is advisable to call it with a non-Error severity for stderr, like

155-- which case it is advisable to call it with a non-Error severity for stderr, like

107-- `callProcessAndLogOutput (Debug, Debug)`.

156-- `callProcessAndLogOutput (Debug, Debug)`.

108callProcessAndLogOutput

157callProcessAndLogOutput

109−

110 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

158 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

111− => (Severity, Severity) -> CreateProcess -> m ()

159+ => (Severity, Severity) -> ProcessSpec -> m ()

112callProcessAndLogOutput (sev_out, sev_err) process =

160callProcessAndLogOutput (sev_out, sev_err) process =

113 void $ withProcess process $ \out err -> do

161 void $ withProcess process $ \out err -> do

114 stream <- liftIO $ join $ combineStream

162 stream <- liftIO $ join $ combineStream

@@ -118,21 +166,31 @@ callProcessAndLogOutput (sev_out, sev_err) process =

118 where

166 where

119 combineStream s1 s2 = concurrentMerge [s1, s2]

167 combineStream s1 s2 = concurrentMerge [s1, s2]

120

168

121−-- | Like `System.Process.createProcess` but also logs (debug) the process being run

169+-- | Like 'System.Process.createProcess' but also logs (debug) the process being run

122createProcess

170createProcess

123 :: (MonadIO m, CliLog m)

171 :: (MonadIO m, CliLog m)

124− => CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)

172+ => ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)

125−createProcess p = do

173+createProcess procSpec = do

174+ p <- mkCreateProcess procSpec

126− putLog Debug $ "Creating process: " <> reconstructCommand (cmdspec p)

175+ putLog Debug $ "Creating process: " <> reconstructProcSpec procSpec

127 liftIO $ Process.createProcess p

176 liftIO $ Process.createProcess p

128

177

129-- | Like `System.Process.createProcess_` but also logs (debug) the process being run

178-- | Like `System.Process.createProcess_` but also logs (debug) the process being run

130createProcess_

179createProcess_

131 :: (MonadIO m, CliLog m)

180 :: (MonadIO m, CliLog m)

132− => String -> CreateProcess -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)

181+ => String -> ProcessSpec -> m (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)

133−createProcess_ name p = do

182+createProcess_ name procSpec = do

183+ p <- mkCreateProcess procSpec

134− putLog Debug $ "Creating process " <> T.pack name <> ": " <> reconstructCommand (cmdspec p)

184+ putLog Debug $ "Creating process " <> T.pack name <> ": " <> reconstructProcSpec procSpec

135− liftIO $ Process.createProcess p

185+ liftIO $ Process.createProcess_ name p

186+

187+mkCreateProcess :: MonadIO m => ProcessSpec -> m Process.CreateProcess

188+mkCreateProcess (ProcessSpec p override') = do

189+ case override' of

190+ Nothing -> pure p

191+ Just override -> do

192+ procEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (Process.env p)

193+ pure $ p { Process.env = Just $ Map.toAscList (override procEnv) }

136

194

137-- | Like `System.Process.callProcess` but also logs (debug) the process being run

195-- | Like `System.Process.callProcess` but also logs (debug) the process being run

138callProcess

196callProcess

@@ -152,17 +210,17 @@ callCommand cmd = do

152

210

153withProcess

211withProcess

154 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

212 :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

155− => CreateProcess -> (Handle -> Handle -> m ()) -> m (Handle, Handle)

213+ => ProcessSpec -> (Handle -> Handle -> m ()) -> m (Handle, Handle)

156withProcess process f = do -- TODO: Use bracket.

214withProcess process f = do -- TODO: Use bracket.

157 -- FIXME: Using `withCreateProcess` here leads to something operating illegally on closed handles.

215 -- FIXME: Using `withCreateProcess` here leads to something operating illegally on closed handles.

158− (_, Just out, Just err, p) <- createProcess $ process

216+ (_, Just out, Just err, p) <- createProcess $ overCreateProcess

159− { std_out = CreatePipe , std_err = CreatePipe }

217+ (\x -> x { std_out = CreatePipe , std_err = CreatePipe }) process

160

218

161 f out err -- Pass the handles to the passed function

219 f out err -- Pass the handles to the passed function

162

220

163 liftIO (waitForProcess p) >>= \case

221 liftIO (waitForProcess p) >>= \case

164 ExitSuccess -> return (out, err)

222 ExitSuccess -> return (out, err)

165− ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (cmdspec process) code

223+ ExitFailure code -> throwError $ review asProcessFailure $ ProcessFailure (Process.cmdspec $ _processSpec_createProcess process) code

166

224

167-- Create an input stream from the file handle, associating each item with the given severity.

225-- Create an input stream from the file handle, associating each item with the given severity.

168streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))

226streamHandle :: Severity -> Handle -> IO (InputStream (Severity, BSC.ByteString))

@@ -179,8 +237,12 @@ streamToLog stream = fix $ \loop -> do

179

237

180-- | Pretty print a 'CmdSpec'

238-- | Pretty print a 'CmdSpec'

181reconstructCommand :: Process.CmdSpec -> Text

239reconstructCommand :: Process.CmdSpec -> Text

240+reconstructCommand p = case p of

182−reconstructCommand (Process.ShellCommand str) = T.pack str

241+ Process.ShellCommand str -> T.pack str

183−reconstructCommand (Process.RawCommand c as) = processToShellString c as

242+ Process.RawCommand c as -> processToShellString c as

184 where

243 where

185 processToShellString cmd args = T.unwords $ map quoteAndEscape (cmd : args)

244 processToShellString cmd args = T.unwords $ map quoteAndEscape (cmd : args)

186 quoteAndEscape x = "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

245 quoteAndEscape x = "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

246+

247+reconstructProcSpec :: ProcessSpec -> Text

248+reconstructProcSpec = reconstructCommand . Process.cmdspec . _processSpec_createProcess

lib/command/obelisk-command.cabal+10−10

@@ -1,5 +1,5 @@

1name: obelisk-command

2−version: 0.1

2+version: 0.5

3cabal-version: >= 1.8

4build-type: Simple

@@ -7,35 +7,35 @@ library

7 hs-source-dirs: src

8 build-depends:

9 aeson

10− , ansi-terminal

11− , Cabal

12 , aeson-pretty

10 , aeson-pretty

11+ , ansi-terminal

13 , base

12 , base

14 , base16-bytestring

13 , base16-bytestring

15 , binary

14 , binary

16 , bytestring

15 , bytestring

17− , obelisk-cliapp

16+ , Cabal

18 , containers

17 , containers

19 , data-default

18 , data-default

20 , directory

19 , directory

21 , either

20 , either

22 , errors

21 , errors

22+ , exceptions

23 , filepath

24+ , git

24 , github

25 , github

25 , here

26 , here

26− , git

27 , hnix

28 , hpack

29 , io-streams

30− , exceptions

31− , logging-effect

32 , lens

30 , lens

31+ , logging-effect

32+ , megaparsec

33 , modern-uri

34 , monad-loops

35 , mtl

36− , megaparsec

37 , network

36 , network

38 , network-uri

37 , network-uri

38+ , obelisk-cliapp

39 , optparse-applicative

40 , placeholders

41 , process

@@ -58,8 +58,8 @@ library

58 Obelisk.Command.Thunk

59 Obelisk.Command.Utils

60 Obelisk.Command.VmBuilder

61− -- -fobject-code is so that the StaticPointers extension can work in ghci

61+ Obelisk.Command.Preprocessor

62− ghc-options: -Wall -fobject-code

62+ ghc-options: -Wall

64executable ob

65 main-is: src-bin/ob.hs

lib/command/src/Obelisk/Command.hs+64−74

@@ -3,8 +3,6 @@

3{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE StaticPointers #-}

7−{-# LANGUAGE TypeApplications #-}

8module Obelisk.Command where

6module Obelisk.Command where

10import Control.Monad

8import Control.Monad

@@ -13,8 +11,8 @@ import qualified Data.Binary as Binary

13import Data.Bool (bool)

11import Data.Bool (bool)

14import qualified Data.ByteString.Base16 as Base16

12import qualified Data.ByteString.Base16 as Base16

15import qualified Data.ByteString.Lazy as LBS

13import qualified Data.ByteString.Lazy as LBS

14+import Data.Foldable (for_)

16import Data.List

15import Data.List

17−import Data.Maybe (catMaybes)

18import qualified Data.Text as T

16import qualified Data.Text as T

19import Data.Text.Encoding

17import Data.Text.Encoding

20import Data.Text.Encoding.Error (lenientDecode)

18import Data.Text.Encoding.Error (lenientDecode)

@@ -30,13 +28,12 @@ import System.Posix.Process (executeFile)

31import Obelisk.App

29import Obelisk.App

32import Obelisk.CliApp

30import Obelisk.CliApp

33−import Obelisk.CliApp.Demo (cliDemo)

34import Obelisk.Command.Deploy

31import Obelisk.Command.Deploy

35import Obelisk.Command.Project

32import Obelisk.Command.Project

36import Obelisk.Command.Run

33import Obelisk.Command.Run

37import Obelisk.Command.Thunk

34import Obelisk.Command.Thunk

38−import Obelisk.Command.Utils

39import qualified Obelisk.Command.VmBuilder as VmBuilder

35import qualified Obelisk.Command.VmBuilder as VmBuilder

36+import qualified Obelisk.Command.Preprocessor as Preprocessor

42data Args = Args

39data Args = Args

@@ -95,53 +92,33 @@ data ObCommand

95 | ObCommand_Watch

92 | ObCommand_Watch

96 | ObCommand_Shell ShellOpts

93 | ObCommand_Shell ShellOpts

97 | ObCommand_Doc String [String] -- shell and list of packages

94 | ObCommand_Doc String [String] -- shell and list of packages

95+ | ObCommand_Hoogle String Int -- shell and port

98 | ObCommand_Internal ObInternal

96 | ObCommand_Internal ObInternal

99 deriving Show

97 deriving Show

100

101data ObInternal

99data ObInternal

102− = ObInternal_RunStaticIO StaticKey

100+ -- the preprocessor argument syntax is also handled outside

103− | ObInternal_CLIDemo

101+ -- optparse-applicative, but it shouldn't ever conflict with another syntax

102+ = ObInternal_ApplyPackages String String String [String]

104 deriving Show

103 deriving Show

105

104

106−inNixShell' :: MonadObelisk m => StaticPtr (ObeliskT IO ()) -> m ()

107−inNixShell' p = withProjectRoot "." $ \root -> do

108− cmd <- liftIO $ unwords <$> mkCmd -- TODO: shell escape instead of unwords

109− projectShell root True "ghc" (Just cmd)

110− where

111− mkCmd = do

112− argsCfg <- getArgsConfig

113− myArgs <- getArgs

114− obArgs <- parseCLIArgs argsCfg myArgs

115− progName <- getObeliskExe

116− return $ progName : catMaybes

117− [ Just "--no-handoff"

118− , bool Nothing (Just "--verbose") $ _args_verbose obArgs

119− , Just "internal"

120− , Just "run-static-io"

121− , Just $ encodeStaticKey $ staticKey p

122− ]

123−

124obCommand :: ArgsConfig -> Parser ObCommand

105obCommand :: ArgsConfig -> Parser ObCommand

125obCommand cfg = hsubparser

106obCommand cfg = hsubparser

126− (mconcat

107+ (mconcat

127− [ command "init" $ info (ObCommand_Init <$> initSource <*> initForce) $ progDesc "Initialize an Obelisk project"

108+ [ command "init" $ info (ObCommand_Init <$> initSource <*> initForce) $ progDesc "Initialize an Obelisk project"

128− , command "deploy" $ info (ObCommand_Deploy <$> deployCommand cfg) $ progDesc "Prepare a deployment for an Obelisk project"

109+ , command "deploy" $ info (ObCommand_Deploy <$> deployCommand cfg) $ progDesc "Prepare a deployment for an Obelisk project"

129− , command "run" $ info (pure ObCommand_Run) $ progDesc "Run current project in development mode"

110+ , command "run" $ info (pure ObCommand_Run) $ progDesc "Run current project in development mode"

130− , command "thunk" $ info (ObCommand_Thunk <$> thunkCommand) $ progDesc "Manipulate thunk directories"

111+ , command "thunk" $ info (ObCommand_Thunk <$> thunkCommand) $ progDesc "Manipulate thunk directories"

131− , command "repl" $ info (pure ObCommand_Repl) $ progDesc "Open an interactive interpreter"

112+ , command "repl" $ info (pure ObCommand_Repl) $ progDesc "Open an interactive interpreter"

132− , command "watch" $ info (pure ObCommand_Watch) $ progDesc "Watch current project for errors and warnings"

113+ , command "watch" $ info (pure ObCommand_Watch) $ progDesc "Watch current project for errors and warnings"

133− , command "shell" $ info (ObCommand_Shell <$> shellOpts) $ progDesc "Enter a shell with project dependencies"

114+ , command "shell" $ info (ObCommand_Shell <$> shellOpts) $ progDesc "Enter a shell with project dependencies"

134− , command "doc" $ info (ObCommand_Doc <$> shellFlags <*> packageNames) $

115+ , command "doc" $ info (ObCommand_Doc <$> shellFlags <*> packageNames) $

135− progDesc "List paths to haddock documentation for specified packages"

116+ progDesc "List paths to haddock documentation for specified packages"

136− <> footerDoc (Just $

117+ <> footerDoc (Just $

137− text "Hint: To open the documentation you can pipe the output of this command like"

118+ text "Hint: To open the documentation you can pipe the output of this command like"

138− <$$> text "ob doc reflex reflex-dom-core | xargs -n1 xdg-open")

119+ <$$> text "ob doc reflex reflex-dom-core | xargs -n1 xdg-open")

139− ])

120+ , command "hoogle" $ info (ObCommand_Hoogle <$> shellFlags <*> portOpt 8080) $ progDesc "Run a hoogle server locally for your project's dependency tree"

140− <|> subparser

141− (mconcat

142− [ internal

143− , command "internal" (info (ObCommand_Internal <$> internalCommand) mempty)

144− ])

121+ ])

145

122

146packageNames :: Parser [String]

123packageNames :: Parser [String]

147packageNames = some (strArgument (metavar "PACKAGE-NAME..."))

124packageNames = some (strArgument (metavar "PACKAGE-NAME..."))

@@ -206,12 +183,6 @@ data DeployInitOpts = DeployInitOpts

206 }

183 }

207 deriving Show

184 deriving Show

208

185

209−internalCommand :: Parser ObInternal

210−internalCommand = subparser $ mconcat

211− [ command "run-static-io" $ info (ObInternal_RunStaticIO <$> argument (eitherReader decodeStaticKey) (action "static-key")) mempty

212− , command "clidemo" $ info (pure ObInternal_CLIDemo) mempty

213− ]

214−

215--TODO: Result should provide normalised path and also original user input for error reporting.

186--TODO: Result should provide normalised path and also original user input for error reporting.

216thunkDirectoryParser :: Parser FilePath

187thunkDirectoryParser :: Parser FilePath

217thunkDirectoryParser = fmap (dropTrailingPathSeparator . normalise) . strArgument $ mconcat

188thunkDirectoryParser = fmap (dropTrailingPathSeparator . normalise) . strArgument $ mconcat

@@ -220,20 +191,35 @@ thunkDirectoryParser = fmap (dropTrailingPathSeparator . normalise) . strArgumen

220 , help "Path to directory containing thunk data"

191 , help "Path to directory containing thunk data"

221 ]

192 ]

222

193

194+thunkConfig :: Parser ThunkConfig

195+thunkConfig = ThunkConfig

196+ <$>

197+ ( flag' (Just True) (long "private" <> help "Mark thunks as pointing to a private repository")

198+ <|> flag' (Just False) (long "public" <> help "Mark thunks as pointing to a public repository")

199+ <|> pure Nothing

200+ )

201+

202+thunkUpdateConfig :: Parser ThunkUpdateConfig

203+thunkUpdateConfig = ThunkUpdateConfig

204+ <$> optional (strOption (long "branch" <> metavar "BRANCH" <> help "Use the given branch when looking for the latest revision"))

205+ <*> thunkConfig

206+

207+thunkPackConfig :: Parser ThunkPackConfig

208+thunkPackConfig = ThunkPackConfig

209+ <$> switch (long "force" <> short 'f' <> help "Force packing thunks even if there are branches not pushed upstream, uncommitted changes, stashes. This will cause changes that have not been pushed upstream to be lost; use with care.")

210+ <*> thunkConfig

211+

223data ThunkCommand

212data ThunkCommand

224− = ThunkCommand_Update [FilePath] (Maybe String)

213+ = ThunkCommand_Update [FilePath] ThunkUpdateConfig

225 | ThunkCommand_Unpack [FilePath]

214 | ThunkCommand_Unpack [FilePath]

226− | ThunkCommand_Pack [FilePath] Bool

215+ | ThunkCommand_Pack [FilePath] ThunkPackConfig

227 deriving Show

216 deriving Show

228

217

229−forceFlag :: Parser Bool

230−forceFlag = switch $ long "force" <> short 'f' <> help "Force packing thunks even if there are branches not pushed upstream, uncommitted changes, stashes. This will cause changes that have not been pushed upstream to be lost; use with care."

231−

232thunkCommand :: Parser ThunkCommand

218thunkCommand :: Parser ThunkCommand

233thunkCommand = hsubparser $ mconcat

219thunkCommand = hsubparser $ mconcat

234− [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser <*> optional (strOption (long "branch" <> metavar "BRANCH"))) $ progDesc "Update thunk to latest revision available"

220+ [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser <*> thunkUpdateConfig) $ progDesc "Update thunk to latest revision available"

235 , command "unpack" $ info (ThunkCommand_Unpack <$> some thunkDirectoryParser) $ progDesc "Unpack thunk into git checkout of revision it points to"

221 , command "unpack" $ info (ThunkCommand_Unpack <$> some thunkDirectoryParser) $ progDesc "Unpack thunk into git checkout of revision it points to"

236− , command "pack" $ info (ThunkCommand_Pack <$> some thunkDirectoryParser <*> forceFlag) $ progDesc "Pack git checkout into thunk that points at the current branch's upstream"

222+ , command "pack" $ info (ThunkCommand_Pack <$> some thunkDirectoryParser <*> thunkPackConfig) $ progDesc "Pack git checkout into thunk that points at the current branch's upstream"

237 ]

223 ]

238

224

239data ShellOpts

225data ShellOpts

@@ -254,20 +240,24 @@ shellOpts = ShellOpts

254 <$> shellFlags

240 <$> shellFlags

255 <*> optional (strArgument (metavar "COMMAND"))

241 <*> optional (strArgument (metavar "COMMAND"))

256

242

243+portOpt :: Int -> Parser Int

244+portOpt dfault = option auto (long "port" <> short 'p' <> help "Port number for server" <> showDefault <> value dfault <> metavar "INT")

245+

257parserPrefs :: ParserPrefs

246parserPrefs :: ParserPrefs

258parserPrefs = defaultPrefs

247parserPrefs = defaultPrefs

259 { prefShowHelpOnEmpty = True

248 { prefShowHelpOnEmpty = True

260 }

249 }

261

250

262parseCLIArgs :: ArgsConfig -> [String] -> IO Args

251parseCLIArgs :: ArgsConfig -> [String] -> IO Args

263−parseCLIArgs cfg as = pure as >>= handleParseResult . execParserPure parserPrefs (argsInfo cfg)

252+parseCLIArgs cfg = handleParseResult . execParserPure parserPrefs (argsInfo cfg)

264

253

265-- | Create an Obelisk config for the current process.

254-- | Create an Obelisk config for the current process.

266mkObeliskConfig :: IO Obelisk

255mkObeliskConfig :: IO Obelisk

267mkObeliskConfig = do

256mkObeliskConfig = do

268 cliArgs <- getArgs

257 cliArgs <- getArgs

269 -- This function should not use argument parser (full argument parsing happens post handoff)

258 -- This function should not use argument parser (full argument parsing happens post handoff)

259+ -- TODO: See if we can use the argument parser with a subset of the parsers to get logging level out.

270− let logLevel = toLogLevel $ "-v" `elem` cliArgs

260+ let logLevel = toLogLevel $ any (`elem` ["-v", "--verbose"]) cliArgs

271 notInteractive <- not <$> isInteractiveTerm

261 notInteractive <- not <$> isInteractiveTerm

272 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case

262 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case

273 ObeliskError_ProcessError (ProcessFailure p code) ann ->

263 ObeliskError_ProcessError (ProcessFailure p code) ann ->

@@ -332,6 +322,9 @@ main' argsCfg = do

332 liftIO $ executeFile impl False ("--no-handoff" : myArgs) Nothing

322 liftIO $ executeFile impl False ("--no-handoff" : myArgs) Nothing

333 case myArgs of

323 case myArgs of

334 "--no-handoff" : as -> go as -- If we've been told not to hand off, don't hand off

324 "--no-handoff" : as -> go as -- If we've been told not to hand off, don't hand off

325+ origPath:inPath:outPath:preprocessorName:packagePaths

326+ | preprocessorName == preprocessorIdentifier && any (\c -> c == '.' || c == pathSeparator) origPath ->

327+ ob $ ObCommand_Internal $ ObInternal_ApplyPackages origPath inPath outPath packagePaths

335 a:as -- Otherwise bash completion would always hand-off even if the user isn't trying to

328 a:as -- Otherwise bash completion would always hand-off even if the user isn't trying to

336 | "--bash-completion" `isPrefixOf` a

329 | "--bash-completion" `isPrefixOf` a

337 && "--no-handoff" `elem` as -> go (a:as)

330 && "--no-handoff" `elem` as -> go (a:as)

@@ -358,7 +351,7 @@ ob = \case

358 Right (ThunkData_Packed ptr) -> return ptr

351 Right (ThunkData_Packed ptr) -> return ptr

359 Right (ThunkData_Checkout (Just ptr)) -> return ptr

352 Right (ThunkData_Checkout (Just ptr)) -> return ptr

360 Right (ThunkData_Checkout Nothing) ->

353 Right (ThunkData_Checkout Nothing) ->

361− getThunkPtr False root

354+ getThunkPtr False root Nothing

362 let sshKeyPath = _deployInitOpts_sshKey deployOpts

355 let sshKeyPath = _deployInitOpts_sshKey deployOpts

363 hostname = _deployInitOpts_hostname deployOpts

356 hostname = _deployInitOpts_hostname deployOpts

364 route = _deployInitOpts_route deployOpts

357 route = _deployInitOpts_route deployOpts

@@ -372,25 +365,22 @@ ob = \case

372 Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg

365 Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg

373 DeployCommand_Update -> deployUpdate "."

366 DeployCommand_Update -> deployUpdate "."

374 DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs

367 DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs

375− ObCommand_Run -> inNixShell' $ static run

368+ ObCommand_Run -> run

376− -- inNixShell ($(mkClosure 'ghcidAction) ())

377 ObCommand_Thunk tc -> case tc of

369 ObCommand_Thunk tc -> case tc of

378− ThunkCommand_Update thunks mBranch -> mapM_ ((flip updateThunkToLatest) mBranch) thunks

370+ ThunkCommand_Update thunks config -> for_ thunks (updateThunkToLatest config)

379− ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks

371+ ThunkCommand_Unpack thunks -> for_ thunks unpackThunk

380− ThunkCommand_Pack thunks force -> forM_ thunks (packThunk force)

372+ ThunkCommand_Pack thunks config -> for_ thunks (packThunk config)

381 ObCommand_Repl -> runRepl

373 ObCommand_Repl -> runRepl

382− ObCommand_Watch -> inNixShell' $ static runWatch

374+ ObCommand_Watch -> runWatch

383 ObCommand_Shell so -> withProjectRoot "." $ \root ->

375 ObCommand_Shell so -> withProjectRoot "." $ \root ->

384 projectShell root False (_shellOpts_shell so) (_shellOpts_command so)

376 projectShell root False (_shellOpts_shell so) (_shellOpts_command so)

385− ObCommand_Doc shell pkgs -> withProjectRoot "." $ \root ->

377+ ObCommand_Doc shell' pkgs -> withProjectRoot "." $ \root ->

386− projectShell root False shell (Just $ haddockCommand pkgs)

378+ projectShell root False shell' (Just $ haddockCommand pkgs)

379+ ObCommand_Hoogle shell' port -> withProjectRoot "." $ \root -> do

380+ nixShellWithHoogle root True shell' $ Just $ "hoogle server -p " <> show port <> " --local"

387 ObCommand_Internal icmd -> case icmd of

381 ObCommand_Internal icmd -> case icmd of

388− ObInternal_RunStaticIO k -> liftIO (unsafeLookupStaticPtr @(ObeliskT IO ()) k) >>= \case

382+ ObInternal_ApplyPackages origPath inPath outPath packagePaths -> do

389− Nothing -> failWith $ "ObInternal_RunStaticIO: no such StaticKey: " <> T.pack (show k)

383+ liftIO $ Preprocessor.applyPackages origPath inPath outPath packagePaths

390− Just p -> do

391− c <- getObelisk

392− liftIO $ runObelisk c $ deRefStaticPtr p

393− ObInternal_CLIDemo -> cliDemo

394

384

395haddockCommand :: [String] -> String

385haddockCommand :: [String] -> String

396haddockCommand pkgs = unwords

386haddockCommand pkgs = unwords

lib/command/src/Obelisk/Command/Deploy.hs+19−23

@@ -14,33 +14,29 @@ import Data.Aeson (FromJSON, ToJSON, encode, eitherDecode)

14import Data.Bits

15import qualified Data.ByteString.Lazy as BSL

16import Data.Default

17−import qualified Data.HashMap.Strict as HM

18import qualified Data.Map as Map

17import qualified Data.Map as Map

19−import Data.Text (Text)

20import qualified Data.Set as Set

18import qualified Data.Set as Set

21import qualified Data.Text as T

19import qualified Data.Text as T

22import qualified Data.Text.IO as T

20import qualified Data.Text.IO as T

23import GHC.Generics

21import GHC.Generics

24−import Nix.Pretty

25−import Nix.String (principledMakeNixStringWithoutContext)

26−import Nix.Value

27import System.Directory

22import System.Directory

28−import System.Environment (getEnvironment)

29import System.FilePath

23import System.FilePath

30import System.IO

24import System.IO

31import System.Posix.Files

25import System.Posix.Files

32−import System.Process (delegate_ctlc, env, proc, cwd)

33import Text.URI (URI)

26import Text.URI (URI)

34import qualified Text.URI as URI

27import qualified Text.URI as URI

35import Text.URI.Lens

28import Text.URI.Lens

37import Obelisk.App (MonadObelisk)

30import Obelisk.App (MonadObelisk)

31+import Obelisk.CliApp (

38−import Obelisk.CliApp (Severity (..), callProcessAndLogOutput, failWith, putLog, withSpinner)

32+ Severity (..), callProcessAndLogOutput, failWith, proc, putLog,

33+ setCwd, setDelegateCtlc, setEnvOverride, withSpinner)

39import Obelisk.Command.Nix

34import Obelisk.Command.Nix

40import Obelisk.Command.Project

35import Obelisk.Command.Project

41import Obelisk.Command.Thunk

36import Obelisk.Command.Thunk

42import Obelisk.Command.Utils

37import Obelisk.Command.Utils

39+

44deployInit

40deployInit

45 :: MonadObelisk m

41 :: MonadObelisk m

46 => ThunkPtr

42 => ThunkPtr

@@ -57,7 +53,7 @@ deployInit thunkPtr deployDir sshKeyPath hostnames route adminEmail enableHttps

57 False -> failWith $ T.pack $ "ob deploy init: file does not exist: " <> sshKeyPath

53 False -> failWith $ T.pack $ "ob deploy init: file does not exist: " <> sshKeyPath

58 True -> pure $ deployDir </> "ssh_key"

54 True -> pure $ deployDir </> "ssh_key"

59 callProcessAndLogOutput (Notice, Error) $

55 callProcessAndLogOutput (Notice, Error) $

60− proc "cp" [sshKeyPath, localKey]

56+ proc cp [sshKeyPath, localKey]

61 liftIO $ setFileMode localKey $ ownerReadMode .|. ownerWriteMode

57 liftIO $ setFileMode localKey $ ownerReadMode .|. ownerWriteMode

62 return localKey

58 return localKey

63 withSpinner "Validating configuration" $ do

59 withSpinner "Validating configuration" $ do

@@ -82,7 +78,7 @@ deployInit thunkPtr deployDir sshKeyPath hostnames route adminEmail enableHttps

82 writeDeployConfig deployDir "backend_hosts" $ unlines hostnames

78 writeDeployConfig deployDir "backend_hosts" $ unlines hostnames

83 writeDeployConfig deployDir "enable_https" $ show enableHttps

79 writeDeployConfig deployDir "enable_https" $ show enableHttps

84 writeDeployConfig deployDir "admin_email" adminEmail

80 writeDeployConfig deployDir "admin_email" adminEmail

85− writeDeployConfig deployDir ("config" </> "common" </> "route") $ route

81+ writeDeployConfig deployDir ("config" </> "common" </> "route") route

86 withSpinner "Creating source thunk (./src)" $ liftIO $ do

82 withSpinner "Creating source thunk (./src)" $ liftIO $ do

87 createThunk (deployDir </> "src") thunkPtr

83 createThunk (deployDir </> "src") thunkPtr

88 setupObeliskImpl deployDir

84 setupObeliskImpl deployDir

@@ -107,7 +103,7 @@ deployPush deployPath getNixBuilders = do

107 Right (ThunkData_Packed ptr) -> return ptr

103 Right (ThunkData_Packed ptr) -> return ptr

108 Right (ThunkData_Checkout _) -> do

104 Right (ThunkData_Checkout _) -> do

109 checkGitCleanStatus srcPath True >>= \case

105 checkGitCleanStatus srcPath True >>= \case

110− True -> packThunk False srcPath

106+ True -> packThunk (ThunkPackConfig False (ThunkConfig Nothing)) srcPath

111 False -> failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."

107 False -> failWith $ T.pack $ "ob deploy push: ensure " <> srcPath <> " has no pending changes and latest is pushed upstream."

112 Left err -> failWith $ "ob deploy push: couldn't read src thunk: " <> T.pack (show err)

108 Left err -> failWith $ "ob deploy push: couldn't read src thunk: " <> T.pack (show err)

113 let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr

109 let version = show . _thunkRev_commit $ _thunkPtr_rev thunkPtr

@@ -157,7 +153,7 @@ deployPush deployPath getNixBuilders = do

157 ]

153 ]

158 isClean <- checkGitCleanStatus deployPath True

154 isClean <- checkGitCleanStatus deployPath True

159 when (not isClean) $ do

155 when (not isClean) $ do

160− withSpinner "Commiting changes to Git" $ do

156+ withSpinner "Committing changes to Git" $ do

161 callProcessAndLogOutput (Debug, Error) $ proc "git"

157 callProcessAndLogOutput (Debug, Error) $ proc "git"

162 ["-C", deployPath, "add", "."]

158 ["-C", deployPath, "add", "."]

163 callProcessAndLogOutput (Debug, Error) $ proc "git"

159 callProcessAndLogOutput (Debug, Error) $ proc "git"

@@ -165,12 +161,11 @@ deployPush deployPath getNixBuilders = do

165 putLog Notice $ "Deployed => " <> T.pack route

161 putLog Notice $ "Deployed => " <> T.pack route

166 where

162 where

167 callProcess' envMap cmd args = do

163 callProcess' envMap cmd args = do

168− processEnv <- Map.toList . (envMap <>) . Map.fromList <$> liftIO getEnvironment

164+ let p = setEnvOverride (envMap <>) $ setDelegateCtlc True $ proc cmd args

169− let p = (proc cmd args) { delegate_ctlc = True, env = Just processEnv }

170 callProcessAndLogOutput (Notice, Notice) p

165 callProcessAndLogOutput (Notice, Notice) p

171

166

172deployUpdate :: MonadObelisk m => FilePath -> m ()

167deployUpdate :: MonadObelisk m => FilePath -> m ()

173−deployUpdate deployPath = updateThunkToLatest (deployPath </> "src") Nothing

168+deployUpdate deployPath = updateThunkToLatest (ThunkUpdateConfig Nothing (ThunkConfig Nothing)) (deployPath </> "src")

174

169

175data PlatformDeployment = Android | IOS

170data PlatformDeployment = Android | IOS

176 deriving (Show, Eq)

171 deriving (Show, Eq)

@@ -205,7 +200,7 @@ deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do

205 , _keytoolConfig_storepass = keyStorePassword

200 , _keytoolConfig_storepass = keyStorePassword

206 , _keytoolConfig_keypass = keyStorePassword

201 , _keytoolConfig_keypass = keyStorePassword

207 }

202 }

208− createKeystore root $ keyToolConf

203+ createKeystore root keyToolConf

209 liftIO $ BSL.writeFile keytoolConfPath $ encode keyToolConf

204 liftIO $ BSL.writeFile keytoolConfPath $ encode keyToolConf

210 checkKeytoolConfExist <- liftIO $ doesFileExist keytoolConfPath

205 checkKeytoolConfExist <- liftIO $ doesFileExist keytoolConfPath

211 unless checkKeytoolConfExist $ failWith "Missing android KeytoolConfig"

206 unless checkKeytoolConfExist $ failWith "Missing android KeytoolConfig"

@@ -213,16 +208,17 @@ deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do

213 liftIO $ print keytoolConfContents

208 liftIO $ print keytoolConfContents

214 keyArgs <- case eitherDecode keytoolConfContents :: Either String KeytoolConfig of

209 keyArgs <- case eitherDecode keytoolConfContents :: Either String KeytoolConfig of

215 Left err -> failWith $ T.pack err

210 Left err -> failWith $ T.pack err

216− Right conf -> [ "--sign"

211+ Right conf -> pure [ "--sign"

217 , "--store-file", _keytoolConfig_keystore conf

212 , "--store-file", _keytoolConfig_keystore conf

218 , "--store-password", _keytoolConfig_storepass conf

213 , "--store-password", _keytoolConfig_storepass conf

219 , "--key-alias", _keytoolConfig_alias conf

214 , "--key-alias", _keytoolConfig_alias conf

220 , "--key-password", _keytoolConfig_keypass conf]

215 , "--key-password", _keytoolConfig_keypass conf]

221− let expr = unlines

216+ let expr = unwords

222 [ "with (import ", srcDir, " {});"

217 [ "with (import ", srcDir, " {});"

223 , "android.frontend.override (drv: {"

218 , "android.frontend.override (drv: {"

224− , " isRelease = true;"

219+ , "isRelease = true;"

225− , " staticSrc = (passthru.__androidWithConfig ", configDir, ").frontend.staticSrc;"

220+ , "staticSrc = (passthru.__androidWithConfig ", configDir, ").frontend.staticSrc;"

221+ , "assets = (passthru.__androidWithConfig ", configDir, ").frontend.assets;"

226 , "})"

222 , "})"

227 ]

223 ]

228 return (Target

224 return (Target

@@ -246,7 +242,7 @@ deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do

246 let mobileArtifact = case platform of

242 let mobileArtifact = case platform of

247 IOS -> "iOS App"

243 IOS -> "iOS App"

248 Android -> "Android APK"

244 Android -> "Android APK"

249− in putLog Notice $ T.pack $ unwords ["Your recently built", mobileArtifact, "can be found at the following path:", show result]

245+ putLog Notice $ T.pack $ unwords ["Your recently built", mobileArtifact, "can be found at the following path:", show result]

250 callProcessAndLogOutput (Notice, Error) $ proc (result </> "bin" </> "deploy") (mobileArgs ++ extraArgs)

246 callProcessAndLogOutput (Notice, Error) $ proc (result </> "bin" </> "deploy") (mobileArgs ++ extraArgs)

251 where

247 where

252 withEcho showEcho f = do

248 withEcho showEcho f = do

@@ -266,13 +262,13 @@ instance ToJSON KeytoolConfig

266createKeystore :: MonadObelisk m => FilePath -> KeytoolConfig -> m ()

262createKeystore :: MonadObelisk m => FilePath -> KeytoolConfig -> m ()

267createKeystore root config = do

263createKeystore root config = do

268 let expr = "with (import " <> toImplDir root <> ").reflex-platform.nixpkgs; pkgs.mkShell { buildInputs = [ pkgs.jdk ]; }"

264 let expr = "with (import " <> toImplDir root <> ").reflex-platform.nixpkgs; pkgs.mkShell { buildInputs = [ pkgs.jdk ]; }"

269− callProcessAndLogOutput (Notice,Notice) $ (proc "nix-shell" ["-E" , expr, "--run" , keytoolCmd]) { cwd = Just root }

265+ callProcessAndLogOutput (Notice,Notice) $ setCwd (Just root) $ proc "nix-shell" ["-E" , expr, "--run" , keytoolCmd]

270 where

266 where

271 keytoolCmd = processToShellString "keytool"

267 keytoolCmd = processToShellString "keytool"

272 [ "-genkeypair", "-noprompt"

268 [ "-genkeypair", "-noprompt"

273 , "-keystore", _keytoolConfig_keystore config

269 , "-keystore", _keytoolConfig_keystore config

274 , "-keyalg", "RSA", "-keysize", "2048"

270 , "-keyalg", "RSA", "-keysize", "2048"

275− , "-validity", "1000000000"

271+ , "-validity", "1000000"

276 , "-storepass", _keytoolConfig_storepass config

272 , "-storepass", _keytoolConfig_storepass config

277 , "-alias", _keytoolConfig_alias config

273 , "-alias", _keytoolConfig_alias config

278 , "-keypass", _keytoolConfig_keypass config

274 , "-keypass", _keytoolConfig_keypass config

lib/command/src/Obelisk/Command/Nix.hs+45−15

@@ -9,22 +9,31 @@

9{-# LANGUAGE TemplateHaskell #-}

10{-# LANGUAGE TypeApplications #-}

11module Obelisk.Command.Nix

12− ( nixCmd

12+ ( Arg (..)

13− , NixCmd (..)

14− , nixCmdConfig_target

15− , nixCmdConfig_args

16− , nixCmdConfig_builders

17 , NixBuildConfig (..)

13 , NixBuildConfig (..)

18 , nixBuildConfig_common

14 , nixBuildConfig_common

19 , nixBuildConfig_outLink

15 , nixBuildConfig_outLink

16+ , NixCmd (..)

17+ , nixCmdConfig_args

18+ , nixCmdConfig_builders

19+ , nixCmdConfig_target

20+ , NixCommonConfig (..)

20 , NixInstantiateConfig (..)

21 , NixInstantiateConfig (..)

21 , nixInstantiateConfig_eval

22 , nixInstantiateConfig_eval

22− , NixCommonConfig (..)

23+ , NixShellConfig (..)

23− , Target (..)

24+ , nixShellConfig_common

25+ , nixShellConfig_pure

26+ , nixShellConfig_run

24 , OutLink (..)

27 , OutLink (..)

25− , Arg (..)

28+ , Target (..)

29+ , target_attr

30+ , target_expr

31+ , target_path

32+

26 , boolArg

33 , boolArg

34+ , nixCmd

27 , rawArg

35 , rawArg

36+ , runNixShellConfig

28 , strArg

37 , strArg

29 ) where

38 ) where

@@ -37,7 +46,6 @@ import Data.List (intercalate)

37import Data.Maybe

46import Data.Maybe

38import Data.Monoid ((<>))

47import Data.Monoid ((<>))

39import qualified Data.Text as T

48import qualified Data.Text as T

40−import System.Process (proc)

42import Obelisk.App (MonadObelisk)

50import Obelisk.App (MonadObelisk)

43import Obelisk.CliApp

51import Obelisk.CliApp

@@ -63,10 +71,10 @@ data Arg

63 deriving (Eq, Show)

71 deriving (Eq, Show)

65strArg :: String -> String -> Arg

73strArg :: String -> String -> Arg

66−strArg k = Arg_Str k

74+strArg = Arg_Str

68rawArg :: String -> String -> Arg

76rawArg :: String -> String -> Arg

69−rawArg k = Arg_Expr k

77+rawArg = Arg_Expr

71boolArg :: String -> Bool -> Arg

79boolArg :: String -> Bool -> Arg

72boolArg k = Arg_Expr k . bool "false" "true"

80boolArg k = Arg_Expr k . bool "false" "true"

@@ -86,7 +94,7 @@ makeClassy ''NixCommonConfig

86instance Default NixCommonConfig where

94instance Default NixCommonConfig where

87 def = NixCommonConfig def mempty mempty

95 def = NixCommonConfig def mempty mempty

89−runNixCommonConfig :: NixCommonConfig -> [FilePath]

97+runNixCommonConfig :: NixCommonConfig -> [String]

90runNixCommonConfig cfg = mconcat [maybeToList path, attrArg, exprArg, args, buildersArg]

98runNixCommonConfig cfg = mconcat [maybeToList path, attrArg, exprArg, args, buildersArg]

91 where

99 where

92 path = _target_path $ _nixCmdConfig_target cfg

100 path = _target_path $ _nixCmdConfig_target cfg

@@ -124,7 +132,7 @@ instance HasNixCommonConfig NixBuildConfig where

124instance Default NixBuildConfig where

132instance Default NixBuildConfig where

125 def = NixBuildConfig def def

133 def = NixBuildConfig def def

126

134

127−runNixBuildConfig :: NixBuildConfig -> [FilePath]

135+runNixBuildConfig :: NixBuildConfig -> [String]

128runNixBuildConfig cfg = mconcat

136runNixBuildConfig cfg = mconcat

129 [ runNixCommonConfig $ cfg ^. nixCommonConfig

137 [ runNixCommonConfig $ cfg ^. nixCommonConfig

130 , case _nixBuildConfig_outLink cfg of

138 , case _nixBuildConfig_outLink cfg of

@@ -145,12 +153,26 @@ instance HasNixCommonConfig NixInstantiateConfig where

145instance Default NixInstantiateConfig where

153instance Default NixInstantiateConfig where

146 def = NixInstantiateConfig def False

154 def = NixInstantiateConfig def False

147

155

148−runNixInstantiateConfig :: NixInstantiateConfig -> [FilePath]

156+runNixInstantiateConfig :: NixInstantiateConfig -> [String]

149runNixInstantiateConfig cfg = mconcat

157runNixInstantiateConfig cfg = mconcat

150 [ runNixCommonConfig $ cfg ^. nixCommonConfig

158 [ runNixCommonConfig $ cfg ^. nixCommonConfig

151 , "--eval" <$ guard (_nixInstantiateConfig_eval cfg)

159 , "--eval" <$ guard (_nixInstantiateConfig_eval cfg)

152 ]

160 ]

153

161

162+data NixShellConfig = NixShellConfig

163+ { _nixShellConfig_common :: NixCommonConfig

164+ , _nixShellConfig_pure :: Bool

165+ , _nixShellConfig_run :: Maybe String

166+ }

167+

168+makeLenses ''NixShellConfig

169+

170+instance HasNixCommonConfig NixShellConfig where

171+ nixCommonConfig = nixShellConfig_common

172+

173+instance Default NixShellConfig where

174+ def = NixShellConfig def False Nothing

175+

154data NixCmd

176data NixCmd

155 = NixCmd_Build NixBuildConfig

177 = NixCmd_Build NixBuildConfig

156 | NixCmd_Instantiate NixInstantiateConfig

178 | NixCmd_Instantiate NixInstantiateConfig

@@ -158,9 +180,17 @@ data NixCmd

158instance Default NixCmd where

180instance Default NixCmd where

159 def = NixCmd_Build def

181 def = NixCmd_Build def

160

182

183+runNixShellConfig :: NixShellConfig -> [String]

184+runNixShellConfig cfg = mconcat

185+ [ runNixCommonConfig $ cfg ^. nixCommonConfig

186+ , [ "--pure" | cfg ^. nixShellConfig_pure ]

187+ ] ++ mconcat [

188+ ["--run", run] | run <- maybeToList $ cfg ^. nixShellConfig_run

189+ ]

190+

161nixCmd :: MonadObelisk m => NixCmd -> m FilePath

191nixCmd :: MonadObelisk m => NixCmd -> m FilePath

162nixCmd cmdCfg = withSpinner' ("Running " <> cmd <> desc) (Just $ const $ "Built " <> desc) $ do

192nixCmd cmdCfg = withSpinner' ("Running " <> cmd <> desc) (Just $ const $ "Built " <> desc) $ do

163− output <- readProcessAndLogStderr Debug $ proc (T.unpack cmd) $ options

193+ output <- readProcessAndLogStderr Debug $ proc (T.unpack cmd) options

164 -- Remove final newline that Nix appends

194 -- Remove final newline that Nix appends

165 Just (outPath, '\n') <- pure $ T.unsnoc output

195 Just (outPath, '\n') <- pure $ T.unsnoc output

166 pure $ T.unpack outPath

196 pure $ T.unpack outPath

lib/command/src/Obelisk/Command/Preprocessor.hsnew file+96

@@ -0,0 +1,96 @@

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE OverloadedStrings #-}

4+module Obelisk.Command.Preprocessor where

6+import qualified Data.ByteString.Lazy as BL

7+import qualified Data.ByteString.Lazy.Builder as BU

8+import Data.List (intersperse, isPrefixOf, sortOn)

9+import Data.Maybe (fromMaybe)

10+import qualified Data.Text.Lazy.Builder as TL

11+import qualified Data.Text.Lazy.Encoding as TL

12+import Distribution.Compiler (CompilerFlavor (..))

13+import Language.Haskell.Extension (Extension (..), Language(..))

14+import System.IO (IOMode (..), hClose, hPutStrLn, openFile, stderr)

15+import System.FilePath (hasTrailingPathSeparator, joinPath, normalise, splitPath)

16+

17+import Obelisk.Command.Run (CabalPackageInfo (..), parseCabalPackage')

18+

19+applyPackages :: FilePath -> FilePath -> FilePath -> [FilePath] -> IO ()

20+applyPackages origPath inPath outPath packagePaths = do

21+ -- This code is intended to be executed via ghci's -pgmF preprocessor option

22+ -- The command line arguments are passed in via ghc, which dictates the first three options and meanings

23+ -- In order for this code to execute, origPath must contain either a '.' character or a '/' character.

24+ -- (This is to avoid the possibility of the command line syntax conflicting with another ob command)

25+ -- We do have control over the remaining arguments, but they must be the same for all files.

26+ -- Thus, the fourth command line argument must be "apply-packages", which has already been handled.

27+ -- We assume all the remaining arguments passed in are paths to cabal or hpack package specifications.

28+

29+ outFile <- openFile outPath WriteMode

30+ let hPutTextBuilder h = BU.hPutBuilder h . TL.encodeUtf8Builder . TL.toLazyText

31+

32+ -- putStr "--------------------------------------------------------------------------------\n"

33+ -- print args

34+ -- putStr "--------------------------------------------------------------------------------\n"

35+

36+ -- Thus we must select among the packagePaths for the file we are going to parse.

37+

38+ let takeDirs = takeWhile hasTrailingPathSeparator

39+ packageDirs = sortOn (negate . length . takeDirs) $ map (splitPath . normalise) packagePaths

40+ origDir = splitPath $ normalise origPath

41+ matches = [ joinPath d | d <- packageDirs, takeDirs d `isPrefixOf` origDir ]

42+

43+ -- So the first element of matches is going to be the deepest path to a package spec that contains

44+ -- our file as a subdirectory.

45+

46+ case matches of

47+ [] -> hPutTextBuilder outFile (lineNumberPragma origPath) -- TODO: probably should produce a warning

48+ (packagePath:_) -> do

49+ parseCabalPackage' packagePath >>= \case

50+ Left err ->

51+ hPutStrLn stderr $ "Error: Unable to parse cabal package " <> packagePath <> "; Skipping preprocessor on " <> origPath <> ". Error was " <> show err

52+ Right (_warnings, packageInfo) ->

53+ hPutTextBuilder outFile (generateHeader origPath packageInfo)

54+

55+ BL.readFile inPath >>= BL.hPut outFile

56+ hClose outFile

57+

58+

59+ -- I'm pretty sure there's a certain amount of oversimplification in CabalPackageInfo, so I doubt this is fully robust.

60+

61+generateHeader :: FilePath -> CabalPackageInfo -> TL.Builder

62+generateHeader origPath packageInfo =

63+ hsExtensions <> ghcOptions <> lineNumberPragma origPath

64+ where

65+ hsExtensions =

66+ if not (null extList)

67+ then TL.fromText "{-# LANGUAGE "

68+ <> mconcat (intersperse (TL.fromText ", ") extList)

69+ <> TL.fromText " #-}\n"

70+ else mempty

71+ extList = addDefaultLanguage $ concatMap showExt $ _cabalPackageInfo_defaultExtensions packageInfo

72+ addDefaultLanguage =

73+ case _cabalPackageInfo_defaultLanguage packageInfo of

74+ Nothing -> id

75+ Just x -> case x of

76+ UnknownLanguage ext -> ( TL.fromString ext :)

77+ ext -> ( TL.fromString (show ext) :)

78+ showExt = \case

79+ EnableExtension ext -> [TL.fromString (show ext)]

80+ DisableExtension _ -> []

81+ UnknownExtension ext -> [TL.fromString ext]

82+

83+ ghcOptions =

84+ if not (null optList)

85+ then TL.fromText "{-# OPTIONS_GHC "

86+ <> mconcat (intersperse (TL.fromText " ") optList)

87+ <> TL.fromText " #-}\n"

88+ else mempty

89+ optList = map TL.fromString

90+ $ filter (\x -> not (isPrefixOf "-O" x))

91+ $ fromMaybe []

92+ $ lookup GHC (_cabalPackageInfo_compilerOptions packageInfo)

93+

94+lineNumberPragma :: FilePath -> TL.Builder

95+lineNumberPragma origPath =

96+ TL.fromText "{-# LINE 1 \"" <> TL.fromString origPath <> TL.fromText "\" #-}\n"

lib/command/src/Obelisk/Command/Project.hs+142−56

@@ -3,37 +3,55 @@

3{-# LANGUAGE OverloadedStrings #-}

4module Obelisk.Command.Project

5 ( InitSource (..)

6− , initProject

7 , findProjectObeliskCommand

6 , findProjectObeliskCommand

8 , findProjectRoot

7 , findProjectRoot

9− , withProjectRoot

8+ , initProject

10− , inProjectShell

9+ , nixShellRunConfig

11− , inImpureProjectShell

10+ , nixShellRunProc

11+ , nixShellWithHoogle

12+ , nixShellWithPkgs

13+ , obeliskDirName

12 , projectShell

14 , projectShell

13−

14− , toObeliskDir

15 , toImplDir

16+ , toNixPath

17+ , toObeliskDir

18+ , withProjectRoot

16 ) where

19 ) where

21+import Control.Concurrent.MVar (MVar, newMVar, withMVarMasked)

22+import Control.Lens ((.~), (?~), (<&>))

18import Control.Monad

23import Control.Monad

19import Control.Monad.IO.Class (liftIO)

24import Control.Monad.IO.Class (liftIO)

20import Control.Monad.State

25import Control.Monad.State

26+import qualified Data.Aeson as Json

21import Data.Bits

27import Data.Bits

28+import qualified Data.ByteString.Lazy as BSL

29+import Data.Default (def)

22−import Data.Function (on)

30+import Data.Function ((&), on)

31+import Data.List (isInfixOf)

32+import Data.Map (Map)

33+import Data.Text (Text)

23import qualified Data.Text as T

34import qualified Data.Text as T

35+import Data.Text.Encoding (decodeUtf8)

36+import Data.Traversable (for)

24import System.Directory

37import System.Directory

38+import System.Environment (lookupEnv)

25import System.FilePath

39import System.FilePath

26import System.IO.Temp

40import System.IO.Temp

41+import System.IO.Unsafe (unsafePerformIO)

27−import System.Posix (FileStatus, UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)

42+import System.Posix (FileStatus, FileMode, CMode (..), UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)

28import System.Posix.Files

43import System.Posix.Files

29−import System.Process (CreateProcess, cwd, proc, waitForProcess, delegate_ctlc)

44+import System.Process (waitForProcess)

31import GitHub.Data.GitData (Branch)

46import GitHub.Data.GitData (Branch)

32import GitHub.Data.Name (Name)

47import GitHub.Data.Name (Name)

34import Obelisk.App (MonadObelisk)

49import Obelisk.App (MonadObelisk)

35import Obelisk.CliApp

50import Obelisk.CliApp

51+import Obelisk.Command.Nix

36import Obelisk.Command.Thunk

52import Obelisk.Command.Thunk

53+import Obelisk.Command.Utils (nixExePath)

54+

37--TODO: Make this module resilient to random exceptions

55--TODO: Make this module resilient to random exceptions

39--TODO: Don't hardcode this

57--TODO: Don't hardcode this

@@ -47,17 +65,21 @@ obeliskSourceWithBranch branch = ThunkSource_GitHub $ GitHubSource

47 { _gitHubSource_owner = "obsidiansystems"

65 { _gitHubSource_owner = "obsidiansystems"

48 , _gitHubSource_repo = "obelisk"

66 , _gitHubSource_repo = "obelisk"

49 , _gitHubSource_branch = Just branch

67 , _gitHubSource_branch = Just branch

68+ , _gitHubSource_private = False

50 }

69 }

52data InitSource

71data InitSource

53− = InitSource_Default

72+ = InitSource_Default

54− | InitSource_Branch (Name Branch)

73+ | InitSource_Branch (Name Branch)

55− | InitSource_Symlink FilePath

74+ | InitSource_Symlink FilePath

56− deriving Show

75+ deriving Show

76+

77+obeliskDirName :: FilePath

78+obeliskDirName = ".obelisk"

58-- | Path to obelisk directory in given path

80-- | Path to obelisk directory in given path

59toObeliskDir :: FilePath -> FilePath

81toObeliskDir :: FilePath -> FilePath

60−toObeliskDir p = p </> ".obelisk"

82+toObeliskDir p = p </> obeliskDirName

62-- | Path to impl file in given path

84-- | Path to impl file in given path

63toImplDir :: FilePath -> FilePath

85toImplDir :: FilePath -> FilePath

@@ -114,15 +136,16 @@ initProject source force = withSystemTempDirectory "ob-init" $ \tmpDir -> do

114findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)

136findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)

115findProjectObeliskCommand target = do

137findProjectObeliskCommand target = do

116 myUid <- liftIO getRealUserID

138 myUid <- liftIO getRealUserID

139+ processUmask <- liftIO getUmask

117 targetStat <- liftIO $ getFileStatus target

140 targetStat <- liftIO $ getFileStatus target

118− (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat myUid >>= \case

141+ (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat processUmask myUid >>= \case

119 Nothing -> pure Nothing

142 Nothing -> pure Nothing

120 Just projectRoot -> liftIO (doesDirectoryExist $ toImplDir projectRoot) >>= \case

143 Just projectRoot -> liftIO (doesDirectoryExist $ toImplDir projectRoot) >>= \case

121 False -> do

144 False -> do

122 putLog Warning $ "Found obelisk directory in " <> T.pack projectRoot <> " but the implementation (impl) file is missing"

145 putLog Warning $ "Found obelisk directory in " <> T.pack projectRoot <> " but the implementation (impl) file is missing"

123 pure Nothing

146 pure Nothing

124 True -> do

147 True -> do

125− walkToImplDir projectRoot myUid -- For security check

148+ walkToImplDir projectRoot myUid processUmask -- For security check

126 return $ Just projectRoot

149 return $ Just projectRoot

127 case (result, insecurePaths) of

150 case (result, insecurePaths) of

128 (Just projDir, []) -> do

151 (Just projDir, []) -> do

@@ -133,17 +156,37 @@ findProjectObeliskCommand target = do

133 putLog Error $ T.unlines

156 putLog Error $ T.unlines

134 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"

157 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"

135 , T.unlines $ fmap (T.pack . normalise) insecurePaths

158 , T.unlines $ fmap (T.pack . normalise) insecurePaths

136− , "Please ensure that all of these directories are owned by you and are not writable by anyone else."

159+ , "Please ensure that all of these directories are owned by you, not world-writable, and no more group-writable than permitted by your umask."

137 ]

160 ]

138 return Nothing

161 return Nothing

139

162

163+-- | Get the umask for the Obelisk process.

164+--

165+-- Because of

166+-- http://man7.org/linux/man-pages/man2/umask.2.html#NOTES we have to set the

167+-- umask to read it. We are using 'withMVarMasked' to guarantee that setting and

168+-- reading isn't interrupted by any exception or interleaved with another thread.

169+getUmask :: IO FileMode

170+getUmask = withMVarMasked globalUmaskLock $ \() -> do

171+ initialMask <- setFileCreationMask safeUmask

172+ void (setFileCreationMask initialMask)

173+ pure initialMask

174+ where

175+ safeUmask :: FileMode

176+ safeUmask = CMode 0o22

177+

178+{-# NOINLINE globalUmaskLock #-}

179+globalUmaskLock :: MVar ()

180+globalUmaskLock = unsafePerformIO (newMVar ())

181+

140-- | Get the FilePath to the containing project directory, if there is one

182-- | Get the FilePath to the containing project directory, if there is one

141findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)

183findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)

142findProjectRoot target = do

184findProjectRoot target = do

143 myUid <- liftIO getRealUserID

185 myUid <- liftIO getRealUserID

144 targetStat <- liftIO $ getFileStatus target

186 targetStat <- liftIO $ getFileStatus target

187+ umask <- liftIO getUmask

145− (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat myUid) []

188+ (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat umask myUid) []

146− return result

189+ return $ makeRelative "." <$> result

147

190

148withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a

191withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a

149withProjectRoot target f = findProjectRoot target >>= \case

192withProjectRoot target f = findProjectRoot target >>= \case

@@ -155,15 +198,15 @@ withProjectRoot target f = findProjectRoot target >>= \case

155-- traversed in the process. Return the project root directory, if found.

198-- traversed in the process. Return the project root directory, if found.

156walkToProjectRoot

199walkToProjectRoot

157 :: (MonadState [FilePath] m, MonadIO m)

200 :: (MonadState [FilePath] m, MonadIO m)

158− => FilePath -> FileStatus -> UserID -> m (Maybe FilePath)

201+ => FilePath -> FileStatus -> FileMode -> UserID -> m (Maybe FilePath)

159−walkToProjectRoot this thisStat myUid = liftIO (doesDirectoryExist this) >>= \case

202+walkToProjectRoot this thisStat desiredUmask myUid = liftIO (doesDirectoryExist this) >>= \case

160 -- It's not a directory, so it can't be a project

203 -- It's not a directory, so it can't be a project

161 False -> do

204 False -> do

162 let dir = takeDirectory this

205 let dir = takeDirectory this

163 dirStat <- liftIO $ getFileStatus dir

206 dirStat <- liftIO $ getFileStatus dir

164− walkToProjectRoot dir dirStat myUid

207+ walkToProjectRoot dir dirStat desiredUmask myUid

165 True -> do

208 True -> do

166− when (not $ isWritableOnlyBy thisStat myUid) $ modify (this:)

209+ when (not $ isWellOwnedAndWellPermissioned thisStat myUid desiredUmask) $ modify (this:)

167 liftIO (doesDirectoryExist $ toObeliskDir this) >>= \case

210 liftIO (doesDirectoryExist $ toObeliskDir this) >>= \case

168 True -> return $ Just this

211 True -> return $ Just this

169 False -> do

212 False -> do

@@ -173,51 +216,94 @@ walkToProjectRoot this thisStat myUid = liftIO (doesDirectoryExist this) >>= \ca

173 isSameFileAs = (==) `on` fileIdentity

216 isSameFileAs = (==) `on` fileIdentity

174 if thisStat `isSameFileAs` nextStat

217 if thisStat `isSameFileAs` nextStat

175 then return Nothing -- Found a cycle; probably hit root directory

218 then return Nothing -- Found a cycle; probably hit root directory

176− else walkToProjectRoot next nextStat myUid

219+ else walkToProjectRoot next nextStat desiredUmask myUid

177

220

178-- | Walk from the given project root directory to its Obelisk implementation

221-- | Walk from the given project root directory to its Obelisk implementation

179-- directory, accumulating potentially insecure directories that were traversed

222-- directory, accumulating potentially insecure directories that were traversed

180-- in the process.

223-- in the process.

181−walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> m ()

224+walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> FileMode -> m ()

182−walkToImplDir projectRoot myUid = do

225+walkToImplDir projectRoot myUid umask = do

183 let obDir = toObeliskDir projectRoot

226 let obDir = toObeliskDir projectRoot

184 obDirStat <- liftIO $ getFileStatus obDir

227 obDirStat <- liftIO $ getFileStatus obDir

185− when (not $ isWritableOnlyBy obDirStat myUid) $ modify (obDir:)

228+ when (not $ isWellOwnedAndWellPermissioned obDirStat myUid umask) $ modify (obDir:)

186 let implThunk = obDir </> "impl"

229 let implThunk = obDir </> "impl"

187 implThunkStat <- liftIO $ getFileStatus implThunk

230 implThunkStat <- liftIO $ getFileStatus implThunk

188− when (not $ isWritableOnlyBy implThunkStat myUid) $ modify (implThunk:)

231+ when (not $ isWellOwnedAndWellPermissioned implThunkStat myUid umask) $ modify (implThunk:)

189

232

190−--TODO: Is there a better way to ask if anyone else can write things?

191−--E.g. what about ACLs?

192−-- | Check to see if directory is only writable by a user whose User ID matches the second argument provided

233+-- | Check to see if directory is writable by a user whose User ID matches the

234+-- second argument provided, and if the fact that other people can write to that

235+-- directory is in accordance with the umask of the system, passed as the third

236+-- argument.

193−isWritableOnlyBy :: FileStatus -> UserID -> Bool

237+isWellOwnedAndWellPermissioned :: FileStatus -> UserID -> FileMode -> Bool

194−isWritableOnlyBy s uid = fileOwner s == uid && fileMode s .&. 0o22 == 0

238+isWellOwnedAndWellPermissioned s uid umask = isOwnedBy s uid && filePermissionIsSafe s umask

195

239

196−-- | Run a command in the given shell for the current project

240+isOwnedBy :: FileStatus -> UserID -> Bool

197−inProjectShell :: MonadObelisk m => String -> String -> m ()

241+isOwnedBy s uid = fileOwner s == uid

198−inProjectShell shellName command = withProjectRoot "." $ \root ->

199− projectShell root True shellName (Just command)

200

242

201−inImpureProjectShell :: MonadObelisk m => String -> String -> m ()

243+-- | Check to see if a directory respect the umask, but check explicitly that

202−inImpureProjectShell shellName command = withProjectRoot "." $ \root ->

244+-- it's not world writable in any case.

203− projectShell root False shellName (Just command)

245+filePermissionIsSafe :: FileStatus -> FileMode -> Bool

246+filePermissionIsSafe s umask = not fileWorldWritable && fileGroupWritable <= umaskGroupWritable

247+ where

248+ fileWorldWritable = fileMode s .&. 0o002 == 0o002

249+ fileGroupWritable = fileMode s .&. 0o020 == 0o020

250+ umaskGroupWritable = umask .&. 0o020 == 0

204

251

252+-- | Nix syntax requires relative paths to be prefixed by @./@ or

253+-- @../@. This will make a 'FilePath' that can be embedded in a Nix

254+-- expression.

255+toNixPath :: FilePath -> FilePath

256+toNixPath root | "/" `isInfixOf` root = root

257+ | otherwise = "./" <> root

258+

205−projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()

259+nixShellRunConfig :: MonadObelisk m => FilePath -> Bool -> Maybe String -> m NixShellConfig

206−projectShell root isPure shellName command = do

260+nixShellRunConfig root isPure command = do

207− (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCtlc $ setCwd (Just root) $ proc "nix-shell" $

261+ nixpkgsPath <- fmap T.strip $ readProcessAndLogStderr Debug $ setCwd (Just root) $

208− [ "default.nix"] <>

262+ proc nixExePath ["eval", "(import .obelisk/impl {}).nixpkgs.path"]

209− -- Keep $NIX_PATH in the env for --pure shells so '<nixpkgs>' works in sub-commands

263+ nixRemote <- liftIO $ lookupEnv "NIX_REMOTE"

210− -- TODO: Don't use <nixpkgs> for anything!

264+ pure $ def

211− (if isPure then [ "--pure", "--keep", "NIX_PATH" ] else []) <>

265+ & nixShellConfig_pure .~ isPure

212− [ "-A"

266+ & nixShellConfig_common . nixCmdConfig_target .~ (def & target_path .~ Nothing)

213− , "shells." <> shellName

267+ & nixShellConfig_run .~ (command <&> \c -> mconcat

214− ] <> case command of

268+ [ "export NIX_PATH=nixpkgs=", T.unpack nixpkgsPath, "; "

215− Nothing -> []

269+ , maybe "" (\v -> "export NIX_REMOTE=" <> v <> "; ") nixRemote

216− Just c -> ["--run", c]

270+ , c

271+ ])

272+

273+nixShellRunProc :: NixShellConfig -> ProcessSpec

274+nixShellRunProc cfg = setDelegateCtlc True $ proc "nix-shell" $ runNixShellConfig cfg

275+

276+nixShellWithPkgs :: MonadObelisk m => FilePath -> Bool -> Bool -> Map Text FilePath -> Maybe String -> m ()

277+nixShellWithPkgs root isPure chdirToRoot packageNamesAndPaths command = do

278+ packageNamesAndAbsPaths <- liftIO $ for packageNamesAndPaths makeAbsolute

279+ defShellConfig <- nixShellRunConfig root isPure command

280+ let setCwd_ = if chdirToRoot then setCwd (Just root) else id

281+ (_, _, _, ph) <- createProcess_ "nixShellWithPkgs" $ setCwd_ $ nixShellRunProc $ defShellConfig

282+ & nixShellConfig_common . nixCmdConfig_target . target_expr ?~

283+ "{root, pkgs}: ((import root {}).passthru.__unstable__.self.extend (_: _: {\

284+ \shellPackages = builtins.fromJSON pkgs;\

285+ \})).project.shells.ghc"

286+ & nixShellConfig_common . nixCmdConfig_args .~

287+ [ rawArg "root" $ toNixPath $ if chdirToRoot then "." else root

288+ , strArg "pkgs" (T.unpack $ decodeUtf8 $ BSL.toStrict $ Json.encode packageNamesAndAbsPaths)

289+ ]

217 void $ liftIO $ waitForProcess ph

290 void $ liftIO $ waitForProcess ph

218

291

219−setCtlc :: CreateProcess -> CreateProcess

292+nixShellWithHoogle :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()

220−setCtlc cfg = cfg { delegate_ctlc = True }

293+nixShellWithHoogle root isPure shell' command = do

294+ defShellConfig <- nixShellRunConfig root isPure command

295+ (_, _, _, ph) <- createProcess_ "nixShellWithHoogle" $ setCwd (Just root) $ nixShellRunProc $ defShellConfig

296+ & nixShellConfig_common . nixCmdConfig_target . target_expr ?~

297+ "{shell}: ((import ./. {}).passthru.__unstable__.self.extend (_: super: {\

298+ \userSettings = super.userSettings // { withHoogle = true; };\

299+ \})).project.shells.${shell}"

300+ & nixShellConfig_common . nixCmdConfig_args .~ [ strArg "shell" shell' ]

301+ void $ liftIO $ waitForProcess ph

221

302

222−setCwd :: Maybe FilePath -> CreateProcess -> CreateProcess

303+projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()

223−setCwd fp cfg = cfg { cwd = fp }

304+projectShell root isPure shellName command = do

305+ defShellConfig <- nixShellRunConfig root isPure command

306+ (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCwd (Just root) $ nixShellRunProc $ defShellConfig

307+ & nixShellConfig_common . nixCmdConfig_target . target_path ?~ "default.nix"

308+ & nixShellConfig_common . nixCmdConfig_target . target_attr ?~ ("shells." <> shellName)

309+ void $ liftIO $ waitForProcess ph

lib/command/src/Obelisk/Command/Run.hs+257−150

@@ -3,48 +3,60 @@

3{-# LANGUAGE MultiParamTypeClasses #-}

4{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TemplateHaskell #-}

6+{-# LANGUAGE TupleSections #-}

7module Obelisk.Command.Run where

9−import Control.Exception (bracket)

9+import Control.Arrow ((&&&))

10+import Control.Exception (Exception, bracket)

10−import Control.Monad

11+import Control.Lens (ifor)

12+import Control.Monad (filterM, unless)

13+import Control.Monad.Except (runExceptT, throwError)

11import Control.Monad.IO.Class (liftIO)

14import Control.Monad.IO.Class (liftIO)

12import Control.Monad.Reader (MonadIO)

15import Control.Monad.Reader (MonadIO)

16+import Data.Coerce (coerce)

13import Data.Either

17import Data.Either

14−import qualified Data.List as L

18+import Data.Foldable (for_, toList)

15import qualified Data.List.NonEmpty as NE

19import qualified Data.List.NonEmpty as NE

20+import Data.Map (Map)

21+import qualified Data.Map as Map

16import Data.Maybe

22import Data.Maybe

23+import qualified Data.Set as Set

24+import Data.Text (Text)

17import qualified Data.Text as T

25import qualified Data.Text as T

26+import Data.Traversable (for)

27+import Debug.Trace (trace)

18import Distribution.Compiler (CompilerFlavor(..))

28import Distribution.Compiler (CompilerFlavor(..))

19import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)

29import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)

20import Distribution.Parsec.ParseResult (runParseResult)

30import Distribution.Parsec.ParseResult (runParseResult)

21−import Distribution.Pretty

31+import qualified Distribution.System as Dist

22import Distribution.Types.BuildInfo

32import Distribution.Types.BuildInfo

23import Distribution.Types.CondTree

33import Distribution.Types.CondTree

24import Distribution.Types.GenericPackageDescription

34import Distribution.Types.GenericPackageDescription

25import Distribution.Types.Library

35import Distribution.Types.Library

26import Distribution.Utils.Generic

36import Distribution.Utils.Generic

37+import qualified Distribution.Parsec.Common as Dist

27−import Hpack.Config

38+import qualified Hpack.Config as Hpack

28−import Hpack.Render

39+import qualified Hpack.Render as Hpack

29−import Hpack.Yaml

40+import qualified Hpack.Yaml as Hpack

30import Language.Haskell.Extension

41import Language.Haskell.Extension

31import Network.Socket hiding (Debug)

42import Network.Socket hiding (Debug)

32import System.Directory

43import System.Directory

44+import System.Environment (getExecutablePath)

33import System.FilePath

45import System.FilePath

34−import System.Process (proc)

46+import qualified System.Info

35import System.IO.Temp (withSystemTempDirectory)

47import System.IO.Temp (withSystemTempDirectory)

36−import System.Which (staticWhich)

37−import Data.ByteString (ByteString)

39−import Obelisk.App (MonadObelisk, ObeliskT)

49+import Obelisk.App (MonadObelisk)

40−import Obelisk.CliApp

50+import Obelisk.CliApp (Severity (..) , failWith, putLog, proc, readCreateProcessWithExitCode, readProcessAndLogStderr, setCwd)

41− ( CliT (..), HasCliConfig, Severity (..)

42− , callCommand, failWith, getCliConfig, putLog

43− , readProcessAndLogStderr, runCli)

44−import Obelisk.Command.Project (inProjectShell, withProjectRoot)

51+import Obelisk.Command.Project (nixShellWithPkgs, toImplDir, withProjectRoot)

52+import Obelisk.Command.Thunk (attrCacheFileName)

53+import Obelisk.Command.Utils (findExePath, ghcidExePath, nixBuildExePath, nixExePath)

46data CabalPackageInfo = CabalPackageInfo

55data CabalPackageInfo = CabalPackageInfo

56+ { _cabalPackageInfo_packageFile :: FilePath

57+ , _cabalPackageInfo_packageName :: T.Text

47− { _cabalPackageInfo_packageRoot :: FilePath

58+ , _cabalPackageInfo_packageRoot :: FilePath

59+ , _cabalPackageInfo_buildable :: Bool

48 , _cabalPackageInfo_sourceDirs :: NE.NonEmpty FilePath

60 , _cabalPackageInfo_sourceDirs :: NE.NonEmpty FilePath

49 -- ^ List of hs src dirs of the library component

61 -- ^ List of hs src dirs of the library component

50 , _cabalPackageInfo_defaultExtensions :: [Extension]

62 , _cabalPackageInfo_defaultExtensions :: [Extension]

@@ -55,152 +67,230 @@ data CabalPackageInfo = CabalPackageInfo

55 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)

67 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)

56 }

68 }

58−-- NOTE: `run` is not polymorphic like the rest because we use StaticPtr to invoke it.

70+-- | Used to signal to obelisk that it's being invoked as a preprocessor

59−run :: ObeliskT IO ()

71+preprocessorIdentifier :: String

60−run = do

72+preprocessorIdentifier = "__preprocessor-apply-packages"

61− let nixPath = $(staticWhich "nix")

73+

62− nixBuildPath = $(staticWhich "nix-build")

74+run :: MonadObelisk m => m ()

75+run = withProjectRoot "." $ \root -> do

63− pkgs <- getLocalPkgs

76+ pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root

64− withGhciScript pkgs $ \dotGhciPath -> do

77+ withGhciScript pkgs root $ \dotGhciPath -> do

65− freePort <- getFreePort

66− assets <- withProjectRoot "." $ \root -> do

78+ assets <- do

67− let importableRoot = if "/" `isInfixOf` root

68− then root

69− else "./" <> root

70− isDerivation <- readProcessAndLogStderr Debug $

79+ isDerivation <- readProcessAndLogStderr Debug $ setCwd (Just root) $

71− proc nixPath

80+ proc nixExePath

72 [ "eval"

81 [ "eval"

73− , "-f"

74− , root

75− , "(let a = import " <> importableRoot <> " {}; in toString (a.reflex.nixpkgs.lib.isDerivation a.passthru.staticFilesImpure))"

82+ , "(let a = import ./. {}; in toString (a.reflex.nixpkgs.lib.isDerivation a.passthru.staticFilesImpure))"

76 , "--raw"

83 , "--raw"

77 -- `--raw` is not available with old nix-instantiate. It drops quotation

84 -- `--raw` is not available with old nix-instantiate. It drops quotation

78 -- marks and trailing newline, so is very convenient for shelling out.

85 -- marks and trailing newline, so is very convenient for shelling out.

79 ]

86 ]

80 -- Check whether the impure static files are a derivation (and so must be built)

87 -- Check whether the impure static files are a derivation (and so must be built)

81 if isDerivation == "1"

88 if isDerivation == "1"

82− then fmap T.strip $ readProcessAndLogStderr Debug $ -- Strip whitespace here because nix-build has no --raw option

89+ then fmap T.strip $ readProcessAndLogStderr Debug $ setCwd (Just root) $ -- Strip whitespace here because nix-build has no --raw option

83− proc nixBuildPath

90+ proc nixBuildExePath

84 [ "--no-out-link"

91 [ "--no-out-link"

85− , "-E", "(import " <> importableRoot <> "{}).passthru.staticFilesImpure"

92+ , "-E", "(import ./. {}).passthru.staticFilesImpure"

86 ]

93 ]

87− else readProcessAndLogStderr Debug $

94+ else readProcessAndLogStderr Debug $ setCwd (Just root) $

88− proc nixPath ["eval", "-f", root, "passthru.staticFilesImpure", "--raw"]

95+ proc nixExePath ["eval", "-f", ".", "passthru.staticFilesImpure", "--raw"]

89 putLog Debug $ "Assets impurely loaded from: " <> assets

96 putLog Debug $ "Assets impurely loaded from: " <> assets

97+ freePort <- getFreePort

90− runGhcid dotGhciPath $ Just $ unwords

98+ runGhcid root True dotGhciPath pkgs $ Just $ unwords

91 [ "Obelisk.Run.run"

99 [ "Obelisk.Run.run"

92 , show freePort

100 , show freePort

93− , "(runServeAsset " ++ show assets ++ ")"

101+ , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"

94 , "Backend.backend"

102 , "Backend.backend"

95 , "Frontend.frontend"

103 , "Frontend.frontend"

96 ]

104 ]

105

98runRepl :: MonadObelisk m => m ()

106runRepl :: MonadObelisk m => m ()

99−runRepl = do

107+runRepl = withProjectRoot "." $ \root -> do

100− pkgs <- getLocalPkgs

108+ pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root

101− withGhciScript pkgs $ \dotGhciPath -> do

109+ withGhciScript pkgs "." $ \dotGhciPath ->

102− runGhciRepl dotGhciPath

110+ runGhciRepl root pkgs dotGhciPath

103

111

104runWatch :: MonadObelisk m => m ()

112runWatch :: MonadObelisk m => m ()

105−runWatch = do

113+runWatch = withProjectRoot "." $ \root -> do

106− pkgs <- getLocalPkgs

114+ pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root

107− withGhciScript pkgs $ \dotGhciPath -> runGhcid dotGhciPath Nothing

115+ withGhciScript pkgs root $ \dotGhciPath ->

116+ runGhcid root True dotGhciPath pkgs Nothing

117+

118+-- | Relative paths to local packages of an obelisk project.

119+--

120+-- These are a combination of the obelisk predefined local packages,

121+-- and any packages that the user has set with the @packages@ argument

122+-- to the Nix @project@ function.

123+getLocalPkgs :: MonadObelisk m => FilePath -> m [FilePath]

124+getLocalPkgs root = do

125+ obeliskPaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"]

126+

127+ -- We do not want to find packages that are embedded inside other obelisk projects, unless that

128+ -- obelisk project is our own.

129+ let exclusions = filter (/= root) $ map takeDirectory obeliskPaths

130+ fmap (map (makeRelative ".")) $ runFind $

131+ ["-L", root, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]

132+ <> concat [["-not", "-path", p </> "*"] | p <- (toImplDir "*" </> attrCacheFileName) : exclusions]

133+ where

134+ runFind args = do

135+ (_exitCode, out, err) <- readCreateProcessWithExitCode $ proc findExePath args

136+ putLog Debug $ T.strip $ T.pack err

137+ pure $ map T.unpack $ T.lines $ T.strip $ T.pack out

138+

139+data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound

140+ deriving (Eq, Ord, Show)

141+instance Exception GuessPackageFileError

108

142

109−-- | Relative paths to local packages of an obelisk project

143+newtype HPackFilePath = HPackFilePath { unHPackFilePath :: FilePath } deriving (Eq, Ord, Show)

110−-- TODO a way to query this

144+newtype CabalFilePath = CabalFilePath { unCabalFilePath :: FilePath } deriving (Eq, Ord, Show)

111−getLocalPkgs :: Applicative f => f [FilePath]

112−getLocalPkgs = pure ["backend", "common", "frontend"]

113

145

146+-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.

147+guessCabalPackageFile

148+ :: (MonadIO m)

149+ => FilePath -- ^ Directory or path to search for cabal package

150+ -> m (Either GuessPackageFileError (Either CabalFilePath HPackFilePath))

151+guessCabalPackageFile pkg = do

152+ liftIO (doesDirectoryExist pkg) >>= \case

153+ False -> case cabalOrHpackFile pkg of

154+ (Just hpack@(Right _)) -> pure $ Right hpack

155+ (Just cabal@(Left (CabalFilePath cabalFilePath))) -> do

156+ -- If the cabal file has a sibling hpack file, we use that instead

157+ -- since running hpack often generates a sibling cabal file

158+ let possibleHpackSibling = takeDirectory cabalFilePath </> Hpack.packageConfig

159+ hasHpackSibling <- liftIO $ doesFileExist possibleHpackSibling

160+ pure $ Right $ if hasHpackSibling then Right (HPackFilePath possibleHpackSibling) else cabal

161+ Nothing -> pure $ Left GuessPackageFileError_NotFound

162+ True -> do

163+ candidates <- liftIO $

164+ filterM (doesFileExist . either unCabalFilePath unHPackFilePath)

165+ =<< mapMaybe (cabalOrHpackFile . (pkg </>)) <$> listDirectory pkg

166+ pure $ case partitionEithers candidates of

167+ ([hpack], _) -> Right $ Left hpack

168+ ([], [cabal]) -> Right $ Right cabal

169+ ([], []) -> Left GuessPackageFileError_NotFound

170+ (hpacks, cabals) -> Left $ GuessPackageFileError_Ambiguous $ coerce hpacks <> coerce cabals

171+

172+cabalOrHpackFile :: FilePath -> Maybe (Either CabalFilePath HPackFilePath)

173+cabalOrHpackFile = \case

174+ x | takeExtension x == ".cabal" -> Just (Left $ CabalFilePath x)

175+ | takeFileName x == Hpack.packageConfig -> Just (Right $ HPackFilePath x)

176+ | otherwise -> Nothing

177+

178+-- | Parses the cabal package in a given directory.

179+-- This automatically figures out which .cabal file or package.yaml (hpack) file to use in the given directory.

114parseCabalPackage

180parseCabalPackage

115− :: (MonadObelisk m)

181+ :: MonadObelisk m

116− => FilePath -- ^ package directory

182+ => FilePath -- ^ Package directory

117 -> m (Maybe CabalPackageInfo)

183 -> m (Maybe CabalPackageInfo)

118−parseCabalPackage dir = do

184+parseCabalPackage dir = parseCabalPackage' dir >>= \case

119− let cabalFp = dir </> (takeBaseName dir <> ".cabal")

185+ Left err -> Nothing <$ putLog Error err

120− hpackFp = dir </> "package.yaml"

186+ Right (warnings, pkgInfo) -> do

121− hasCabal <- liftIO $ doesFileExist cabalFp

187+ for_ warnings $ putLog Warning . T.pack . show

122− hasHpack <- liftIO $ doesFileExist hpackFp

188+ pure $ Just pkgInfo

123−

189+

124− mCabalContents <- if hasCabal

190+-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.

125− then Just <$> liftIO (readUTF8File cabalFp)

191+parseCabalPackage'

126− else if hasHpack

192+ :: (MonadIO m)

127− then do

193+ => FilePath -- ^ Package directory

194+ -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))

195+parseCabalPackage' pkg = runExceptT $ do

196+ (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case

197+ Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg

198+ Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack pkg

199+ Right (Left (CabalFilePath file)) -> (, file, takeBaseName file) <$> liftIO (readUTF8File file)

200+ Right (Right (HPackFilePath file)) -> do

201+ let

128− let decodeOptions = DecodeOptions (ProgramName "ob") hpackFp Nothing decodeYaml

202+ decodeOptions = Hpack.DecodeOptions (Hpack.ProgramName "ob") file Nothing Hpack.decodeYaml

129− liftIO (readPackageConfig decodeOptions) >>= \case

203+ liftIO (Hpack.readPackageConfig decodeOptions) >>= \case

130− Left err -> do

131− putLog Error $ T.pack $ "Failed to parse " <> hpackFp <> ": " <> err

204+ Left err -> throwError $ T.pack $ "Failed to parse " <> file <> ": " <> err

132− return Nothing

133− Right (DecodeResult hpackPackage _ _ _) -> do

205+ Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure (Hpack.renderPackage [] hpackPackage, file, Hpack.packageName hpackPackage)

134− return $ Just $ renderPackage [] hpackPackage

206+

135− else return Nothing

207+ let

136−

137− fmap join $ forM mCabalContents $ \cabalContents -> do

138− let (warnings, result) = runParseResult $ parseGenericPackageDescription $

208+ (warnings, result) = runParseResult $ parseGenericPackageDescription $ toUTF8BS cabalContents

139− toUTF8BS $ cabalContents

209+ osConfVar = case System.Info.os of

140− mapM_ (putLog Warning) $ fmap (T.pack . show) warnings

210+ "linux" -> Just Dist.Linux

141− case result of

211+ "darwin" -> Just Dist.OSX

142− Right gpkg -> do

212+ _ -> trace "Unrecgonized System.Info.os" Nothing

143− return $ do

213+ archConfVar = Just Dist.X86_64 -- TODO: Actually infer this

144− (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg

214+ evalConfVar v = Right $ case v of

215+ OS osVar -> Just osVar == osConfVar

216+ Arch archVar -> Just archVar == archConfVar

217+ Impl GHC _ -> True -- TODO: Actually check version range

218+ _ -> False

219+ case condLibrary <$> result of

220+ Right (Just condLib) -> do

221+ let (_, lib) = simplifyCondTree evalConfVar condLib

145− pure $ CabalPackageInfo

222+ pure $ (warnings,) $ CabalPackageInfo

223+ { _cabalPackageInfo_packageName = T.pack packageName

224+ , _cabalPackageInfo_packageFile = packageFile

146− { _cabalPackageInfo_packageRoot = takeDirectory cabalFp

225+ , _cabalPackageInfo_packageRoot = takeDirectory packageFile

226+ , _cabalPackageInfo_buildable = buildable $ libBuildInfo lib

147− , _cabalPackageInfo_sourceDirs =

227+ , _cabalPackageInfo_sourceDirs =

148− fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib

228+ fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib

149− , _cabalPackageInfo_defaultExtensions =

229+ , _cabalPackageInfo_defaultExtensions =

150− defaultExtensions $ libBuildInfo lib

230+ defaultExtensions $ libBuildInfo lib

151− , _cabalPackageInfo_defaultLanguage =

231+ , _cabalPackageInfo_defaultLanguage =

152− defaultLanguage $ libBuildInfo lib

232+ defaultLanguage $ libBuildInfo lib

153− , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib

233+ , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib

154− }

234+ }

235+ Right Nothing -> throwError "Haskell package has no library component"

155− Left (_, errors) -> do

236+ Left (_, errors) ->

156− putLog Error $ T.pack $ "Failed to parse " <> cabalFp <> ":"

237+ throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)

157− mapM_ (putLog Error) $ fmap (T.pack . show) errors

238+

158− return Nothing

239+parsePackagesOrFail :: MonadObelisk m => [FilePath] -> m (NE.NonEmpty CabalPackageInfo)

159−

240+parsePackagesOrFail dirs = do

160−withUTF8FileContentsM :: (MonadIO m, HasCliConfig e m) => FilePath -> (ByteString -> CliT e IO a) -> m a

241+ (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do

161−withUTF8FileContentsM fp f = do

242+ flip fmap (parseCabalPackage dir) $ \case

162− c <- getCliConfig

243+ Just packageInfo

163− liftIO $ withUTF8FileContents fp $ runCli c . f . toUTF8BS

244+ | _cabalPackageInfo_buildable packageInfo -> Right packageInfo

245+ _ -> Left dir

246+

247+ let packagesByName = Map.fromListWith (<>) [(_cabalPackageInfo_packageName p, p NE.:| []) | p <- packageInfos']

248+ unambiguous <- ifor packagesByName $ \packageName ps -> case ps of

249+ p NE.:| [] -> pure p -- No ambiguity here

250+ p NE.:| _ -> do

251+ putLog Warning $ T.pack $

252+ "Packages named '" <> T.unpack packageName <> "' appear in " <> show (length ps) <> " different locations: "

253+ <> intercalate ", " (map _cabalPackageInfo_packageFile $ toList ps)

254+ <> "; Picking " <> _cabalPackageInfo_packageFile p

255+ pure p

256+

257+ packageInfos <- case NE.nonEmpty $ toList unambiguous of

258+ Nothing -> failWith $ T.pack $ "No valid, buildable packages found in " <> intercalate ", " dirs

259+ Just xs -> pure xs

260+

261+ unless (null pkgDirErrs) $

262+ putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs

263+

264+ pure packageInfos

265+

266+packageInfoToNamePathMap :: [CabalPackageInfo] -> Map Text FilePath

267+packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot)

164

268

165-- | Create ghci configuration to load the given packages

269-- | Create ghci configuration to load the given packages

166withGhciScript

270withGhciScript

167 :: MonadObelisk m

271 :: MonadObelisk m

168− => [FilePath] -- ^ List of packages to load into ghci

272+ => [CabalPackageInfo] -- ^ List of packages to load into ghci

273+ -> FilePath -- ^ All paths written to the .ghci file will be relative to this path

169− -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporory .ghci

274+ -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci

170 -> m ()

275 -> m ()

171−withGhciScript pkgs f = do

276+withGhciScript packageInfos pathBase f = do

172− (pkgDirErrs, packageInfos) <- fmap partitionEithers $ forM pkgs $ \pkg -> do

277+ selfExe <- liftIO getExecutablePath

173− flip fmap (parseCabalPackage pkg) $ \case

278+ let

174− Nothing -> Left pkg

279+ packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos

175− Just packageInfo -> Right packageInfo

280+ modulesToLoad = mconcat

176−

281+ [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]

177− when (null packageInfos) $

282+ , [ "Backend" | "backend" `Set.member` packageNames ]

178− failWith $ T.pack $ "No valid pkgs found in " <> intercalate ", " pkgs

283+ , [ "Frontend" | "frontend" `Set.member` packageNames ]

179− unless (null pkgDirErrs) $

284+ ]

180− putLog Warning $ T.pack $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs

285+ dotGhci = unlines

181−

286+ -- TODO: Shell escape

182− let extensions = packageInfos >>= _cabalPackageInfo_defaultExtensions

287+ [ ":set -F -pgmF " <> selfExe <> " -optF " <> preprocessorIdentifier <> " " <> unwords (map (("-optF " <>) . makeRelative pathBase . _cabalPackageInfo_packageFile) packageInfos)

183− languageFromPkgs = L.nub $ mapMaybe _cabalPackageInfo_defaultLanguage packageInfos

288+ , ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)

184− -- NOTE when no default-language is present cabal sets Haskell98

289+ , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad

185− language = NE.toList $ fromMaybe (Haskell98 NE.:| []) $ NE.nonEmpty languageFromPkgs

186− extensionsLine = if extensions == mempty

187− then ""

188− else ":set " <> intercalate " " ((("-X" <>) . prettyShow) <$> extensions)

189− ghcOptions = concat $ mapMaybe (\case (GHC, xs) -> Just xs; _ -> Nothing) $

190− packageInfos >>= _cabalPackageInfo_compilerOptions

191− dotGhci = unlines $

192− [ ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)

193− , case ghcOptions of

194− [] -> ""

195− xs -> ":set " <> intercalate " " xs

196− , extensionsLine

197− , ":set " <> intercalate " " (("-X" <>) . prettyShow <$> language)

198− , ":load Backend Frontend"

199− , "import Obelisk.Run"

290+ , "import qualified Obelisk.Run"

200− , "import qualified Frontend"

291+ , "import qualified Frontend"

201− , "import qualified Backend"

292+ , "import qualified Backend"

202− ]

293+ ]

203− warnDifferentLanguages language

204 withSystemTempDirectory "ob-ghci" $ \fp -> do

294 withSystemTempDirectory "ob-ghci" $ \fp -> do

205 let dotGhciPath = fp </> ".ghci"

295 let dotGhciPath = fp </> ".ghci"

206 liftIO $ writeFile dotGhciPath dotGhci

296 liftIO $ writeFile dotGhciPath dotGhci

@@ -208,35 +298,52 @@ withGhciScript pkgs f = do

208

298

209 where

299 where

210 rootedSourceDirs pkg = NE.toList $

300 rootedSourceDirs pkg = NE.toList $

211− (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg

301+ makeRelative pathBase . (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg

212−

213−warnDifferentLanguages :: MonadObelisk m => [Language] -> m ()

214−warnDifferentLanguages (_:_:_) = putLog Warning "Different languages detected across packages which may result in errors when loading the repl"

215−warnDifferentLanguages _ = return ()

216

302

217-- | Run ghci repl

303-- | Run ghci repl

218runGhciRepl

304runGhciRepl

219 :: MonadObelisk m

305 :: MonadObelisk m

220− => FilePath -- ^ Path to .ghci

306+ => FilePath -- ^ Path to project root

307+ -> [CabalPackageInfo]

308+ -> FilePath -- ^ Path to .ghci

221 -> m ()

309 -> m ()

222−runGhciRepl dotGhci = inProjectShell "ghc" $ unwords $ "ghci" : ["-no-user-package-db", "-ghci-script", dotGhci]

310+runGhciRepl root packages dotGhci =

311+ -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the

312+ -- ghc that is provided by the shell in the user's project.

313+ nixShellWithPkgs root True False (packageInfoToNamePathMap packages) $ Just $ "ghci " <> makeBaseGhciOptions dotGhci -- TODO: Shell escape

223

314

224-- | Run ghcid

315-- | Run ghcid

225runGhcid

316runGhcid

226 :: MonadObelisk m

317 :: MonadObelisk m

227− => FilePath -- ^ Path to .ghci

318+ => FilePath -- ^ Path to project root

319+ -> Bool -- ^ Should we chdir to root when running this process?

320+ -> FilePath -- ^ Path to .ghci

321+ -> [CabalPackageInfo]

228 -> Maybe String -- ^ Optional command to run at every reload

322 -> Maybe String -- ^ Optional command to run at every reload

229 -> m ()

323 -> m ()

230−runGhcid dotGhci mcmd = callCommand $ unwords $ $(staticWhich "ghcid") : opts

324+runGhcid root chdirToRoot dotGhci packages mcmd =

325+ nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) (Just $ unwords $ ghcidExePath : opts) -- TODO: Shell escape

231 where

326 where

232 opts =

327 opts =

233 [ "-W"

328 [ "-W"

234− --TODO: The decision of whether to use -fwarn-redundant-constraints should probably be made by the user

235− , "--command='ghci -Wall -ignore-dot-ghci -fwarn-redundant-constraints -no-user-package-db -ghci-script " <> dotGhci <> "' "

329+ , "--command='ghci -ignore-dot-ghci " <> makeBaseGhciOptions dotGhci <> "' "

236− , "--reload=config"

237 , "--outputfile=ghcid-output.txt"

330 , "--outputfile=ghcid-output.txt"

331+ ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles

332+ <> map (\x -> "--restart='" <> x <> "'") restartFiles

238− ] <> testCmd

333+ <> testCmd

239− testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'")

334+ testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape

335+

336+ adjustRoot x = if chdirToRoot then makeRelative root x else x

337+ reloadFiles = map adjustRoot [root </> "config"]

338+ restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages

339+

340+makeBaseGhciOptions :: FilePath -> String

341+makeBaseGhciOptions dotGhci =

342+ unwords

343+ [ "-no-user-package-db"

344+ , "-package-env -"

345+ , "-ghci-script " <> dotGhci

346+ ]

240

347

241getFreePort :: MonadIO m => m PortNumber

348getFreePort :: MonadIO m => m PortNumber

242getFreePort = liftIO $ withSocketsDo $ do

349getFreePort = liftIO $ withSocketsDo $ do

lib/command/src/Obelisk/Command/Thunk.hs+258−121

@@ -8,25 +8,31 @@

8{-# LANGUAGE ScopedTypeVariables #-}

9{-# LANGUAGE TypeApplications #-}

10module Obelisk.Command.Thunk

11+ ( GitHubSource (..)

12+ , GitUri (..)

13+ , ReadThunkError (..)

14+ , ThunkConfig (..)

15+ , ThunkData (..)

16+ , ThunkPackConfig (..)

11− ( ThunkPtr (..)

17+ , ThunkPtr (..)

12 , ThunkRev (..)

18 , ThunkRev (..)

13 , ThunkSource (..)

19 , ThunkSource (..)

14− , ThunkData (..)

20+ , ThunkUpdateConfig (..)

15− , ReadThunkError (..)

21+ , attrCacheFileName

16− , GitHubSource (..)

17− , getThunkGitBranch

18− , getLatestRev

19− , updateThunkToLatest

20 , createThunk

22 , createThunk

21 , createThunkWithLatest

23 , createThunkWithLatest

24+ , getLatestRev

25+ , getThunkGitBranch

26+ , getThunkPtr

27+ , gitUriToText

22 , nixBuildAttrWithCache

28 , nixBuildAttrWithCache

23 , nixBuildThunkAttrWithCache

29 , nixBuildThunkAttrWithCache

24− , unpackThunk

25 , packThunk

30 , packThunk

31+ , parseGitUri

26 , readThunk

32 , readThunk

33+ , unpackThunk

27 , updateThunk

34 , updateThunk

28− , getThunkPtr

35+ , updateThunkToLatest

29− , parseGitUri

30 , uriThunkPtr

36 , uriThunkPtr

31 ) where

37 ) where

@@ -42,6 +48,7 @@ import qualified Data.Aeson as Aeson

42import Data.Aeson.Encode.Pretty

48import Data.Aeson.Encode.Pretty

43import qualified Data.Aeson.Types as Aeson

49import qualified Data.Aeson.Types as Aeson

44import qualified Data.ByteString.Lazy as LBS

50import qualified Data.ByteString.Lazy as LBS

51+import Data.Containers.ListUtils (nubOrd)

45import Data.Default

52import Data.Default

46import Data.Either.Combinators (fromRight', rightToMaybe)

53import Data.Either.Combinators (fromRight', rightToMaybe)

47import Data.Git.Ref (Ref)

54import Data.Git.Ref (Ref)

@@ -64,12 +71,12 @@ import GitHub

64import GitHub.Data.Name

71import GitHub.Data.Name

65import Obelisk.Command.Nix

72import Obelisk.Command.Nix

66import System.Directory

73import System.Directory

74+import System.Exit

67import System.FilePath

75import System.FilePath

68import System.IO.Error

76import System.IO.Error

69import System.IO.Temp

77import System.IO.Temp

70import System.Posix (getSymbolicLinkStatus, modificationTime)

78import System.Posix (getSymbolicLinkStatus, modificationTime)

71−import System.Process (proc)

79+import qualified Text.URI as URI

72−import Text.URI

74import Obelisk.App (MonadObelisk)

81import Obelisk.App (MonadObelisk)

75import Obelisk.CliApp

82import Obelisk.CliApp

@@ -111,37 +118,63 @@ data GitHubSource = GitHubSource

111 { _gitHubSource_owner :: Name Owner

118 { _gitHubSource_owner :: Name Owner

112 , _gitHubSource_repo :: Name Repo

119 , _gitHubSource_repo :: Name Repo

113 , _gitHubSource_branch :: Maybe (Name Branch)

120 , _gitHubSource_branch :: Maybe (Name Branch)

121+ , _gitHubSource_private :: Bool

114 }

122 }

115 deriving (Show, Eq, Ord)

123 deriving (Show, Eq, Ord)

116

124

125+newtype GitUri = GitUri { unGitUri :: URI.URI } deriving (Eq, Ord, Show)

126+

127+gitUriToText :: GitUri -> Text

128+gitUriToText (GitUri uri)

129+ | (T.toLower . URI.unRText <$> URI.uriScheme uri) == Just "file"

130+ , Just (_, path) <- URI.uriPath uri

131+ = "/" <> T.intercalate "/" (map URI.unRText $ NonEmpty.toList path)

132+ | otherwise = URI.render uri

133+

117data GitSource = GitSource

134data GitSource = GitSource

118− { _gitSource_url :: URI

135+ { _gitSource_url :: GitUri

119 , _gitSource_branch :: Maybe (Name Branch)

136 , _gitSource_branch :: Maybe (Name Branch)

120 , _gitSource_fetchSubmodules :: Bool

137 , _gitSource_fetchSubmodules :: Bool

138+ , _gitSource_private :: Bool

121 }

139 }

122 deriving (Show, Eq, Ord)

140 deriving (Show, Eq, Ord)

123

141

142+newtype ThunkConfig = ThunkConfig

143+ { _thunkConfig_private :: Maybe Bool

144+ } deriving Show

145+

146+data ThunkUpdateConfig = ThunkUpdateConfig

147+ { _thunkUpdateConfig_branch :: Maybe String

148+ , _thunkUpdateConfig_config :: ThunkConfig

149+ } deriving Show

150+

151+data ThunkPackConfig = ThunkPackConfig

152+ { _thunkPackConfig_force :: Bool

153+ , _thunkPackConfig_config :: ThunkConfig

154+ } deriving Show

155+

124-- | Convert a GitHub source to a regular Git source. Assumes no submodules.

156-- | Convert a GitHub source to a regular Git source. Assumes no submodules.

125forgetGithub :: Bool -> GitHubSource -> GitSource

157forgetGithub :: Bool -> GitHubSource -> GitSource

126forgetGithub useSsh s = GitSource

158forgetGithub useSsh s = GitSource

127− { _gitSource_url = URI

159+ { _gitSource_url = GitUri $ URI.URI

128− { uriScheme = Just $ fromRight' $ mkScheme $ if useSsh then "ssh" else "https"

160+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme $ if useSsh then "ssh" else "https"

129− , uriAuthority = Right $ Authority

161+ , URI.uriAuthority = Right $ URI.Authority

130− { authUserInfo = UserInfo (fromRight' $ mkUsername "git") Nothing

162+ { URI.authUserInfo = URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing

131 <$ guard useSsh

163 <$ guard useSsh

132− , authHost = fromRight' $ mkHost "github.com"

164+ , URI.authHost = fromRight' $ URI.mkHost "github.com"

133− , authPort = Nothing

165+ , URI.authPort = Nothing

134 }

166 }

135− , uriPath = Just ( False

167+ , URI.uriPath = Just ( False

136− , fromRight' . mkPathPiece <$>

168+ , fromRight' . URI.mkPathPiece <$>

137 untagName (_gitHubSource_owner s)

169 untagName (_gitHubSource_owner s)

138 :| [ untagName (_gitHubSource_repo s) <> ".git" ]

170 :| [ untagName (_gitHubSource_repo s) <> ".git" ]

139 )

171 )

140− , uriQuery = []

172+ , URI.uriQuery = []

141− , uriFragment = Nothing

173+ , URI.uriFragment = Nothing

142 }

174 }

143 , _gitSource_branch = _gitHubSource_branch s

175 , _gitSource_branch = _gitHubSource_branch s

144 , _gitSource_fetchSubmodules = False

176 , _gitSource_fetchSubmodules = False

177+ , _gitSource_private = _gitHubSource_private s

145 }

178 }

146

179

147getThunkGitBranch :: ThunkPtr -> Maybe Text

180getThunkGitBranch :: ThunkPtr -> Maybe Text

@@ -155,20 +188,20 @@ commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c

155-- TODO: Use spinner here.

188-- TODO: Use spinner here.

156getNixSha256ForUriUnpacked

189getNixSha256ForUriUnpacked

157 :: MonadObelisk m

190 :: MonadObelisk m

158− => URI

191+ => GitUri

159 -> m NixSha256

192 -> m NixSha256

160getNixSha256ForUriUnpacked uri =

193getNixSha256ForUriUnpacked uri =

161− withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> render uri) $ do

194+ withExitFailMessage ("nix-prefetch-url: Failed to determine sha256 hash of URL " <> gitUriToText uri) $ do

162 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $

195 [hash] <- fmap T.lines $ readProcessAndLogOutput (Debug, Debug) $

163− proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , T.unpack $ render uri]

196+ proc "nix-prefetch-url" ["--unpack", "--type", "sha256", T.unpack $ gitUriToText uri]

164 pure hash

197 pure hash

165

198

166−nixPrefetchGit :: MonadObelisk m => URI -> Text -> Bool -> m NixSha256

199+nixPrefetchGit :: MonadObelisk m => GitUri -> Text -> Bool -> m NixSha256

167nixPrefetchGit uri rev fetchSubmodules =

200nixPrefetchGit uri rev fetchSubmodules =

168− withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> render uri <> " at " <> rev) $ do

201+ withExitFailMessage ("nix-prefetch-git: Failed to determine sha256 hash of Git repo " <> gitUriToText uri <> " at " <> rev) $ do

169 out <- readProcessAndLogStderr Debug $

202 out <- readProcessAndLogStderr Debug $

170 proc "nix-prefetch-git" $ filter (/="")

203 proc "nix-prefetch-git" $ filter (/="")

171− [ "--url", T.unpack $ render uri

204+ [ "--url", T.unpack $ gitUriToText uri

172 , "--rev", T.unpack rev

205 , "--rev", T.unpack rev

173 , if fetchSubmodules then "--fetch-submodules" else ""

206 , if fetchSubmodules then "--fetch-submodules" else ""

174 , "--quiet"

207 , "--quiet"

@@ -199,6 +232,9 @@ readThunk thunkDir = do

199 False -> return $ return Nothing

232 False -> return $ return Nothing

200 False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir

233 False -> liftIO $ fmap ThunkData_Packed <$> readPackedThunk thunkDir

201

234

235+attrCacheFileName :: FilePath

236+attrCacheFileName = ".attr-cache"

237+

202data ThunkType = ThunkType

238data ThunkType = ThunkType

203 { _thunkType_loader :: FilePath

239 { _thunkType_loader :: FilePath

204 , _thunkType_json :: FilePath

240 , _thunkType_json :: FilePath

@@ -211,7 +247,7 @@ gitHubThunkType :: ThunkType

211gitHubThunkType = ThunkType

247gitHubThunkType = ThunkType

212 { _thunkType_loader = "default.nix"

248 { _thunkType_loader = "default.nix"

213 , _thunkType_json = "github.json"

249 , _thunkType_json = "github.json"

214− , _thunkType_optional = Set.fromList [".attr-cache"]

250+ , _thunkType_optional = Set.fromList [attrCacheFileName]

215 , _thunkType_loaderVersions = gitHubStandaloneLoaders

251 , _thunkType_loaderVersions = gitHubStandaloneLoaders

216 , _thunkType_parser = parseThunkPtr $ \v ->

252 , _thunkType_parser = parseThunkPtr $ \v ->

217 ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v

253 ThunkSource_GitHub <$> parseGitHubSource v <|> ThunkSource_Git <$> parseGitSource v

@@ -221,7 +257,7 @@ gitThunkType :: ThunkType

221gitThunkType = ThunkType

257gitThunkType = ThunkType

222 { _thunkType_loader = "default.nix"

258 { _thunkType_loader = "default.nix"

223 , _thunkType_json = "git.json"

259 , _thunkType_json = "git.json"

224− , _thunkType_optional = Set.fromList [".attr-cache"]

260+ , _thunkType_optional = Set.fromList [attrCacheFileName]

225 , _thunkType_loaderVersions = plainGitStandaloneLoaders

261 , _thunkType_loaderVersions = plainGitStandaloneLoaders

226 , _thunkType_parser = parseThunkPtr $ fmap ThunkSource_Git . parseGitSource

262 , _thunkType_parser = parseThunkPtr $ fmap ThunkSource_Git . parseGitSource

227 }

263 }

@@ -286,10 +322,12 @@ parseGitHubSource v = do

286 owner <- v Aeson..: "owner"

322 owner <- v Aeson..: "owner"

287 repo <- v Aeson..: "repo"

323 repo <- v Aeson..: "repo"

288 branch <- v Aeson..:! "branch"

324 branch <- v Aeson..:! "branch"

325+ private <- v Aeson..:? "private"

289 pure $ GitHubSource

326 pure $ GitHubSource

290 { _gitHubSource_owner = owner

327 { _gitHubSource_owner = owner

291 , _gitHubSource_repo = repo

328 , _gitHubSource_repo = repo

292 , _gitHubSource_branch = branch

329 , _gitHubSource_branch = branch

330+ , _gitHubSource_private = fromMaybe False private

293 }

331 }

294

332

295parseGitSource :: Aeson.Object -> Aeson.Parser GitSource

333parseGitSource :: Aeson.Object -> Aeson.Parser GitSource

@@ -297,10 +335,12 @@ parseGitSource v = do

297 Just url <- parseGitUri <$> v Aeson..: "url"

335 Just url <- parseGitUri <$> v Aeson..: "url"

298 branch <- v Aeson..:! "branch"

336 branch <- v Aeson..:! "branch"

299 fetchSubmodules <- v Aeson..:! "fetchSubmodules"

337 fetchSubmodules <- v Aeson..:! "fetchSubmodules"

338+ private <- v Aeson..:? "private"

300 pure $ GitSource

339 pure $ GitSource

301 { _gitSource_url = url

340 { _gitSource_url = url

302 , _gitSource_branch = branch

341 , _gitSource_branch = branch

303 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules

342 , _gitSource_fetchSubmodules = fromMaybe False fetchSubmodules

343+ , _gitSource_private = fromMaybe False private

304 }

344 }

305

345

306overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()

346overwriteThunk :: MonadObelisk m => FilePath -> ThunkPtr -> m ()

@@ -327,13 +367,15 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of

327 , ("branch" .=) <$> _gitHubSource_branch s

367 , ("branch" .=) <$> _gitHubSource_branch s

328 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)

368 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)

329 , Just $ "sha256" .= _thunkRev_nixSha256 rev

369 , Just $ "sha256" .= _thunkRev_nixSha256 rev

370+ , Just $ "private" .= _gitHubSource_private s

330 ]

371 ]

331 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes

372 ThunkSource_Git s -> encodePretty' plainGitCfg $ Aeson.object $ catMaybes

332− [ Just $ "url" .= render (_gitSource_url s)

373+ [ Just $ "url" .= gitUriToText (_gitSource_url s)

333 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)

374 , Just $ "rev" .= Ref.toHexString (_thunkRev_commit rev)

334 , ("branch" .=) <$> _gitSource_branch s

375 , ("branch" .=) <$> _gitSource_branch s

335 , Just $ "sha256" .= _thunkRev_nixSha256 rev

376 , Just $ "sha256" .= _thunkRev_nixSha256 rev

336 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s

377 , Just $ "fetchSubmodules" .= _gitSource_fetchSubmodules s

378+ , Just $ "private" .= _gitSource_private s

337 ]

379 ]

338 where

380 where

339 githubCfg = defConfig

381 githubCfg = defConfig

@@ -354,6 +396,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of

354 [ "url"

396 [ "url"

355 , "rev"

397 , "rev"

356 , "sha256"

398 , "sha256"

399+ , "private"

357 , "fetchSubmodules"

400 , "fetchSubmodules"

358 ] <> compare

401 ] <> compare

359 , confTrailingNewline = True

402 , confTrailingNewline = True

@@ -361,7 +404,7 @@ encodeThunkPtrData (ThunkPtr rev src) = case src of

361

404

362createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()

405createThunk :: MonadIO m => FilePath -> ThunkPtr -> m ()

363createThunk target thunk = liftIO $ do

406createThunk target thunk = liftIO $ do

364− createDirectoryIfMissing True (target </> ".attr-cache")

407+ createDirectoryIfMissing True (target </> attrCacheFileName)

365 T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)

408 T.writeFile (target </> "default.nix") (thunkPtrLoader thunk)

366 let

409 let

367 jsonFileName = case _thunkPtr_source thunk of

410 jsonFileName = case _thunkPtr_source thunk of

@@ -377,8 +420,8 @@ createThunkWithLatest target s = do

377 , _thunkPtr_rev = rev

420 , _thunkPtr_rev = rev

378 }

421 }

379

422

380−updateThunkToLatest :: MonadObelisk m => FilePath -> Maybe String -> m ()

423+updateThunkToLatest :: MonadObelisk m => ThunkUpdateConfig -> FilePath -> m ()

381−updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do

424+updateThunkToLatest (ThunkUpdateConfig mBranch thunkConfig) target = withSpinner' ("Updating thunk " <> T.pack target <> " to latest") (pure $ const $ "Thunk " <> T.pack target <> " updated to latest") $ do

382 checkThunkDirectory "ob thunk update directory cannot be '.'" target

425 checkThunkDirectory "ob thunk update directory cannot be '.'" target

383 -- check to see if thunk should be updated to a specific branch or just update it's current branch

426 -- check to see if thunk should be updated to a specific branch or just update it's current branch

384 case mBranch of

427 case mBranch of

@@ -390,7 +433,7 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t

390 ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"

433 ThunkData_Checkout _ -> failWith "cannot update an unpacked thunk"

391 let src = _thunkPtr_source ptr

434 let src = _thunkPtr_source ptr

392 rev <- getLatestRev src

435 rev <- getLatestRev src

393− overwriteThunk overwrite $ ThunkPtr

436+ overwriteThunk overwrite $ modifyThunkPtrByConfig thunkConfig $ ThunkPtr

394 { _thunkPtr_source = src

437 { _thunkPtr_source = src

395 , _thunkPtr_rev = rev

438 , _thunkPtr_rev = rev

396 }

439 }

@@ -398,24 +441,25 @@ updateThunkToLatest target mBranch = withSpinner' ("Updating thunk " <> T.pack t

398 Left err -> failWith $ T.pack $ "thunk update: " <> show err

441 Left err -> failWith $ T.pack $ "thunk update: " <> show err

399 Right c -> case c of

442 Right c -> case c of

400 ThunkData_Packed t -> case _thunkPtr_source t of

443 ThunkData_Packed t -> case _thunkPtr_source t of

401− ThunkSource_Git tsg -> setThunk target tsg branch

444+ ThunkSource_Git tsg -> setThunk thunkConfig target tsg branch

402 ThunkSource_GitHub tsgh -> do

445 ThunkSource_GitHub tsgh -> do

403 let tsg = forgetGithub False tsgh

446 let tsg = forgetGithub False tsgh

404− setThunk target tsg branch

447+ setThunk thunkConfig target tsg branch

405− ThunkData_Checkout _ -> failWith $ T.pack $ "thunk located at " <> (show target) <> " is unpacked. Use ob thunk pack on the desired directory and then try ob thunk update again."

448+ ThunkData_Checkout _ -> failWith $ T.pack $ "thunk located at " <> show target <> " is unpacked. Use ob thunk pack on the desired directory and then try ob thunk update again."

406

449

407−setThunk :: MonadObelisk m => FilePath -> GitSource -> String -> m ()

450+setThunk :: MonadObelisk m => ThunkConfig -> FilePath -> GitSource -> String -> m ()

408−setThunk target gs branch = do

451+setThunk thunkConfig target gs branch = do

409− newThunkPtr <- uriThunkPtr (_gitSource_url gs) (Just $ T.pack branch) Nothing

452+ newThunkPtr <- uriThunkPtr (_gitSource_url gs) (_thunkConfig_private thunkConfig) (Just $ T.pack branch) Nothing

410 overwriteThunk target newThunkPtr

453 overwriteThunk target newThunkPtr

411− updateThunkToLatest target Nothing

454+ updateThunkToLatest (ThunkUpdateConfig Nothing thunkConfig) target

412

455

413-- | All recognized github standalone loaders, ordered from newest to oldest.

456-- | All recognized github standalone loaders, ordered from newest to oldest.

414-- This tool will only ever produce the newest one when it writes a thunk.

457-- This tool will only ever produce the newest one when it writes a thunk.

415gitHubStandaloneLoaders :: NonEmpty Text

458gitHubStandaloneLoaders :: NonEmpty Text

416gitHubStandaloneLoaders =

459gitHubStandaloneLoaders =

417− gitHubStandaloneLoaderV2 :|

460+ gitHubStandaloneLoaderV4 :|

418 [ gitHubStandaloneLoaderV3

461 [ gitHubStandaloneLoaderV3

462+ , gitHubStandaloneLoaderV2

419 , gitHubStandaloneLoaderV1

463 , gitHubStandaloneLoaderV1

420 ]

464 ]

421

465

@@ -455,10 +499,24 @@ gitHubStandaloneLoaderV3 = T.unlines

455 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"

499 , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"

456 ]

500 ]

457

501

502+gitHubStandaloneLoaderV4 :: Text

503+gitHubStandaloneLoaderV4 = T.unlines

504+ [ "# DO NOT HAND-EDIT THIS FILE"

505+ , "let fetch = { private ? false, fetchSubmodules ? false, owner, repo, rev, sha256, ... }:"

506+ , " if !fetchSubmodules && !private then builtins.fetchTarball {"

507+ , " url = \"https://github.com/${owner}/${repo}/archive/${rev}.tar.gz\"; inherit sha256;"

508+ , " } else (import <nixpkgs> {}).fetchFromGitHub {"

509+ , " inherit owner repo rev sha256 fetchSubmodules private;"

510+ , " };"

511+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./github.json)))"

512+ ]

513+

458plainGitStandaloneLoaders :: NonEmpty Text

514plainGitStandaloneLoaders :: NonEmpty Text

459plainGitStandaloneLoaders =

515plainGitStandaloneLoaders =

460− plainGitStandaloneLoaderV1 :|

516+ plainGitStandaloneLoaderV4 :|

517+ [ plainGitStandaloneLoaderV1

461− [ plainGitStandaloneLoaderV2

518+ , plainGitStandaloneLoaderV2

519+ , plainGitStandaloneLoaderV3

462 ]

520 ]

463

521

464plainGitStandaloneLoaderV1 :: Text

522plainGitStandaloneLoaderV1 :: Text

@@ -479,6 +537,41 @@ plainGitStandaloneLoaderV2 = T.unlines

479 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"

537 , "in import (fetchGit (builtins.fromJSON (builtins.readFile ./git.json)))"

480 ]

538 ]

481

539

540+-- This loader has a bug because @builtins.fetchGit@ is not given a @ref@

541+-- and will fail to find commits without this because it does shallow clones.

542+plainGitStandaloneLoaderV3 :: Text

543+plainGitStandaloneLoaderV3 = T.unlines

544+ [ "# DO NOT HAND-EDIT THIS FILE"

545+ , "let fetch = {url, rev, ref ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"

546+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"

547+ , " if firstChar == \"/\" then /. + url"

548+ , " else if firstChar == \".\" then ./. + url"

549+ , " else url;"

550+ , " in if !fetchSubmodules && private then builtins.fetchGit {"

551+ , " url = realUrl; inherit rev;"

552+ , " } else (import <nixpkgs> {}).fetchgit {"

553+ , " url = realUrl; inherit rev sha256;"

554+ , " };"

555+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"

556+ ]

557+

558+plainGitStandaloneLoaderV4 :: Text

559+plainGitStandaloneLoaderV4 = T.unlines

560+ [ "# DO NOT HAND-EDIT THIS FILE"

561+ , "let fetch = {url, rev, branch ? null, sha256 ? null, fetchSubmodules ? false, private ? false, ...}:"

562+ , " let realUrl = let firstChar = builtins.substring 0 1 url; in"

563+ , " if firstChar == \"/\" then /. + url"

564+ , " else if firstChar == \".\" then ./. + url"

565+ , " else url;"

566+ , " in if !fetchSubmodules && private then builtins.fetchGit {"

567+ , " url = realUrl; inherit rev;"

568+ , " ${if branch == null then null else \"ref\"} = branch;"

569+ , " } else (import <nixpkgs> {}).fetchgit {"

570+ , " url = realUrl; inherit rev sha256;"

571+ , " };"

572+ , "in import (fetch (builtins.fromJSON (builtins.readFile ./git.json)))"

573+ ]

574+

482thunkFileNames :: [FilePath]

575thunkFileNames :: [FilePath]

483thunkFileNames = ["default.nix", "github.json", "git.json"]

576thunkFileNames = ["default.nix", "github.json", "git.json"]

484

577

@@ -505,7 +598,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do

505 let cacheErrHandler e

598 let cacheErrHandler e

506 | isDoesNotExistError e = return Nothing -- expected from a cache miss

599 | isDoesNotExistError e = return Nothing -- expected from a cache miss

507 | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing

600 | otherwise = putLog Error (T.pack $ displayException e) >> return Nothing

508− cacheDir = thunkDir </> ".attr-cache"

601+ cacheDir = thunkDir </> attrCacheFileName

509 cachePath = cacheDir </> attr <.> "out"

602 cachePath = cacheDir </> attr <.> "out"

510 latestChange <- liftIO $ do

603 latestChange <- liftIO $ do

511 createDirectoryIfMissing False cacheDir

604 createDirectoryIfMissing False cacheDir

@@ -520,7 +613,7 @@ nixBuildThunkAttrWithCache thunkDir attr = do

520 Just c -> return c

613 Just c -> return c

521 Nothing -> do

614 Nothing -> do

522 putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]

615 putLog Warning $ T.pack $ mconcat [thunkDir, ": ", attr, " not cached, building ..."]

523− _ <- nixCmd $ NixCmd_Build$ def

616+ _ <- nixCmd $ NixCmd_Build $ def

524 Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath

617 Lens.& nixBuildConfig_outLink Lens..~ OutLink_IndirectRoot cachePath

525 Lens.& nixCmdConfig_target Lens..~ Target

618 Lens.& nixCmdConfig_target Lens..~ Target

526 { _target_path = Just thunkDir

619 { _target_path = Just thunkDir

@@ -568,13 +661,13 @@ updateThunk p f = withSystemTempDirectory "obelisk-thunkptr-" $ \tmpDir -> do

568 Right (ThunkData_Packed _) -> do

661 Right (ThunkData_Packed _) -> do

569 let tmpThunk = tmpDir </> "thunk"

662 let tmpThunk = tmpDir </> "thunk"

570 callProcessAndLogOutput (Notice, Error) $

663 callProcessAndLogOutput (Notice, Error) $

571− proc "cp" ["-r", "-T", thunkDir, tmpThunk]

664+ proc cp ["-r", "-T", thunkDir, tmpThunk]

572 return tmpThunk

665 return tmpThunk

573− Right _ -> failWith $ "Thunk is not packed"

666+ Right _ -> failWith "Thunk is not packed"

574 updateThunkFromTmp p' = do

667 updateThunkFromTmp p' = do

575− _ <- packThunk' True False p'

668+ _ <- packThunk' True (ThunkPackConfig False (ThunkConfig Nothing)) p'

576 callProcessAndLogOutput (Notice, Error) $

669 callProcessAndLogOutput (Notice, Error) $

577− proc "cp" ["-r", "-T", p', p]

670+ proc cp ["-r", "-T", p', p]

578

671

579finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)

672finalMsg :: Bool -> (a -> Text) -> Maybe (a -> Text)

580finalMsg noTrail s = if noTrail then Nothing else Just s

673finalMsg noTrail s = if noTrail then Nothing else Just s

@@ -606,7 +699,7 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with

606 let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo

699 let git = callProcessAndLogOutput (Notice, Notice) . gitProc tmpRepo

607 git $ [ "clone" ]

700 git $ [ "clone" ]

608 ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))

701 ++ ("--recursive" <$ guard (_gitSource_fetchSubmodules s))

609− ++ [ T.unpack $ render $ _gitSource_url s ]

702+ ++ [ T.unpack $ gitUriToText $ _gitSource_url s ]

610 ++ do branch <- maybeToList $ _gitSource_branch s

703 ++ do branch <- maybeToList $ _gitSource_branch s

611 [ "--branch", T.unpack $ untagName branch ]

704 [ "--branch", T.unpack $ untagName branch ]

612 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]

705 git ["reset", "--hard", Ref.toHexString $ _thunkRev_commit $ _thunkPtr_rev tptr]

@@ -615,31 +708,39 @@ unpackThunk' noTrail thunkDir = checkThunkDirectory "Can't pack/unpack from with

615

708

616 liftIO $ createDirectory obGitDir

709 liftIO $ createDirectory obGitDir

617 callProcessAndLogOutput (Notice, Error) $

710 callProcessAndLogOutput (Notice, Error) $

618− proc "cp" ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]

711+ proc cp ["-r", "-T", thunkDir </> ".", obGitDir </> "orig-thunk"]

619 callProcessAndLogOutput (Notice, Error) $

712 callProcessAndLogOutput (Notice, Error) $

620 proc "rm" ["-r", thunkDir]

713 proc "rm" ["-r", thunkDir]

621 callProcessAndLogOutput (Notice, Error) $

714 callProcessAndLogOutput (Notice, Error) $

622 proc "mv" ["-T", tmpRepo, thunkDir]

715 proc "mv" ["-T", tmpRepo, thunkDir]

623

716

624--TODO: add a rollback mode to pack to the original thunk

717--TODO: add a rollback mode to pack to the original thunk

625−packThunk :: MonadObelisk m => Bool -> FilePath -> m ThunkPtr

718+packThunk :: MonadObelisk m => ThunkPackConfig -> FilePath -> m ThunkPtr

626packThunk = packThunk' False

719packThunk = packThunk' False

627

720

628−packThunk' :: MonadObelisk m => Bool -> Bool -> FilePath -> m ThunkPtr

721+packThunk' :: MonadObelisk m => Bool -> ThunkPackConfig -> FilePath -> m ThunkPtr

629−packThunk' noTrail force thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case

722+packThunk' noTrail (ThunkPackConfig force thunkConfig) thunkDir = checkThunkDirectory "Can't pack/unpack from within the thunk directory" thunkDir >> readThunk thunkDir >>= \case

630 Left err -> failWith $ T.pack $ "thunk pack: " <> show err

723 Left err -> failWith $ T.pack $ "thunk pack: " <> show err

631 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"

724 Right (ThunkData_Packed _) -> failWith "pack: thunk is already packed"

632 Right (ThunkData_Checkout _) -> do

725 Right (ThunkData_Checkout _) -> do

633 withSpinner' ("Packing thunk " <> T.pack thunkDir)

726 withSpinner' ("Packing thunk " <> T.pack thunkDir)

634 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do

727 (finalMsg noTrail $ const $ "Packed thunk " <> T.pack thunkDir) $ do

635− thunkPtr <- getThunkPtr (not force) thunkDir

728+ thunkPtr <- modifyThunkPtrByConfig thunkConfig <$> getThunkPtr (not force) thunkDir (_thunkConfig_private thunkConfig)

636 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]

729 callProcessAndLogOutput (Debug, Error) $ proc "rm" ["-rf", thunkDir]

637 liftIO $ createThunk thunkDir thunkPtr

730 liftIO $ createThunk thunkDir thunkPtr

638 pure thunkPtr

731 pure thunkPtr

639

732

733+modifyThunkPtrByConfig :: ThunkConfig -> ThunkPtr -> ThunkPtr

734+modifyThunkPtrByConfig (ThunkConfig markPrivate') ptr = case markPrivate' of

735+ Nothing -> ptr

736+ Just markPrivate -> ptr { _thunkPtr_source = case _thunkPtr_source ptr of

737+ ThunkSource_Git s -> ThunkSource_Git $ s { _gitSource_private = markPrivate }

738+ ThunkSource_GitHub s -> ThunkSource_GitHub $ s { _gitHubSource_private = markPrivate }

739+ }

740+

640−getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> m ThunkPtr

741+getThunkPtr :: forall m. MonadObelisk m => Bool -> FilePath -> Maybe Bool -> m ThunkPtr

641−getThunkPtr checkClean thunkDir = do

742+getThunkPtr checkClean thunkDir mPrivate = do

642− when checkClean $ ensureCleanGitRepo thunkDir True $

743+ when checkClean $ ensureCleanGitRepo thunkDir True

643 "thunk pack: thunk checkout contains unsaved modifications"

744 "thunk pack: thunk checkout contains unsaved modifications"

644

745

645 -- Check whether there are any stashes

746 -- Check whether there are any stashes

@@ -652,7 +753,7 @@ getThunkPtr checkClean thunkDir = do

652 ] ++ T.lines stashOutput

753 ] ++ T.lines stashOutput

653 True -> return ()

754 True -> return ()

654

755

655− -- Get current branch ``

756+ -- Get current branch

656 (mCurrentBranch, mCurrentCommit) <- do

757 (mCurrentBranch, mCurrentCommit) <- do

657 b <- listToMaybe

758 b <- listToMaybe

658 <$> T.lines

759 <$> T.lines

@@ -661,7 +762,7 @@ getThunkPtr checkClean thunkDir = do

661 <$> T.lines

762 <$> T.lines

662 <$> readGitProcess thunkDir ["rev-parse", "HEAD"]

763 <$> readGitProcess thunkDir ["rev-parse", "HEAD"]

663 case b of

764 case b of

664− (Just "HEAD") -> failWith $ T.unlines $

765+ (Just "HEAD") -> failWith $ T.unlines

665 [ "thunk pack: You are in 'detached HEAD' state."

766 [ "thunk pack: You are in 'detached HEAD' state."

666 , "If you want to pack at the current ref \

767 , "If you want to pack at the current ref \

667 \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."

768 \then please create a new branch with 'git checkout -b <new-branch-name>' and push this upstream."

@@ -733,7 +834,7 @@ getThunkPtr checkClean thunkDir = do

733 [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"

834 [ "thunk pack: Certain branches in the thunk have commits not yet pushed upstream:"

734 , ""

835 , ""

735 ] ++

836 ] ++

736− (flip map (Map.toList nonGood) $ \(branch, (upstream, (ahead, behind))) -> mconcat

837+ flip map (Map.toList nonGood) (\(branch, (upstream, (ahead, behind))) -> mconcat

737 [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++

838 [" ", branch, " ahead: ", T.pack (show ahead), " behind: ", T.pack (show behind), " remote branch ", upstream]) ++

738 [ ""

839 [ ""

739 , "Please push these upstream and try again. (Or just fetch, if they are somehow \

840 , "Please push these upstream and try again. (Or just fetch, if they are somehow \

@@ -741,7 +842,7 @@ getThunkPtr checkClean thunkDir = do

741 ]

842 ]

742

843

743 -- We assume it's safe to pack the thunk at this point

844 -- We assume it's safe to pack the thunk at this point

744− putLog Informational $ "All changes safe in git remotes. OK to pack thunk."

845+ putLog Informational "All changes safe in git remotes. OK to pack thunk."

745

846

746 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch

847 let remote = maybe "origin" snd $ flip Map.lookup headUpstream =<< mCurrentBranch

747

848

@@ -754,7 +855,7 @@ getThunkPtr checkClean thunkDir = do

754 remoteUri <- case parseGitUri remoteUri' of

855 remoteUri <- case parseGitUri remoteUri' of

755 Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'

856 Nothing -> failWith $ "Could not identify git remote: " <> remoteUri'

756 Just uri -> pure uri

857 Just uri -> pure uri

757− uriThunkPtr remoteUri mCurrentBranch mCurrentCommit

858+ uriThunkPtr remoteUri mPrivate mCurrentBranch mCurrentCommit

758

859

759-- | Get the latest revision available from the given source

860-- | Get the latest revision available from the given source

760getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev

861getLatestRev :: MonadObelisk m => ThunkSource -> m ThunkRev

@@ -773,18 +874,18 @@ getLatestRev os = do

773-- performance. If that doesn't work (e.g. authentication issue), we fall back

874-- performance. If that doesn't work (e.g. authentication issue), we fall back

774-- on just doing things the normal way for git repos in general, and save it as

875-- on just doing things the normal way for git repos in general, and save it as

775-- a regular git thunk.

876-- a regular git thunk.

776−uriThunkPtr :: MonadObelisk m => URI -> Maybe Text -> Maybe Text -> m ThunkPtr

877+uriThunkPtr :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> Maybe Text -> m ThunkPtr

777−uriThunkPtr uri mbranch mcommit = do

878+uriThunkPtr uri mPrivate mbranch mcommit = do

778 commit <- case mcommit of

879 commit <- case mcommit of

779 Nothing -> gitGetCommitBranch uri mbranch >>= return . snd

880 Nothing -> gitGetCommitBranch uri mbranch >>= return . snd

780 (Just c) -> return c

881 (Just c) -> return c

781− (src, rev) <- case uriToThunkSource uri mbranch of

882+ (src, rev) <- uriToThunkSource uri mPrivate mbranch >>= \case

782 ThunkSource_GitHub s -> do

883 ThunkSource_GitHub s -> do

783 rev <- runExceptT $ githubThunkRev s commit

884 rev <- runExceptT $ githubThunkRev s commit

784 case rev of

885 case rev of

785 Right r -> pure (ThunkSource_GitHub s, r)

886 Right r -> pure (ThunkSource_GitHub s, r)

786 Left e -> do

887 Left e -> do

787− putLog Warning $ "\

888+ putLog Warning "\

788\Failed to fetch archive from GitHub. This is probably a private repo. \

889\Failed to fetch archive from GitHub. This is probably a private repo. \

789\Falling back on normal fetchgit. Original failure:"

890\Falling back on normal fetchgit. Original failure:"

790 errorToWarning e

891 errorToWarning e

@@ -801,34 +902,66 @@ uriThunkPtr uri mbranch mcommit = do

801-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with

902-- If the thunk is a GitHub thunk and fails, we do *not* fall back like with

802-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method

903-- `uriThunkPtr`. Unlike a plain URL, a thunk src explicitly states which method

803-- should be employed, and so we respect that.

904-- should be employed, and so we respect that.

804−uriToThunkSource :: URI -> Maybe Text -> ThunkSource

905+uriToThunkSource :: MonadObelisk m => GitUri -> Maybe Bool -> Maybe Text -> m ThunkSource

805−uriToThunkSource u

906+uriToThunkSource (GitUri u) mPrivate

806− | Right uriAuth <- uriAuthority u

907+ | Right uriAuth <- URI.uriAuthority u

807− , Just scheme <- unRText <$> uriScheme u

908+ , Just scheme <- URI.unRText <$> URI.uriScheme u

808 , case scheme of

909 , case scheme of

809− "ssh" -> uriAuth == Authority

910+ "ssh" -> uriAuth == URI.Authority

810− { authUserInfo = Just $ UserInfo (fromRight' $ mkUsername "git") Nothing

911+ { URI.authUserInfo = Just $ URI.UserInfo (fromRight' $ URI.mkUsername "git") Nothing

811− , authHost = fromRight' $ mkHost "github.com"

912+ , URI.authHost = fromRight' $ URI.mkHost "github.com"

812− , authPort = Nothing

913+ , URI.authPort = Nothing

813 }

914 }

814 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"

915 s -> s `L.elem` [ "git", "https", "http" ] -- "http:" just redirects to "https:"

815− && unRText (authHost uriAuth) == "github.com"

916+ && URI.unRText (URI.authHost uriAuth) == "github.com"

816− , Just (_, owner :| [repoish]) <- uriPath u

917+ , Just (_, owner :| [repoish]) <- URI.uriPath u

918+ = \mbranch -> do

919+ isPrivate <- getIsPrivate

817− = \mbranch -> ThunkSource_GitHub $ GitHubSource

920+ pure $ ThunkSource_GitHub $ GitHubSource

818− { _gitHubSource_owner = N $ unRText owner

921+ { _gitHubSource_owner = N $ URI.unRText owner

819− , _gitHubSource_repo = N $ let

922+ , _gitHubSource_repo = N $ let

820− repoish' = unRText repoish

923+ repoish' = URI.unRText repoish

821− in case T.stripSuffix ".git" repoish' of

924+ in fromMaybe repoish' $ T.stripSuffix ".git" repoish'

822− Just repo -> repo

823− Nothing -> repoish'

824− , _gitHubSource_branch = N <$> mbranch

925+ , _gitHubSource_branch = N <$> mbranch

926+ , _gitHubSource_private = isPrivate

825− }

927+ }

826

928

929+ | otherwise = \mbranch -> do

930+ isPrivate <- getIsPrivate

827− | otherwise = \mbranch -> ThunkSource_Git $ GitSource

931+ pure $ ThunkSource_Git $ GitSource

828− { _gitSource_url = u

932+ { _gitSource_url = GitUri u

829− , _gitSource_branch = N <$> mbranch

933+ , _gitSource_branch = N <$> mbranch

830− , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?

934+ , _gitSource_fetchSubmodules = False -- TODO: How do we determine if this should be true?

935+ , _gitSource_private = isPrivate

936+ }

937+ where

938+ getIsPrivate = maybe (guessGitRepoIsPrivate $ GitUri u) pure mPrivate

939+

940+guessGitRepoIsPrivate :: MonadObelisk m => GitUri -> m Bool

941+guessGitRepoIsPrivate uri = flip fix urisToTry $ \loop -> \case

942+ [] -> pure True

943+ uriAttempt:xs -> do

944+ result <- readCreateProcessWithExitCode $

945+ isolateGitProc $

946+ gitProcNoRepo

947+ [ "ls-remote"

948+ , "--quiet"

949+ , "--exit-code"

950+ , "--symref"

951+ , T.unpack $ gitUriToText uriAttempt

952+ ]

953+ case result of

954+ (ExitSuccess, _, _) -> pure False -- Must be a public repo

955+ _ -> loop xs

956+ where

957+ urisToTry = nubOrd $

958+ -- Include the original URI if it isn't using SSH because SSH will certainly fail.

959+ [uri | fmap URI.unRText (URI.uriScheme (unGitUri uri)) /= Just "ssh"] <>

960+ [changeScheme "https" uri, changeScheme "http" uri]

961+ changeScheme scheme (GitUri u) = GitUri $ u

962+ { URI.uriScheme = URI.mkScheme scheme

963+ , URI.uriAuthority = (\x -> x { URI.authUserInfo = Nothing }) <$> URI.uriAuthority u

831− }

964+ }

832

965

833-- Funny signature indicates no effects depend on the optional branch name.

966-- Funny signature indicates no effects depend on the optional branch name.

834githubThunkRev

967githubThunkRev

@@ -840,19 +973,19 @@ githubThunkRev

840githubThunkRev s commit = do

973githubThunkRev s commit = do

841 owner <- forcePP $ _gitHubSource_owner s

974 owner <- forcePP $ _gitHubSource_owner s

842 repo <- forcePP $ _gitHubSource_repo s

975 repo <- forcePP $ _gitHubSource_repo s

843− revTarball <- mkPathPiece $ commit <> ".tar.gz"

976+ revTarball <- URI.mkPathPiece $ commit <> ".tar.gz"

844− let archiveUri = URI

977+ let archiveUri = GitUri $ URI.URI

845− { uriScheme = Just $ fromRight' $ mkScheme "https"

978+ { URI.uriScheme = Just $ fromRight' $ URI.mkScheme "https"

846− , uriAuthority = Right $ Authority

979+ , URI.uriAuthority = Right $ URI.Authority

847− { authUserInfo = Nothing

980+ { URI.authUserInfo = Nothing

848− , authHost = fromRight' $ mkHost "github.com"

981+ , URI.authHost = fromRight' $ URI.mkHost "github.com"

849− , authPort = Nothing

982+ , URI.authPort = Nothing

850 }

983 }

851− , uriPath = Just ( False

984+ , URI.uriPath = Just ( False

852− , owner :| [ repo, fromRight' $ mkPathPiece "archive", revTarball ]

985+ , owner :| [ repo, fromRight' $ URI.mkPathPiece "archive", revTarball ]

853 )

986 )

854− , uriQuery = []

987+ , URI.uriQuery = []

855− , uriFragment = Nothing

988+ , URI.uriFragment = Nothing

856 }

989 }

857 hash <- getNixSha256ForUriUnpacked archiveUri

990 hash <- getNixSha256ForUriUnpacked archiveUri

858 putLog Debug $ "Nix sha256 is " <> hash

991 putLog Debug $ "Nix sha256 is " <> hash

@@ -861,8 +994,8 @@ githubThunkRev s commit = do

861 , _thunkRev_nixSha256 = hash

994 , _thunkRev_nixSha256 = hash

862 }

995 }

863 where

996 where

864− forcePP :: Name entity -> m (RText 'PathPiece)

997+ forcePP :: Name entity -> m (URI.RText 'URI.PathPiece)

865− forcePP = mkPathPiece . untagName

998+ forcePP = URI.mkPathPiece . untagName

866

999

867gitThunkRev

1000gitThunkRev

868 :: MonadObelisk m

1001 :: MonadObelisk m

@@ -871,11 +1004,11 @@ gitThunkRev

871 -> m ThunkRev

1004 -> m ThunkRev

872gitThunkRev s commit = do

1005gitThunkRev s commit = do

873 let u = _gitSource_url s

1006 let u = _gitSource_url s

874− protocols = ["https", "ssh", "git"]

1007+ protocols = ["file", "https", "ssh", "git"]

875− Just scheme <- pure $ unRText <$> uriScheme u

1008+ scheme = maybe "file" URI.unRText $ URI.uriScheme $ (\(GitUri x) -> x) u

876 unless (T.toLower scheme `elem` protocols) $

1009 unless (T.toLower scheme `elem` protocols) $

877 failWith $ "obelisk currently only supports "

1010 failWith $ "obelisk currently only supports "

878− <> T.intercalate ", " protocols <> " protocols for non-GitHub remotes"

1011+ <> T.intercalate ", " protocols <> " protocols for plain Git remotes"

879 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s

1012 hash <- nixPrefetchGit u commit $ _gitSource_fetchSubmodules s

880 putLog Informational $ "Nix sha256 is " <> hash

1013 putLog Informational $ "Nix sha256 is " <> hash

881 pure $ ThunkRev

1014 pure $ ThunkRev

@@ -888,11 +1021,12 @@ gitThunkRev s commit = do

888--

1021--

889-- If the branch name is passed in, it is returned exactly as-is. If it is not

1022-- If the branch name is passed in, it is returned exactly as-is. If it is not

890-- passed it, the default branch of the repo is used instead.

1023-- passed it, the default branch of the repo is used instead.

1024+

891gitGetCommitBranch

1025gitGetCommitBranch

892− :: MonadObelisk m => URI -> Maybe Text -> m (Text, CommitId)

1026+ :: MonadObelisk m => GitUri -> Maybe Text -> m (Text, CommitId)

893gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do

1027gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote " <> uriMsg) $ do

894 (_, bothMaps) <- gitLsRemote

1028 (_, bothMaps) <- gitLsRemote

895− (T.unpack $ render uri)

1029+ (T.unpack $ gitUriToText uri)

896 (GitRef_Branch <$> mbranch)

1030 (GitRef_Branch <$> mbranch)

897 Nothing

1031 Nothing

898 branch <- case mbranch of

1032 branch <- case mbranch of

@@ -908,18 +1042,21 @@ gitGetCommitBranch uri mbranch = withExitFailMessage ("Failure for git remote "

908 pure (branch, commit)

1042 pure (branch, commit)

909 where

1043 where

910 rethrowE = either failWith pure

1044 rethrowE = either failWith pure

911− uriMsg = render uri

1045+ uriMsg = gitUriToText uri

1046+

1047+parseGitUri :: Text -> Maybe GitUri

1048+parseGitUri x = GitUri <$> (parseFileURI x <|> parseAbsoluteURI x <|> parseSshShorthand x)

912

1049

913−parseGitUri :: Text -> Maybe URI

1050+parseFileURI :: Text -> Maybe URI.URI

914−parseGitUri x = parseAbsoluteURI x <|> parseSshShorthand x

1051+parseFileURI uri = if "/" `T.isPrefixOf` uri then parseAbsoluteURI ("file://" <> uri) else Nothing

915

1052

916−parseAbsoluteURI :: Text -> Maybe URI

1053+parseAbsoluteURI :: Text -> Maybe URI.URI

917parseAbsoluteURI uri = do

1054parseAbsoluteURI uri = do

918− parsedUri <- mkURI uri

1055+ parsedUri <- URI.mkURI uri

919− guard $ isPathAbsolute parsedUri

1056+ guard $ URI.isPathAbsolute parsedUri

920− pure $ parsedUri

1057+ pure parsedUri

921

1058

922−parseSshShorthand :: Text -> Maybe URI

1059+parseSshShorthand :: Text -> Maybe URI.URI

923parseSshShorthand uri = do

1060parseSshShorthand uri = do

924 -- This is what git does to check that the remote

1061 -- This is what git does to check that the remote

925 -- is not a local file path when parsing shorthand.

1062 -- is not a local file path when parsing shorthand.

@@ -932,4 +1069,4 @@ parseSshShorthand uri = do

932 -- This check is used to disambiguate a filepath containing a colon from shorthand

1069 -- This check is used to disambiguate a filepath containing a colon from shorthand

933 guard $ isNothing (T.findIndex (=='/') authAndHostname)

1070 guard $ isNothing (T.findIndex (=='/') authAndHostname)

934 && not (T.null colonAndPath)

1071 && not (T.null colonAndPath)

935− mkURI properUri

1072+ URI.mkURI properUri

lib/command/src/Obelisk/Command/Utils.hs+39−17

@@ -4,6 +4,7 @@

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE OverloadedStrings #-}

6{-# LANGUAGE PatternGuards #-}

7+{-# LANGUAGE TemplateHaskell #-}

7module Obelisk.Command.Utils where

8module Obelisk.Command.Utils where

9import Control.Applicative hiding (many)

10import Control.Applicative hiding (many)

@@ -20,18 +21,28 @@ import Data.Maybe (maybeToList)

20import Data.Text (Text)

21import Data.Text (Text)

21import qualified Data.Text as T

22import qualified Data.Text as T

22import Data.Void (Void)

23import Data.Void (Void)

23−import System.Directory (canonicalizePath)

24−import System.Environment (getExecutablePath)

25import System.Exit (ExitCode)

24import System.Exit (ExitCode)

26−import qualified System.Process as P

25+import System.Which (staticWhich)

27import Text.Megaparsec as MP

26import Text.Megaparsec as MP

28import Text.Megaparsec.Char as MP

27import Text.Megaparsec.Char as MP

30import Obelisk.App (MonadObelisk)

29import Obelisk.App (MonadObelisk)

31import Obelisk.CliApp

30import Obelisk.CliApp

33−getObeliskExe :: IO FilePath

32+cp :: FilePath

34−getObeliskExe = getExecutablePath >>= canonicalizePath

33+cp = $(staticWhich "cp")

34+

35+ghcidExePath :: FilePath

36+ghcidExePath = $(staticWhich "ghcid")

37+

38+findExePath :: FilePath

39+findExePath = $(staticWhich "find")

40+

41+nixExePath :: FilePath

42+nixExePath = $(staticWhich "nix")

43+

44+nixBuildExePath :: FilePath

45+nixBuildExePath = $(staticWhich "nix-build")

36-- Check whether the working directory is clean

47-- Check whether the working directory is clean

37checkGitCleanStatus :: MonadObelisk m => FilePath -> Bool -> m Bool

48checkGitCleanStatus :: MonadObelisk m => FilePath -> Bool -> m Bool

@@ -61,20 +72,31 @@ initGit repo = do

61 git ["add", "."]

72 git ["add", "."]

62 git ["commit", "-m", "Initial commit."]

73 git ["commit", "-m", "Initial commit."]

64−gitProcNoRepo :: [String] -> P.CreateProcess

75+gitProcNoRepo :: [String] -> ProcessSpec

65−gitProcNoRepo = P.proc "git"

76+gitProcNoRepo args = setEnvOverride (M.singleton "GIT_TERMINAL_PROMPT" "0" <>) $ proc "git" args

67−gitProc :: FilePath -> [String] -> P.CreateProcess

78+gitProc :: FilePath -> [String] -> ProcessSpec

68gitProc repo = gitProcNoRepo . runGitInDir

79gitProc repo = gitProcNoRepo . runGitInDir

69 where

80 where

70 runGitInDir args' = case filter (not . null) args' of

81 runGitInDir args' = case filter (not . null) args' of

71 args@("clone":_) -> args <> [repo]

82 args@("clone":_) -> args <> [repo]

72 args -> ["-C", repo] <> args

83 args -> ["-C", repo] <> args

85+isolateGitProc :: ProcessSpec -> ProcessSpec

86+isolateGitProc = setEnvOverride (overrides <>)

87+ where

88+ overrides = M.fromList

89+ [ ("HOME", "/dev/null")

90+ , ("GIT_CONFIG_NOSYSTEM", "1")

91+ , ("GIT_TERMINAL_PROMPT", "0") -- git 2.3+

92+ , ("GIT_ASKPASS", "echo") -- pre git 2.3 to just use empty password

93+ , ("GIT_SSH_COMMAND", "ssh -o PreferredAuthentications password -o PubkeyAuthentication no -o GSSAPIAuthentication no")

94+ ]

95+

74−-- | Recursively copy a directory using `cp -a`

96+-- | Recursively copy a directory using `cp -a` -- TODO: Should use -rT instead of -a

75−copyDir :: FilePath -> FilePath -> P.CreateProcess

97+copyDir :: FilePath -> FilePath -> ProcessSpec

76copyDir src dest =

98copyDir src dest =

77− (P.proc "cp" ["-a", ".", dest]) { P.cwd = Just src }

99+ setCwd (Just src) $ proc cp ["-a", ".", dest] -- TODO: This will break if dest is relative since we change cwd

100

79readGitProcess :: MonadObelisk m => FilePath -> [String] -> m Text

101readGitProcess :: MonadObelisk m => FilePath -> [String] -> m Text

80readGitProcess repo = readProcessAndLogOutput (Debug, Notice) . gitProc repo

102readGitProcess repo = readProcessAndLogOutput (Debug, Notice) . gitProc repo

@@ -87,15 +109,15 @@ processToShellString cmd args = unwords $ map quoteAndEscape (cmd : args)

87 where quoteAndEscape x = T.unpack $ "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

109 where quoteAndEscape x = T.unpack $ "'" <> T.replace "'" "'\''" (T.pack x) <> "'"

110

89-- | A simpler wrapper for CliApp's most used process function with sensible defaults.

111-- | A simpler wrapper for CliApp's most used process function with sensible defaults.

90−runProc :: MonadObelisk m => P.CreateProcess -> m ()

112+runProc :: MonadObelisk m => ProcessSpec -> m ()

91runProc = callProcessAndLogOutput (Notice, Error)

113runProc = callProcessAndLogOutput (Notice, Error)

114

93-- | Like runProc, but all output goes to Debug logging level

115-- | Like runProc, but all output goes to Debug logging level

94−runProcSilently :: MonadObelisk m => P.CreateProcess -> m ()

116+runProcSilently :: MonadObelisk m => ProcessSpec -> m ()

95runProcSilently = callProcessAndLogOutput (Debug, Debug)

117runProcSilently = callProcessAndLogOutput (Debug, Debug)

118

97-- | A simpler wrapper for CliApp's readProcessAndLogStderr with sensible defaults.

119-- | A simpler wrapper for CliApp's readProcessAndLogStderr with sensible defaults.

98−readProc :: MonadObelisk m => P.CreateProcess -> m Text

120+readProc :: MonadObelisk m => ProcessSpec -> m Text

99readProc = readProcessAndLogOutput (Debug, Error)

121readProc = readProcessAndLogOutput (Debug, Error)

100

122

101tshow :: Show a => a -> Text

123tshow :: Show a => a -> Text

@@ -129,13 +151,13 @@ gitLsRemote repository mRef mBranch = do

129 (exitCode, out, _err) <- case mBranch of

151 (exitCode, out, _err) <- case mBranch of

130 Nothing -> readCreateProcessWithExitCode $ gitProcNoRepo $

152 Nothing -> readCreateProcessWithExitCode $ gitProcNoRepo $

131 ["ls-remote", "--exit-code", "--symref", repository]

153 ["ls-remote", "--exit-code", "--symref", repository]

132− ++ (maybeToList $ T.unpack . showGitRef <$> mRef)

154+ ++ maybeToList (T.unpack . showGitRef <$> mRef)

133− Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo $

155+ Just branchName -> readCreateProcessWithExitCode $ gitProcNoRepo

134 ["ls-remote", "--exit-code", repository, branchName]

156 ["ls-remote", "--exit-code", repository, branchName]

135 let t = T.pack out

157 let t = T.pack out

136 maps <- case MP.runParser parseLsRemote "" t of

158 maps <- case MP.runParser parseLsRemote "" t of

137 Left err -> failWith $ T.pack $ MP.errorBundlePretty err

159 Left err -> failWith $ T.pack $ MP.errorBundlePretty err

138− Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers $ table

160+ Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers table

139 putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)

161 putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)

140 pure (exitCode, maps)

162 pure (exitCode, maps)

141

163

lib/command/src/Obelisk/Command/VmBuilder.hs−1

@@ -18,7 +18,6 @@ import System.Directory (createDirectoryIfMissing)

18import System.Exit (ExitCode(..))

19import System.FilePath ((<.>), (</>))

20import qualified System.Info

21−import System.Process (proc)

23import Obelisk.App (MonadObelisk, getObeliskUserStateDir)

22import Obelisk.App (MonadObelisk, getObeliskUserStateDir)

24import Obelisk.CliApp

23import Obelisk.CliApp

lib/executable-config/lookup/obelisk-executable-config-lookup.cabal+1−1

@@ -27,7 +27,7 @@ library

27 build-depends: directory

29 build-depends:

30− base,

30+ base,

31 base64-bytestring,

32 bytestring,

33 containers,

lib/executable-config/lookup/src-other/Obelisk/ExecutableConfig/Lookup.hs+1−8

@@ -1,18 +1,11 @@

1−{-# LANGUAGE LambdaCase #-}

2{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE OverloadedStrings #-}

3module Obelisk.ExecutableConfig.Lookup where

2module Obelisk.ExecutableConfig.Lookup where

5import Data.Map (Map)

4import Data.Map (Map)

6−import qualified Data.Map as Map

7import Data.Text (Text)

5import Data.Text (Text)

8−import qualified Data.Text as T

9import Data.ByteString (ByteString)

6import Data.ByteString (ByteString)

10−import qualified Data.ByteString as BS

11−import System.Directory

12−import System.FilePath

13−import Control.Monad

15−import Obelisk.Configs.Internal.Directory

8+import Obelisk.Configs.Internal.Directory (getConfigsFromDirectory)

17getConfigs :: IO (Map Text ByteString)

10getConfigs :: IO (Map Text ByteString)

18getConfigs = getConfigsFromDirectory "config"

11getConfigs = getConfigsFromDirectory "config"

lib/frontend/src/Obelisk/Frontend.hs+2−2

@@ -5,6 +5,7 @@

5{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE OverloadedStrings #-}

8+{-# LANGUAGE PackageImports #-}

8{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RecursiveDo #-}

10{-# LANGUAGE RecursiveDo #-}

10{-# LANGUAGE ScopedTypeVariables #-}

11{-# LANGUAGE ScopedTypeVariables #-}

@@ -45,7 +46,7 @@ import qualified GHCJS.DOM.History as DOM

45import qualified GHCJS.DOM.Window as DOM

46import qualified GHCJS.DOM.Window as DOM

46import Language.Javascript.JSaddle (MonadJSM, JSM, jsNull)

47import Language.Javascript.JSaddle (MonadJSM, JSM, jsNull)

47import GHCJS.DOM (currentDocument)

48import GHCJS.DOM (currentDocument)

48−import GHCJS.DOM.Document (getHead)

49+import "ghcjs-dom" GHCJS.DOM.Document (getHead)

49import GHCJS.DOM.Node (Node, removeChild_)

50import GHCJS.DOM.Node (Node, removeChild_)

50import GHCJS.DOM.NodeList (IsNodeList, item, getLength)

51import GHCJS.DOM.NodeList (IsNodeList, item, getLength)

51import GHCJS.DOM.ParentNode (querySelectorAll)

52import GHCJS.DOM.ParentNode (querySelectorAll)

@@ -197,7 +198,6 @@ runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend = d

197 , PrimMonad m

198 , PrimMonad m

198 , MonadSample DomTimeline (Performable m)

199 , MonadSample DomTimeline (Performable m)

199 , DOM.MonadJSM m

200 , DOM.MonadJSM m

200− , Monad (Performable (Client (HydrationDomBuilderT s DomTimeline m)))

201 , MonadFix (Client (HydrationDomBuilderT s DomTimeline m))

202 , MonadFix (Performable m)

203 , MonadFix m

lib/frontend/src/Obelisk/Frontend/Cookie.hs+2−1

@@ -6,6 +6,7 @@

6{-# LANGUAGE FlexibleInstances #-}

7{-# LANGUAGE GeneralizedNewtypeDeriving #-}

8{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE PackageImports #-}

9{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE TypeFamilies #-}

11{-# LANGUAGE UndecidableInstances #-}

12{-# LANGUAGE UndecidableInstances #-}

@@ -22,7 +23,7 @@ import Data.Text.Encoding (encodeUtf8)

22import Reflex

23import Reflex

23import Reflex.Host.Class

24import Reflex.Host.Class

24import Reflex.Dom.Core

25import Reflex.Dom.Core

25−import GHCJS.DOM.Document (getCookie, Document)

26+import "ghcjs-dom" GHCJS.DOM.Document (getCookie, Document)

26import GHCJS.DOM.Types (MonadJSM)

27import GHCJS.DOM.Types (MonadJSM)

27import Web.Cookie

28import Web.Cookie

lib/route/src/Obelisk/Route.hs+12−5

@@ -20,10 +20,11 @@

20{-# LANGUAGE ViewPatterns #-}

21module Obelisk.Route

22 ( R

23− , pattern (:/)

24 , (:.)

23 , (:.)

25− , pattern (:.)

24+ , (?/)

26 , hoistR

25 , hoistR

26+ , pattern (:.)

27+ , pattern (:/)

27 , PageName

28 , PageName

28 , PathQuery

29 , PathQuery

29 , Encoder

30 , Encoder

@@ -194,10 +195,16 @@ import Data.Aeson (FromJSON, ToJSON)

194

195

195type R f = DSum f Identity --TODO: Better name

196type R f = DSum f Identity --TODO: Better name

196

197

197−{-# COMPLETE (:/) #-}

198+-- | Convenience builder for an 'R' using 'Identity' for the functor.

198−infixr 5 :/

199pattern (:/) :: f a -> a -> R f

200pattern a :/ b = a :=> Identity b

201+{-# COMPLETE (:/) #-}

202+infixr 5 :/

203+

204+-- | Like '(:/)' but adds a 'Just' wrapper around the right-hand side.

205+(?/) :: f (Maybe a) -> a -> R f

206+r ?/ a = r :/ Just a

207+infixr 5 ?/

201

208

202mapSome :: (forall a. f a -> g a) -> Some f -> Some g

209mapSome :: (forall a. f a -> g a) -> Some f -> Some g

203mapSome f (Some a) = Some $ f a

210mapSome f (Some a) = Some $ f a

@@ -881,7 +888,7 @@ instance (GCompare br, GCompare fr) => GCompare (FullRoute br fr) where

881 gcompare (FullRoute_Frontend x) (FullRoute_Frontend y) = gcompare x y

888 gcompare (FullRoute_Frontend x) (FullRoute_Frontend y) = gcompare x y

882

889

883instance (UniverseSome br, UniverseSome fr) => UniverseSome (FullRoute br fr) where

890instance (UniverseSome br, UniverseSome fr) => UniverseSome (FullRoute br fr) where

884− universeSome = [Some (FullRoute_Backend x) | Some x <- universeSome]

891+ universeSome = [Some (FullRoute_Backend x) | Some x <- universeSome]

885 ++ [Some (FullRoute_Frontend x) | Some x <- universeSome]

892 ++ [Some (FullRoute_Frontend x) | Some x <- universeSome]

886

893

887-- | Build the typical top level application route encoder from a route for handling 404's,

894-- | Build the typical top level application route encoder from a route for handling 404's,

lib/route/src/Obelisk/Route/Frontend.hs+96−16

@@ -7,15 +7,11 @@

7{-# LANGUAGE FlexibleContexts #-}

8{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE GADTs #-}

10−{-# LANGUAGE KindSignatures #-}

11{-# LANGUAGE LambdaCase #-}

10{-# LANGUAGE LambdaCase #-}

12−{-# LANGUAGE MultiParamTypeClasses #-}

13{-# LANGUAGE OverloadedStrings #-}

11{-# LANGUAGE OverloadedStrings #-}

14{-# LANGUAGE PatternSynonyms #-}

12{-# LANGUAGE PatternSynonyms #-}

15{-# LANGUAGE RankNTypes #-}

13{-# LANGUAGE RankNTypes #-}

16{-# LANGUAGE ScopedTypeVariables #-}

14{-# LANGUAGE ScopedTypeVariables #-}

17−{-# LANGUAGE TemplateHaskell #-}

18−{-# LANGUAGE TupleSections #-}

19{-# LANGUAGE TypeFamilies #-}

15{-# LANGUAGE TypeFamilies #-}

20{-# LANGUAGE TypeOperators #-}

16{-# LANGUAGE TypeOperators #-}

21{-# LANGUAGE ViewPatterns #-}

17{-# LANGUAGE ViewPatterns #-}

@@ -53,6 +49,7 @@ module Obelisk.Route.Frontend

53 , runRouteToUrlT

49 , runRouteToUrlT

54 , mapRouteToUrlT

50 , mapRouteToUrlT

55 , routeLink

51 , routeLink

52+ , routeLinkDynAttr

56 , dynRouteLink

53 , dynRouteLink

57 , adaptedUriPath

54 , adaptedUriPath

58 , setAdaptedUriPath

55 , setAdaptedUriPath

@@ -63,7 +60,7 @@ import Prelude hiding ((.), id)

63import Obelisk.Route

60import Obelisk.Route

65import Control.Category (Category (..), (.))

62import Control.Category (Category (..), (.))

66−import Control.Category.Cartesian

63+import Control.Category.Cartesian ((&&&))

67import Control.Lens hiding (Bifunctor, bimap, universe, element)

64import Control.Lens hiding (Bifunctor, bimap, universe, element)

68import Control.Monad ((<=<))

65import Control.Monad ((<=<))

69import Control.Monad.Fix

66import Control.Monad.Fix

@@ -74,6 +71,7 @@ import Control.Monad.Trans.Control

74import Data.Coerce

71import Data.Coerce

75import Data.Dependent.Sum (DSum (..))

72import Data.Dependent.Sum (DSum (..))

76import Data.GADT.Compare

73import Data.GADT.Compare

74+import Data.Map (Map)

77import Data.Monoid

75import Data.Monoid

78import Data.Proxy

76import Data.Proxy

79import Data.Text (Text)

77import Data.Text (Text)

@@ -92,7 +90,9 @@ import Reflex.Dom.Builder.Class

92import Data.Type.Coercion

90import Data.Type.Coercion

93import Language.Javascript.JSaddle --TODO: Get rid of this - other platforms can also be routed

91import Language.Javascript.JSaddle --TODO: Get rid of this - other platforms can also be routed

94import Reflex.Dom.Core

92import Reflex.Dom.Core

93+import qualified GHCJS.DOM as DOM

95import qualified GHCJS.DOM.Types as DOM

94import qualified GHCJS.DOM.Types as DOM

95+import qualified GHCJS.DOM.Window as Window

96import Network.URI

97import Data.Maybe (fromMaybe)

98import qualified Data.List as L

@@ -509,46 +509,126 @@ runRouteViewT routeEncoder switchover useHash a = do

509-- | A link widget that, when clicked, sets the route to the provided route. In non-javascript

510-- contexts, this widget falls back to using @href@s to control navigation

511routeLink

512− :: forall t m a route.

512+ :: forall t m a route js.

513 ( DomBuilder t m

514 , RouteToUrl route m

515 , SetRoute t route m

516+ , Prerender js t m

516 )

517 )

517 => route -- ^ Target route

518 => route -- ^ Target route

518 -> m a -- ^ Child widget

519 -> m a -- ^ Child widget

519 -> m a

520 -> m a

520routeLink r w = do

521routeLink r w = do

522+ (e, a) <- routeLinkImpl r w

523+ scrollToTop e

524+ return a

525+

526+-- | Raw implementation of 'routeLink'. Does not scroll to the top of the page on clicks.

527+routeLinkImpl

528+ :: forall t m a route.

529+ ( DomBuilder t m

530+ , RouteToUrl route m

531+ , SetRoute t route m

532+ )

533+ => route -- ^ Target route

534+ -> m a -- ^ Child widget

535+ -> m (Event t (), a)

536+routeLinkImpl r w = do

521 enc <- askRouteToUrl

537 enc <- askRouteToUrl

522 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))

538 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))

523 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)

539 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)

524 & elementConfig_initialAttributes .~ "href" =: enc r

540 & elementConfig_initialAttributes .~ "href" =: enc r

525 (e, a) <- element "a" cfg w

541 (e, a) <- element "a" cfg w

526 setRoute $ r <$ domEvent Click e

542 setRoute $ r <$ domEvent Click e

527− return a

543+ return (domEvent Click e, a)

528

544

529−-- | A link widget that, when clicked, sets the route to current value of the

545+scrollToTop :: forall m t js. (Prerender js t m, Monad m) => Event t () -> m ()

530−-- provided dynamic route. In non-javascript contexts the value of the dynamic post

546+scrollToTop e = prerender_ blank $ performEvent_ $ ffor e $ \_ -> liftJSM $ DOM.currentWindow >>= \case

531−-- build is used so the link still works like 'routeLink'.

547+ Nothing -> pure ()

548+ Just win -> Window.scrollTo win 0 0

549+

550+-- | Like 'routeLinkDynAttr' but without custom attributes.

532dynRouteLink

551dynRouteLink

533− :: forall t m a route.

552+ :: forall t m a route js.

534 ( DomBuilder t m

553 ( DomBuilder t m

535 , PostBuild t m

554 , PostBuild t m

536− , RouteToUrl (R route) m

555+ , RouteToUrl route m

537− , SetRoute t (R route) m

556+ , SetRoute t route m

557+ , Prerender js t m

538 )

558 )

539− => Dynamic t (R route) -- ^ Target route

559+ => Dynamic t route -- ^ Target route

540 -> m a -- ^ Child widget

560 -> m a -- ^ Child widget

541 -> m a

561 -> m a

542−dynRouteLink dr w = do

562+dynRouteLink r w = do

563+ (e, a) <- dynRouteLinkImpl r w

564+ scrollToTop e

565+ return a

566+

567+-- | Raw implementation of 'dynRouteLink'. Does not scroll to the top of the page on clicks.

568+dynRouteLinkImpl

569+ :: forall t m a route.

570+ ( DomBuilder t m

571+ , PostBuild t m

572+ , RouteToUrl route m

573+ , SetRoute t route m

574+ )

575+ => Dynamic t route -- ^ Target route

576+ -> m a -- ^ Child widget

577+ -> m (Event t (), a)

578+dynRouteLinkImpl dr w = do

543 enc <- askRouteToUrl

579 enc <- askRouteToUrl

544 er <- dynamicAttributesToModifyAttributes $ ("href" =:) . enc <$> dr

580 er <- dynamicAttributesToModifyAttributes $ ("href" =:) . enc <$> dr

545 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))

581 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))

546 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)

582 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)

547 & elementConfig_modifyAttributes .~ er

583 & elementConfig_modifyAttributes .~ er

548 (e, a) <- element "a" cfg w

584 (e, a) <- element "a" cfg w

549− setRoute $ tag (current dr) $ domEvent Click e

585+ let clk = domEvent Click e

586+ setRoute $ tag (current dr) clk

587+ return (clk, a)

588+

589+-- | An @a@-tag link widget that, when clicked, sets the route to current value of the

590+-- provided dynamic route. In non-JavaScript contexts the value of the dynamic post

591+-- build is used so the link still works like 'routeLink'.

592+routeLinkDynAttr

593+ :: forall t m a route js.

594+ ( DomBuilder t m

595+ , PostBuild t m

596+ , RouteToUrl (R route) m

597+ , SetRoute t (R route) m

598+ , Prerender js t m

599+ )

600+ => Dynamic t (Map AttributeName Text) -- ^ Attributes for @a@ element. Note that if @href@ is present it will be ignored

601+ -> Dynamic t (R route) -- ^ Target route

602+ -> m a -- ^ Child widget of the @a@ element

603+ -> m a

604+routeLinkDynAttr dAttr dr w = do

605+ (e, a) <- routeLinkDynAttrImpl dAttr dr w

606+ scrollToTop e

550 return a

607 return a

551

608

609+-- | Raw implementation of 'routeLinkDynAttr'. Does not scroll to the top of the page on clicks.

610+routeLinkDynAttrImpl

611+ :: forall t m a route.

612+ ( DomBuilder t m

613+ , PostBuild t m

614+ , RouteToUrl (R route) m

615+ , SetRoute t (R route) m

616+ )

617+ => Dynamic t (Map AttributeName Text) -- ^ Attributes for @a@ element. Note that if @href@ is present it will be ignored

618+ -> Dynamic t (R route) -- ^ Target route

619+ -> m a -- ^ Child widget of the @a@ element

620+ -> m (Event t (), a)

621+routeLinkDynAttrImpl dAttr dr w = do

622+ enc <- askRouteToUrl

623+ er <- dynamicAttributesToModifyAttributes $ zipDynWith (<>) (("href" =:) . enc <$> dr) dAttr

624+ let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))

625+ & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)

626+ & elementConfig_modifyAttributes .~ er

627+ (e, a) <- element "a" cfg w

628+ let clk = domEvent Click e

629+ setRoute $ tag (current dr) clk

630+ return (clk, a)

631+

552-- On ios due to sandboxing when loading the page from a file adapt the

632-- On ios due to sandboxing when loading the page from a file adapt the

553-- path to be based on the hash.

633-- path to be based on the hash.

554

634

lib/run/obelisk-run.cabal+3

@@ -48,3 +48,6 @@ library

48 exposed-modules:

49 Obelisk.Run

50 ghc-options: -Wall -fwarn-redundant-constraints

51+ if os(linux)

52+ cpp-options: -DIPROUTE_SUPPORTED

53+ build-depends: which

lib/run/src/Obelisk/Run.hs+40−22

@@ -1,3 +1,8 @@

1+{-# LANGUAGE CPP #-}

2+#if defined(IPROUTE_SUPPORTED)

3+{-# LANGUAGE TemplateHaskell #-}

4+#endif

1{-# LANGUAGE ConstraintKinds #-}

6{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FlexibleInstances #-}

@@ -62,16 +67,19 @@ import Snap.Core (Snap)

62import System.Environment

67import System.Environment

63import System.IO

68import System.IO

64import System.Process

69import System.Process

65−import System.Exit (ExitCode(..))

66import Text.URI (URI)

70import Text.URI (URI)

67import qualified Text.URI as URI

71import qualified Text.URI as URI

68import Text.URI.Lens

72import Text.URI.Lens

69import Web.Cookie

73import Web.Cookie

75+#if defined(IPROUTE_SUPPORTED)

76+import qualified System.Which

77+#endif

78+

71run

79run

72 :: Int -- ^ Port to run the backend

80 :: Int -- ^ Port to run the backend

73 -> ([Text] -> Snap ()) -- ^ Static asset handler

81 -> ([Text] -> Snap ()) -- ^ Static asset handler

74− -> Backend fullRoute frontendRoute -- ^ Backend

82+ -> Backend backendRoute frontendRoute -- ^ Backend

75 -> Frontend (R frontendRoute) -- ^ Frontend

83 -> Frontend (R frontendRoute) -- ^ Frontend

76 -> IO ()

84 -> IO ()

77run port serveStaticAsset backend frontend = do

85run port serveStaticAsset backend frontend = do

@@ -82,14 +90,18 @@ run port serveStaticAsset backend frontend = do

82 Left e -> hPutStrLn stderr $ "backend error:\n" <> T.unpack e

90 Left e -> hPutStrLn stderr $ "backend error:\n" <> T.unpack e

83 Right validFullEncoder -> do

91 Right validFullEncoder -> do

84 publicConfigs <- getPublicConfigs

92 publicConfigs <- getPublicConfigs

85− backendTid <- forkIO $ handle handleBackendErr $ withArgs ["--quiet", "--port", show port] $ do

93+ backendTid <- forkIO $ handle handleBackendErr $ withArgs ["--quiet", "--port", show port] $

86− _backend_run backend $ \serveRoute -> do

94+ _backend_run backend $ \serveRoute ->

87− runSnapWithCommandLineArgs $ do

95+ runSnapWithCommandLineArgs $

88 getRouteWith validFullEncoder >>= \case

96 getRouteWith validFullEncoder >>= \case

89 Identity r -> case r of

97 Identity r -> case r of

90 FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a

98 FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a

91 FullRoute_Frontend obeliskRoute :/ a ->

99 FullRoute_Frontend obeliskRoute :/ a ->

92− serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) serveStaticAsset frontend publicConfigs $ obeliskRoute :/ a

100+ serveDefaultObeliskApp appRouteToUrl allJsUrl serveStaticAsset frontend publicConfigs $ obeliskRoute :/ a

101+ where

102+ appRouteToUrl (k :/ v) = renderObeliskRoute validFullEncoder (FullRoute_Frontend (ObeliskRoute_App k) :/ v)

103+ allJsUrl = renderAllJsPath validFullEncoder

104+

93 let conf = defRunConfig { _runConfig_redirectPort = port }

105 let conf = defRunConfig { _runConfig_redirectPort = port }

94 runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid

106 runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid

107

@@ -99,7 +111,7 @@ runServeAsset rootPath = Snap.serveAsset "" rootPath . T.unpack . T.intercalate

111

100getConfigRoute :: Map Text ByteString -> Either Text URI

112getConfigRoute :: Map Text ByteString -> Either Text URI

101getConfigRoute configs = case Map.lookup "common/route" configs of

113getConfigRoute configs = case Map.lookup "common/route" configs of

102− Just r ->

114+ Just r ->

103 let stripped = T.strip (T.decodeUtf8 r)

115 let stripped = T.strip (T.decodeUtf8 r)

104 in case URI.mkURI stripped of

116 in case URI.mkURI stripped of

105 Just route -> Right route

117 Just route -> Right route

@@ -121,21 +133,21 @@ runWidget conf configs frontend validFullEncoder = do

121 putStrLn $ "Frontend running on " <> T.unpack (URI.render uri)

133 putStrLn $ "Frontend running on " <> T.unpack (URI.render uri)

122 settings = setBeforeMainLoop beforeMainLoop (setPort port (setTimeout 3600 defaultSettings))

134 settings = setBeforeMainLoop beforeMainLoop (setPort port (setTimeout 3600 defaultSettings))

123 -- Providing TLS here will also incidentally provide it to proxied requests to the backend.

135 -- Providing TLS here will also incidentally provide it to proxied requests to the backend.

124− prepareRunner = case (uri ^? uriScheme . _Just . unRText) of

136+ prepareRunner = case uri ^? uriScheme . _Just . unRText of

125− Just "https" -> do

137+ Just "https" -> do

126 -- Generate a private key and self-signed certificate for TLS

138 -- Generate a private key and self-signed certificate for TLS

127 privateKey <- RSA.generateRSAKey' 2048 3

139 privateKey <- RSA.generateRSAKey' 2048 3

128

140

129 certRequest <- X509Request.newX509Req

141 certRequest <- X509Request.newX509Req

130 _ <- X509Request.setPublicKey certRequest privateKey

142 _ <- X509Request.setPublicKey certRequest privateKey

131− _ <- X509Request.signX509Req certRequest privateKey Nothing

143+ _ <- X509Request.signX509Req certRequest privateKey Nothing

132

144

133 cert <- X509.newX509 >>= X509Request.makeX509FromReq certRequest

145 cert <- X509.newX509 >>= X509Request.makeX509FromReq certRequest

134 _ <- X509.setPublicKey cert privateKey

146 _ <- X509.setPublicKey cert privateKey

135 now <- getCurrentTime

147 now <- getCurrentTime

136 _ <- X509.setNotBefore cert $ addUTCTime (-1) now

148 _ <- X509.setNotBefore cert $ addUTCTime (-1) now

137 _ <- X509.setNotAfter cert $ addUTCTime (365 * 24 * 60 * 60) now

149 _ <- X509.setNotAfter cert $ addUTCTime (365 * 24 * 60 * 60) now

138− _ <- X509.signX509 cert privateKey Nothing

150+ _ <- X509.signX509 cert privateKey Nothing

139

151

140 certByteString <- BSUTF8.fromString <$> PEM.writeX509 cert

152 certByteString <- BSUTF8.fromString <$> PEM.writeX509 cert

141 privateKeyByteString <- BSUTF8.fromString <$> PEM.writePKCS8PrivateKey privateKey Nothing

153 privateKeyByteString <- BSUTF8.fromString <$> PEM.writePKCS8PrivateKey privateKey Nothing

@@ -181,7 +193,8 @@ obeliskApp configs opts frontend validFullEncoder uri backend = do

181 }

193 }

182 FullRoute_Frontend (ObeliskRoute_App appRouteComponent) :/ appRouteRest -> do

194 FullRoute_Frontend (ObeliskRoute_App appRouteComponent) :/ appRouteRest -> do

183 let cookies = maybe [] parseCookies $ lookup (fromString "Cookie") (W.requestHeaders req)

195 let cookies = maybe [] parseCookies $ lookup (fromString "Cookie") (W.requestHeaders req)

196+ routeToUrl (k :/ v) = renderObeliskRoute validFullEncoder $ FullRoute_Frontend (ObeliskRoute_App k) :/ v

184− html <- renderJsaddleFrontend configs cookies (mkRouteToUrl validFullEncoder) (appRouteComponent :/ appRouteRest) frontend

197+ html <- renderJsaddleFrontend configs cookies routeToUrl (appRouteComponent :/ appRouteRest) frontend

185 sendResponse $ W.responseLBS H.status200 [("Content-Type", staticRenderContentType)] $ BSLC.fromStrict html

198 sendResponse $ W.responseLBS H.status200 [("Content-Type", staticRenderContentType)] $ BSLC.fromStrict html

186 _ -> backend req sendResponse

199 _ -> backend req sendResponse

187

200

@@ -212,17 +225,22 @@ logPortBindErr p e = getProcessIdForPort p >>= \case

212 Nothing -> putStrLn $ "runWidget: " <> show e

225 Nothing -> putStrLn $ "runWidget: " <> show e

213 Just pid -> putStrLn $ unwords [ "Port", show p, "is being used by process ID", show pid <> ".", "Please kill that process or change the port in config/common/route."]

226 Just pid -> putStrLn $ unwords [ "Port", show p, "is being used by process ID", show pid <> ".", "Please kill that process or change the port in config/common/route."]

214

227

228+ssPath :: Maybe String

229+ssPath =

230+#if defined(IPROUTE_SUPPORTED)

231+ Just $(System.Which.staticWhich "ss")

232+#else

233+ Nothing

234+#endif

235+

215getProcessIdForPort :: Int -> IO (Maybe Int)

236getProcessIdForPort :: Int -> IO (Maybe Int)

216−getProcessIdForPort port = do

237+getProcessIdForPort port = case ssPath of

217− -- First check if 'ss' is available

238+ Just ss -> do

218− (c, _, _) <- readProcessWithExitCode "which" ["ss"] mempty

219− case c of

220− ExitSuccess -> do

221− xs <- lines <$> readProcess "ss" ["-lptn", "sport = " <> show port] mempty

239+ xs <- lines <$> readProcess ss ["-lptn", "sport = " <> show port] mempty

222− case uncons xs of

240+ case uncons xs of

223− Just (_, x:_) -> return $ A.maybeResult $ A.parse parseSsPid $ BSC.pack x

241+ Just (_, x:_) -> return $ A.maybeResult $ A.parse parseSsPid $ BSC.pack x

224− _ -> return Nothing

242+ _ -> return Nothing

225− _ -> return Nothing

243+ _ -> return Nothing

226

244

227parseSsPid :: A.Parser Int

245parseSsPid :: A.Parser Int

228parseSsPid = do

246parseSsPid = do

lib/selftest/obelisk-selftest.cabal+4−2

@@ -11,16 +11,18 @@ library

11 base

12 , containers

13 , directory

14+ , filepath

14 , hspec

15 , hspec

15 , http-client

16 , http-client

16 , http-types

17 , http-types

17 , HUnit

18 , HUnit

19+ , network

18 , obelisk-cliapp

20 , obelisk-cliapp

19 , obelisk-executable-config-lookup

21 , obelisk-executable-config-lookup

20 , obelisk-run

22 , obelisk-run

23+ , which

21 , process

24 , process

22− , network

23− , shelly

25+ , shelly >= 1.9.0

24 , temporary

26 , temporary

25 , text

27 , text

26 exposed-modules:

28 exposed-modules:

lib/selftest/src/Obelisk/SelfTest.hs+205−95

@@ -1,9 +1,11 @@

1+{-# LANGUAGE DoAndIfThenElse #-}

1{-# LANGUAGE EmptyCase #-}

2{-# LANGUAGE EmptyCase #-}

2{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PatternGuards #-}

5{-# LANGUAGE PatternGuards #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeApplications #-}

7+{-# LANGUAGE ViewPatterns #-}

8+{-# LANGUAGE TemplateHaskell #-}

7module Obelisk.SelfTest where

9module Obelisk.SelfTest where

9import Control.Exception (bracket, throw)

11import Control.Exception (bracket, throw)

@@ -11,7 +13,7 @@ import Control.Monad

11import Control.Monad.IO.Class

13import Control.Monad.IO.Class

12import Data.Bool (bool)

14import Data.Bool (bool)

13import Data.Function (fix)

15import Data.Function (fix)

14−import Data.Semigroup (Semigroup, (<>))

16+import Data.Semigroup ((<>))

15import qualified Data.Set as Set

17import qualified Data.Set as Set

16import Data.String

18import Data.String

17import Data.Text (Text)

19import Data.Text (Text)

@@ -21,12 +23,13 @@ import qualified Data.Text.IO as T

21import qualified Network.HTTP.Client as HTTP

23import qualified Network.HTTP.Client as HTTP

22import qualified Network.HTTP.Types as HTTP

24import qualified Network.HTTP.Types as HTTP

23import qualified Network.Socket as Socket

25import qualified Network.Socket as Socket

24−import Shelly

26+import Shelly hiding (cp)

25−import System.Directory (withCurrentDirectory, getDirectoryContents)

27+import System.Directory (getCurrentDirectory, withCurrentDirectory, getDirectoryContents)

26import System.Environment

28import System.Environment

27import System.Exit (ExitCode (..))

29import System.Exit (ExitCode (..))

28−import System.Info

30+import System.Which (staticWhich)

31+import qualified System.Info

29−import System.IO (Handle, hClose)

32+import System.IO (Handle, hClose, hIsEOF, hGetContents)

30import System.IO.Temp

33import System.IO.Temp

31import System.Process (readProcessWithExitCode, CreateProcess(cwd), readCreateProcessWithExitCode, proc)

34import System.Process (readProcessWithExitCode, CreateProcess(cwd), readCreateProcessWithExitCode, proc)

32import Test.Hspec

35import Test.Hspec

@@ -43,16 +46,42 @@ data ObRunState

43 | ObRunState_BackendStarted

46 | ObRunState_BackendStarted

44 deriving (Eq, Show)

47 deriving (Eq, Show)

46−doubleQuotes :: (IsString a, Semigroup a) => a -> a

49+cp :: FilePath

47−doubleQuotes s = "\"" <> s <> "\""

50+cp = $(staticWhich "cp")

51+

52+cabalPath :: FilePath

53+cabalPath = $(staticWhich "cabal")

54+

55+gitPath :: FilePath

56+gitPath = $(staticWhich "git")

57+

58+chownPath :: FilePath

59+chownPath = $(staticWhich "chown")

60+

61+chmodPath :: FilePath

62+chmodPath = $(staticWhich "chmod")

63+

64+whoamiPath :: FilePath

65+whoamiPath = $(staticWhich "whoami")

66+

67+nixBuildPath :: FilePath

68+nixBuildPath = $(staticWhich "nix-build")

69+

70+lnPath :: FilePath

71+lnPath = $(staticWhich "ln")

72+

73+rmPath :: FilePath

74+rmPath = $(staticWhich "rm")

75+

76+gitUserConfig :: [Text]

77+gitUserConfig = ["-c", "user.name=Obelisk Selftest", "-c", "user.email=noreply@example.com"]

49commit :: Text -> Sh ()

79commit :: Text -> Sh ()

50−commit msg = void $ run "git"

80+commit msg = void $ run gitPath $ gitUserConfig <> [ "commit"

51− [ "commit"

52 , "--no-gpg-sign"

81 , "--no-gpg-sign"

53 , "--allow-empty"

82 , "--allow-empty"

54 , "-m"

83 , "-m"

55− , doubleQuotes msg

84+ , msg

56 ]

85 ]

58-- TODO replace Void and stop using loosely typed synchronous exceptions

87-- TODO replace Void and stop using loosely typed synchronous exceptions

@@ -68,111 +97,168 @@ tshow = T.pack . show

68shellyOb :: MonadIO m => (Sh a -> Sh a) -> Sh a -> m a

97shellyOb :: MonadIO m => (Sh a -> Sh a) -> Sh a -> m a

69shellyOb f obTest = shelly $ f obTest

98shellyOb f obTest = shelly $ f obTest

100+-- Set "ob" in a single place so it can be replaced with a

101+-- link to obelisk in the nix store in the future,

102+-- and avoid PATH hacking before calling this script.

103+ob :: FilePath

104+ob = "ob"

105+

106+augmentWithVerbosity :: (String -> [Text] -> a) -> String -> Bool -> [Text] -> a

107+augmentWithVerbosity runner executable isVerbose args = runner executable $ (if isVerbose then ("-v" :) else id) args

108+

71main :: IO ()

109main :: IO ()

72main = do

110main = do

73 -- Note: you can pass hspec arguments as well, eg: `-m <pattern>`

111 -- Note: you can pass hspec arguments as well, eg: `-m <pattern>`

74− isVerbose <- (elem "-v") <$> getArgs

112+ isVerbose <- elem "-v" <$> getArgs

75 unless isVerbose $

113 unless isVerbose $

76 putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output"

114 putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output"

77 let verbosity = bool silently verbosely isVerbose

115 let verbosity = bool silently verbosely isVerbose

78− nixBuild args = run "nix-build" ("--no-out-link" : args)

116+ nixBuild args = run nixBuildPath ("--no-out-link" : args)

79− obeliskImpl <- fromString <$> getEnv "OBELISK_IMPL"

117+ obeliskImplDirtyReadOnly <- fromString <$> getCurrentDirectory

118+ let runOb_ = augmentWithVerbosity run_ ob isVerbose

119+ let runOb = augmentWithVerbosity run ob isVerbose

120+ let testObRunInDir' = augmentWithVerbosity testObRunInDir ob isVerbose ["run"]

121+ let testThunkPack' = augmentWithVerbosity testThunkPack ob isVerbose []

122+ let

123+ withObeliskImplClean f =

124+ withSystemTempDirectory "obelisk-impl-clean" $ \(fromString -> obeliskImpl) -> do

125+ void . shellyOb verbosity $ chdir obeliskImpl $ do

126+ run_ gitPath ["clone", "file://" <> toTextIgnore obeliskImplDirtyReadOnly, toTextIgnore obeliskImpl]

127+ f obeliskImpl

128+

129+ withObeliskImplDirty f =

130+ withSystemTempDirectory "obelisk-impl-copy" $ \(fromString -> obeliskImpl) -> do

131+ void . shellyOb verbosity $ chdir obeliskImpl $ do

132+ user <- T.strip <$> run whoamiPath []

133+ run_ cp ["-rT", "--no-preserve=mode", toTextIgnore obeliskImplDirtyReadOnly, toTextIgnore obeliskImpl]

134+ run_ chownPath ["-R", user, toTextIgnore obeliskImpl]

135+ run_ chmodPath ["-R", "g-rw,o-rw", toTextIgnore obeliskImpl]

136+ f obeliskImpl

137+

138+ withInitCache f obeliskImpl =

139+ withSystemTempDirectory "init Cache λ" $ \initCache -> do

140+ -- Setup the ob init cache

141+ void . shellyOb verbosity $ chdir initCache $ do

142+ runOb_ ["init", "--symlink", toTextIgnore obeliskImpl]

143+ run_ gitPath ["init"]

144+

145+ f initCache

146+

147+ withObeliskImplDirtyAndInitCache f =

148+ withObeliskImplDirty $ \impl -> withInitCache (f impl) impl

149+

80 httpManager <- HTTP.newManager HTTP.defaultManagerSettings

150 httpManager <- HTTP.newManager HTTP.defaultManagerSettings

81− [p0, p1, p2, p3] <- liftIO $ getFreePorts 4

151+

82− withSystemTempDirectory "initCache" $ \initCache -> do

152+ withObeliskImplDirtyAndInitCache $ \obeliskImplDirty initCache ->

83− -- Setup the ob init cache

84− void . shellyOb verbosity $ chdir (fromString initCache) $ do

85− run_ "ob" ["init"]

86− run_ "git" ["init"]

87 hspec $ parallel $ do

153 hspec $ parallel $ do

88 let shelly_ = void . shellyOb verbosity

154 let shelly_ = void . shellyOb verbosity

155

156+ defaultTmpDirName = "test λ"

157+

90− inTmp :: (Shelly.FilePath -> Sh a) -> IO ()

158+ inTmp' :: FilePath -> (FilePath -> Sh a) -> IO ()

91− inTmp f = withTmp (chdir <*> f)

159+ inTmp' dirname f = withTmp' dirname (chdir <*> f)

160+ inTmp = inTmp' defaultTmpDirName

161

93− withTmp f = shelly_ . withSystemTempDirectory "test" $ f . fromString

162+ withTmp' dirname f = shelly_ . withSystemTempDirectory dirname $ f . fromString

163+ withTmp = withTmp' defaultTmpDirName

164

95− inTmpObInit f = inTmp $ \dir -> do

165+ inTmpObInit' dirname f = inTmp' dirname $ \dir -> do

96− run_ "cp" ["-a", fromString $ initCache <> "/.", toTextIgnore dir]

166+ run_ cp ["-rT", fromString initCache, toTextIgnore dir]

97 f dir

167 f dir

168+ inTmpObInit = inTmpObInit' defaultTmpDirName

169+

170+ -- To be used in tests that change the obelisk impl directory

171+ inTmpObInitWithImplCopy f = inTmpObInit $ \dir ->

172+ withObeliskImplClean $ \(fromString -> implClean) -> do

173+ run_ rmPath [thunk]

174+ run_ lnPath ["-s", implClean, thunk]

175+ f dir

176

99 assertRevEQ a b = liftIO . assertEqual "" "" =<< diff a b

177 assertRevEQ a b = liftIO . assertEqual "" "" =<< diff a b

100 assertRevNE a b = liftIO . assertBool "" . (/= "") =<< diff a b

178 assertRevNE a b = liftIO . assertBool "" . (/= "") =<< diff a b

101

179

102− revParseHead = T.strip <$> run "git" ["rev-parse", "HEAD"]

180+ revParseHead = T.strip <$> run gitPath ["rev-parse", "HEAD"]

103

181

104 commitAll = do

182 commitAll = do

105− run_ "git" ["add", "."]

183+ run_ gitPath ["add", "."]

106 commit "checkpoint"

184 commit "checkpoint"

107 revParseHead

185 revParseHead

108

186

109 thunk = ".obelisk/impl"

187 thunk = ".obelisk/impl"

110− update = run "ob" ["thunk", "update", thunk] >> commitAll

188+ update = runOb ["thunk", "update", thunk] >> commitAll

111− pack = run "ob" ["thunk", "pack", thunk] >> commitAll

189+ pack = runOb ["thunk", "pack", thunk] >> commitAll

112− unpack = run "ob" ["thunk", "unpack", thunk] >> commitAll

190+ unpack = runOb ["thunk", "unpack", thunk] >> commitAll

113

191

114− diff a b = run "git" ["diff", a, b]

192+ diff a b = run gitPath ["diff", a, b]

115

193

116 describe "ob init" $ parallel $ do

194 describe "ob init" $ parallel $ do

117− it "works with default impl" $ inTmp $ \_ -> run "ob" ["init"]

195+ it "works with default impl" $ inTmp $ \_ -> runOb ["init"]

118− it "works with master branch impl" $ inTmp $ \_ -> run "ob" ["init", "--branch", "master"]

196+ it "works with master branch impl" $ inTmp $ \_ -> runOb ["init", "--branch", "master"]

119− it "works with symlink" $ inTmp $ \_ -> run "ob" ["init", "--symlink", obeliskImpl]

197+ it "works with symlink" $ inTmp $ \_ -> runOb ["init", "--symlink", toTextIgnore obeliskImplDirty]

120− it "doesn't silently overwrite existing files" $ withSystemTempDirectory "ob-init" $ \dir -> do

198+ it "doesn't silently overwrite existing files" $ withSystemTempDirectory "ob-init λ" $ \dir -> do

121− let p force = (proc "ob" $ "--no-handoff" : "init" : if force then ["--force"] else []) { cwd = Just dir }

199+ let p force = (System.Process.proc ob $ "--no-handoff" : "-v" : "init" : ["--force"|force]) { cwd = Just dir }

122 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p False) ""

200 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p False) ""

123 (ExitFailure _, _, _) <- readCreateProcessWithExitCode (p False) ""

201 (ExitFailure _, _, _) <- readCreateProcessWithExitCode (p False) ""

124 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p True) ""

202 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p True) ""

125 pure ()

203 pure ()

126

204

127 it "doesn't create anything when given an invalid impl" $ inTmp $ \tmp -> do

205 it "doesn't create anything when given an invalid impl" $ inTmp $ \tmp -> do

128− void $ errExit False $ run "ob" ["init", "--symlink", "/dev/null"]

206+ void $ errExit False $ runOb ["init", "--symlink", "/dev/null"]

129 ls tmp >>= liftIO . assertEqual "" []

207 ls tmp >>= liftIO . assertEqual "" []

130

208

131− it "produces a valid route config" $ inTmpObInit $ \tmp -> liftIO $ do

209+ it "produces a valid route config" $ inTmpObInit $ \tmp -> liftIO $

132 withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ do

210 withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ do

133 configs <- getConfigs

211 configs <- getConfigs

134 return (either (const Nothing) Just $ getConfigRoute configs) `shouldNotReturn` Nothing

212 return (either (const Nothing) Just $ getConfigRoute configs) `shouldNotReturn` Nothing

135

213

136 -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"

214 -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"

137 -- when not run by 'nix-build --attr selftest'

215 -- when not run by 'nix-build --attr selftest'

138− describe "ob run" $ parallel $ do

216+ describe "ob run" $ {- NOT parallel $ -} do

139− it "works in root directory" $ inTmpObInit $ \_ -> do

217+ it "works in root directory" $ inTmpObInit $ \_ -> testObRunInDir' Nothing httpManager

140− testObRunInDir p0 p1 Nothing httpManager

141− it "works in sub directory" $ inTmpObInit $ \_ -> do

142− testObRunInDir p2 p3 (Just "frontend") httpManager

218+ it "works in sub directory" $ inTmpObInit $ \_ -> testObRunInDir' (Just "frontend") httpManager

143

219

144 describe "obelisk project" $ parallel $ do

220 describe "obelisk project" $ parallel $ do

145− it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , obeliskImpl]

221+ it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , toTextIgnore obeliskImplDirty]

146− it "can build obelisk skeleton" $ inTmpObInit $ \_ -> nixBuild ["-A", "skeleton", obeliskImpl]

222+ it "can build obelisk skeleton" $ inTmpObInit $ \_ -> nixBuild ["-A", "skeleton", toTextIgnore obeliskImplDirty]

147− it "can build obelisk shell" $ inTmpObInit $ \_ -> nixBuild ["-A", "shell", obeliskImpl]

223+ it "can build obelisk shell" $ inTmpObInit $ \_ -> nixBuild ["-A", "shell", toTextIgnore obeliskImplDirty]

148− it "can build everything" $ inTmpObInit $ \_ -> nixBuild [obeliskImpl]

224+ it "can build everything" $ inTmpObInit $ \_ -> nixBuild [toTextIgnore obeliskImplDirty]

149

225

150 describe "blank initialized project" $ parallel $ do

226 describe "blank initialized project" $ parallel $ do

151

227

152− it "can build ghc.backend" $ inTmpObInit $ \_ -> do

228+ it "can build ghc.backend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghc.backend"]

153− nixBuild ["-A", "ghc.backend"]

154− it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> do

229+ it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghcjs.frontend"]

155− nixBuild ["-A", "ghcjs.frontend"]

156

230

157− if os == "darwin"

231+ if System.Info.os == "darwin"

158− then it "can build ios" $ inTmpObInit $ \_ -> nixBuild ["-A", "ios.frontend"]

232+ then it "can build ios" $ inTmpObInit $ \_ -> nixBuild ["-A", "ios.frontend"]

233+ else it "can build android after accepting license" $ inTmpObInit $ \dir -> do

234+ let defaultNixPath = dir </> ("default.nix" :: FilePath)

235+ writefile defaultNixPath

236+ =<< T.replace

237+ "# config.android_sdk.accept_license = false;"

238+ "config.android_sdk.accept_license = true;"

239+ <$> readfile defaultNixPath

159− else it "can build android" $ inTmpObInit $ \_ -> nixBuild ["-A", "android.frontend"]

240+ nixBuild ["-A", "android.frontend"]

160

241

161 forM_ ["ghc", "ghcjs"] $ \compiler -> do

242 forM_ ["ghc", "ghcjs"] $ \compiler -> do

162 let

243 let

163− shell = "shells." <> compiler

244+ shellName = "shells." <> compiler

164− inShell cmd' = run "nix-shell" ["default.nix", "-A", fromString shell, "--run", cmd']

245+ inShell cmd' = run_ "nix-shell" ["default.nix", "-A", fromString shellName, "--run", cmd']

165− it ("can enter " <> shell) $ inTmpObInit $ \_ -> inShell "exit"

246+ it ("can enter " <> shellName) $ inTmpObInit $ \_ -> inShell "exit"

166− it ("can build in " <> shell) $ inTmpObInit $ \_ -> inShell $ "cabal new-build --" <> fromString compiler <> " all"

247+ -- NOTE: We override the temporary directory name because cabal has a bug preventing new-build from working

167−

248+ -- in a path that has unicode characters.

249+ it ("can build in " <> shellName) $ inTmpObInit' "test" $ \_ -> inShell $

250+ T.pack cabalPath <> " --version; " <> T.pack cabalPath <> " new-build --" <> T.pack compiler <> " all"

251+

168− it "has idempotent thunk update" $ inTmpObInit $ \_ -> do

252+ it "has idempotent thunk update" $ inTmpObInitWithImplCopy $ \_ -> do

253+ _ <- pack

169 u <- update

254 u <- update

170 uu <- update

255 uu <- update

171 assertRevEQ u uu

256 assertRevEQ u uu

172

257

173 describe "ob thunk pack/unpack" $ parallel $ do

258 describe "ob thunk pack/unpack" $ parallel $ do

174− it "has thunk pack and unpack inverses" $ inTmpObInit $ \_ -> do

259+ it "has thunk pack and unpack inverses" $ inTmpObInitWithImplCopy $ \_ -> do

175

260

261+ _ <- pack

176 e <- commitAll

262 e <- commitAll

177 eu <- unpack

263 eu <- unpack

178 eup <- pack

264 eup <- pack

@@ -185,76 +271,93 @@ main = do

185

271

186 it "unpacks the correct branch" $ withTmp $ \dir -> do

272 it "unpacks the correct branch" $ withTmp $ \dir -> do

187 let branch = "master"

273 let branch = "master"

188− run_ "git" ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch]

274+ run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch]

189− run_ "ob" ["thunk", "pack", toTextIgnore dir]

275+ runOb_ ["thunk", "pack", toTextIgnore dir]

190− run_ "ob" ["thunk", "unpack", toTextIgnore dir]

276+ runOb_ ["thunk", "unpack", toTextIgnore dir]

191− branch' <- chdir dir $ run "git" ["rev-parse", "--abbrev-ref", "HEAD"]

277+ branch' <- chdir dir $ run gitPath ["rev-parse", "--abbrev-ref", "HEAD"]

192 liftIO $ assertEqual "" branch (T.strip branch')

278 liftIO $ assertEqual "" branch (T.strip branch')

193

279

194− it "can pack and unpack plain git repos" $ do

280+ it "can pack and unpack plain git repos" $

195 shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do

281 shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do

196 let repo = toTextIgnore $ dir </> ("repo" :: String)

282 let repo = toTextIgnore $ dir </> ("repo" :: String)

197− run_ "git" ["clone", "https://github.com/haskell/process.git", repo]

283+ run_ gitPath ["clone", "https://github.com/haskell/process.git", repo]

198 origHash <- chdir (fromText repo) revParseHead

284 origHash <- chdir (fromText repo) revParseHead

199

285

200− run_ "ob" ["thunk", "pack", repo]

286+ runOb_ ["thunk", "pack", repo]

201 packedFiles <- Set.fromList <$> ls (fromText repo)

287 packedFiles <- Set.fromList <$> ls (fromText repo)

202 liftIO $ assertEqual "" packedFiles $ Set.fromList $ (repo </>) <$>

288 liftIO $ assertEqual "" packedFiles $ Set.fromList $ (repo </>) <$>

203 ["default.nix", "github.json", ".attr-cache" :: String]

289 ["default.nix", "github.json", ".attr-cache" :: String]

204

290

205− run_ "ob" ["thunk", "unpack", repo]

291+ runOb_ ["thunk", "unpack", repo]

206 chdir (fromText repo) $ do

292 chdir (fromText repo) $ do

207 unpackHash <- revParseHead

293 unpackHash <- revParseHead

208 assertRevEQ origHash unpackHash

294 assertRevEQ origHash unpackHash

209

295

210− testThunkPack $ fromText repo

296+ testThunkPack' $ fromText repo

211

297

212− it "aborts thunk pack when there are uncommitted files" $ inTmpObInit $ \dir -> do

298+ it "aborts thunk pack when there are uncommitted files" $ inTmpObInitWithImplCopy $ \dir -> do

213− void $ unpack

214− testThunkPack (dir </> thunk)

299+ testThunkPack' (dir </> thunk)

215

300

216 describe "ob thunk update --branch" $ parallel $ do

301 describe "ob thunk update --branch" $ parallel $ do

217 it "can change a thunk to the latest version of a desired branch" $ withTmp $ \dir -> do

302 it "can change a thunk to the latest version of a desired branch" $ withTmp $ \dir -> do

218 let branch1 = "master"

303 let branch1 = "master"

219 branch2 = "develop"

304 branch2 = "develop"

220− run_ "git" ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch1]

305+ run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", branch1]

221− run_ "ob" ["thunk" , "pack", toTextIgnore dir]

306+ runOb_ ["thunk" , "pack", toTextIgnore dir]

222− run_ "ob" ["thunk", "update", toTextIgnore dir, "--branch", branch2]

307+ runOb_ ["thunk", "update", toTextIgnore dir, "--branch", branch2]

223

308

224 it "doesn't create anything when given an invalid branch" $ withTmp $ \dir -> do

309 it "doesn't create anything when given an invalid branch" $ withTmp $ \dir -> do

225 let checkDir dir' = liftIO $ getDirectoryContents $ T.unpack $ toTextIgnore dir'

310 let checkDir dir' = liftIO $ getDirectoryContents $ T.unpack $ toTextIgnore dir'

226− run_ "git" ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", "master"]

311+ run_ gitPath ["clone", "https://github.com/reflex-frp/reflex.git", toTextIgnore dir, "--branch", "master"]

227− run_ "ob" ["thunk" , "pack", toTextIgnore dir]

312+ runOb_ ["thunk" , "pack", toTextIgnore dir]

228 startingContents <- checkDir dir

313 startingContents <- checkDir dir

229− void $ errExit False $ run "ob" ["thunk", "update", toTextIgnore dir, "--branch", "dumble-palooza"]

314+ void $ errExit False $ runOb ["thunk", "update", toTextIgnore dir, "--branch", "dumble-palooza"]

230 checkDir dir >>= liftIO . assertEqual "" startingContents

315 checkDir dir >>= liftIO . assertEqual "" startingContents

231

316

317+ describe "ob hoogle" $ {- NOT parallel -} do

318+ it "starts a hoogle server on the given port" $ inTmpObInit $ \_ -> do

319+ [p0] <- liftIO $ getFreePorts 1

320+ maskExitSuccess $ runHandle "ob" ["hoogle", "--port", T.pack (show p0)] $ \stdout -> fix $ \loop -> do

321+ ln <- liftIO $ T.hGetLine stdout

322+ echo ln

323+ let search = "Server starting on port " <> T.pack (show p0)

324+ case search `T.isInfixOf` ln of

325+ False -> loop -- keep waiting

326+ True -> do

327+ let req uri = liftIO $ HTTP.parseRequest uri >>= flip HTTP.httpLbs httpManager

328+ req ("http://127.0.0.1:" <> show p0) >>= \r -> case HTTP.responseStatus r == HTTP.ok200 of

329+ False -> errorExit $ "Request to hoogle server failed: " <> T.pack (show r)

330+ True -> exit 0

331+

332+maskExitSuccess :: Sh () -> Sh ()

333+maskExitSuccess = handle_sh (\case ExitSuccess -> pure (); e -> throw e)

232

334

233-- | Run `ob run` in the given directory (maximum of one level deep)

335-- | Run `ob run` in the given directory (maximum of one level deep)

234−testObRunInDir :: Socket.PortNumber -> Socket.PortNumber -> Maybe Shelly.FilePath -> HTTP.Manager -> Sh ()

336+testObRunInDir :: String -> [Text] -> Maybe FilePath -> HTTP.Manager -> Sh ()

235−testObRunInDir p0 p1 mdir httpManager = handle_sh (\case ExitSuccess -> pure (); e -> throw e) $ do

337+testObRunInDir executable extraArgs mdir httpManager = maskExitSuccess $ do

338+ [p0, p1] <- liftIO $ getFreePorts 2

236 let uri p = "http://localhost:" <> T.pack (show p) <> "/" -- trailing slash required for comparison

339 let uri p = "http://localhost:" <> T.pack (show p) <> "/" -- trailing slash required for comparison

237 writefile "config/common/route" $ uri p0

340 writefile "config/common/route" $ uri p0

238− maybe id chdir mdir $ runHandle "ob" ["run"] $ \stdout -> do

341+ maybe id chdir mdir $ runHandles executable extraArgs [] $ \_stdin stdout stderr -> do

239− firstUri <- handleObRunStdout httpManager stdout

342+ firstUri <- handleObRunStdout httpManager stdout stderr

240 let newUri = uri p1

343 let newUri = uri p1

241 when (firstUri == newUri) $ errorExit $

344 when (firstUri == newUri) $ errorExit $

242 "Startup URI (" <> firstUri <> ") is the same as test URI (" <> newUri <> ")"

345 "Startup URI (" <> firstUri <> ") is the same as test URI (" <> newUri <> ")"

243 maybe id (\_ -> chdir "..") mdir $ alterRouteTo newUri stdout

346 maybe id (\_ -> chdir "..") mdir $ alterRouteTo newUri stdout

244− runningUri <- handleObRunStdout httpManager stdout

347+ runningUri <- handleObRunStdout httpManager stdout stderr

245 if runningUri /= newUri

348 if runningUri /= newUri

246 then errorExit $ "Reloading failed: expected " <> newUri <> " but got " <> runningUri

349 then errorExit $ "Reloading failed: expected " <> newUri <> " but got " <> runningUri

247 else exit 0

350 else exit 0

248

351

249−testThunkPack :: Shelly.FilePath -> Sh ()

352+testThunkPack :: String -> [Text] -> FilePath -> Sh ()

250−testThunkPack path' = withTempFile (T.unpack $ toTextIgnore path') "test-file" $ \file handle -> do

353+testThunkPack executable args path' = withTempFile (T.unpack $ toTextIgnore path') "test-file" $ \file handle -> do

251− let pack' = readProcessWithExitCode "ob" ["thunk", "pack", T.unpack $ toTextIgnore path'] ""

354+ let pack' = readProcessWithExitCode executable (T.unpack <$> ["thunk", "pack", toTextIgnore path'] ++ args) ""

252 ensureThunkPackFails q = liftIO $ pack' >>= \case

355 ensureThunkPackFails q = liftIO $ pack' >>= \case

253 (code, out, err)

356 (code, out, err)

254− | code == ExitSuccess -> fail "ob thunk pack succeeded when it should have failed"

357+ | code == ExitSuccess -> fail $ "ob thunk pack succeeded when it should have failed with error '" <> show q <> "'"

255 | q `T.isInfixOf` T.pack (out <> err) -> pure ()

358 | q `T.isInfixOf` T.pack (out <> err) -> pure ()

256− | otherwise -> fail $ "ob thunk pack failed for an unexpected reason: " <> show out <> "\nstderr: " <> err

359+ | otherwise -> fail $ "ob thunk pack failed for an unexpected reason, expecting '" <> show q <> "', received: " <> show out <> "\nstderr: " <> err

257− git = chdir path' . run "git"

360+ git = chdir path' . run gitPath

258 -- Untracked files

361 -- Untracked files

259 ensureThunkPackFails "Untracked files"

362 ensureThunkPackFails "Untracked files"

260 void $ git ["add", T.pack file]

363 void $ git ["add", T.pack file]

@@ -267,7 +370,7 @@ testThunkPack path' = withTempFile (T.unpack $ toTextIgnore path') "test-file" $

267 liftIO $ T.hPutStrLn handle "test file" >> hClose handle

370 liftIO $ T.hPutStrLn handle "test file" >> hClose handle

268 ensureThunkPackFails "modified"

371 ensureThunkPackFails "modified"

269 -- Existing stashes

372 -- Existing stashes

270− void $ git ["stash"]

373+ void $ git $ gitUserConfig <> [ "stash" ]

271 ensureThunkPackFails "has stashes"

374 ensureThunkPackFails "has stashes"

272

375

273-- | Blocks until a non-empty line is available

376-- | Blocks until a non-empty line is available

@@ -288,9 +391,12 @@ alterRouteTo uri stdout = do

288 "Reloading failed: " <> T.pack (show t)

391 "Reloading failed: " <> T.pack (show t)

289

392

290-- | Handle stdout of `ob run`: check that the frontend and backend servers are started correctly

393-- | Handle stdout of `ob run`: check that the frontend and backend servers are started correctly

291−handleObRunStdout :: HTTP.Manager -> Handle -> Sh Text

394+handleObRunStdout :: HTTP.Manager -> Handle -> Handle -> Sh Text

292−handleObRunStdout httpManager stdout = flip fix (ObRunState_Init, []) $ \loop (state, msgs) -> do

395+handleObRunStdout httpManager stdout stderr = flip fix (ObRunState_Init, []) $ \loop (state, msgs) -> do

396+ isEOF <- liftIO $ hIsEOF stdout

397+ if isEOF

398+ then handleObRunError msgs

293− liftIO (T.hGetLine stdout) >>= \t -> case state of

399+ else liftIO (T.hGetLine stdout) >>= \t -> case state of

294 ObRunState_Init

400 ObRunState_Init

295 | "Running test..." `T.isPrefixOf` t -> loop (ObRunState_BackendStarted, msgs)

401 | "Running test..." `T.isPrefixOf` t -> loop (ObRunState_BackendStarted, msgs)

296 ObRunState_Startup

402 ObRunState_Startup

@@ -302,8 +408,12 @@ handleObRunStdout httpManager stdout = flip fix (ObRunState_Init, []) $ \loop (s

302 obRunCheck httpManager stdout uri

408 obRunCheck httpManager stdout uri

303 pure uri

409 pure uri

304 | not (T.null t) -> errorExit $ "Started: " <> t -- If theres any other output here, startup failed

410 | not (T.null t) -> errorExit $ "Started: " <> t -- If theres any other output here, startup failed

305− _ | "Failed" `T.isPrefixOf` t -> errorExit $ "ob run failed: " <> T.unlines (reverse $ t : msgs)

411+ _ | "Failed" `T.isPrefixOf` t -> handleObRunError (t : msgs)

306 | otherwise -> loop (state, t : msgs)

412 | otherwise -> loop (state, t : msgs)

413+ where

414+ handleObRunError msgs = do

415+ stderrContent <- liftIO $ hGetContents stderr

416+ errorExit $ "ob run failed: " <> T.unlines (reverse msgs) <> " stderr: " <> T.pack stderrContent

307

417

308-- | Make requests to frontend/backend servers to check they are working properly

418-- | Make requests to frontend/backend servers to check they are working properly

309obRunCheck :: HTTP.Manager -> Handle -> Text -> Sh ()

419obRunCheck :: HTTP.Manager -> Handle -> Text -> Sh ()

lib/snap-extras/obelisk-snap-extras.cabal+1−1

@@ -1,6 +1,6 @@

1name: obelisk-snap-extras

2version: 0.1

3−synopsys: Extra functionality for Snap that should be considered for upstreaming

3+synopsis: Extra functionality for Snap that should be considered for upstreaming

4license: BSD3

5build-type: Simple

6cabal-version: >=1.2

lib/snap-extras/src/Obelisk/Snap/Extras.hs+1−1

@@ -2,13 +2,13 @@

2module Obelisk.Snap.Extras

3 ( cachePermanently

4 , doNotCache

5+ , ensureSecure

5 , serveFileIfExists

6 , serveFileIfExists

6 , serveFileIfExistsAs

7 , serveFileIfExistsAs

7 ) where

8 ) where

9import Control.Monad.IO.Class

10import Control.Monad.IO.Class

10import Data.ByteString (ByteString)

11import Data.ByteString (ByteString)

11−import Data.Monoid

12import Data.String

13import Snap.Core

14import Snap.Util.FileServe

lib/tabulation/src/Data/Tabulation.hs+1−1

@@ -8,7 +8,7 @@ import Control.Lens

8-- | This is a class for record types whose fields can be enumerated by an associated GADT. It's closely related to the concept of a representable functor, except without the functor part, and the fields are not all the same type.

9class HasFields a where

10 type Field a :: * -> *

11−

11+

12 fieldLens :: Field a x -> Lens' a x

13 tabulateFieldsA :: Applicative f => (forall x. Field a x -> f x) -> f a

release.nix+8−95

@@ -1,97 +1,10 @@

1−{ self-args ? {

1+{

2− config.android_sdk.accept_license = true;

2+ supportedSystems ? [ "x86_64-linux" "x86_64-darwin" ]

3− iosSdkVersion = "10.2";

4− }

5−, local-self ? import ./. self-args

6}:

3}:

4+rec {

5+ recurseForDerivations = true;

6+ build = import ./all-builds.nix { inherit supportedSystems; };

7+ test = import ./all-tests.nix { inherit supportedSystems; };

8−let

9+ inherit (build) metaCache;

9− inherit (local-self.nixpkgs) lib runCommand nix;

10+}

10−

11− cacheBuildSystems = [ "x86_64-linux" "x86_64-darwin" ];

12−

13− obeliskPackagesCommon = [

14− "obelisk-frontend"

15− "obelisk-route"

16− "obelisk-executable-config-lookup"

17− ];

18−

19− obeliskPackagesBackend = obeliskPackagesCommon ++ [

20− "obelisk-asset-manifest"

21− "obelisk-asset-serve-snap"

22− "obelisk-backend"

23− "obelisk-cliapp"

24− "obelisk-command"

25− "obelisk-executable-config-inject"

26− "obelisk-frontend"

27− "obelisk-run"

28− "obelisk-route"

29− "obelisk-selftest"

30− "obelisk-snap-extras"

31− ];

32−

33− pnameToAttrs = pkgsSet: pnames:

34− lib.listToAttrs (map

35− (name: { inherit name; value = pkgsSet.${name}; })

36− pnames);

37−

38− concatDepends = let

39− extractDeps = x: (x.override {

40− mkDerivation = drv: {

41− out = builtins.concatLists [

42− (drv.buildDepends or [])

43− (drv.libraryHaskellDepends or [])

44− (drv.executableHaskellDepends or [])

45− ];

46− };

47− }).out;

48− in pkgAttrs: builtins.concatLists (map extractDeps (builtins.attrValues pkgAttrs));

49−

50− perPlatform = lib.genAttrs cacheBuildSystems (system: let

51− obelisk = import ./. (self-args // { inherit system; });

52− reflex-platform = obelisk.reflex-platform;

53− ghc = pnameToAttrs

54− obelisk.haskellPackageSets.ghc

55− obeliskPackagesBackend;

56− ghcjs = pnameToAttrs

57− obelisk.haskellPackageSets.ghcjs

58− obeliskPackagesCommon;

59− cachePackages = builtins.concatLists [

60− (builtins.attrValues ghc)

61− (builtins.attrValues ghcjs)

62− (concatDepends ghc)

63− (concatDepends ghcjs)

64− (lib.optional reflex-platform.androidSupport androidSkeleton)

65− (lib.optional reflex-platform.iosSupport iosSkeleton)

66− [ command serverSkeletonExe serverSkeletonShell ]

67− ];

68− command = obelisk.command;

69− skeleton = import ./skeleton { inherit obelisk; };

70− serverSkeletonExe = skeleton.exe;

71− # TODO fix nixpkgs so it doesn't try to run the result of haskell shells as setup hooks.

72− serverSkeletonShell = local-self.nixpkgs.runCommand "shell-safe-for-dep" {} ''

73− touch "$out"

74− echo "return" >> "$out"

75− cat "${skeleton.shells.ghc}" >> "$out"

76− '';

77− androidSkeleton = (import ./skeleton { inherit obelisk; }).android.frontend;

78− iosSkeleton = (import ./skeleton { inherit obelisk; }).ios.frontend;

79− in {

80− inherit

81− command

82− ghc ghcjs

83− serverSkeletonExe

84− serverSkeletonShell

85− ;

86− cache = reflex-platform.pinBuildInputs "obelisk-${system}" cachePackages;

87− } // lib.optionalAttrs reflex-platform.androidSupport {

88− inherit androidSkeleton;

89− } // lib.optionalAttrs reflex-platform.iosSupport {

90− inherit iosSkeleton;

91− });

92−

93− metaCache = local-self.reflex-platform.pinBuildInputs

94− "obelisk-everywhere"

95− (map (a: a.cache) (builtins.attrValues perPlatform));

96−

97−in perPlatform // { inherit metaCache; }

scripts/ghcid-this-lib+1−1

@@ -1,4 +1,4 @@

1#!/usr/bin/env bash

2set -euo pipefail

4−nix-shell -E "with (import ../.. {}); reflex-platform.workOn haskellPackageSets.ghc haskellPackageSets.ghc.obelisk-$(basename $PWD)" --run "cabal configure ; ghcid -c'cabal repl'"

4+nix-shell -E "with (import ../.. {}); reflex-platform.workOn haskellPackageSets.ghc haskellPackageSets.ghc.obelisk-$(basename $PWD)" --run "ghcid -c 'cabal new-repl'"

skeleton/.gitignore+1

@@ -1,5 +1,6 @@

1dist-newstyle

2result

3+result-*

3result-android

4result-android

4result-ios

5result-ios

5result-exe

6result-exe

skeleton/backend/src/Backend.hs−3

@@ -1,6 +1,3 @@

1−{-# LANGUAGE FlexibleContexts #-}

2−{-# LANGUAGE RankNTypes #-}

3−{-# LANGUAGE TypeFamilies #-}

4module Backend where

1module Backend where

6import Common.Route

3import Common.Route

skeleton/common/common.cabal−3

@@ -9,9 +9,6 @@ library

9 , obelisk-route

10 , mtl

11 , text

12− default-extensions:

13− TypeFamilies

14− PolyKinds

15 exposed-modules:

12 exposed-modules:

16 Common.Api

13 Common.Api

17 Common.Route

14 Common.Route

skeleton/common/src/Common/Route.hs+1

@@ -8,6 +8,7 @@

8{-# LANGUAGE OverloadedStrings #-}

9{-# LANGUAGE RankNTypes #-}

10{-# LANGUAGE TemplateHaskell #-}

11+{-# LANGUAGE TypeFamilies #-}

11module Common.Route where

12module Common.Route where

13{- -- You will probably want these imports for composing Encoders.

14{- -- You will probably want these imports for composing Encoders.

skeleton/frontend/frontend.cabal+1

@@ -9,6 +9,7 @@ library

9 , common

10 , obelisk-frontend

11 , obelisk-route

12+ , jsaddle

12 , reflex-dom

13 , reflex-dom

13 , obelisk-executable-config-lookup

14 , obelisk-executable-config-lookup

14 , obelisk-generated-static

15 , obelisk-generated-static

skeleton/frontend/src/Frontend.hs+21−3

@@ -1,25 +1,43 @@

1{-# LANGUAGE DataKinds #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE TypeApplications #-}

4module Frontend where

5module Frontend where

7+import Control.Monad

6import qualified Data.Text as T

8import qualified Data.Text as T

7import qualified Data.Text.Encoding as T

9import qualified Data.Text.Encoding as T

10+import Language.Javascript.JSaddle (eval, liftJSM)

11+

8import Obelisk.Frontend

12import Obelisk.Frontend

9import Obelisk.Configs

13import Obelisk.Configs

10import Obelisk.Route

14import Obelisk.Route

15+import Obelisk.Generated.Static

16+

11import Reflex.Dom.Core

17import Reflex.Dom.Core

13import Common.Api

19import Common.Api

14import Common.Route

20import Common.Route

15−import Obelisk.Generated.Static

22+

23+-- This runs in a monad that can be run on the client or the server.

24+-- To run code in a pure client or pure server context, use one of the

25+-- `prerender` functions.

17frontend :: Frontend (R FrontendRoute)

26frontend :: Frontend (R FrontendRoute)

18frontend = Frontend

27frontend = Frontend

28+ { _frontend_head = do

19− { _frontend_head = el "title" $ text "Obelisk Minimal Example"

29+ el "title" $ text "Obelisk Minimal Example"

30+ elAttr "link" ("href" =: static @"main.css" <> "type" =: "text/css" <> "rel" =: "stylesheet") blank

20 , _frontend_body = do

31 , _frontend_body = do

21− text "Welcome to Obelisk!"

32+ el "h1" $ text "Welcome to Obelisk!"

22 el "p" $ text $ T.pack commonStuff

33 el "p" $ text $ T.pack commonStuff

34+

35+ -- `prerender` and `prerender_` let you choose a widget to run on the server

36+ -- during prerendering and a different widget to run on the client with

37+ -- JavaScript. The following will generate a `blank` widget on the server and

38+ -- print "Hello, World!" on the client.

39+ prerender_ blank $ liftJSM $ void $ eval ("console.log('Hello, World!')" :: T.Text)

40+

23 elAttr "img" ("src" =: static @"obelisk.jpg") blank

41 elAttr "img" ("src" =: static @"obelisk.jpg") blank

24 el "div" $ do

42 el "div" $ do

25 exampleConfig <- getConfig "common/example"

43 exampleConfig <- getConfig "common/example"

skeleton/static/main.cssnew file+3

@@ -0,0 +1,3 @@

1+p {

2+ color: red;

3+}